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

 Every monad gives rise to an adjunction

 If a bicategory has Eilenberg-Moore objects, then every monad arises from an
 adjunction. This is the so-called free-algebra adjunction.

 This generalizes the construction in Monads.MonadAlgebras.v.
 Note: since we can instantiate this construction for Kleisli objects as well, the
 construction also generalizes the construction in Monads.KleisliCategory.v

 Contents
 1. Adjunction from monad
 2. The monad from the adjunction from a monad is equivalent to the original monad

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.Monads.Examples.AdjunctionToMonad.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion.

Local Open Scope cat.

Section MonadToAdjunction.
  Context {B : bicat}
          (HB : bicat_has_em B)
          (m : mnd B).

  Let x : B := ob_of_mnd m.
  Let f : x --> x := endo_of_mnd m.
  Let η : id₁ _ ==> f := unit_of_mnd m.
  Let μ : f · f ==> f := mult_of_mnd m.

  Let e : em_cone m := pr1 (HB m).
  Let He : has_em_ump _ e := pr2 (HB m).

  Let l : e --> x := mor_of_mnd_mor (mor_of_em_cone _ e).
  Let lf : l · f ==> l := mnd_mor_endo (mor_of_em_cone _ e) • lunitor _.

  (**
   1. Adjunction from monad
   *)
  Definition free_alg_1cell_cone
    : em_cone m.
  Proof.
    use make_em_cone.
    - exact x.
    - exact f.
    - exact (μ • linvunitor _).
    - abstract
        (refine (!(id2_left _) @ _) ;
         rewrite !vassocr ;
         apply maponpaths_2 ;
         refine (!_) ;
         exact (mnd_unit_right m)).
    - abstract
        (rewrite !vassocr ;
         apply maponpaths_2 ;
         rewrite !vassocl ;
         use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
         rewrite !vassocr ;
         rewrite rwhisker_vcomp ;
         rewrite !vassocl ;
         rewrite linvunitor_lunitor ;
         rewrite id2_right ;
         rewrite !vassocr ;
         exact (!(mnd_mult_assoc m))).
  Defined.

  Definition free_alg_1cell
    : x --> e
    := em_ump_1_mor _ He free_alg_1cell_cone.

  Definition mnd_to_unit
    : id₁ x ==> free_alg_1cell · l
    := η • cell_of_mnd_cell ((em_ump_1_inv2cell _ He free_alg_1cell_cone)^-1).

  Definition mnd_to_counit_cell_data
    : mnd_cell_data
        (# (mnd_incl B) (l · free_alg_1cell) · mor_of_em_cone m e)
        (# (mnd_incl B) (id₁ e) · mor_of_em_cone m e)
    := rassociator _ _ _
       • (_ ◃ cell_of_mnd_cell (em_ump_1_inv2cell _ He free_alg_1cell_cone))
       • mnd_mor_endo (mor_of_em_cone m e).

  Local Definition em_ump_mnd_cell_endo_help
    : (_ ◃ mnd_mor_endo (mor_of_em_cone m e))
      • lassociator _ _ _
      • (runitor _ ▹ _)
      • cell_of_mnd_cell (em_ump_1_inv2cell m He free_alg_1cell_cone)
      =
      lassociator _ _ _
      • (cell_of_mnd_cell (em_ump_1_inv2cell m He free_alg_1cell_cone) ▹ endo_of_mnd m)
      • μ.
  Proof.
    refine (_ @ vassocr _ _ _).
    use vcomp_move_L_pM ; [ is_iso | ].
    use (vcomp_rcancel (linvunitor _)) ; [ is_iso | ].
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite linvunitor_natural.
      rewrite <- lwhisker_hcomp.
      rewrite linvunitor_assoc.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      apply idpath.
    }
    refine (_ @ mnd_cell_endo (em_ump_1_inv2cell m He free_alg_1cell_cone)).
    rewrite !vassocr.
    apply idpath.
  Qed.

  Definition mnd_to_counit_is_mnd_cell
    : is_mnd_cell mnd_to_counit_cell_data.
  Proof.
    unfold is_mnd_cell ; cbn.
    unfold mnd_to_counit_cell_data.
    rewrite runitor_lunitor_identity.
    rewrite lunitor_linvunitor.
    rewrite id2_rwhisker.
    rewrite id2_right.
    rewrite !vassocl.
    rewrite lassociator_rassociator.
    rewrite id2_right.
    rewrite !vassocr.
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    etrans.
    {
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite lwhisker_hcomp.
        rewrite <- inverse_pentagon_3.
        rewrite <- rwhisker_hcomp.
        apply idpath.
      }
      rewrite !vassocl.
      rewrite lwhisker_lwhisker_rassociator.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        do 3 apply maponpaths_2.
        rewrite rwhisker_vcomp.
        apply maponpaths.
        rewrite linvunitor_assoc.
        rewrite !vassocl.
        rewrite rassociator_lassociator.
        rewrite id2_right.
        rewrite <- runitor_triangle.
        apply idpath.
      }
      rewrite !vassocl.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          apply maponpaths_2.
          rewrite rwhisker_rwhisker_alt.
          rewrite !vassocl.
          rewrite vcomp_whisker.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        do 4 apply maponpaths_2.
        rewrite rwhisker_hcomp.
        rewrite !vassocl.
        rewrite <- inverse_pentagon_4.
        rewrite <- lwhisker_hcomp.
        apply idpath.
      }
      apply maponpaths.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      rewrite !vassocr.
      apply em_ump_mnd_cell_endo_help.
    }
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    rewrite <- rassociator_rassociator.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocl.
    apply maponpaths.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite rassociator_lassociator.
      rewrite lwhisker_id2.
      rewrite id2_left.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite rwhisker_lwhisker_rassociator.
    rewrite !vassocl.
    apply maponpaths.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite <- linvunitor_assoc.
      rewrite lwhisker_hcomp.
      rewrite <- linvunitor_natural.
      apply idpath.
    }
    use vcomp_move_R_pM ; [ is_iso | ].
    rewrite !vassocr.
    use vcomp_move_R_Mp ; [ is_iso | ].
    refine (!_).
    refine (_ @ mnd_mor_mu (mor_of_em_cone m e)).
    rewrite !vassocl.
    do 4 apply maponpaths.
    refine (!_).
    apply lunitor_triangle.
  Qed.

  Definition mnd_to_counit_mnd_cell
    : # (mnd_incl B) (l · free_alg_1cell) · mor_of_em_cone m e
      ==>
      # (mnd_incl B) (id₁ e) · mor_of_em_cone m e.
  Proof.
    use make_mnd_cell.
    - exact mnd_to_counit_cell_data.
    - exact mnd_to_counit_is_mnd_cell.
  Defined.

  Definition mnd_to_counit
    : l · free_alg_1cell ==> id₁ e
    := em_ump_2_cell _ He mnd_to_counit_mnd_cell.

  Definition mnd_to_left_adjoint_data
    : left_adjoint_data free_alg_1cell
    := l ,, (mnd_to_unit ,, mnd_to_counit).

  Local Definition em_ump_mnd_cell_endo_inv_help
    : (cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1) ▹ endo_of_mnd m)
      • rassociator _ _ _
      • (_ ◃ mnd_mor_endo (mor_of_em_cone m e))
      =
      μ
      • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)
      • (_ ◃ linvunitor _).
  Proof.
    use (vcomp_rcancel (lassociator _ _ _ • ((runitor _) ▹ _) • linvunitor _)) ; [ is_iso | ].
    refine (!_).
    etrans.
    {
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite lwhisker_hcomp.
      rewrite !vassocr.
      etrans.
      {
        do 2 apply maponpaths_2.
        apply triangle_l_inv.
      }
      rewrite <- rwhisker_hcomp.
      apply maponpaths_2.
      refine (rwhisker_vcomp _ _ _ @ _).
      rewrite rinvunitor_runitor.
      apply id2_rwhisker.
    }
    rewrite id2_left.
    rewrite linvunitor_natural.
    rewrite <- lwhisker_hcomp.
    refine (vassocr _ _ _ @ _).
    refine (mnd_cell_endo ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1) @ _).
    rewrite !vassocl.
    apply maponpaths.
    cbn.
    rewrite !vassocl.
    do 3 apply maponpaths.
    rewrite <- rwhisker_vcomp.
    rewrite !vassocl.
    apply maponpaths.
    rewrite linvunitor_assoc.
    apply idpath.
  Qed.

  Definition mnd_to_left_adjoint_axioms
    : left_adjoint_axioms mnd_to_left_adjoint_data.
  Proof.
    split.
    - use (em_ump_eq _ He).
      + apply id₂.
      + use eq_mnd_cell ; cbn.
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !rwhisker_hcomp.
          rewrite <- triangle_l.
          rewrite <- lwhisker_hcomp, <- rwhisker_hcomp.
          rewrite !vassocr.
          rewrite <- rwhisker_lwhisker_rassociator.
          apply maponpaths_2.
          do 2 apply maponpaths.
          exact (maponpaths
                   cell_of_mnd_cell
                   (em_ump_2_eq _ He mnd_to_counit_mnd_cell)).
        }
        cbn ; unfold mnd_to_counit_cell_data.
        rewrite !vassocl.
        rewrite lwhisker_vcomp.
        rewrite !vassocl.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite <- !lwhisker_vcomp.
          rewrite !vassocr.
          rewrite rassociator_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_rwhisker_alt.
          rewrite !vassocl.
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite lwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        unfold mnd_to_unit.
        rewrite !vassocr.
        rewrite <- linvunitor_assoc.
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite vcomp_whisker.
          rewrite !vassocl.
          apply idpath.
        }
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !vassocr.
          apply maponpaths_2.
          apply em_ump_mnd_cell_endo_inv_help.
        }
        etrans.
        {
          rewrite !vassocr.
          etrans.
          {
            do 5 apply maponpaths_2.
            rewrite lwhisker_hcomp.
            rewrite <- linvunitor_natural.
            apply idpath.
          }
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            do 3 apply maponpaths_2.
            apply mnd_unit_left.
          }
          rewrite id2_left.
          rewrite !vassocr.
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            exact (maponpaths
                     cell_of_mnd_cell
                     (vcomp_rinv (em_ump_1_inv2cell m He free_alg_1cell_cone))).
          }
          apply id2_left.
        }
        rewrite lwhisker_vcomp.
        rewrite linvunitor_lunitor.
        apply lwhisker_id2.
      + rewrite psfunctor_id2.
        apply id2_rwhisker.
    - cbn.
      rewrite !vassocl.
      unfold mnd_to_unit.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        apply maponpaths_2.
        exact (maponpaths
                 cell_of_mnd_cell
                 (em_ump_2_eq _ He mnd_to_counit_mnd_cell)).
      }
      simpl.
      unfold mnd_to_counit_cell_data.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        do 2 apply maponpaths_2.
        apply maponpaths.
        exact (maponpaths
                 cell_of_mnd_cell
                 (vcomp_linv (em_ump_1_inv2cell m He free_alg_1cell_cone))).
      }
      cbn.
      rewrite lwhisker_id2.
      rewrite id2_left.
      rewrite !vassocr.
      use vcomp_move_R_Mp ; [ is_iso | ].
      refine (!(mnd_mor_unit (mor_of_em_cone m e)) @ _).
      cbn.
      rewrite id2_rwhisker.
      rewrite id2_left, id2_right.
      apply idpath.
  Qed.

  Definition mnd_to_left_adjoint
    : left_adjoint free_alg_1cell
    := mnd_to_left_adjoint_data ,, mnd_to_left_adjoint_axioms.

  Definition mnd_to_adjunction
    : adjunction x e
    := free_alg_1cell ,, mnd_to_left_adjoint.

  (**
   2. The monad from the adjunction from a monad is equivalent to the original monad
   *)
  Definition mnd_to_adjunction_to_mnd_data
    : mnd_mor_data
        (mnd_from_adjunction mnd_to_adjunction)
        m.
  Proof.
    use make_mnd_mor_data.
    - exact (id₁ _).
    - exact (lunitor _
             • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone)^-1)
             • rinvunitor _).
  Defined.

  Definition mnd_to_adjunction_to_mnd_law₁
    : linvunitor (id₁ x)
      • (mnd_to_unit ▹ id₁ x)
      =
      rinvunitor (id₁ x)
      • (id₁ x ◃ unit_of_mnd m)
      • ((lunitor f • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1))
     • rinvunitor _).
  Proof.
    rewrite lunitor_V_id_is_left_unit_V_id.
    rewrite !vassocl.
    apply maponpaths.
    unfold mnd_to_unit.
    rewrite !vassocr.
    rewrite vcomp_lunitor.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite lunitor_runitor_identity.
    rewrite runitor_rinvunitor.
    rewrite id2_left.
    apply idpath.
  Qed.

  Definition mnd_to_adjunction_to_mnd_law₂
    : lassociator (id₁ _) f f
      • ((lunitor f
          • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)
          • rinvunitor (em_ump_1_mor m He free_alg_1cell_cone · pr1 (mor_of_em_cone m e)))
         ▹ endo_of_mnd m)
      • rassociator (free_alg_1cell · l) (id₁ x) f
      • (free_alg_1cell · l
           ◃ (lunitor f
              • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)
              • rinvunitor (em_ump_1_mor m He free_alg_1cell_cone · pr1 (mor_of_em_cone m e))))
      • lassociator (free_alg_1cell · l) (free_alg_1cell · l) (id₁ x)
      • ((((rassociator free_alg_1cell l (free_alg_1cell · l)
            • (free_alg_1cell ◃ lassociator l free_alg_1cell l))
            • (free_alg_1cell ◃ (mnd_to_counit ▹ l)))
            • (free_alg_1cell ◃ lunitor l)) ▹ id₁ x)
      =
      (id₁ x ◃ μ)
      • ((lunitor f • cell_of_mnd_cell ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1))
      • rinvunitor (em_ump_1_mor m He free_alg_1cell_cone · pr1 (mor_of_em_cone m e))).
  Proof.
    rewrite <- !lwhisker_vcomp.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocr.
    rewrite lunitor_triangle.
    rewrite vcomp_lunitor.
    rewrite !vassocl.
    apply maponpaths.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      do 7 apply maponpaths_2.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      rewrite lwhisker_vcomp.
      rewrite linvunitor_lunitor.
      rewrite lwhisker_id2.
      apply idpath.
    }
    rewrite id2_left.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite rinvunitor_triangle.
      rewrite !vassocl.
      rewrite !rwhisker_vcomp.
      rewrite rwhisker_hcomp.
      rewrite <- rinvunitor_natural.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      do 4 apply maponpaths.
      apply maponpaths_2.
      apply maponpaths.
      pose (p := maponpaths cell_of_mnd_cell (em_ump_2_eq m He mnd_to_counit_mnd_cell)).
      cbn in p.
      exact p.
    }
    unfold mnd_to_counit_cell_data.
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      etrans.
      {
        do 2 apply maponpaths_2.
        rewrite <- !lwhisker_vcomp.
        rewrite !vassocr.
        apply maponpaths_2.
        apply lwhisker_lwhisker_rassociator.
      }
      apply maponpaths_2.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !lwhisker_vcomp.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      do 3 apply maponpaths_2.
      rewrite lwhisker_vcomp.
      etrans.
      {
        apply maponpaths.
        exact (maponpaths
                 cell_of_mnd_cell
                 (vcomp_linv (em_ump_1_inv2cell m He free_alg_1cell_cone))).
      }
      apply lwhisker_id2.
    }
    rewrite id2_left.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    use (vcomp_rcancel (linvunitor _)) ; [ is_iso | ].
    pose (p := mnd_cell_endo ((em_ump_1_inv2cell m He free_alg_1cell_cone) ^-1)).
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      rewrite linvunitor_natural.
      rewrite <- lwhisker_hcomp.
      rewrite !vassocr.
      exact p.
    }
    apply maponpaths.
    cbn.
    rewrite !vassocl.
    apply maponpaths.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocl.
    rewrite <- linvunitor_assoc.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    rewrite <- !lwhisker_vcomp.
    rewrite runitor_rwhisker.
    apply idpath.
  Qed.

  Definition mnd_to_adjunction_to_mnd_laws
    : mnd_mor_laws mnd_to_adjunction_to_mnd_data.
  Proof.
    split.
    - exact mnd_to_adjunction_to_mnd_law₁.
    - exact mnd_to_adjunction_to_mnd_law₂.
  Qed.

  Definition mnd_to_adjunction_to_mnd
    : mnd_from_adjunction mnd_to_adjunction
      -->
      m.
  Proof.
    use make_mnd_mor.
    - exact mnd_to_adjunction_to_mnd_data.
    - exact mnd_to_adjunction_to_mnd_laws.
  Defined.

  Definition mnd_to_adjunction_to_mnd_adj_equivalence
             (HB_2_0 : is_univalent_2_0 B)
    : left_adjoint_equivalence mnd_to_adjunction_to_mnd.
  Proof.
    use to_equivalence_mnd.
    - exact HB_2_0.
    - apply internal_adjoint_equivalence_identity.
    - cbn.
      is_iso.
      apply (from_invertible_mnd_2cell
               (inv_of_invertible_2cell (em_ump_1_inv2cell m He free_alg_1cell_cone))).
  Defined.
End MonadToAdjunction.


(******************************************************************************)
(** * Definition of executions (common basis for all types of executions) *)
(******************************************************************************)

Require Import Arith Lia.
Require Import Classical Peano_dec.
(*From hahn*) Require Import Hahn.
Require Import Events.

Set Implicit Arguments.

(** Definition of an execution *)
Record execution :=
  { acts : list actid;
    lab : actid -> label;
    iico_data : actid -> actid -> Prop ;   (** intrinsic data dependency *)
    iico_ctrl : actid -> actid -> Prop ;   (** intrinsic control dependency *)

    data : actid -> actid -> Prop ;   (** data dependency *)
    addr : actid -> actid -> Prop ;   (** address dependency *)
    ctrl : actid -> actid -> Prop ;   (** control dependency *)
    lxsx : actid -> actid -> Prop ;   (** load-exclusive -> store-exclusive *)
    amo : actid -> actid -> Prop ;    (** read -> write of atomic operation *)

    (* Representation of a data dependency to CAS.
        It goes from a read to an exclusive read.
        Consider the example:

        a := read (x);
        CAS(y, a, 1);

        In the execution, there is an rmw_dep edge between a read event representing `a := ⦗x⦘'
        and a read event representing `CAS(y, a, 1)'.
     *)
    (* rmw_dep : actid -> actid -> Prop ; *)

    rf : actid -> actid -> Prop ;
    co : actid -> actid -> Prop ;
  }.

Section Execution.

Variable G : execution.

Definition acts_set := fun x => In x (acts G).

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'NTid_' t" := (fun x => tid x <> t) (at level 1).

Notation "'E'" := acts_set.
Notation "'lab'" := (lab G).
Notation "'rf'" := (rf G).
Notation "'co'" := (co G).
Notation "'lxsx'" := (lxsx G).
Notation "'amo'" := (amo G).
Notation "'data'" := (data G).
Notation "'addr'" := (addr G).
Notation "'ctrl'" := (ctrl G).

Notation "'loc'" := (loc lab).
Notation "'val'" := (val lab).
Notation "'same_loc'" := (same_loc lab).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'Br'" := (fun a => is_true (is_br lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).
Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).

Definition po := ⦗E⦘ ⨾ ext_sb ⨾  ⦗E⦘.
Definition si := ⦗E⦘ ⨾ ext_si ⨾  ⦗E⦘.
Definition rmw := lxsx ∪ amo.

Record Wf :=
  { data_in_po : data ⊆ po ;
    wf_dataD : data ≡ ⦗R⦘ ⨾ data ⨾ ⦗W⦘ ;
    addr_in_po : addr ⊆ po ;
    wf_addrD : addr ≡ ⦗R⦘ ⨾ addr ⨾ ⦗RW⦘ ;
    ctrl_in_po : ctrl ⊆ po ;
    wf_ctrlD : ctrl ≡ ⦗R⦘ ⨾ ctrl ;
    ctrl_po : ctrl ⨾ po ⊆ ctrl ;
    wf_rmwD : rmw ≡ ⦗R⦘ ⨾ rmw ⨾ ⦗W⦘ ;
    wf_rmwl : rmw ⊆ same_loc ;
    wf_rmwi : rmw ⊆ immediate po ;

    wf_siD     : forall x y, si x y -> si_matching_label (lab x) (lab y) ;
    wf_sil     : si ∩ same_loc ≡ ⦗ E ⦘ ;
    wf_si_data : si ⨾ data ⨾ si ⊆ data ;
    wf_si_ctrl : si ⨾ ctrl ⨾ si ⊆ ctrl ;
    wf_si_addr : si ⨾ addr ⨾ si ⊆ addr ;
    si_lxsx    : si ⨾ lxsx ≡ lxsx ⨾ si ;
    si_amo     : si ⨾ amo ≡ amo ⨾ si ;

    wf_rfE : rf ≡ ⦗E⦘ ⨾ rf ⨾ ⦗E⦘ ;
    wf_rfD : rf ≡ ⦗W⦘ ⨾ rf ⨾ ⦗R⦘ ;
    wf_rfl : rf ⊆ same_loc ;
    wf_rfv : funeq val rf ;
    wf_rff : functional rf⁻¹ ;
    wf_coE : co ≡ ⦗E⦘ ⨾ co ⨾ ⦗E⦘ ;
    wf_coD : co ≡ ⦗W⦘ ⨾ co ⨾ ⦗W⦘ ;
    wf_col : co ⊆ same_loc ;
    co_trans : transitive co ;
    wf_co_total : forall ol, is_total (E ∩₁ W ∩₁ (fun x => loc x = ol)) co ;
    co_irr : irreflexive co ;
    wf_init : forall l, (exists b, E b /\ loc b = Some l) -> E (InitEvent l) ;
    wf_init_lab : forall l, lab (InitEvent l) = Astore false Opln_write l 0 ;
  }.

Implicit Type WF : Wf.

(******************************************************************************)
(** ** Derived relations  *)
(******************************************************************************)

(* reads-before, aka from-read *)
Definition fr := rf⁻¹ ⨾ co.

Definition deps := data ∪ addr ∪ ctrl.

(******************************************************************************)
(** ** Consistency definitions  *)
(******************************************************************************)

Definition complete := E ∩₁ R  ⊆₁ codom_rel rf.
Definition rmw_atomicity := rmw ∩ ((fr \ po) ⨾ (co \ po)) ⊆ ∅₂.

(******************************************************************************)
(** ** Basic transitivity properties *)
(******************************************************************************)

Lemma po_trans : transitive po.
Proof using.
  unfold po; unfolder; ins; desf; splits; auto.
  eby eapply ext_sb_trans.
Qed.

Lemma po_po : po ⨾ po ⊆ po.
Proof using.
  generalize po_trans; basic_solver 21.
Qed.

Lemma po_same_loc_trans: transitive (po ∩ same_loc).
Proof using.
  apply transitiveI.
  unfold Events.same_loc.
  unfolder; ins; desf; eauto.
  splits.
  generalize po_trans; basic_solver 21.
  congruence.
Qed.

Lemma po_same_loc_W_trans : transitive (po ∩ same_loc ⨾ ⦗W⦘).
Proof using.
  generalize po_same_loc_trans; unfold transitive.
  basic_solver 21.
Qed.

(******************************************************************************)
(** ** Basic properties *)
(******************************************************************************)

Lemma po_neq_loc_in_po : po \ same_loc ⊆ po.
Proof using. basic_solver. Qed.

Lemma fr_co WF : fr ⨾ co ⊆ fr.
Proof using. by unfold fr; rewrite seqA, rewrite_trans; [|apply WF]. Qed.

Lemma rmw_in_po WF: rmw ⊆ po.
Proof using. rewrite wf_rmwi; basic_solver. Qed.

Lemma deps_in_po WF: deps ⊆ po.
Proof using. unfold deps; unionL; apply WF. Qed.

Lemma amo_in_po WF: amo ⊆ po.
Proof using. eapply inclusion_trans, rmw_in_po; vauto. Qed.

Lemma lxsx_in_po WF: lxsx ⊆ po.
Proof using. eapply inclusion_trans, rmw_in_po; vauto. Qed.

(******************************************************************************)
(** ** Same Location relations  *)
(******************************************************************************)

Lemma loceq_rf WF : funeq loc rf.
Proof using. apply WF. Qed.

Lemma loceq_co WF : funeq loc co.
Proof using. apply WF. Qed.

Lemma loceq_rmw WF : funeq loc rmw.
Proof using. apply WF. Qed.

Lemma loceq_fr WF : funeq loc fr.
Proof using.
  generalize (loceq_co WF), (loceq_rf WF).
  unfold funeq, fr; unfolder; ins; desf.
  transitivity (loc z); eauto using sym_eq.
Qed.

Lemma wf_frl WF : fr ⊆ same_loc.
Proof using.
  unfold fr.
  rewrite (wf_rfl WF), (wf_col WF).
  unfold Events.same_loc.
  unfolder; ins; desc; congruence.
Qed.

(******************************************************************************)
(** ** Relations in graph *)
(******************************************************************************)

Lemma wf_poE : po ≡ ⦗E⦘ ⨾ po ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; unfold po; basic_solver.
Qed.

Lemma wf_dataE WF: data ≡ ⦗E⦘ ⨾ data ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite data_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_addrE WF: addr ≡ ⦗E⦘ ⨾ addr ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite addr_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_ctrlE WF: ctrl ≡ ⦗E⦘ ⨾ ctrl ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite ctrl_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_depsE WF: deps ≡ ⦗E⦘ ⨾ deps ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite deps_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_amoE WF: amo ≡ ⦗E⦘ ⨾ amo ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite amo_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_lxsxE WF: lxsx ≡ ⦗E⦘ ⨾ lxsx ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite lxsx_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_rmwE WF : rmw ≡ ⦗E⦘ ⨾ rmw ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; rewrite rmw_in_po, wf_poE; basic_solver.
Qed.

Lemma wf_frE WF : fr ≡ ⦗E⦘ ⨾ fr ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; unfold fr;
    rewrite wf_rfE, wf_coE; basic_solver.
Qed.

Lemma wf_siE WF: si ≡ ⦗E⦘ ⨾ si ⨾ ⦗E⦘.
Proof using.
  apply doms_helper; unfold si; basic_solver.
Qed.

(******************************************************************************)
(** ** Domains and codomains  *)
(******************************************************************************)

Lemma wf_frD WF : fr ≡ ⦗R⦘ ⨾ fr ⨾ ⦗W⦘.
Proof using.
  apply doms_helper; unfold fr;
    rewrite wf_rfD, wf_coD; basic_solver.
Qed.

Lemma wf_depsD WF : deps ≡ ⦗R⦘ ⨾ deps.
Proof using.
  split; [|basic_solver].
  unfold deps.
  rewrite (wf_dataD WF) at 1.
  rewrite (wf_ctrlD WF) at 1.
  rewrite (wf_addrD WF) at 1.
  basic_solver.
Qed.

(******************************************************************************)
(** ** Irreflexive relations *)
(******************************************************************************)

Lemma po_irr : irreflexive po.
Proof using.
  unfold po; unfolder; ins; desf.
  eby eapply ext_sb_irr.
Qed.

Lemma fr_irr WF : irreflexive fr.
Proof using.
  rewrite (wf_frD WF); type_solver.
Qed.

(******************************************************************************)
(** ** Same instruction *)
(******************************************************************************)

Lemma si_po : si ⨾ po ≡ po.
Proof using.
  unfold si, po, ext_si, ext_sb; unfolder; splits; ins; desf; desf; splits; ins.
  exists (InitEvent l); ins.
  eexists (ThreadEvent _ _ _); splits; ins; eauto.
Qed.

Lemma po_si : po ⨾ si ≡ po.
Proof using.
  unfold si, po; unfolder; splits; ins; desf; splits; ins;
    try exists y; unfold ext_si, ext_sb in *; desf; desf.
Qed.

Lemma si_refl x (EV: E x) :  si x x.
Proof using.
  unfold si in *; unfolder; auto using ext_si_refl.
Qed.

Lemma si_sym :  symmetric si.
Proof using.
  unfold si in *; unfolder; ins; desf.
  eauto 8 using ext_si_symm.
Qed.

Lemma si_trans : transitive si.
Proof using.
  unfold si in *; unfolder; ins; desf; eauto using ext_si_trans.
Qed.

Lemma si_si : si ⨾ si ≡ si.
Proof using.
  unfold si; unfolder; split; ins; desf; splits; ins.
  eapply ext_si_trans; eauto.
  eauto 6 using ext_si_refl.
Qed.

Lemma si_rmw WF : si ⨾ rmw ≡ rmw ⨾ si.
Proof using.
  unfold rmw; relsf; rewrite si_amo, si_lxsx; ins.
Qed.

Lemma addr_si WF : addr ⨾ si ≡ addr.
Proof using.
  rewrite wf_addrE; ins.
  assert (X := wf_si_addr WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold si in *; unfolder in *; desf.
Qed.

Lemma ctrl_si WF : ctrl ⨾ si ≡ ctrl.
Proof using.
  rewrite wf_ctrlE; ins.
  assert (X := wf_si_ctrl WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold si in *; unfolder in *; desf.
Qed.

Lemma data_si WF : data ⨾ si ≡ data.
Proof using.
  rewrite wf_dataE; ins.
  assert (X := wf_si_data WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold si in *; unfolder in *; desf.
Qed.

Lemma si_addr WF : si ⨾ addr ≡ addr.
Proof using.
  rewrite wf_addrE; ins.
  assert (X := wf_si_addr WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold si in *; unfolder in *; desf.
Qed.

Lemma si_ctrl WF : si ⨾ ctrl ≡ ctrl.
Proof using.
  rewrite wf_ctrlE; ins.
  assert (X := wf_si_ctrl WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold Execution.si in *; unfolder in *; desf.
Qed.

Lemma si_data WF : si ⨾ data ≡ data.
Proof using.
  rewrite wf_dataE; ins.
  assert (X := wf_si_data WF); unfolder in *; ins; splits; ins; desf; splits; ins;
    eauto 8 using si_refl.
  unfold Execution.si in *; unfolder in *; desf.
Qed.

Lemma W_si WF : ⦗W⦘ ⨾ si ≡ si ⨾ ⦗W⦘.
Proof using.
  unfolder; ins; desf; splits; ins; desf; splits; eauto.
  eapply (wf_siD WF) in H0; unfolder in *; desf; type_solver.
  eapply (wf_siD WF) in H; unfolder in *; desf; type_solver.
Qed.

Lemma R_si WF : ⦗R⦘ ⨾ si ≡ si ⨾ ⦗R⦘.
Proof using.
  unfolder; ins; desf; splits; ins; desf; splits; eauto.
  eapply (wf_siD WF) in H0; unfolder in *; desf; type_solver.
  eapply (wf_siD WF) in H; unfolder in *; desf; type_solver.
Qed.

(******************************************************************************)
(** ** Acyclic relations *)
(******************************************************************************)

Lemma po_acyclic : acyclic po.
Proof using.
  apply trans_irr_acyclic; [apply po_irr| apply po_trans].
Qed.

Lemma co_acyclic WF: acyclic co.
Proof using.
    by apply trans_irr_acyclic; [apply co_irr| apply co_trans].
Qed.

Lemma wf_po : well_founded po.
Proof using.
  eapply wf_finite; auto.
  apply po_acyclic.
  rewrite (dom_l wf_poE).
  unfold doma; basic_solver.
Qed.

(******************************************************************************)
(** ** init *)
(******************************************************************************)

Lemma init_w WF: is_init ⊆₁ W.
Proof using.
  unfolder; ins.
  unfold is_init in *; destruct x; desf.
  specialize (wf_init_lab WF l); unfold is_w; desf.
Qed.

Lemma read_or_fence_is_not_init WF a (A: R a \/ F a) : ~ is_init a.
Proof using.
  generalize ((init_w WF) a).
  type_solver.
Qed.

Lemma no_po_to_init : po ≡ po ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
  split; [|basic_solver].
  unfold po; rewrite ext_sb_to_non_init at 1; basic_solver.
Qed.

Lemma no_rf_to_init WF : rf ≡ rf ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
  split; [|basic_solver].
  rewrite (wf_rfD WF) at 1.
  generalize (read_or_fence_is_not_init WF).
  basic_solver 42.
Qed.

Lemma rmw_from_non_init WF : rmw ≡ ⦗fun x => ~ is_init x⦘ ⨾ rmw.
Proof using.
  split; [|basic_solver].
  rewrite (wf_rmwD WF).
  generalize (read_or_fence_is_not_init WF).
  basic_solver 42.
Qed.

Lemma rmw_non_init_lr WF : rmw ≡ ⦗set_compl is_init⦘ ⨾ rmw ⨾ ⦗set_compl is_init⦘.
Proof using.
  split; [|basic_solver].
  rewrite (rmw_from_non_init WF) at 1.
  rewrite <- seqA.
  apply codom_rel_helper.
  rewrite (rmw_in_po WF).
  rewrite no_po_to_init.
  basic_solver.
Qed.

Lemma init_same_loc WF a b (A: is_init a) (B: is_init b) (LOC: loc a = loc b):
  a = b.
Proof using.
destruct a, b; desf.
cut (l = l0); [by ins; subst|].
unfold Events.loc in LOC.
rewrite (wf_init_lab WF l), (wf_init_lab WF l0) in LOC; desf.
Qed.

(******************************************************************************)
(** ** More properties *)
(******************************************************************************)

Lemma po_semi_total_l x y z :
  po x y -> po x z -> is_init x /\ ~ is_init y /\ ~ is_init z \/ po y z \/ po z y \/ si y z.
Proof using.
  unfold Execution.po, Execution.si, ext_sb, ext_si; ins; unfolder in *; desf; desf;
    ins; eauto 6.
  right; forward eapply (Nat.lt_trichotomy index0 index1) as K; desf.
    + left; eexists; splits; eauto; eexists; splits; eauto; ins.
    + right; right; eexists; splits; eauto; eexists; splits; eauto; ins.
    + right; left; eexists; splits; eauto; eexists; splits; eauto; ins.
Qed.

Lemma po_semi_total_r x y z :
  po y x -> po z x -> po y z \/ po z y \/ is_init y /\ is_init z \/ si y z.
Proof using.
  unfold Execution.po, Execution.si, ext_sb, ext_si; ins; unfolder in *; desf; desf; eauto.
  - left; eexists; splits; eauto; eexists; splits; eauto; ins.
  - right; left; eexists; splits; eauto; eexists; splits; eauto; ins.
  - forward eapply (Nat.lt_trichotomy index index1) as K; desf.
    + left; eexists; splits; eauto; eexists; splits; eauto; ins.
    + right; right; right; eexists; splits; eauto; eexists; splits; eauto; ins.
    + right; left; eexists; splits; eauto; eexists; splits; eauto; ins.
Qed.

Lemma po_tid_init x y (PO : po x y): tid x = tid y \/ is_init x.
Proof using.
  generalize ext_sb_tid_init; unfold po in *.
  unfolder in *; basic_solver.
Qed.

Lemma E_ntid_po_prcl thread :
  dom_rel (⦗set_compl is_init⦘ ⨾ po ⨾ ⦗E ∩₁ NTid_ thread⦘) ⊆₁ E ∩₁ NTid_ thread.
Proof using.
  rewrite (dom_l wf_poE).
  unfolder. ins. desf. splits; auto.
  match goal with
  | H : po _ _ |- _ => rename H into PO
  end.
  apply po_tid_init in PO. desf.
  intros BB. rewrite BB in *. desf.
Qed.

Lemma po_tid_init': po ≡ po ∩ same_tid ∪ ⦗is_init⦘ ⨾ po.
Proof using.
split; [|basic_solver].
unfold po.
rewrite ext_sb_tid_init' at 1.
basic_solver 42.
Qed.

Lemma ninit_po_same_tid : ⦗ set_compl is_init ⦘ ⨾ po ⊆ same_tid.
Proof using.
  rewrite po_tid_init'.
  basic_solver.
Qed.

Lemma same_tid_trans : transitive same_tid.
Proof using.
  red. unfold same_tid. ins.
  etransitivity; eauto.
Qed.

Lemma rf_rf WF : rf ⨾ rf ≡ ∅₂.
Proof using. rewrite (wf_rfD WF); type_solver. Qed.
Lemma rf_co WF : rf ⨾ co ≡ ∅₂.
Proof using. rewrite (wf_rfD WF), (wf_coD WF); type_solver. Qed.
Lemma co_transp_rf WF : co ⨾  rf⁻¹ ≡ ∅₂.
Proof using. rewrite (wf_rfD WF), (wf_coD WF); type_solver. Qed.
Lemma co_fr WF : co ⨾ fr ≡ ∅₂.
Proof using. rewrite (wf_coD WF), (wf_frD WF); type_solver. Qed.
Lemma fr_fr WF : fr ⨾ fr ≡ ∅₂.
Proof using. rewrite (wf_frD WF); type_solver. Qed.
Lemma rf_transp_rf WF: rf ⨾ rf⁻¹ ⊆ ⦗fun _ => True⦘.
Proof using. by apply functional_alt, WF. Qed.
Lemma rf_fr WF : rf ⨾ fr ⊆ co.
Proof using. unfold fr; sin_rewrite rf_transp_rf; rels. Qed.
Lemma rmw_in_po_loc WF: rmw ⊆ po ∩ same_loc.
Proof using. by rewrite (loceq_same_loc (loceq_rmw WF)), (rmw_in_po WF). Qed.
Lemma rf_irr WF: irreflexive rf.
Proof using. rewrite (wf_rfD WF); type_solver. Qed.
Lemma co_co WF: co ⨾ co ⊆ co.
Proof using. apply rewrite_trans, WF. Qed.

Lemma wf_rmwf WF: functional rmw.
Proof using.
  rewrite (rmw_from_non_init WF).
  arewrite (rmw ⊆ rmw ∩ rmw).
  rewrite (wf_rmwi WF) at 1.
  rewrite (wf_rmwl WF) at 1.
  unfolder; ins; desc.
  forward eapply po_semi_total_l with (y:=y) (z:=z) as X; eauto; desf.
  all: try solve [exfalso; eauto].
  apply (wf_sil WF); split; ins; congruence.
Qed.

Lemma wf_rmw_invf WF: functional (rmw)⁻¹.
Proof using.
  rewrite (rmw_from_non_init WF).
  arewrite (rmw ⊆ rmw ∩ rmw).
  rewrite (wf_rmwi WF) at 1.
  rewrite (wf_rmwl WF) at 1.
  unfolder; ins; desc.
  forward eapply po_semi_total_r with (y:=y) (z:=z) as X; eauto; desf.
  all: try solve [exfalso; eauto].
  apply (wf_sil WF); split; ins; congruence.
Qed.

(******************************************************************************)
(** ** external-internal restrictions *)
(******************************************************************************)

Definition rfe := rf \ po.
Definition coe := co \ po.
Definition fre := fr \ po.
Definition rfi := rf ∩ po.
Definition coi := co ∩ po.
Definition fri := fr ∩ po.

Lemma ri_union_re r : r ≡ r ∩ po ∪ r \ po.
Proof using. unfolder; split; ins; desf; tauto. Qed.

Lemma rfi_union_rfe : rf ≡ rfi ∪ rfe.
Proof using. apply ri_union_re. Qed.
Lemma coi_union_coe : co ≡ coi ∪ coe.
Proof using. apply ri_union_re. Qed.
Lemma fri_union_fre : fr ≡ fri ∪ fre.
Proof using. apply ri_union_re. Qed.

Lemma ri_dom r d1 d2 (DOM: r ≡ ⦗d1⦘ ⨾ r ⨾ ⦗d2⦘) : r ∩ po ⊆ ⦗d1⦘ ⨾ r ∩ po ⨾ ⦗d2⦘.
Proof using. rewrite DOM at 1; basic_solver. Qed.
Lemma re_dom r d1 d2 (DOM: r ≡ ⦗d1⦘ ⨾ r ⨾ ⦗d2⦘) : r \ po ⊆ ⦗d1⦘ ⨾ (r \ po) ⨾ ⦗d2⦘.
Proof using. rewrite DOM at 1; basic_solver. Qed.

Lemma wf_rfiE WF: rfi ≡ ⦗E⦘ ⨾ rfi ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_rfE WF)). Qed.
Lemma wf_coiE WF: coi ≡ ⦗E⦘ ⨾ coi ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_coE WF)). Qed.
Lemma wf_friE WF: fri ≡ ⦗E⦘ ⨾ fri ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_frE WF)). Qed.
Lemma wf_rfeE WF: rfe ≡ ⦗E⦘ ⨾ rfe ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_rfE WF)). Qed.
Lemma wf_coeE WF: coe ≡ ⦗E⦘ ⨾ coe ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_coE WF)). Qed.
Lemma wf_freE WF: fre ≡ ⦗E⦘ ⨾ fre ⨾ ⦗E⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_frE WF)). Qed.
Lemma wf_rfiD WF : rfi ≡ ⦗W⦘ ⨾ rfi ⨾ ⦗R⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_rfD WF)). Qed.
Lemma wf_coiD WF : coi ≡ ⦗W⦘ ⨾ coi ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_coD WF)). Qed.
Lemma wf_friD WF : fri ≡ ⦗R⦘ ⨾ fri ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (ri_dom (wf_frD WF)). Qed.
Lemma wf_rfeD WF : rfe ≡ ⦗W⦘ ⨾ rfe ⨾ ⦗R⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_rfD WF)). Qed.
Lemma wf_coeD WF : coe ≡ ⦗W⦘ ⨾ coe ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_coD WF)). Qed.
Lemma wf_freD WF : fre ≡ ⦗R⦘ ⨾ fre ⨾ ⦗W⦘.
Proof using. split; [|basic_solver]. apply (re_dom (wf_frD WF)). Qed.

Lemma rfi_in_po : rfi ⊆ po.
Proof using. unfold rfi; basic_solver. Qed.

Lemma rfi_in_rf : rfi ⊆ rf.
Proof using. unfold rfi; basic_solver. Qed.

Lemma rfe_in_rf : rfe ⊆ rf.
Proof using. unfold rfe; basic_solver. Qed.

Lemma coi_in_po : coi ⊆ po.
Proof using. unfold coi; basic_solver. Qed.

Lemma coi_in_co : coi ⊆ co.
Proof using. unfold coi; basic_solver. Qed.

Lemma coe_in_co : coe ⊆ co.
Proof using. unfold coe; basic_solver. Qed.

Lemma ninit_rfi_same_tid : ⦗ set_compl is_init ⦘ ⨾ rfi ⊆ same_tid.
Proof using.
  arewrite (rfi ⊆ po).
  apply ninit_po_same_tid.
Qed.

Lemma coi_trans WF : transitive coi.
Proof using.
  apply transitiveI.
  generalize po_trans (co_trans WF). intros PO CO.
  unfold coi.
  unfolder. ins. desf.
  split; [eapply CO|eapply PO]; eauto.
Qed.

Lemma fri_in_po : fri ⊆ po.
Proof using. unfold fri; basic_solver. Qed.

Lemma fri_in_fr : fri ⊆ fr.
Proof using. unfold fri; basic_solver. Qed.

Lemma fre_in_fr : fre ⊆ fr.
Proof using. unfold fre; basic_solver. Qed.

Lemma fri_coi WF : fri ⨾ coi ⊆ fri.
Proof using.
  unfold fri, coi.
  unfolder. ins. desf.
  split.
  { apply fr_co; auto. basic_solver. }
  eapply po_trans; eauto.
Qed.

(******************************************************************************)
(** ** properties of external/internal relations *)
(******************************************************************************)

Lemma seq_ii r1 r2 r3 (A: r1 ⨾ r2 ⊆ r3): r1 ∩ po ⨾ r2 ∩ po ⊆ r3 ∩ po.
Proof using.
generalize po_trans.
unfolder in *; basic_solver 21.
Qed.

(*
Lemma re_ri WF  r r' (IRR: irreflexive r)  (IRR2: irreflexive (r ⨾ po))
  (N: r ⊆ r ⨾  ⦗ fun x => ~ is_init x ⦘): (r \ po) ⨾ (r' ∩ po) ⊆ r ⨾  r' \ po.
Proof using.
  rewrite N at 1.
  unfolder; ins; desf; splits; eauto.
  intro.
  forward eapply po_semi_total_r with (y:=x) (z:=z) as X; eauto; desf.
admit.
  eauto using po_irr.
  eapply po_irr; eauto.
  by desf; revert IRR2; basic_solver.
eby intro; subst; eapply IRR.
Qed.

Lemma ri_re WF  r r' (IRR: irreflexive r')  (IRR2: irreflexive (r' ⨾ po)):
 ⦗ fun x => ~ is_init x ⦘ ⨾ (r ∩ po) ⨾ (r' \ po) ⊆ r ⨾  r' \ po.
Proof using.
unfolder; ins; desf; splits; eauto.
intro.
eapply po_semi_total_l with (x:=x) (y:=z) (z:=y) in H4; eauto.
by desf; revert IRR2; basic_solver.
eby intro; subst; eapply IRR.
Qed.
 *)

Lemma rfi_in_poloc WF : rf ∩ po ⊆ restr_eq_rel loc po.
Proof using. rewrite wf_rfl; basic_solver 12. Qed.
Lemma coi_in_poloc WF : co ∩ po ⊆ restr_eq_rel loc po.
Proof using. rewrite wf_col; basic_solver 12. Qed.
Lemma fri_in_poloc WF : fr ∩ po ⊆ restr_eq_rel loc po.
Proof using. rewrite (loceq_same_loc (loceq_fr WF)).
unfolder; unfold Events.same_loc in *.
ins; desf; splits; eauto; congruence.
Qed.
Lemma rfi_in_poloc' WF : rfi ⊆ po ∩ same_loc.
Proof using. generalize (wf_rfl WF); unfold rfi; basic_solver 12. Qed.
Lemma coi_in_poloc' WF : coi ⊆ po ∩ same_loc.
Proof using. generalize (wf_col WF); unfold coi; basic_solver 12. Qed.
Lemma fri_in_poloc' WF : fri ⊆ po ∩ same_loc.
Proof using. generalize (wf_frl WF); unfold fri; basic_solver 12. Qed.

Lemma rf_rmw_po_minus_po WF: (rf ⨾ rmw ⨾ po^? ⨾ ⦗W⦘) \ po ⊆ rfe ⨾ rmw ⨾ po^? ⨾ ⦗W⦘.
Proof using.
rewrite (seq_minus_transitive po_trans).
unionL; [by unfold rfe; basic_solver 12|].
rewrite (rmw_in_po WF) at 1.
arewrite (po ⨾ po^? ⨾ ⦗W⦘ ⊆ po) by generalize po_trans; basic_solver 21.
relsf.
Qed.

Lemma rf_rmw_po_rt_rf WF: ((rf ⨾ rmw ⨾ po^? ⨾ ⦗W⦘)^* ⨾ rf) \ po ⊆ po^? ⨾ rfe ⨾ (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ rf)^*.
Proof using.
rewrite rtE; relsf.
rewrite rtE, minus_union_l.
relsf; unionL; [by unfold rfe; basic_solver 12|].
rewrite (seq_minus_transitive po_trans).
unionL; [|by unfold rfe; basic_solver 12].
unionR right.
rewrite (ct_minus_transitive po_trans).
arewrite ((rf ⨾ rmw ⨾ po^? ⨾ ⦗W⦘) ∩ po ⊆ po).
generalize po_trans; ins; relsf.
rewrite (rf_rmw_po_minus_po WF).
rewrite !seqA.
arewrite (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ (rf ⨾ rmw ⨾ po^? ⨾ ⦗W⦘)^* ⨾ rf ⊆ (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ rf )^+); [|done].
rewrite rtE; relsf; unionL; [by econs|].
rewrite ct_seq_swap, !seqA.
rewrite ct_begin at 2.
by rewrite inclusion_t_rt, !seqA.
Qed.

Lemma rmw_rf_ct WF : (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ rf)^+ ⊆ (rmw ⨾ po^? ⨾ ⦗W⦘ ∪ rfe)^+ ⨾ rf.
Proof using.
  apply inclusion_t_ind_left.
  { hahn_frame; vauto. }
  rewrite ct_begin; hahn_frame; relsf.
  arewrite (rfe ⊆ rf) at 2.
  seq_rewrite (rf_rf WF).
  relsf.
  rewrite rfi_union_rfe; relsf; unionL.
  { arewrite (rfi ⊆ po).
    rewrite (rmw_in_po WF) at 2.
    arewrite (po^? ⨾ ⦗W⦘ ⨾ po ⨾ po ⨾ po^? ⊆ po^?).
    generalize po_trans; basic_solver 21.
    basic_solver 21. }
  rewrite rt_begin at 2.
  rewrite rt_begin at 2.
  basic_solver 42.
Qed.

Lemma rmw_rf_rt_1 WF : (rmw ⨾ po^? ⨾ ⦗W⦘ ⨾ rf)^* ⊆ (rmw ⨾ po^? ⨾ ⦗W⦘ ∪ rfe)^* ⨾ rfi^?.
Proof using.
rewrite rtE; unionL; [basic_solver 12|].
rewrite (rmw_rf_ct WF).
rewrite rfi_union_rfe; relsf.
rewrite inclusion_t_rt.
relsf; unionL.
basic_solver 12.
rewrite rt_end at 2; basic_solver 12.
Qed.

(******************************************************************************)
(** ** exclusive reads/writes *)
(******************************************************************************)

Definition W_ex := codom_rel rmw.

Lemma W_ex_not_init WF : W_ex ⊆₁ set_compl is_init.
Proof using.
  unfolder. ins. desf.
  match goal with
  | H : W_ex _ |- _ => rename H into WEX
  end.
  destruct WEX as [z WEX].
  apply (rmw_in_po WF) in WEX.
  apply no_po_to_init in WEX. unfolder in WEX. desf.
Qed.

Lemma W_ex_in_W WF : W_ex ⊆₁ W.
Proof using.
unfold W_ex; rewrite (dom_r (wf_rmwD WF)); basic_solver.
Qed.

Lemma W_ex_in_E WF : W_ex ⊆₁ E.
Proof using.
  unfold W_ex. rewrite (dom_r (wf_rmwE WF)). basic_solver.
Qed.

Lemma W_ex_eq_EW_W_ex WF : W_ex ≡₁ E ∩₁ W ∩₁ W_ex.
Proof using.
  generalize (W_ex_in_E WF).
  generalize (W_ex_in_W WF).
  clear. basic_solver 10.
Qed.

Lemma rmw_W_ex : rmw ⊆ rmw ⨾ ⦗W_ex⦘.
Proof using.
  unfold W_ex; basic_solver.
Qed.

Lemma W_ex_si WF : ⦗W_ex⦘ ⨾ si ≡ si ⨾ ⦗W_ex⦘.
Proof using.
  unfold W_ex; unfolder; split; ins; desf.
  forward apply (proj2 (si_rmw WF) x0 y); unfolder; ins; desf; eauto.
  forward apply (proj2 (si_rmw WF) x0 x); unfolder; ins; desf; eauto using si_sym.
Qed.

(******************************************************************************)
(** ** rf ; rmw *)
(******************************************************************************)

Lemma wf_rfrmwE WF: rf ⨾ rmw ≡ ⦗ E ⦘ ⨾ (rf ⨾ rmw) ⨾ ⦗ E ⦘.
Proof using.
split; [|basic_solver].
rewrite (wf_rfE WF) at 1.
rewrite (wf_rmwE WF) at 1.
basic_solver.
Qed.

Lemma wf_rfrmwD WF: rf ⨾ rmw ≡ ⦗ W ⦘ ⨾ (rf ⨾ rmw) ⨾ ⦗ W ⦘.
Proof using.
split; [|basic_solver].
rewrite (wf_rfD WF) at 1.
rewrite (wf_rmwD WF) at 1.
basic_solver.
Qed.

Lemma wf_rfrmwl WF: rf ⨾ rmw ⊆ same_loc.
Proof using.
rewrite (wf_rfl WF), (wf_rmwl WF).
generalize same_loc_trans; basic_solver.
Qed.

Lemma wf_rfrmwf WF: functional (rf ⨾ rmw)⁻¹.
Proof using.
hahn_rewrite transp_seq.
by apply functional_seq; [apply wf_rmw_invf|apply WF].
Qed.

Lemma wf_rfirmwf WF : functional (rfi ⨾ rmw)⁻¹.
Proof using. arewrite (rfi ⊆ rf). eapply wf_rfrmwf; eauto. Qed.

Lemma wf_rfermwf WF : functional (rfe ⨾ rmw)⁻¹.
Proof using. arewrite (rfe ⊆ rf). eapply wf_rfrmwf; eauto. Qed.

Lemma rt_rf_rmw : (rf ⨾ rmw)^* ⊆ (rfi ⨾ rmw)^* ⨾ (rfe ⨾ rmw ⨾ (rfi ⨾ rmw)^*)^*.
Proof using.
  eapply rt_ind_left with (P:=fun r=> r); eauto with hahn.
  basic_solver 12.
  intros k H.
  rewrite !seqA, H.
  rewrite rfi_union_rfe; relsf; unionL.
  { rewrite rt_begin at 3.
    basic_solver 21. }
  rewrite (rt_begin (rfe ⨾ rmw ⨾ (rfi ⨾ rmw)^*)) at 2.
  basic_solver 21.
Qed.

Lemma rfi_rmw_in_po_same_loc_W WF : rfi ⨾ rmw ⊆ (po ∩ same_loc) ⨾ ⦗W⦘.
Proof using.
  rewrite (dom_r (wf_rmwD WF)).
  rewrite rfi_in_poloc', rmw_in_po_loc; auto.
  sin_rewrite rewrite_trans; [done|].
  apply po_same_loc_trans.
Qed.

Lemma rfi_rmw_in_po_loc WF : rfi ⨾ rmw ⊆ po ∩ same_loc.
Proof using.
  rewrite (rfi_rmw_in_po_same_loc_W WF). basic_solver.
Qed.

End Execution.

(******************************************************************************)
(** ** Tactics *)
(******************************************************************************)

#[global]
Hint Unfold rfe coe fre rfi coi fri : ie_unfolderDb.
Tactic Notation "ie_unfolder" :=  repeat autounfold with ie_unfolderDb in *.


Require Import Coq.Logic.Decidable.
Require Import PeanoNat.
Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Bool.
Require Import Nat.

Require Import LIR.maps.

Require Import LIR.lir.
Require Import LIR.pallene.

(*
** Convert a Pallene type to its corresponding Lir type
*)
Definition PT2IRT (t : PType) : IRType :=
  match t with
  | PTStar => IRTStar
  | PTNil => Tag2Type TgNil
  | PTInt => Tag2Type TgInt
  | PTArr _ => Tag2Type TgTbl
  | PTFun _ _ =>  Tag2Type TgFun
  end.

Lemma PT2IRTFun : forall T1 T2,
    PT2IRT (PTFun T1 T2) = IRTFun.
Proof. intros T1 T2. unfold PT2IRT. trivial. Qed.

(*
** Convert a Pallene environment to a Lir environment
*)
Fixpoint TP2TGamma (Γ : Map PType) : IREnvironment :=
  match Γ with
  | MEmpty => MEmpty
  | MCons var T Γ' => MCons var (PT2IRT T) (TP2TGamma Γ')
  end.

Lemma TP2TGammaIn : forall Γ var T,
    In Γ var = Some T -> In (TP2TGamma Γ) var = Some (PT2IRT T).
Proof.
  induction Γ; intros var T H; breakStrDec;
  auto;
  congruence.
Qed.

(*
** Casts an expression of type 't1' to one of type 't2'.
*)
Definition Cast (t1 t2 : IRType) (e : IRE) : IRE :=
  match t1, t2 with
  | IRTStar, IRTStar => e
  | IRTStar, Tag2Type t => IREBox t e
  | Tag2Type t, IRTStar => IREUnbox t e
  | Tag2Type t1', Tag2Type t2' => if dec_Tag t1' t2' then e
                                  else IREUnbox t1' (IREBox t2' e)
  end.

Notation "'<' t1 '<=' t2 '>' e" := (Cast t1 t2 e)
    (at level 50, t1 at next level, t2 at next level).

Lemma SubstCast : forall var e1 e2 T T',
  [var := e1] (<T <= T'> e2) = (<T <= T'> [var := e1] e2).
Proof.
  intros.
  destruct T; destruct T'; simpl; trivial.
  destruct (dec_Tag t t0); subst; trivial.
Qed.

Lemma StCastF : forall m e T T',
  m / e --> fail  ->
  m / (<T <= T'> e) --> fail.
Proof.
  intros.
  destruct T; destruct T'; simpl; eauto using stepF.
  destruct (dec_Tag t t0); eauto using stepF.
Qed.

Lemma CastStep : forall t1 t2 e m e' m',
  m / e --> m' / e' ->
  m / (<t1 <= t2> e) --> m' / (<t1 <= t2> e').
Proof.
  intros * HSt.
  unfold Cast.
  destruct t1; destruct t2; eauto using step.
  destruct (dec_Tag t t0); eauto using step.
Qed.

Lemma CastStepF : forall t1 t2 e m,
  m / e --> fail ->
  m / (<t1 <= t2> e) --> fail.
Proof.
  intros * HSt.
  unfold Cast.
  destruct t1; destruct t2; eauto using stepF.
  destruct (dec_Tag t t0); eauto using stepF.
Qed.

Lemma CongCast : forall t1 t2 e m e' m',
  m / e -->* m' / e' ->
  m / (<t1 <= t2> e) -->* m' / (<t1 <= t2> e').
Proof.
  intros * HSt.
  induction HSt; eauto using multistep, CastStep.
Qed.

(*
** Get the ground type of an expression; if correctly typed;
** otherwise assume nil. (The expression will always be correctly
** typed.)
*)
Definition GtypeOf Γ e : IRType :=
  match typeOf Γ e with
  | Some T => PT2IRT T
  | None => IRTNil
  end.

Lemma GtypeOfT : forall Γ e T, typeOf Γ e = Some T -> GtypeOf Γ e = PT2IRT T.
Proof. intros. unfold GtypeOf. rewrite H. trivial. Qed.

Lemma GtypeOfT' : forall Γ e T, Γ |p= e : T -> GtypeOf Γ e = PT2IRT T.
Proof. eauto using GtypeOfT, typeOfCorrect'. Qed.

Lemma tagStar2type : forall Γ e,
    GtypeOf Γ e = IRTStar -> typeOf Γ e = Some PTStar.
Proof.
  unfold GtypeOf.
  intros Γ e H.
  destruct (typeOf Γ e) eqn:?; try easy.
  destruct p; easy.
Qed.

(*
** Translation (compilation) of Pallene programs to Lir
*)
Fixpoint Pall2Lir (Γ : PEnvironment) (e : PE) : IRE :=
  match e with
  | PENil => IRENil
  | PENum a => IRENum a
  | PEPlus e1 e2 => IREPlus (Pall2Lir Γ e1) (Pall2Lir Γ e2)
  | PENew _ => IRENew
  | PETAddr a _ => IRETAddr a
  | PEFAddr a _ _ => IREFAddr a
  | PEGet e1 e2 =>
         <GtypeOf Γ e <= IRTStar>
           (IREGet (Pall2Lir Γ e1) (<IRTStar <= (Tag2Type TgInt)> (Pall2Lir Γ e2)))
  | PESet e1 e2 e3 =>
         (IRESet (Pall2Lir Γ e1)
                 (<IRTStar <= Tag2Type TgInt> (Pall2Lir Γ e2))
                 (<IRTStar <= GtypeOf Γ e3> Pall2Lir Γ e3))
  | PEVar var => IREVar var
  | PEFun var T body _  => let Γ' := (var |=> T; Γ) in
        IREFun var
          (IRELet var (PT2IRT T) (<PT2IRT T <= IRTStar> (IREVar var))
                     (<IRTStar <= GtypeOf Γ' body> (Pall2Lir Γ' body)))
  | PELet var T init body =>
      IRELet var (PT2IRT T) (Pall2Lir Γ init) (Pall2Lir (var |=> T; Γ) body)
  | PEApp e1 e2 => <GtypeOf Γ e <= IRTStar>
         (IREApp (Pall2Lir Γ e1)
                  (<IRTStar <= (GtypeOf Γ e2)> Pall2Lir Γ e2))
  | PECast e1 t => <PT2IRT t <= GtypeOf Γ e1> (Pall2Lir Γ e1)
  end.

Lemma invertCall : forall {Γ e1 e2 T1 T2},
  typeOf Γ e1 = Some (PTFun T1 T2) ->
  typeOf Γ e2 = Some T1 ->
  typeOf Γ (PEApp e1 e2) = Some T2.
Proof.
  intros Γ e1 r2 T1 T2 H1 H2.
  simpl. rewrite H1. rewrite H2.
  destruct (dec_TP T1 T1); congruence.
Qed.

Lemma invertFun : forall {Γ e1 e2 T1 T2},
    typeOf Γ e1 = Some (PTFun T1 T2) ->
    GtypeOf Γ (PEApp e1 e2) = IRTStar ->
    T2 = PTStar.
Proof.
  intros Γ e1 e2 T1 T2 H1 H2.
  unfold GtypeOf in H2.
  destruct (typeOf Γ (PEApp e1 e2)) eqn:?; try easy.
  apply typeOfCorrect'' in H1.
  apply typeOfCorrect'' in Heqo.
  destruct p; try easy.
  inversion Heqo; subst.
  apply (PTypeUnique _ _ _ _ H1) in H4.
  congruence.
Qed.

Ltac breakTagOf :=
  match goal with
  [H: typeOf _ ?E = Some ?T |- context C [GtypeOf _ ?E] ] =>
    apply GtypeOfT in H; rewrite H; destruct (PT2IRT T) eqn:?;
    eauto using IRTyping
  end.

Lemma PT2IRTag : forall {tg T},
  PT2IRT T = Tag2Type tg -> T <> PTStar.
Proof.
  intros * Heq HCnt.
  destruct T; discriminate.
Qed.

Lemma PTStarB : forall (T : PType),
    PT2IRT T = IRTStar -> T = PTStar.
Proof.
  intros T H.
  destruct T; inversion H; easy.
Qed.

Ltac T2Star :=
  repeat match goal with
  |[H: PT2IRT _ = IRTStar |- _] => rewrite (PTStarB _ H) in *
  end.

Lemma typeStar : forall {Γ e T},
    typeOf Γ e = Some T -> GtypeOf Γ e = IRTStar -> T = PTStar.
Proof.
  intros Γ e T HT Htg.
  unfold GtypeOf in Htg.
  rewrite HT in Htg.
  auto using PTStarB.
Qed.

Lemma typeTag : forall {Γ e T tg},
    typeOf Γ e = Some T ->
    GtypeOf Γ e = Tag2Type tg ->
    PT2IRT T = Tag2Type tg.
Proof.
  intros Γ e T tg HT Htg.
  unfold GtypeOf in Htg.
  rewrite HT in Htg.
  auto.
Qed.

(*
** Compilation of well-typed programs results in well-typed code
*)
Theorem Pall2LirWellTyped : forall Γ Γ' (e : PE) T T',
    Γ |p= e : T ->
    TP2TGamma Γ = Γ' ->
    PT2IRT T = T' ->
    Γ' |= (Pall2Lir Γ e) : T'.
Proof with eauto using IRTyping.
  intros * H Eq1 Eq2. subst.
  induction H; simpl in *;
  eauto using IRTyping, TP2TGammaIn;
  repeat match goal with
  | [H: PTyping ?G ?E ?T |- _] =>
      apply typeOfCorrect in H
  end.

  - (* Get *)
    unfold GtypeOf. simpl. rewrite H. rewrite H0.
    destruct (PT2IRT T) eqn:?; simpl; eauto using IRTyping.

  - (* Set *)
    unfold GtypeOf. rewrite H1.
    destruct (PT2IRT T) eqn:?; simpl; eauto using IRTyping.

  - (* Fun *)
    apply IRTyFun. eapply IRTyLet.
    + destruct (GtypeOf (var |=> Tvar; Γ)) eqn:?; subst.
      * apply IRTyBox.
        eapply inclusion_typing.
        ** unfold GtypeOf in Heqi. rewrite H in Heqi.
           rewrite <- Heqi. eauto.
        ** eapply inclusion_shadow'.
      *  unfold GtypeOf in Heqi. rewrite H in Heqi.
        rewrite Heqi in IHPTyping.
        simpl in IHPTyping.
        eapply inclusion_typing; eauto.
        apply inclusion_shadow'.
    + unfold Cast.
      destruct (PT2IRT Tvar) eqn:?.
      * apply IRTyUnbox.
        ** trivial.
        ** apply IRTyVar. apply InEq.
      * subst. simpl.
        apply IRTyVar. apply InEq.

  - (* App *)
    destruct (GtypeOf Γ (PEApp e1 e2)) eqn:?.
    + specialize (invertCall H H0) as H2.
      unfold GtypeOf in Heqi. rewrite H2 in Heqi.
      simpl.
      apply IRTyUnbox; trivial.
      eapply IRTyApp; eauto.
      destruct (GtypeOf Γ e2) eqn:?.
      * apply IRTyBox.
        specialize (typeTag H0 Heqi0) as HTt.
        rewrite <- HTt. trivial.
      * replace T1 with PTStar in * by (symmetry; eauto using typeStar).
        trivial.
    + unfold Cast.
      specialize (invertFun H Heqi); intros; subst; simpl.
      destruct (GtypeOf Γ e2) eqn:?.
      * eapply IRTyApp; eauto using IRTyping.
        eapply IRTyBox.
        replace (Tag2Type t) with (PT2IRT T1); trivial.
        eauto using typeTag.
      * eapply IRTyApp; eauto using IRTyping.
        replace T1 with PTStar in * by (symmetry; eauto using typeStar).
        trivial.

  - (* Cast *)
    unfold Cast.
    destruct (PT2IRT T2) eqn:?;
    unfold GtypeOf;
    rewrite H;
    destruct (PT2IRT T1) eqn:?.
    + destruct (dec_Tag t t0); subst; trivial.
      eapply IRTyUnbox; trivial.
      eapply IRTyBox.
      trivial.
    + apply IRTyUnbox; trivial.
  + apply IRTyBox. trivial.
  + unfold PT2IRT in *.
    trivial.
Qed.

Lemma typeOfEq : forall Γ1 e1 Γ2 e2 T,
  Γ1 |p= e1 : T ->
  Γ2 |p= e2 : T ->
  typeOf Γ1 e1 = typeOf Γ2 e2.
Proof.
  intros * HTy1 HTy2.
  erewrite typeOfCorrect'; eauto.
  erewrite typeOfCorrect'; eauto.
Qed.

Lemma GtypeOfEq : forall Γ1 e1 Γ2 e2 T,
  Γ1 |p= e1 : T ->
  Γ2 |p= e2 : T ->
  GtypeOf Γ1 e1 = GtypeOf Γ2 e2.
Proof.
  intros * HTy1 HTy2.
  unfold GtypeOf.
  erewrite typeOfEq; eauto.
Qed.

Ltac GtypeOf2T :=
  repeat   (* replace GtypeOfs with theirs types *)
      (erewrite GtypeOfT';
       eauto 4 using PTyping, PinclusionType, inclusion_update,
                   Psubst_typing, inclusion_shadow, inclusion_permute,
                   PexpPreservation).

Lemma Pall2LirEEnv : forall Γ Γ' e T,
  Γ |p= e : T ->
  inclusion Γ Γ' ->
  Pall2Lir Γ e = Pall2Lir Γ' e.
Proof.
  intros * HTy HIn.
  generalize dependent Γ'.
  induction HTy; intros; subst; trivial;
  simpl;   (* expose GtypeOfs *)
  GtypeOf2T;
  repeat match goal with   (* do the rewrites from the hypotheses *)
  | [ H: _ -> _ -> _ = _ |- _] =>
     erewrite H; eauto using inclusion_update; clear H
  end.
Qed.

Lemma Psubst : forall Γ var Tvar e1 e2 te,
  (var |=> Tvar; Γ) |p= e2 : te ->
  MEmpty |p= e1 : Tvar ->
  Pall2Lir Γ ([var := e1]p e2) =
    [var := (Pall2Lir MEmpty e1)] (Pall2Lir (var |=> Tvar; Γ) e2).
Proof.
  intros * HTy2 HTy1.
  generalize dependent te.
  generalize dependent Γ.
  induction e2; intros * HTy2; trivial; inversion HTy2; subst;
  simpl;

  repeat match goal with   (* do the rewrites from the hypotheses *)
  | [ H: _ -> _ -> _ -> _ = _ |- _] =>
     erewrite H; eauto using inclusion_update, PTyping; clear H
  end.

  - GtypeOf2T.
    destruct (PT2IRT te); trivial.

  - simpl.
    GtypeOf2T.
    destruct (PT2IRT T); trivial.

  - breakStrDec.
    symmetry. eauto using Pall2LirEEnv, PinclusionType, inclusion_empty.

  - simpl.
    GtypeOf2T.
    destruct (PT2IRT te).
    + destruct t; simpl; destruct (PT2IRT T1); trivial.
    + simpl.
      destruct (PT2IRT T1); trivial.

   - breakStrDec; simpl.
     + GtypeOf2T.
       replace (Pall2Lir (s |=> p; (s |=> Tvar; Γ)) e2)
         with (Pall2Lir (s |=> p; Γ) e2); trivial.
       eauto using Pall2LirEEnv,  inclusion_shadow,
         PinclusionType, inclusion_shadow'.
     + destruct (PT2IRT p); subst.
       * GtypeOf2T.
         destruct t;
         simpl;
            f_equal;
            f_equal;
            breakStrDec;
           destruct (PT2IRT p0); simpl;
               f_equal;
                    replace (Pall2Lir (s |=> p; (var |=> Tvar; Γ)) e2)
                      with  (Pall2Lir (var |=> Tvar; (s |=> p; Γ)) e2);
                    eauto using Pall2LirEEnv, inclusion_permute,
                                   PinclusionType.
      * simpl.
        f_equal.
        f_equal.
        ** breakStrDec.
        ** GtypeOf2T.
           destruct (PT2IRT p0); simpl;
           f_equal;
           replace (Pall2Lir (s |=> p; (var |=> Tvar; Γ)) e2)
             with  (Pall2Lir (var |=> Tvar; (s |=> p; Γ)) e2);
           eauto using Pall2LirEEnv, inclusion_permute, PinclusionType.

  - destruct (string_dec var s) eqn:HVeq; subst.
    + simpl. f_equal;
       eauto using Pall2LirEEnv,  inclusion_shadow,
         PinclusionType, inclusion_shadow'.
    + simpl. f_equal; eauto.
      replace (Pall2Lir (s |=> p; (var |=> Tvar; Γ)) e2_2)
      with (Pall2Lir (var |=> Tvar; (s |=> p; Γ)) e2_2) by
           eauto using Pall2LirEEnv, inclusion_permute, PinclusionType.
      eauto using Pall2LirEEnv, inclusion_permute, PinclusionType.

  - simpl. GtypeOf2T.
    destruct (PT2IRT te); subst; destruct (PT2IRT T1); subst; simpl;
    try destruct (dec_Tag t t0); subst; eauto.
Qed.

Theorem PValueValue : forall e, PValue e -> Value (Pall2Lir MEmpty e).
Proof.
  intros * PV.
  induction PV; simpl; eauto using Value.
  destruct (GtypeOf MEmpty v); eauto using Value.
Defined.

Fixpoint MPall2Lir (m : PMem) : Mem :=
  match m with
  | PEmptyMem => EmptyMem
  | PUpdateT addr idx (PEV v ev) m =>
      UpdateT addr
              idx
              (EV (Pall2Lir MEmpty v) (PValueValue v ev))
              (MPall2Lir m)
  | PUpdateF addr var T body m =>
      UpdateF addr
              var
              (IRELet var (PT2IRT T) (<PT2IRT T <= IRTStar> (IREVar var))
                 (Pall2Lir (var |=> T; MEmpty) body))
              (MPall2Lir m)
  end.

Lemma MPall2LirCorrect : forall m,
  Pmem_correct m -> mem_correct (MPall2Lir m).
Proof.
  induction m; intros H; only 1: constructor;
  inversion H; subst.
  - destruct p. eauto using mem_correct, Pall2LirWellTyped.
  - constructor; auto.
    constructor.
    + eauto using inclusion_typing, inclusion_shadow', Pall2LirWellTyped.
    + destruct (PT2IRT p); eauto using IRTyping, InEq.
Qed.

Lemma sameFreeaux : forall m,
  Pfreshaux m = freshaux (MPall2Lir m).
Proof.
  induction m; trivial.
  - destruct p. simpl. congruence.
  - simpl. congruence.
Qed.

Lemma P2LfreshT : forall m m' free,
  (free, m') = PfreshT m ->
  (free, MPall2Lir m') = freshT (MPall2Lir m).
Proof.
  unfold PfreshT,  freshT.
  intros * HEq.
  induction m; injection HEq; intros; subst; trivial;
  try (destruct p); rewrite sameFreeaux; trivial.
Qed.

Lemma TagFromType : forall e T,
  MEmpty |p= e : T ->
  GtypeOf MEmpty e = PT2IRT T.
Proof.
  unfold GtypeOf. intros * HTy.
  replace (typeOf MEmpty e) with (Some T); trivial.
  symmetry; eauto using typeOfCorrect'.
Qed.

Lemma PreserveTagOf' : forall m e T m' e',
  Pmem_correct m ->
  m / e -p-> m' / e' ->
  MEmpty |p= e : T ->
  GtypeOf MEmpty e' = PT2IRT T.
Proof.
  intros * HM HSt HTy.
  eauto using TagFromType, PexpPreservation.
Qed.

Lemma PreserveTagOf : forall m e t m' e',
  Pmem_correct m ->
  MEmpty |p= e : t ->
  m / e -p-> m' / e' ->
  GtypeOf MEmpty e = GtypeOf MEmpty e'.
Proof.
  unfold GtypeOf. intros * HM HTy Hst.
  replace (typeOf MEmpty e') with (typeOf MEmpty e)
        by eauto using pstep, PexpPreservTypeOf.
  trivial.
Qed.

Opaque Index_dec.

Lemma PqueryT2 : forall {m a idx v},
  Pmem_correct m ->
  PqueryT a idx m = v ->
  queryT a (IREBox TgInt (IRENum idx)) (MPall2Lir m) = Pall2Lir MEmpty v.
Proof.
  intros * HMC HQr.
  generalize dependent v.
  induction HMC; intros * HEq.
  - simpl in HEq. subst. trivial.
  - destruct v.
    subst. simpl.
    breakIndexDec; subst; auto.
  - simpl. inversion HMC; subst; auto.
Qed.

Lemma PqueryF2 : forall {m a var T body body'},
  Pmem_correct m ->
  (var, T, body) = PqueryF a m ->
  (var, body') = queryF a (MPall2Lir m) ->
  body'= IRELet var (PT2IRT T) (< PT2IRT T <= IRTStar > IREVar var)
               (Pall2Lir (var |=> T; MEmpty) body).
Proof.
  intros * HMC.
  induction m; intros * HQr1 HQr2; inversion HMC; subst.
  - injection HQr1; injection HQr2; intros; subst; trivial.
  - destruct p. eauto.
  - simpl in *. destruct (Nat.eq_dec a a0); eauto.
    injection HQr1; injection HQr2; intros; subst; trivial.
Qed.

Lemma PqueryF2V : forall {m a var var' T body body'},
  Pmem_correct m ->
  (var, T, body) = PqueryF a m ->
  (var', body') = queryF a (MPall2Lir m) ->
  var = var'.
Proof.
  intros * HMC.
  induction m; intros * HQr1 HQr2; inversion HMC; subst.
  - injection HQr1; injection HQr2; intros; subst; trivial.
  - destruct p. eauto.
  - simpl in *. destruct (Nat.eq_dec a a0); eauto.
    injection HQr1; injection HQr2; intros; subst; trivial.
Qed.

Lemma PQueryQuery : forall {s type body a m},
  Pmem_correct m ->
  (s, type, body) = PqueryF a m ->
  (s, IRELet s (PT2IRT type) (< PT2IRT type <= IRTStar > IREVar s)
         (Pall2Lir (s |=> type; MEmpty) body)) = queryF a (MPall2Lir m).
Proof.
  intros * HM HEq.
  destruct (queryF a (MPall2Lir m)) eqn:HEq1.
  symmetry in HEq1.
  specialize (PqueryF2V HM HEq HEq1) as ?; subst.
  specialize (PqueryF2 HM HEq HEq1) as ?; subst.
  trivial.
Qed.

Lemma PCastBox : forall v T v' t,
  MEmpty |p= v : PTStar ->
  PValue v ->
  PCast v T = Some v' ->
  PT2IRT T = Tag2Type t ->
  Pall2Lir MEmpty v = IREBox t (Pall2Lir MEmpty v').
Proof.
  intros * HTy HV HCst Heq.
  assert (T <> PTStar) by (intros contra; subst; discriminate).
  specialize (ValStar _ HV HTy) as [v'' [Heq' HV']]; subst.
  simpl in *.
  assert (HCst': PCast v'' T = Some v') by (destruct T; easy).
  inversion HTy; subst.
  clear HCst HV HTy.
  generalize dependent T.
  generalize dependent t.
  generalize dependent T1.
  induction HV'; intros * HTy * HEq HNEq HCst.

  - destruct T; simpl in *; try discriminate.
    injection HEq; injection HCst; intros; subst. trivial.

  - destruct T; simpl in *; try discriminate.
    injection HEq; injection HCst; intros; subst. trivial.

  - destruct T0; simpl in *; try discriminate.
    injection HEq; injection HCst; intros; subst. trivial.

  - destruct T; simpl in *; try discriminate.
    injection HEq; injection HCst; intros; subst. trivial.

  - unfold GtypeOf.
    replace (typeOf MEmpty (PECast v PTStar)) with (Some T1)
      by (symmetry; eauto using typeOfCorrect').
    inversion HTy; subst.
    simpl.
    eapply IHHV'; clear IHHV'; eauto.
    subst. simpl in *.
    destruct T; trivial; discriminate.
Qed.

Lemma subsCast : forall var e T,
  [var := e] (< T <= IRTStar > IREVar var) =
  < T <= IRTStar > e.
Proof.
  intros.
  destruct T; breakStrDec.
Qed.

Lemma PCast2Star : forall {v v' T tg},
  PValue v ->
  MEmpty |p= v : T ->
  PT2IRT T = Tag2Type tg ->
  PCast v PTStar = Some v' ->
  Pall2Lir MEmpty v' = IREBox tg (Pall2Lir MEmpty v).
Proof.
  intros * HV HTy HEq HCast.
  specialize (PT2IRTag HEq) as ?.
  assert (v' = PECast v PTStar).
  { induction HV; simpl in *;
  injection HCast; try congruence.
  exfalso.
  inversion HTy; subst; eauto. }
  subst; simpl.
  GtypeOf2T.
  destruct T; only 1: easy;
  inversion HEq; subst; trivial.
Qed.

Lemma PCast2NStar : forall {v v' tg1 T1 tg2 T2},
  PValue v ->
  PT2IRT T1 = Tag2Type tg1 ->
  PT2IRT T2 = Tag2Type tg2 ->
  MEmpty |p= v : T1 ->
  PCast v T2 = Some v' ->
  tg1 = tg2.
Proof.
  intros * HV HEq1 HEq2 HTy HCst.
  destruct T1; only 1: (exfalso; eapply PT2IRTag in HEq1; easy);
  destruct T2; only 1: (exfalso; eapply PT2IRTag in HEq2; easy);
  inversion HEq1; inversion HEq2; subst; trivial;
  inversion HTy; subst; discriminate.
Qed.

Lemma castTags : forall v v' T1 T2 t,
  PValue v ->
  MEmpty |p= v : T1 ->
  PCast v T2 = Some v' ->
  PT2IRT T1 = Tag2Type t ->
  PT2IRT T2 = Tag2Type t ->
  Pall2Lir MEmpty v = Pall2Lir MEmpty v'.
Proof.
  intros * HV HTy HCst HEq1 HEq2.
  induction HV; inversion HTy; subst; inversion HEq1; subst;
  destruct T2; try discriminate;
  simpl in HCst; try congruence;
  injection HCst; intros; subst; trivial.
Qed.

Lemma castStar : forall v v' T t,
  PValue v ->
  MEmpty |p= v : T ->
  PCast v PTStar = Some v' ->
  PT2IRT T = Tag2Type t ->
  IREBox t (Pall2Lir MEmpty v) = Pall2Lir MEmpty v'.
Proof.
  intros * HV HTy HCst HEq.
  induction HV; inversion HTy; subst; inversion HEq; subst;
  simpl in HCst;
  injection HCst; intros; subst; trivial.
Qed.

Lemma castFStar : forall v v' T t,
  PValue v ->
  MEmpty |p= v : PTStar ->
  PCast v T = Some v' ->
  PT2IRT T = Tag2Type t ->
  (Pall2Lir MEmpty v) = IREBox t (Pall2Lir MEmpty v').
Proof.
  intros * HV HTy HCst HEq.
  induction HV; inversion HTy; subst.
  simpl.
  GtypeOf2T.
  assert (PCast v T = Some v') by (destruct T; easy).
  destruct (PT2IRT T1) eqn:?.
  - replace t with t0 by eauto using PCast2NStar.
    f_equal.
    destruct HV; simpl;
    destruct T; try easy;
      try (simpl in H; injection H; intros; subst; trivial);
      inversion H1; subst; discriminate.
  - T2Star.
    auto.
Qed.

Theorem SimPallLir : forall m e T m' e',
  Pmem_correct m ->
  MEmpty |p= e : T ->
  m / e -p-> m' / e' ->
  multistep (MPall2Lir m) (Pall2Lir MEmpty e)
            (MPall2Lir m') (Pall2Lir MEmpty e').
Proof.
  intros * HM HTy HSt.
  generalize dependent T.
  induction HSt; intros * HTy;
  inversion HTy; subst;

  (* instantiate induction hipothesis *)
  try match goal with
    | [H: Pmem_correct ?m -> forall _, PTyping MEmpty ?E _ -> _,
       HM: Pmem_correct ?m,
       HTy: PTyping MEmpty ?E _ |- _] =>
      specialize (H HM _ HTy)
  end;
  simpl;

  try (GtypeOf2T;
       simpl; eauto using step, multistep1, PValueValue, P2LfreshT,
              CongPlus1, CongPlus2, CongCast, CongGet1, CongUnbox,
              CongGet1, CongGet2, CongBox, CongLet; fail).

  - inversion H2; subst.
    erewrite <- PqueryT2; eauto.
    GtypeOf2T.
    2:{ eauto using PMCTy. }
    eauto using CongCast, multistep1, step, Value.

  - destruct (GtypeOf MEmpty e3); eauto using CongSet1.

  - destruct (GtypeOf MEmpty e3); eauto using CongSet2, CongBox, PValueValue.

  - GtypeOf2T.
    destruct (PT2IRT T0);
      eapply CongSet3; eauto using CongBox, PValueValue, Value.

 - eapply multistep1.
   eapply StSet.
   eauto using Value.

  - eapply multistep1.
    eapply StFun.
    fold Pall2Lir.
    unfold PfreshF in H.
    injection H; intros; subst.
    unfold freshF.
    rewrite sameFreeaux. trivial.

  - (* Let *)
    eapply multistep1.
    erewrite Psubst; eauto using step, PValueValue.

  - GtypeOf2T.
    destruct (PT2IRT T);
    eauto using CongUnbox, CongApp1.

  - GtypeOf2T.
    destruct (PT2IRT T);
      destruct (PT2IRT T1);
      eauto using CongUnbox, CongApp2, PValueValue, CongBox.

  - GtypeOf2T.
    2:{ eapply PTyLet.
        - eauto using PTyCast.
        - eapply PMCTyF; eauto. }
    inversion H4; subst.
    simpl.
    eapply CongCast.
    destruct (PT2IRT T0) eqn:?.
    + eapply MStMStep.
      * eapply StApp.
        ** eauto using PValueValue, Value.
        ** eapply PQueryQuery; eauto.
      * eapply MStMStep.
        ** eapply StLet; eauto using PValueValue, Value.
        ** simpl. destruct (string_dec var var); try easy.
           rewrite SubstCast. simpl.
           destruct (string_dec var var); try easy.
           simpl.
           destruct (PT2IRT type) eqn:?; simpl.
           *** destruct (dec_Tag t0 t) eqn:?; subst; simpl.
               ++ eapply multistep1. eauto using step, PValueValue.
               ++ eapply MStRefl.
           *** eapply MStRefl.

    + eapply MStMStep.
      * eapply StApp.
        ** eauto using PValueValue, Value.
        ** eapply PQueryQuery; eauto.
      * eapply MStMStep.
        ** eapply StLet; eauto using PValueValue, Value.
        ** simpl. destruct (string_dec var var); try easy.
           rewrite SubstCast. simpl.
           destruct (string_dec var var); try easy.
           simpl.
           eapply MStRefl.

  - GtypeOf2T.
    destruct (PT2IRT T0) eqn:?; destruct (PT2IRT T1) eqn:?; simpl;
    T2Star.
    + replace t0 with t in * by (symmetry; eauto using PCast2NStar).
      destruct (dec_Tag t t); try easy.
      erewrite castTags; eauto using multistep.
    + erewrite PCastBox; eauto using multistep1, step, PValueValue,
                                     CastValue.
    + erewrite <- PCast2Star; eauto using multistep.
    + rewrite CastToItsType in H1; trivial.
      replace v' with v by congruence.
      constructor.
Qed.

(*
** Simulation for Fails
*)

(*
** A cast to a type IR-equivalent to its onw type never fails.
*)
Lemma CastToItsIRType : forall v T T',
  PCast v T' = None ->
  MEmpty |p= v : T ->
  PValue v ->
  PT2IRT T = PT2IRT T'->
  False.
Proof.
  intros * HEq HTy HV.
  inversion HV; subst; inversion HTy; subst;
  destruct T' eqn:?; easy.
Qed.

Lemma CastToStar': forall v, PCast v PTStar = None -> False.
Proof.
  intros.
  specialize (CastToStar v) as [? ?].
  congruence.
Qed.

Ltac CastToStarNone :=
  try match goal with
  |[H: PCast _ PTStar = None |- _] =>
 exfalso; apply (CastToStar' _ H)
end.

(*
** Main lemma for fail simulation: A failed cast in Pallene will
** fail when translated to Lir.
*)
Lemma CastFail : forall {v} m {T T'},
  PValue v ->
  MEmpty |p= v : T ->
  PCast v T' = None ->
  (MPall2Lir m) / (< PT2IRT T' <= PT2IRT T > Pall2Lir MEmpty v) --> fail.
Proof.
  intros * HV HTy HC.
  induction HV; inversion HTy; subst;
  destruct T'; simpl in HC;
   (* easy cases *)
      (* impossible cases (PCast could not fail) *)
      try discriminate;
      (* cases that actually fail *)
      try (eapply StUnboxF; try easy; eauto using Value; fail);
   (* not so easy cases *)
   destruct T1; simpl; GtypeOf2T; simpl;
      (* specialize induction hypothesis *)
      try (specialize (IHHV H3 HC); simpl in IHHV; trivial);
      (* cases that actually fail *)
      try (eapply StUnboxF; auto using stepF, PValueValue; easy);
      (* impossible cases (PCast could not fail) *)
      try (exfalso; eauto using CastToItsIRType; fail).
 Qed.

(*
** 'CastFail' when original type is *
*)
Lemma CastFailStar : forall v m t T,
  PValue v ->
  MEmpty |p= v : PTStar ->
  PCast v T = None ->
  PT2IRT T = Tag2Type t ->
  (MPall2Lir m) /  (IREUnbox t (Pall2Lir MEmpty v)) --> fail.
Proof.
  intros * HV HTy HCst Heq.
  specialize (CastFail m HV HTy HCst) as ?.
  simpl in H. unfold Cast in H. rewrite Heq in H.
  trivial.
Qed.

(*
** Similar to 'CastFail', but pass through * when going from T to T'
*)
Lemma DoubleCastFail : forall v m T T',
  PCast v T' = None ->
  PValue v ->
  MEmpty |p= v : T  ->
  (MPall2Lir m) /
    (<PT2IRT T' <= IRTStar> (<IRTStar <= PT2IRT T> Pall2Lir MEmpty v)) --> fail.
Proof.
  intros * HCst HV HTy.
  destruct (PT2IRT T') eqn:?; T2Star.
  * destruct (PT2IRT T) eqn:?; simpl; T2Star.
    ** eapply StUnboxF; eauto using PValueValue.
       intros ?. subst.
       eapply CastToItsIRType; eauto. congruence.
    ** specialize (CastFail m HV HTy HCst) as ?.
       destruct (PT2IRT T'); inversion Heqi; subst; trivial.
  * CastToStarNone.
Qed.

Lemma WCast : forall t v,
      (match t with | Tag2Type t => IREBox t v | IRTStar => v end) =
      Cast IRTStar t v.
Proof. trivial. Qed.

Lemma CanonQuery : forall m a idx,
  Pmem_correct m ->
    exists (o : IRE) (t : Tag),
         Pall2Lir MEmpty (PqueryT a idx m) = IREBox t o /\ Value o.
Proof.
  intros * HM.
  specialize (PMCTy m a idx MEmpty HM) as ?.
  specialize (PMCValue m a idx) as ?.
  remember (PqueryT a idx m) as v.
  assert (MEmpty |= (Pall2Lir MEmpty v) : IRTStar)
    by eauto using Pall2LirWellTyped.
  assert (Value (Pall2Lir MEmpty v)) by eauto using PValueValue.
  specialize (valbox MEmpty (Pall2Lir MEmpty v) H1 H2)
     as [? [? [? [? ?]]]].
  eexists; eexists; eauto.
Qed.

Lemma SimPallLirF : forall m e T,
  Pmem_correct m ->
  MEmpty |p= e : T ->
  m / e -p-> fail ->
  multistepF (MPall2Lir m) (Pall2Lir MEmpty e).
Proof.
  intros * HM HTy HSt.
  generalize dependent T.
  induction HSt; intros * HTy;
  inversion HTy; subst;

  (* instantiate induction hipothesis *)
  try match goal with
    | [H: Pmem_correct ?m -> forall _, PTyping MEmpty ?E _ -> _,
       HM: Pmem_correct ?m,
       HTy: PTyping MEmpty ?E _ |- _] => specialize (H HM _ HTy)
    end;
    try (inversion IHHSt; subst;
         eauto 12 using multistepF, stepF, PValueValue, Value,
           CongCast, CastStepF,
           CongPlus1, CongPlus2, CongGet1, CongGet2, CongBox,
           CongSet1, CongSet2, CongSet3, CongApp1, CongApp2, CongLet;
         fail);
     simpl; GtypeOf2T;
       eauto using multistep, multistepF, CastFail.

Qed.


(** This file extends the HeapLang program logic with some derived laws (not
using the lifting lemmas) about arrays and prophecies.

For utility functions on arrays (e.g., freeing/copying an array), see
[heap_lang.lib.array].  *)

From stdpp Require Import fin_maps.
From iris.bi Require Import lib.fractional.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Export primitive_laws.
From iris.heap_lang Require Import tactics notation.
From iris.prelude Require Import options.

(** The [array] connective is a version of [mapsto] that works
with lists of values. *)

Definition array `{!heapGS_gen hlc Σ} (l : loc) (dq : dfrac) (vs : list val) : iProp Σ :=
  [∗ list] i ↦ v ∈ vs, (l +ₗ i) ↦{dq} v.

Notation "l ↦∗ dq vs" := (array l dq vs)
  (at level 20, dq custom dfrac  at level 1, format "l  ↦∗ dq  vs") : bi_scope.

(** We have [FromSep] and [IntoSep] instances to split the fraction (via the
[AsFractional] instance below), but not for splitting the list, as that would
lead to overlapping instances. *)

Section lifting.
Context `{!heapGS_gen hlc Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val → iProp Σ.
Implicit Types σ : state.
Implicit Types v : val.
Implicit Types vs : list val.
Implicit Types l : loc.
Implicit Types sz off : nat.

Global Instance array_timeless l q vs : Timeless (array l q vs) := _.

Global Instance array_fractional l vs : Fractional (λ q, l ↦∗{#q} vs)%I := _.
Global Instance array_as_fractional l q vs :
  AsFractional (l ↦∗{#q} vs) (λ q, l ↦∗{#q} vs)%I q.
Proof. split; done || apply _. Qed.

Lemma array_nil l dq : l ↦∗{dq} [] ⊣⊢ emp.
Proof. by rewrite /array. Qed.

Lemma array_singleton l dq v : l ↦∗{dq} [v] ⊣⊢ l ↦{dq} v.
Proof. by rewrite /array /= right_id Loc.add_0. Qed.

Lemma array_app l dq vs ws :
  l ↦∗{dq} (vs ++ ws) ⊣⊢ l ↦∗{dq} vs ∗ (l +ₗ length vs) ↦∗{dq} ws.
Proof.
  rewrite /array big_sepL_app.
  setoid_rewrite Nat2Z.inj_add.
  by setoid_rewrite Loc.add_assoc.
Qed.

Lemma array_cons l dq v vs : l ↦∗{dq} (v :: vs) ⊣⊢ l ↦{dq} v ∗ (l +ₗ 1) ↦∗{dq} vs.
Proof.
  rewrite /array big_sepL_cons Loc.add_0.
  setoid_rewrite Loc.add_assoc.
  setoid_rewrite Nat2Z.inj_succ.
  by setoid_rewrite Z.add_1_l.
Qed.

Global Instance array_cons_frame l dq v vs R Q :
  Frame false R (l ↦{dq} v ∗ (l +ₗ 1) ↦∗{dq} vs) Q →
  Frame false R (l ↦∗{dq} (v :: vs)) Q | 2.
Proof. by rewrite /Frame array_cons. Qed.

Lemma update_array l dq vs off v :
  vs !! off = Some v →
  ⊢ l ↦∗{dq} vs -∗ ((l +ₗ off) ↦{dq} v ∗ ∀ v', (l +ₗ off) ↦{dq} v' -∗ l ↦∗{dq} <[off:=v']>vs).
Proof.
  iIntros (Hlookup) "Hl".
  rewrite -[X in (l ↦∗{_} X)%I](take_drop_middle _ off v); last done.
  iDestruct (array_app with "Hl") as "[Hl1 Hl]".
  iDestruct (array_cons with "Hl") as "[Hl2 Hl3]".
  assert (off < length vs) as H by (apply lookup_lt_is_Some; by eexists).
  rewrite take_length min_l; last by lia. iFrame "Hl2".
  iIntros (w) "Hl2".
  clear Hlookup. assert (<[off:=w]> vs !! off = Some w) as Hlookup.
  { apply list_lookup_insert. lia. }
  rewrite -[in (l ↦∗{_} <[off:=w]> vs)%I](take_drop_middle (<[off:=w]> vs) off w Hlookup).
  iApply array_app. rewrite take_insert; last by lia. iFrame.
  iApply array_cons. rewrite take_length min_l; last by lia. iFrame.
  rewrite drop_insert_gt; last by lia. done.
Qed.

(** * Rules for allocation *)
Lemma mapsto_seq_array l dq v n :
  ([∗ list] i ∈ seq 0 n, (l +ₗ (i : nat)) ↦{dq} v) -∗
  l ↦∗{dq} replicate n v.
Proof.
  rewrite /array. iInduction n as [|n'] "IH" forall (l); simpl.
  { done. }
  iIntros "[$ Hl]". rewrite -fmap_S_seq big_sepL_fmap.
  setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
  setoid_rewrite <-Loc.add_assoc. iApply "IH". done.
Qed.

Lemma twp_allocN s E v n :
  (0 < n)%Z →
  [[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  [[{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hzs Φ) "_ HΦ". iApply twp_allocN_seq; [done..|].
  iIntros (l) "Hlm". iApply "HΦ".
  iDestruct (big_sepL_sep with "Hlm") as "[Hl $]".
  by iApply mapsto_seq_array.
Qed.
Lemma wp_allocN s E v n :
  (0 < n)%Z →
  {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  {{{ l, RET LitV (LitLoc l); l ↦∗ replicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (? Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN; [auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_allocN_vec s E v n :
  (0 < n)%Z →
  [[{ True }]]
    AllocN #n v @ s ; E
  [[{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hzs Φ) "_ HΦ". iApply twp_allocN; [ lia | done | .. ].
  iIntros (l) "[Hl Hm]". iApply "HΦ". rewrite vec_to_list_replicate. iFrame.
Qed.
Lemma wp_allocN_vec s E v n :
  (0 < n)%Z →
  {{{ True }}}
    AllocN #n v @ s ; E
  {{{ l, RET #l; l ↦∗ vreplicate (Z.to_nat n) v ∗
         [∗ list] i ∈ seq 0 (Z.to_nat n), meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (? Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN_vec; [auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

(** * Rules for accessing array elements *)
Lemma twp_load_offset s E l dq off vs v :
  vs !! off = Some v →
  [[{ l ↦∗{dq} vs }]] ! #(l +ₗ off) @ s; E [[{ RET v; l ↦∗{dq} vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_load with "Hl1"). iIntros "Hl1". iApply "HΦ".
  iDestruct ("Hl2" $! v) as "Hl2". rewrite list_insert_id; last done.
  iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_load_offset s E l dq off vs v :
  vs !! off = Some v →
  {{{ ▷ l ↦∗{dq} vs }}} ! #(l +ₗ off) @ s; E {{{ RET v; l ↦∗{dq} vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_load_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_load_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) :
  [[{ l ↦∗{dq} vs }]] ! #(l +ₗ off) @ s; E [[{ RET vs !!! off; l ↦∗{dq} vs }]].
Proof. apply twp_load_offset. by apply vlookup_lookup. Qed.
Lemma wp_load_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) :
  {{{ ▷ l ↦∗{dq} vs }}} ! #(l +ₗ off) @ s; E {{{ RET vs !!! off; l ↦∗{dq} vs }}}.
Proof. apply wp_load_offset. by apply vlookup_lookup. Qed.

Lemma twp_store_offset s E l off vs v :
  is_Some (vs !! off) →
  [[{ l ↦∗ vs }]] #(l +ₗ off) <- v @ s; E [[{ RET #(); l ↦∗ <[off:=v]> vs }]].
Proof.
  iIntros ([w Hlookup] Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_store with "Hl1"). iIntros "Hl1".
  iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_store_offset s E l off vs v :
  is_Some (vs !! off) →
  {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ <[off:=v]> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  [[{ l ↦∗ vs }]] #(l +ₗ off) <- v @ s; E [[{ RET #(); l ↦∗ vinsert off v vs }]].
Proof.
  setoid_rewrite vec_to_list_insert. apply twp_store_offset.
  eexists. by apply vlookup_lookup.
Qed.
Lemma wp_store_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  {{{ ▷ l ↦∗ vs }}} #(l +ₗ off) <- v @ s; E {{{ RET #(); l ↦∗ vinsert off v vs }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store_offset_vec with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_xchg_offset s E l off vs v v' :
  vs !! off = Some v →
  [[{ l ↦∗ vs }]] Xchg #(l +ₗ off) v' @ s; E [[{ RET v; l ↦∗ <[off:=v']> vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_xchg with "Hl1"). iIntros "Hl1".
  iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_xchg_offset s E l off vs v v' :
  vs !! off = Some v →
  {{{ ▷ l ↦∗ vs }}} Xchg #(l +ₗ off) v' @ s; E {{{ RET v; l ↦∗ <[off:=v']> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_xchg_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_xchg_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
  [[{ l ↦∗ vs }]] Xchg #(l +ₗ off) v @ s; E [[{ RET (vs !!! off); l ↦∗ vinsert off v vs }]].
Proof.
  setoid_rewrite vec_to_list_insert. apply twp_xchg_offset.
  by apply vlookup_lookup.
Qed.
Lemma wp_xchg_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v :
   {{{ ▷ l ↦∗ vs }}} Xchg #(l +ₗ off) v @ s; E {{{ RET (vs !!! off); l ↦∗ vinsert off v vs }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_xchg_offset_vec with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
  vs !! off = Some v' →
  v' = v1 →
  vals_compare_safe v' v1 →
  [[{ l ↦∗ vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (v', #true); l ↦∗ <[off:=v2]> vs }]].
Proof.
  iIntros (Hlookup ?? Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_cmpxchg_suc with "Hl1"); [done..|].
  iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_cmpxchg_suc_offset s E l off vs v' v1 v2 :
  vs !! off = Some v' →
  v' = v1 →
  vals_compare_safe v' v1 →
  {{{ ▷ l ↦∗ vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (v', #true); l ↦∗ <[off:=v2]> vs }}}.
Proof.
  iIntros (??? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off = v1 →
  vals_compare_safe (vs !!! off) v1 →
  [[{ l ↦∗ vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }]].
Proof.
  intros. setoid_rewrite vec_to_list_insert.
  apply twp_cmpxchg_suc_offset; [|done..].
  by apply vlookup_lookup.
Qed.
Lemma wp_cmpxchg_suc_offset_vec s E l sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off = v1 →
  vals_compare_safe (vs !!! off) v1 →
  {{{ ▷ l ↦∗ vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (vs !!! off, #true); l ↦∗ vinsert off v2 vs }}}.
Proof.
  iIntros (?? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc_offset_vec with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail_offset s E l dq off vs v0 v1 v2 :
  vs !! off = Some v0 →
  v0 ≠ v1 →
  vals_compare_safe v0 v1 →
  [[{ l ↦∗{dq} vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (v0, #false); l ↦∗{dq} vs }]].
Proof.
  iIntros (Hlookup HNEq Hcmp Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_cmpxchg_fail with "Hl1"); first done.
  { destruct Hcmp; by [ left | right ]. }
  iIntros "Hl1". iApply "HΦ". iDestruct ("Hl2" $! v0) as "Hl2".
  rewrite list_insert_id; last done. iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_cmpxchg_fail_offset s E l dq off vs v0 v1 v2 :
  vs !! off = Some v0 →
  v0 ≠ v1 →
  vals_compare_safe v0 v1 →
  {{{ ▷ l ↦∗{dq} vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (v0, #false); l ↦∗{dq} vs }}}.
Proof.
  iIntros (??? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_fail_offset with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off ≠ v1 →
  vals_compare_safe (vs !!! off) v1 →
  [[{ l ↦∗{dq} vs }]]
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  [[{ RET (vs !!! off, #false); l ↦∗{dq} vs }]].
Proof.
  intros. apply twp_cmpxchg_fail_offset; [|done..].
  by apply vlookup_lookup.
Qed.
Lemma wp_cmpxchg_fail_offset_vec s E l dq sz (off : fin sz) (vs : vec val sz) v1 v2 :
  vs !!! off ≠ v1 →
  vals_compare_safe (vs !!! off) v1 →
  {{{ ▷ l ↦∗{dq} vs }}}
    CmpXchg #(l +ₗ off) v1 v2 @ s; E
  {{{ RET (vs !!! off, #false); l ↦∗{dq} vs }}}.
Proof.
  intros. eapply wp_cmpxchg_fail_offset; [|done..].
  by apply vlookup_lookup.
Qed.

Lemma twp_faa_offset s E l off vs (i1 i2 : Z) :
  vs !! off = Some #i1 →
  [[{ l ↦∗ vs }]] FAA #(l +ₗ off) #i2 @ s; E
  [[{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }]].
Proof.
  iIntros (Hlookup Φ) "Hl HΦ".
  iDestruct (update_array l _ _ _ _ Hlookup with "Hl") as "[Hl1 Hl2]".
  iApply (twp_faa with "Hl1").
  iIntros "Hl1". iApply "HΦ". iApply "Hl2". iApply "Hl1".
Qed.
Lemma wp_faa_offset s E l off vs (i1 i2 : Z) :
  vs !! off = Some #i1 →
  {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
  {{{ RET LitV (LitInt i1); l ↦∗ <[off:=#(i1 + i2)]> vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa_offset with "H"); [by eauto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
  vs !!! off = #i1 →
  [[{ l ↦∗ vs }]] FAA #(l +ₗ off) #i2 @ s; E
  [[{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }]].
Proof.
  intros. setoid_rewrite vec_to_list_insert. apply twp_faa_offset.
  by apply vlookup_lookup.
Qed.
Lemma wp_faa_offset_vec s E l sz (off : fin sz) (vs : vec val sz) (i1 i2 : Z) :
  vs !!! off = #i1 →
  {{{ ▷ l ↦∗ vs }}} FAA #(l +ₗ off) #i2 @ s; E
  {{{ RET LitV (LitInt i1); l ↦∗ vinsert off #(i1 + i2) vs }}}.
Proof.
  iIntros (? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa_offset_vec with "H"); [by eauto..|]; iIntros "H HΦ".
  by iApply "HΦ".
Qed.

(** Derived prophecy laws *)

(** Lemmas for some particular expression inside the [Resolve]. *)
Lemma wp_resolve_proph s E (p : proph_id) (pvs : list (val * val)) v :
  {{{ proph p pvs }}}
    ResolveProph (Val $ LitV $ LitProphecy p) (Val v) @ s; E
  {{{ pvs', RET (LitV LitUnit); ⌜pvs = (LitV LitUnit, v)::pvs'⌝ ∗ proph p pvs' }}}.
Proof.
  iIntros (Φ) "Hp HΦ". iApply (wp_resolve with "Hp"); first done.
  iApply lifting.wp_pure_step_later; first done.
  iIntros "!> _". iApply wp_value. iIntros (vs') "HEq Hp". iApply "HΦ". iFrame.
Qed.

Lemma wp_resolve_cmpxchg_suc s E l (p : proph_id) (pvs : list (val * val)) v1 v2 v :
  vals_compare_safe v1 v1 →
  {{{ proph p pvs ∗ ▷ l ↦ v1 }}}
    Resolve (CmpXchg #l v1 v2) #p v @ s; E
  {{{ RET (v1, #true) ; ∃ pvs', ⌜pvs = ((v1, #true)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦ v2 }}}.
Proof.
  iIntros (Hcmp Φ) "[Hp Hl] HΦ".
  iApply (wp_resolve with "Hp"); first done.
  assert (val_is_unboxed v1) as Hv1; first by destruct Hcmp.
  iApply (wp_cmpxchg_suc with "Hl"); [done..|]. iIntros "!> Hl".
  iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.

Lemma wp_resolve_cmpxchg_fail s E l (p : proph_id) (pvs : list (val * val)) dq v' v1 v2 v :
  v' ≠ v1 → vals_compare_safe v' v1 →
  {{{ proph p pvs ∗ ▷ l ↦{dq} v' }}}
    Resolve (CmpXchg #l v1 v2) #p v @ s; E
  {{{ RET (v', #false) ; ∃ pvs', ⌜pvs = ((v', #false)%V, v)::pvs'⌝ ∗ proph p pvs' ∗ l ↦{dq} v' }}}.
Proof.
  iIntros (NEq Hcmp Φ) "[Hp Hl] HΦ".
  iApply (wp_resolve with "Hp"); first done.
  iApply (wp_cmpxchg_fail with "Hl"); [done..|]. iIntros "!> Hl".
  iIntros (pvs' ->) "Hp". iApply "HΦ". eauto with iFrame.
Qed.

End lifting.

Typeclasses Opaque array.


Require Crypto.Algebra.Hierarchy.
Require Import Crypto.Util.Notations.
(*Require Crypto.Curves.Montgomery.XZ.*)

Module MxDH. (* from RFC7748 *)
  Section MontgomeryLadderKeyExchange.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv} {Feq_dec:Decidable.DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "x ^ 2" := (x*x).
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Notation "2" := (1+1). Local Notation "4" := (2+2).

    Context {a b: F}. (* parameters of the Montgomery curve *)
    Context {nonsquare_aa_m4:~exists sqrt, sqrt^2 = a^2-4} {five_neq_zero:1+4<>0}.

    (* Implemention from RFC7748. Note that this differs from EFD and
       Montgomery '87 in the choice of which precomputed constant to use
       for [a] *)
    (* Ideally we would want to verify that this correspons to
       x-coordinate addition on the relevant elliptic curve, as
       specified by addition formulas in Montgomery coordinates.
       However, even if we did get to doing that, we still would not
       want to change the type of the ladder function to talk about
       points that are on the curve -- there are contexts where this
       can be, carefully, used with values that are not verified to
       be on the curve *)
    Context {a24:F} {a24_correct:4*a24 = a-2}.
    Section generic.
      Context (F4 : Type)
              (pair4 : F -> F -> F -> F -> F4)
              (let_in : F -> (F -> F4) -> F4).
      Local Notation "'llet' x := y 'in' z" := (let_in y (fun x => z)).
      Definition ladderstep_gen (X1:F) (P1 P2:F * F) : F4 :=
        let '(X2, Z2) := P1 in
        let '(X3, Z3) := P2 in
        llet A := X2+Z2 in
        llet AA := A^2 in
        llet B := X2-Z2 in
        llet BB := B^2 in
        llet E := AA-BB in
        llet C := X3+Z3 in
        llet D := X3-Z3 in
        llet DA := D*A in
        llet CB := C*B in
        llet X5 := (DA+CB)^2 in
        llet Z5 := X1*(DA-CB)^2 in
        llet X4 := AA*BB in
        llet Z4 := E*(AA + a24*E) in
        pair4 X4 Z4 X5 Z5.
    End generic.

    (** TODO: Make this the only ladderstep? *)
    Definition ladderstep_other_assoc (X1:F) (P1 P2:F*F) : F*F*F*F :=
      Eval cbv beta delta [ladderstep_gen] in
        @ladderstep_gen
            (F*F*F*F)
            (fun X3 Y3 Z3 T3 => (X3, Y3, Z3, T3))
            (fun x f => let y := x in f y)
            X1 P1 P2.

    Definition ladderstep (X1:F) (P1 P2:F*F) : (F*F)*(F*F) :=
      Eval cbv beta delta [ladderstep_gen] in
        @ladderstep_gen
            ((F*F)*(F*F))
            (fun X3 Y3 Z3 T3 => ((X3, Y3), (Z3, T3)))
            (fun x f => let y := x in f y)
            X1 P1 P2.

    (*Import Curves.Montgomery.XZ.
    Goal forall X1 P1 P2, Logic.eq (ladderstep X1 P1 P2) (@M.xzladderstep F Fadd Fsub Fmul a24 X1 P1 P2).
    Proof.
      intros ? [? ?] [? ?].
      reflexivity.
    Qed.*)

    Context {cswap:bool->F*F->F*F->(F*F)*(F*F)}.

    Fixpoint downto_iter (i:nat) : list nat :=
      match i with
      | Datatypes.S i' => cons i' (downto_iter i')
      | O => nil
      end.

    Definition downto {state} init count (step:state->nat->state) : state :=
      List.fold_left step (downto_iter count) init.

    Local Notation xor := Coq.Init.Datatypes.xorb.

    (* Ideally, we would verify that this corresponds to x coordinate
    multiplication *)
    Definition montladder bound (testbit:nat->bool) (u:F) :=
      let '(P1, P2, swap) :=
          downto
            ((1, 0), (u, 1), false)
            bound
            (fun state i =>
               let '(P1, P2, swap) := state in
               let s_i := testbit i in
               let swap := xor swap s_i in
               let '(P1, P2) := cswap swap P1 P2 in
               let swap := s_i in
               let '(P1, P2) := ladderstep u P1 P2 in
               (P1, P2, swap)
            ) in
      let '((x, z), _) := cswap swap P1 P2 in
      x * Finv z.
  End MontgomeryLadderKeyExchange.
End MxDH.

(* see [Test.Curve25519SpecTestVectors] for sanity-checks *)