From Perennial.program_proof Require Import grove_prelude.
From iris.base_logic Require Export lib.ghost_var.
From Perennial.program_proof.grove_shared Require Import urpc_proof urpc_spec.
From Goose.github_com.mit_pdos.gokv Require Import tutorial.

Module decision.
  Inductive t := Unknown | Commit | Abrt.
  Definition is_byte (x:t) (b: u8) :=
    match x with
    | Unknown => b = U8 0
    | Commit => b = U8 1
    | Abrt => b = U8 2
    end.
End decision.

(* PLAN:

- start by giving the participant a spec
- will have a single piece of ghost state for the global preferences

One gname for each participant
participant ghost state is a single agree(bool) for its preference

also a global decision ghost variable that reflects all of the preferences

Three parallel lists at the coordinator:
- physical list of decisions
- physical list of participant clerks
- ghost list of participant gnames

coordinator's one-shot decision

 *)

Module global_names.
  Record t :=
    mk { decision: gname; }.
End global_names.

Module participant_names.
  Record t :=
    mk { preference: gname;
         urpc: server_chan_gnames; }.
End participant_names.

Module coordinator_names.
  Record t :=
    mk { participants: list gname;
         globals: global_names.t;
        }.
End coordinator_names.

Section iris.
  Context `{!heapGS Σ}.
  Context `{!urpcregG Σ}.
  Context `{inG Σ (agreeR boolO)}.

  Definition is_preference (γ: participant_names.t) (pref: bool) : iProp Σ :=
    own γ.(participant_names.preference) (to_agree pref).

  Definition is_decision (γ: coordinator_names.t) (decision: bool) : iProp Σ :=
    own γ.(coordinator_names.globals).(global_names.decision) (to_agree decision).

  Program Definition GetPreference_spec (γ: participant_names.t)
    : list u8 → (list u8 -d> iProp Σ) -d> iProp Σ :=
    λ reqData, λne (Φ: list u8 -d> iPropO Σ),
      (* ignore request *)
      (∀ (pref: bool), is_preference γ pref -∗
      Φ (if pref then [U8 1] else [U8 0]))%I.
  Next Obligation. solve_proper. Defined.

  Definition is_participant_host (γ: participant_names.t) (host:u64) : iProp Σ :=
    "#H0" ∷ handler_spec γ.(participant_names.urpc) host (U64 0) (GetPreference_spec γ) ∗
    "#Hdom" ∷ handlers_dom γ.(participant_names.urpc) {[ (U64 0) ]}.

  Definition is_participant_clerk (ck: loc) (γ: participant_names.t) : iProp Σ :=
    ∃ (cl:loc) host,
      "#client" ∷ readonly (ck ↦[ParticipantClerk :: "client"] #cl) ∗
      "#Hhost" ∷ is_participant_host γ host ∗
      "#His_cl" ∷ is_uRPCClient cl host.

  Lemma wp_byteToPref (n: u8) :
    {{{ True }}}
      byteToPref #n
    {{{ (pref: bool), RET #pref; ⌜if decide (int.Z n = 1)%Z then pref = true else pref = false⌝ }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    wp_lam.
    wp_pures.
    iModIntro.
    iApply "HΦ".
    iPureIntro.
    destruct (decide _); subst.
    - rewrite bool_decide_eq_true //.
      f_equal.
      f_equal.
      admit.
    - rewrite bool_decide_eq_false //.
      admit.
  Admitted.

  Lemma wp_ParticipantClerk_GetPreference ck γ :
    is_participant_clerk ck γ -∗
    {{{ True }}}
      ParticipantClerk__GetPreference #ck
    {{{ (pref: bool), RET #pref;
        is_preference γ pref
    }}}.
  Proof.
    iIntros "#Hclerk".
    iIntros (Φ) "!> _ HΦ".

    wp_lam.

    wp_apply (wp_frame_wand with "HΦ").

    wp_apply wp_NewSlice. iIntros (req_s) "Hreq".
    wp_pures.
    wp_apply wp_NewSlice. iIntros (reply_s) "Hreply".
    rewrite replicate_0.
    wp_apply wp_ref_to.
    { val_ty. }
    iIntros (reply_l) "Hreply_l".
    wp_pures.
    iNamed "Hclerk".
    wp_loadField.

    wp_apply (wp_Client__Call2 with "[] [] [Hreq] Hreply_l").
    { iFrame "#". }
    { iNamed "Hhost".
      iFrame "#". }
    { iApply (is_slice_to_small with "Hreq"). }
    - iIntros "!> !>".
      cbn.
      iIntros (pref) "#Hpref _".
      iIntros (?) "reply_l Hrep_s".
      wp_step.
      wp_apply wp_Assume.
      iIntros "_". (* already true? *)
      wp_step.
      wp_load.
      wp_apply (wp_SliceGet _ _ _ _ _ _ _ (U8 (if pref then 1 else 0)%Z) with "[$Hrep_s]").
      { iPureIntro.
        destruct pref; reflexivity. }
      iIntros "Hrep_s".
      wp_pures.

      wp_apply wp_byteToPref.
      iIntros (pref').
      iIntros (Hpref').
      iIntros "HΦ".
      iApply "HΦ".

      assert (pref = pref').
      { (* U8/word nonsense *)
        revert Hpref'. destruct (decide _), pref; auto; exfalso.
        - admit. (* word failure; contradiction with e (after compute) *)
        - admit. (* word failure; contradiction with e (after compute) *)
      }

      subst; iFrame "#".
  Admitted.

  Definition is_coord_clerk (ck: loc) (γ: coordinator_names.t) : iProp Σ := True.

  Lemma wp_CoordinatorClerk_GetDecision ck γ :
    is_coord_clerk ck γ -∗
    {{{ True }}}
      CoordinatorClerk__GetDecision #ck
    {{{ (decision: decision.t) (b: u8), RET #b;
        ⌜decision.is_byte decision b⌝ ∗
        match decision with
        | decision.Commit => is_decision γ true
        | decision.Abrt => is_decision γ false
        | decision.Unknown => True
        end
    }}}.
  Proof.
  Admitted.

End iris.


From isla Require Import opsem.

Definition a7428 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 16%N)) Mk_annot :t:
  Smt (DefineConst 150%Z (Manyop (Bvmanyarith Bvor) [Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot; Unop (ZeroExtend 48%N) (Val (Val_Symbolic 0%Z) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R6" [] (RegVal_Base (Val_Symbolic 150%Z)) Mk_annot :t:
  Smt (DeclareConst 151%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 151%Z)) Mk_annot :t:
  Smt (DefineConst 152%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 151%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 152%Z)) Mk_annot :t:
  tnil
.


Require Import Recdef.
Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import ZArith.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.tweetNaclBase.
Require Import tweetnacl20140427.verif_salsa_base.

Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.Snuffle.
Require Import VST.floyd.library.

Definition CoreInSEP (data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte))
                     (v: val * val * val) : mpred :=
  match data with (Nonce, C, K) =>
  match v with (n, c, k) =>
   (SByte Nonce n) * (SByte C c) * (ThirtyTwoByte K k)
  end end.

Definition prepare_data
           (data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)) :=
match data with ((Nonce, C), K) =>
  match Nonce with (N1, N2, N3, N4) =>
  match C with (C1, C2, C3, C4) =>
  match K with ((K1, K2, K3, K4), (L1, L2, L3, L4)) =>
      map littleendian [C1; K1; K2; K3; K4; C2; N1; N2; N3; N4; C3; L1; L2; L3; L4; C4]
  end end end
end.

Lemma prepare_data_length x: length (prepare_data x) = 16%nat.
Proof. destruct x as [[s0 s1] [s2 s3]]. simpl.
  destruct s0 as [[[? ?] ?] ?].
  destruct s1 as [[[? ?] ?] ?].
  destruct s2 as [[[? ?] ?] ?].
  destruct s3 as [[[? ?] ?] ?]. reflexivity.
Qed.

Definition sumlist := combinelist _ Int.add.

Definition sumlist_Some:= combinelist _ Int.add.

Definition sumlist_SomeInv:= combinelist_SomeInv _ Int.add.

Definition sumlist_length:= combinelist_length _ Int.add.

Definition sumlist_symm:= combinelist_symm _ Int.add Int.add_commut.

Definition sumlist_char_nth:= combinelist_char_nth _ Int.add.

Definition sumlist_char_Znth:= combinelist_char_Znth _ Int.add.

Definition Snuffle20 x := bind (Snuffle 20 x) (fun y => sumlist y x).

Lemma Snuffle20_length s l: Snuffle20 s = Some l -> length s = 16%nat -> length l = 16%nat.
Proof. unfold Snuffle20, bind; intros. remember (Snuffle 20 s).
  destruct o; simpl.
    symmetry in Heqo. symmetry in H; rewrite sumlist_symm in H.
      rewrite (sumlist_length _ _ _ H).
      apply (Snuffle_length _ _ _ Heqo H0). inv H.
Qed.

Definition fcore_result h data l :=
  match Snuffle20 (prepare_data data)
  with None => False
     | Some x =>
             if Int.eq (Int.repr h) Int.zero
             then l=QuadChunks2ValList (map littleendian_invert x)
             else match data with ((Nonce, C), K) =>
                    match Nonce with (N1, N2, N3, N4) =>
                    match C with (C1, C2, C3, C4) =>
                    l = QuadByte2ValList (littleendian_invert (Int.sub (Znth 0 x)  (littleendian C1))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 5 x)  (littleendian C2))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 10 x) (littleendian C3))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 15 x) (littleendian C4))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 6 x)  (littleendian N1))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 7 x)  (littleendian N2))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 8 x)  (littleendian N3))) ++
                    QuadByte2ValList (littleendian_invert (Int.sub (Znth 9 x)  (littleendian N4)))
                    end end end
  end.

Definition OutLen h := if Int.eq (Int.repr h) Int.zero then 64 else 32.

Definition fcorePOST_SEP h data d l out :=
  CoreInSEP data d *
  data_at Tsh (tarray tuchar (OutLen h)) l out.

Definition f_core_POST d out h (data: SixteenByte * SixteenByte * (SixteenByte * SixteenByte) ) :=
EX l:_,
   PROP (fcore_result h data l)
   LOCAL ()
   SEP (fcorePOST_SEP h data d l out).

Definition core_spec :=
  DECLARE _core
   WITH c : val, k:val, h:Z,
        nonce:val, out:val, OUT:list val,
        data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)
   PRE [ _out OF tptr tuchar,
         _in OF tptr tuchar,
         _k OF tptr tuchar,
         _c OF tptr tuchar,
         _h OF tint ]
      PROP ()
      LOCAL (temp _in nonce; temp _out out;
             temp _c c; temp _k k; temp _h (Vint (Int.repr h)))
      SEP (CoreInSEP data (nonce, c, k);
           data_at Tsh (tarray tuchar (OutLen h)) OUT out)
  POST [ tvoid ] (f_core_POST (nonce, c, k) out h data).

Definition ld32_spec :=
  DECLARE _ld32
   WITH x : val, B:QuadByte
   PRE [ _x OF tptr tuchar ]
      PROP ()
      LOCAL (temp _x x)
      SEP (data_at Tsh (tarray tuchar 4) (QuadByte2ValList B) x)
  POST [ tuint ]
     PROP ()
     LOCAL (temp ret_temp (Vint (littleendian B)))
     SEP (QByte B x).

Definition st32_spec :=
  DECLARE _st32
   WITH x : val, u:int
   PRE [ _x OF tptr tuchar, _u OF tuint ]
      PROP ()
      LOCAL (temp _x x; temp _u (Vint u))
      SEP (data_at_ Tsh (tarray tuchar 4) x)
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (QByte (littleendian_invert u) x).

Definition L32_spec :=
  DECLARE _L32
   WITH x : int, c: int
   PRE [ _x OF tuint, _c OF tint ]
      PROP (0 < Int.signed c < 32) (*yes, c=Int.zero needs to be ruled out - it leads to undefined behaviour in the shift-right operation*)
      LOCAL (temp _x (Vint x); temp _c (Vint c))
      SEP ()
  POST [ tuint ]
     PROP ()
     LOCAL (temp ret_temp (Vint (Int.rol x c)))
     SEP ().

Definition bigendian64 (b c:QuadByte): int64 :=
  match b, c with (b0, b1, b2, b3), (c0, c1, c2, c3) =>
  Int64.repr
   (       Byte.unsigned c3 +
    2^8  * Byte.unsigned c2 +
    2^16 * Byte.unsigned c1 +
    2^24 * Byte.unsigned c0 +
    2^32 * Byte.unsigned b3 +
    2^40 * Byte.unsigned b2 +
    2^48 * Byte.unsigned b1 +
    2^56 * Byte.unsigned b0
    )
  end.

Definition dl64_spec :=
  DECLARE _dl64
   WITH x : val, B:QuadByte, C: QuadByte
   PRE [ _x OF tptr tuchar ]
      PROP ()
      LOCAL (temp _x x)
      SEP (data_at Tsh (tarray tuchar 8) (QuadByte2ValList B++QuadByte2ValList C) x)
  POST [ tulong ]
     PROP ()
     LOCAL (temp ret_temp (Vlong (bigendian64 B C)))
     SEP (data_at Tsh (tarray tuchar 8) (QuadByte2ValList B++QuadByte2ValList C) x).

Definition bigendian64_invert (w:int64) : QuadByte * QuadByte:=
    let w3 := Int64.unsigned w in
  let b3 := w3 / (2^56) in
    let w2 := Z.modulo w3 (2^56) in
  let b2 := w2 / (2^48) in
    let w1 := Z.modulo w2 (2^48) in
  let b1 := w1 / (2^40) in
    let w0 := Z.modulo w1 (2^40) in
  let b0 := w0 / (2^32) in
    let u3 := Z.modulo w0 (2^32) in
  let c3 := u3 / (2^24) in
    let u2 := Z.modulo u3 (2^24) in
  let c2 := u2 / (2^16) in
    let u1 := Z.modulo u2 (2^16) in
  let c1 := u1 / (2^8) in
    let c0 := Z.modulo u1 (2^8) in
  ((Byte.repr b3, Byte.repr b2, Byte.repr b1, Byte.repr b0),
   (Byte.repr c3, Byte.repr c2, Byte.repr c1, Byte.repr c0)).

Lemma bigendian64_inv: forall b c: QuadByte, bigendian64_invert (bigendian64 b c) = (b,c).
Proof. destruct b as [[[b3 b2] b1] b0]. destruct c as [[[c3 c2] c1] c0].
  unfold bigendian64_invert, bigendian64.
  destruct (Byte.unsigned_range_2 b0). destruct (Byte.unsigned_range_2 b1).
  destruct (Byte.unsigned_range_2 b2). destruct (Byte.unsigned_range_2 b3).
  destruct (Byte.unsigned_range_2 c0). destruct (Byte.unsigned_range_2 c1).
  destruct (Byte.unsigned_range_2 c2). destruct (Byte.unsigned_range_2 c3).
  assert (2 ^ 8 * Byte.unsigned c1 <= 2 ^ 8 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial.
  assert (2 ^ 16 * Byte.unsigned c2 <= 2 ^ 16 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial.
  assert (2 ^ 24 * Byte.unsigned c3 <= 2 ^ 24 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial.
  assert (2 ^ 32 * Byte.unsigned b0 <= 2 ^ 32 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial.
  assert (2 ^ 40 * Byte.unsigned b1 <= 2 ^ 40 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial.
  assert (2 ^ 48 * Byte.unsigned b2 <= 2 ^ 48 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial.
  assert (2 ^ 56 * Byte.unsigned b3 <= 2 ^ 56 * Byte.max_unsigned).
               apply Zmult_le_compat_l; trivial.
  assert (0 <= 2 ^ 8 * Byte.unsigned c1). apply Z.mul_nonneg_cancel_l; trivial.
  assert (0 <= 2 ^ 16 * Byte.unsigned c2). apply Z.mul_nonneg_cancel_l; trivial.
  assert (0 <= 2 ^ 24 * Byte.unsigned c3). apply Z.mul_nonneg_cancel_l; trivial.
  assert (0 <= 2 ^ 32 * Byte.unsigned b0). apply Z.mul_nonneg_cancel_l; trivial.
  assert (0 <= 2 ^ 40 * Byte.unsigned b1). apply Z.mul_nonneg_cancel_l; trivial.
  assert (0 <= 2 ^ 48 * Byte.unsigned b2). apply Z.mul_nonneg_cancel_l; trivial.
  assert (0 <= 2 ^ 56 * Byte.unsigned b3). apply Z.mul_nonneg_cancel_l; trivial.
  rewrite Int64.unsigned_repr.
  2:{ split. clear H0 H2 H4 H6 H8 H10 H12 H14.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
             apply OMEGA2; trivial.
            eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; eassumption.
            unfold Int64.max_unsigned; simpl. omega.
  }
  assert (0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 +
          2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0 + 2 ^ 40 * Byte.unsigned b1 +
          2 ^ 48 * Byte.unsigned b2 < 2 ^ 56).
              split. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2
                      + 2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0
                      + 2 ^ 40 * Byte.unsigned b1 + 2 ^ 48 * Byte.unsigned b2 <= 2 ^ 56 -1). 2: omega.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. simpl. omega.
  erewrite (Zmod_unique _ (2^56) (Byte.unsigned b3)); try eassumption.
     2:{ rewrite (Z.mul_comm (2^56)). rewrite Z.add_comm. reflexivity. }
  assert (0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 +
          2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0 + 2 ^ 40 * Byte.unsigned b1 < 2 ^ 48).
              split. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2
                      + 2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0
                      + 2 ^ 40 * Byte.unsigned b1 <= 2 ^ 48 -1). 2: omega.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption. simpl. omega.
  erewrite (Zmod_unique _ (2^48) (Byte.unsigned b2)); try eassumption.
     2:{ rewrite (Z.mul_comm (2^48)). rewrite Z.add_comm. reflexivity. }
  assert (0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 +
          2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0 < 2 ^ 40).
              split. apply OMEGA2; trivial. apply OMEGA2; trivial.  apply OMEGA2; trivial.  apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2
                      + 2 ^ 24 * Byte.unsigned c3 + 2 ^ 32 * Byte.unsigned b0 <= 2 ^ 40 -1). 2: omega.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. simpl. omega.
  erewrite (Zmod_unique _ (2^40) (Byte.unsigned b1)); try eassumption.
     2:{ rewrite (Z.mul_comm (2^40)). rewrite Z.add_comm. reflexivity. }
  assert (0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 +
          2 ^ 24 * Byte.unsigned c3 < 2 ^ 32).
              split. apply OMEGA2; trivial. apply OMEGA2; trivial. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2
                      + 2 ^ 24 * Byte.unsigned c3 <= 2 ^ 32 -1). 2: omega.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. apply Z.add_le_mono; try eassumption. simpl. omega.
  erewrite (Zmod_unique _ (2^32) (Byte.unsigned b0)); try eassumption.
     2:{ rewrite (Z.mul_comm (2^32)). rewrite Z.add_comm. reflexivity. }
  assert (0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 < 2 ^ 24).
              split. apply OMEGA2; trivial. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 + 2 ^ 16 * Byte.unsigned c2 <= 2 ^ 24 -1). 2: omega.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              apply Z.add_le_mono; try eassumption. simpl. omega.
  erewrite (Zmod_unique _ (2^24) (Byte.unsigned c3)); try eassumption.
     2:{ rewrite (Z.mul_comm (2^24)). rewrite Z.add_comm. reflexivity. }
  assert (0 <= Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 < 2 ^ 16).
             split. apply OMEGA2; trivial.
              assert (Byte.unsigned c0 + 2 ^ 8 * Byte.unsigned c1 <= 2 ^ 16 -1). 2: omega.
              eapply Z.le_trans. apply Z.add_le_mono; try eassumption.
              simpl. omega.
  erewrite (Zmod_unique _ (2^16) (Byte.unsigned c2)); try eassumption.
     2:{ rewrite (Z.mul_comm (2^16)). rewrite Z.add_comm. reflexivity. }
  erewrite (Zmod_unique _ (2^8) (Byte.unsigned c1)).
     2:{ rewrite (Z.mul_comm (2^8)). rewrite Z.add_comm. reflexivity. }
     2: apply Byte.unsigned_range.
  erewrite (Zdiv_unique _ _ (Byte.unsigned b3));
       [  | rewrite (Z.mul_comm (2^56)), Z.add_comm; reflexivity
          | assumption ].
  rewrite Byte.repr_unsigned.
  erewrite (Zdiv_unique _ _ (Byte.unsigned b2));
       [  | rewrite (Z.mul_comm (2^48)), Z.add_comm; reflexivity
          | assumption ].
  rewrite Byte.repr_unsigned.
  erewrite (Zdiv_unique _ _ (Byte.unsigned b1));
       [  | rewrite (Z.mul_comm (2^40)), Z.add_comm; reflexivity
          | assumption ].
  rewrite Byte.repr_unsigned.
  erewrite (Zdiv_unique _ _ (Byte.unsigned b0));
       [  | rewrite (Z.mul_comm (2^32)), Z.add_comm; reflexivity
          | assumption ].
  rewrite Byte.repr_unsigned.
  erewrite (Zdiv_unique _ _ (Byte.unsigned c3));
       [  | rewrite (Z.mul_comm (2^24)), Z.add_comm; reflexivity
          | assumption ].
  rewrite Byte.repr_unsigned.
  erewrite (Zdiv_unique _ _ (Byte.unsigned c2));
       [  | rewrite (Z.mul_comm (2^16)), Z.add_comm; reflexivity
          | assumption ].
  rewrite Byte.repr_unsigned.
  erewrite (Zdiv_unique _ _ (Byte.unsigned c1));
       [  | rewrite (Z.mul_comm (2^8)), Z.add_comm; reflexivity
          | ].
  rewrite Byte.repr_unsigned.
  rewrite Byte.repr_unsigned. trivial.
  apply Byte.unsigned_range.
Qed.

Definition ts64_spec :=
  DECLARE _ts64
   WITH x : val, u:int64
   PRE [ _x OF tptr tuchar, _u OF tulong ]
      PROP ()
      LOCAL (temp _x x; temp _u (Vlong u))
      SEP (data_at_ Tsh (tarray tuchar 8) x)
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (let (B, C) := bigendian64_invert u in
          data_at Tsh (tarray tuchar 8) (QuadByte2ValList B++QuadByte2ValList C) x).

Definition crypto_core_salsa20_spec :=
  DECLARE _crypto_core_salsa20_tweet
   WITH c : val, k:val,
        nonce:val, out:val,
        data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)
   PRE [ _out OF tptr tuchar,
         _in OF tptr tuchar,
         _k OF tptr tuchar,
         _c OF tptr tuchar ]
      PROP ()
      LOCAL (temp _in nonce; temp _out out;
             temp _c c; temp _k k)
      SEP ( CoreInSEP data (nonce, c, k);
            data_at_ Tsh (tarray tuchar 64) out)
  POST [ tint ]
       EX res:_,
       PROP (Snuffle20 (prepare_data data) = Some res)
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (CoreInSEP data (nonce, c, k);
            data_at Tsh (tarray tuchar 64) (QuadChunks2ValList (map littleendian_invert res)) out).

Definition hSalsaOut x :=
           QuadByte2ValList (littleendian_invert (Znth 0  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 5  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 10 x)) ++
           QuadByte2ValList (littleendian_invert (Znth 15 x)) ++
           QuadByte2ValList (littleendian_invert (Znth 6  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 7  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 8  x)) ++
           QuadByte2ValList (littleendian_invert (Znth 9  x)).

Definition crypto_core_hsalsa20_spec :=
  DECLARE _crypto_core_hsalsa20_tweet
   WITH c : val, k:val,
        nonce:val, out:val, OUT: list val,
        data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)
   PRE [ _out OF tptr tuchar,
         _in OF tptr tuchar,
         _k OF tptr tuchar,
         _c OF tptr tuchar ]
      PROP ()
      LOCAL (temp _in nonce; temp _out out;
             temp _c c; temp _k k)
      SEP (CoreInSEP data (nonce, c, k);
           data_at Tsh (tarray tuchar 32) OUT out)
  POST [ tint ]
       EX res:list int,
       PROP (Snuffle 20 (prepare_data data) = Some res)
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (CoreInSEP data (nonce, c, k); data_at Tsh (tarray tuchar 32) (hSalsaOut res) out).

Parameter SIGMA: SixteenByte.
Definition Sigma_vector : val -> mpred :=
  data_at Tsh (tarray tuchar 16) (SixteenByte2ValList SIGMA).

Fixpoint ZZ (zbytes: list byte) (n: nat): int * list byte :=
  match n with
   O => (Int.one, zbytes)
  | S k => match ZZ zbytes k with (u,zb) =>
             let v := (Int.unsigned u + (Byte.unsigned (Znth (Z.of_nat k+8) zb)))
             in (Int.shru (Int.repr v) (Int.repr 8),
                 upd_Znth (Z.of_nat k+8) zb (Byte.repr (Z.modulo v 256))) end

  end.

Fixpoint ZCont (r: nat) (zcont: list byte): list byte :=
  match r with
     O => zcont
   | S n => let zb := ZCont n zcont in
            let zz := ZZ zb (8:nat) in snd zz
  end.

Lemma ZCont0 bytes: ZCont O bytes = bytes. reflexivity. Qed.
Lemma ZContS bytes n: ZCont (S n) bytes = snd (ZZ (ZCont n bytes) 8). reflexivity. Qed.

Definition bytes_at x q i mbytes :=
match x with
  Vint _ => list_repeat (Z.to_nat i) (Byte.zero)
| _ => sublist q (q+i) mbytes
end.

Lemma Zlength_bytes_at x q i mbytes : 0<=q -> 0 <= i ->
  q + i <= Zlength mbytes -> Zlength (bytes_at x q i mbytes) = i.
Proof. intros. destruct x; simpl; try rewrite Zlength_sublist; try omega.
  rewrite Zlength_list_repeat; omega.
Qed.

Definition bxorlist := combinelist _ Byte.xor.
Definition Bl2VL (l: list byte) := map Vint (map Int.repr (map Byte.unsigned l)).

Definition message_at (mCont: list byte) (m:val): mpred :=
  match m with
    Vint i => !!(i=Int.zero) && emp
  | Vptr b z => data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m
  | _ => FF
  end.

Inductive CONTENT SIGMA K (mInit:val) (mCont zbytes:list byte): nat -> list byte -> list byte -> Prop :=
  CONT_zero: CONTENT SIGMA K mInit mCont  zbytes O zbytes nil
| CONT_succ: forall n zN resN ,
             CONTENT SIGMA K mInit mCont zbytes n zN resN ->
             forall d,
             SixteenByte2ValList d = Bl2VL (ZCont n zbytes) ->
             forall snuff srbytes Xor,
             Snuffle20 (prepare_data (d, SIGMA, K)) = Some snuff ->
             QuadChunks2ValList (map littleendian_invert snuff) =
                map Vint (map Int.repr (map Byte.unsigned srbytes)) ->
             bxorlist (bytes_at mInit (Z.of_nat n * 64) 64 mCont) srbytes = Some Xor ->
             CONTENT SIGMA K mInit mCont zbytes (S n) (snd (ZZ zN (8:nat))) (resN++Xor).

Lemma CONT_Zlength SIGMA K mInit mCont zbytes:
  forall n zB x,
   CONTENT SIGMA K mInit mCont zbytes n zB x ->
   Zlength x = (Z.of_nat n * 64)%Z.
Proof.
  induction n; intros; inv H. reflexivity.
  rewrite Zlength_app. erewrite IHn. 2: eassumption.
  unfold bxorlist in H5.
  apply combinelist_Zlength in H5. destruct H5. rewrite H, <- H0; clear H H0.
  apply Snuffle20_length in H3.
  specialize (QuadChunk2ValList_ZLength(map littleendian_invert snuff)).
  rewrite H4; clear H4. repeat rewrite Zlength_map. intros H; rewrite H; clear H.
  rewrite Zlength_correct, H3; clear H3. simpl.
  rewrite Pos2Z.inj_mul, Zpos_P_of_succ_nat, <- Zmult_succ_l_reverse. trivial.
  apply prepare_data_length.
Qed.

Lemma CONTCONT SIGMA K mInit mCont zbytes:
  forall n zB x,
   CONTENT SIGMA K mInit mCont zbytes n zB x ->
   ZCont n zbytes = zB.
Proof.
  induction n; intros; inv H.
  apply ZCont0.
  rewrite ZContS. erewrite IHn. 2: eassumption. trivial.
Qed.

Lemma ZZ_Zlength: forall n zbytes u U, ZZ zbytes n = (u,U) ->
      Zlength zbytes=16 -> Z.of_nat n <= 8 -> Zlength U = 16.
Proof. induction n; simpl; intros.
+ inv H. trivial.
+ remember (ZZ zbytes n). destruct p. symmetry in Heqp. inv H.
  rewrite Zpos_P_of_succ_nat in H1.
  apply IHn in Heqp; trivial; clear IHn.
  rewrite upd_Znth_Zlength; trivial.
  omega.
  omega.
Qed.

Lemma Zlength_ZCont: forall n zbytes, Zlength zbytes = 16 -> Zlength (ZCont n zbytes) = 16.
Proof.
  induction n; intros. rewrite ZCont0. trivial.
  rewrite ZContS. specialize (ZZ_Zlength 8 (ZCont n zbytes)); intros.
  remember (ZZ (ZCont n zbytes) 8). destruct p; simpl.
  apply (H0 _ _ (eq_refl _ )).
  apply IHn; trivial. simpl; omega.
Qed.

Lemma SixteenByte2ValList_exists bytes: Zlength bytes = 16 ->
  exists d, SixteenByte2ValList d = map Vint (map Int.repr (map Byte.unsigned bytes)).
Proof. intros.
  apply listD16 in H.
  destruct H as [v0 [v1 [v2 [v3 [v4 [v5 [v6 [v7 [v8
        [v9 [v10 [v11 [v12 [v13 [v14 [v15 V]]]]]]]]]]]]]]]].
  subst; simpl.
  exists ((v0, v1, v2, v3), (v4, v5, v6, v7), (v8, v9, v10, v11), (v12, v13, v14, v15)).
  rewrite SixteenByte2ValList_char. reflexivity.
Qed.

Definition ContSpec bInit SIGMA K mInit mCont zbytes  srbytes :=
    let n:= (Int64.unsigned bInit) / 64 in
    if zeq ((Int64.unsigned bInit) mod 64) 0
    then exists zbytesR, CONTENT SIGMA K mInit mCont zbytes (Z.to_nat n) zbytesR srbytes
    else exists zN resN d snuff bytes lastbytes(*zbytes*),
         CONTENT SIGMA K mInit mCont zbytes (Z.to_nat n) zN resN /\
             SixteenByte2ValList d = Bl2VL (ZCont (Z.to_nat n) zbytes) /\
             Snuffle20 (prepare_data (d, SIGMA, K)) = Some snuff /\
             QuadChunks2ValList (map littleendian_invert snuff) =
                map Vint (map Int.repr (map Byte.unsigned bytes)) /\
             bxorlist (bytes_at mInit (n * 64) ((Int64.unsigned bInit) mod 64) mCont)
                                (sublist 0 ((Int64.unsigned bInit) mod 64) bytes) = Some lastbytes /\
             (*zbytesR = (snd (ZZ zN (8:nat)))/\*) srbytes = (resN++lastbytes).

(*TODO: refine non-zero-case of this spec, relating COUT to mCont and K and Nonce*)
Definition crypto_stream_xor_postsep b (Nonce:SixteenByte) K mCont cLen nonce c m :=
  (if Int64.eq b Int64.zero
   then data_at_ Tsh (Tarray tuchar cLen noattr) c
   else (EX COUT:_, !!(exists zbytes, match Nonce with (Nnc0, Nnc1, _, _) =>
                SixteenByte2ValList
                  (Nnc0, Nnc1, (Byte.zero, Byte.zero, Byte.zero, Byte.zero),
                           (Byte.zero, Byte.zero, Byte.zero, Byte.zero)) =
                map Vint (map Int.repr (map Byte.unsigned zbytes))
                /\  ContSpec b SIGMA K m mCont zbytes COUT end)
           && data_at Tsh (Tarray tuchar cLen noattr) (Bl2VL COUT) c))
                    * SByte Nonce nonce
                    * message_at mCont m.

(*Precondition length mCont = Int64.unsigned b comes from textual spec in
  https://download.libsodium.org/doc/advanced/salsa20.html
  TODO: support the following part of the tetxual spec:
      m and c can point to the same address (in-place encryption/decryption).
     If they don't, the regions should not overlap.*)
Definition crypto_stream_salsa20_xor_spec :=
  DECLARE _crypto_stream_salsa20_tweet_xor
   WITH c : val, k:val, m:val, nonce:val, b:int64,
        Nonce : SixteenByte, K: SixteenByte * SixteenByte,
        mCont: list byte, gv: globals
   PRE [ _c OF tptr tuchar, _m OF tptr tuchar, _b OF tulong,
         _n OF tptr tuchar, _k OF tptr tuchar]
      PROP (Zlength mCont = Int64.unsigned b)
      LOCAL (temp _c c; temp _m m; temp _b (Vlong b);
             temp _n nonce; temp _k k; gvars gv)
      SEP ( SByte Nonce nonce;
            data_at_ Tsh (Tarray tuchar (Int64.unsigned b) noattr) c;
            ThirtyTwoByte K k;
            Sigma_vector (gv _sigma);
            message_at mCont m
            (*data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m*))
  POST [ tint ]
       PROP ()
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (Sigma_vector (gv _sigma); ThirtyTwoByte K k;
            crypto_stream_xor_postsep b Nonce K mCont (Int64.unsigned b) nonce c m).

Definition f_crypto_stream_xsalsa20_tweet_xor_spec :=
  DECLARE _crypto_stream_salsa20_tweet_xor
   WITH c : val, k:val, nonce:val, m:val, d:int64, mCont: list byte,
        Nonce : SixteenByte, Nonce2 : SixteenByte, K: SixteenByte * SixteenByte,
        gv: globals
   PRE [ _c OF tptr tuchar, _m OF tptr tuchar,  _d OF tulong,
         _n OF tptr tuchar, _k OF tptr tuchar]
      PROP (Zlength mCont = Int64.unsigned d)
      LOCAL (temp _c c; temp _m m; temp _d (Vlong d);
             temp _n nonce; temp _k k; gvars gv)
      SEP ( SByte Nonce nonce; SByte Nonce2 (offset_val 16 nonce);
            data_at_ Tsh (Tarray tuchar (Int64.unsigned d) noattr) c;
            ThirtyTwoByte K k;
            message_at mCont m;
            Sigma_vector (gv _sigma)
            (*data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m*))
  POST [ tint ]
       PROP ()
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (Sigma_vector (gv _sigma);
            EX HSalsaRes:_, crypto_stream_xor_postsep d Nonce2 HSalsaRes
              mCont (Int64.unsigned d)
              (offset_val 16 nonce) c m;
            data_at Tsh (Tarray tuchar 16 noattr) (SixteenByte2ValList Nonce) nonce;
            ThirtyTwoByte K k).

Definition f_crypto_stream_xsalsa20_tweet_spec :=
  DECLARE _crypto_stream_xsalsa20_tweet
   WITH c : val, k:val, nonce:val, d:int64,
        Nonce : SixteenByte, Nonce2 : SixteenByte, K: SixteenByte * SixteenByte,
        gv: globals
   PRE [ _c OF tptr tuchar,  _d OF tulong,
         _n OF tptr tuchar, _k OF tptr tuchar]
      PROP ()
      LOCAL (temp _c c; (*temp _m m;*) temp _d (Vlong d);
             temp _n nonce; temp _k k; gvars gv)
      SEP ( SByte Nonce nonce; SByte Nonce2 (offset_val 16 nonce);
            data_at_ Tsh (Tarray tuchar (Int64.unsigned d) noattr) c;
            ThirtyTwoByte K k;
            Sigma_vector (gv _sigma)
            (*data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m*))
  POST [ tint ]
       PROP ()
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (Sigma_vector (gv _sigma);
            EX HSalsaRes:_, crypto_stream_xor_postsep d Nonce2 HSalsaRes
              (list_repeat (Z.to_nat (Int64.unsigned d)) Byte.zero) (Int64.unsigned d)
              (offset_val 16 nonce) c nullval;
            data_at Tsh (Tarray tuchar 16 noattr) (SixteenByte2ValList Nonce) nonce;
            ThirtyTwoByte K k).
(*            crypto_stream_xor_postsep d Nonce K (list_repeat (Z.to_nat (Int64.unsigned d)) Byte.zero) (Int64.unsigned d) nonce c k nullval). *)

(*TODO: support the following part of the tetxual spec:
      m and c can point to the same address (in-place encryption/decryption).
     If they don't, the regions should not overlap.*)
Definition f_crypto_stream_salsa20_tweet_spec :=
  DECLARE _crypto_stream_salsa20_tweet
   WITH c : val, k:val, nonce:val, d:int64,
        Nonce : SixteenByte, K: SixteenByte * SixteenByte,
        (*mCont: list byte, *) gv: globals
   PRE [ _c OF tptr tuchar, (*_m OF tptr tuchar,*) _d OF tulong,
         _n OF tptr tuchar, _k OF tptr tuchar]
      PROP ((*Zlength mCont = Int64.unsigned b*))
      LOCAL (temp _c c; (*temp _m m;*) temp _d (Vlong d);
             temp _n nonce; temp _k k; gvars gv)
      SEP ( SByte Nonce nonce;
            data_at_ Tsh (Tarray tuchar (Int64.unsigned d) noattr) c;
            ThirtyTwoByte K k;
            Sigma_vector (gv _sigma)
            (*data_at Tsh (tarray tuchar (Zlength mCont)) (Bl2VL mCont) m*))
  POST [ tint ]
       PROP ()
       LOCAL (temp ret_temp (Vint (Int.repr 0)))
       SEP (Sigma_vector (gv _sigma);
            ThirtyTwoByte K k;
            crypto_stream_xor_postsep d Nonce K (list_repeat (Z.to_nat (Int64.unsigned d)) Byte.zero) (Int64.unsigned d) nonce c nullval).

Definition vn_spec :=
  DECLARE _vn
  WITH x:val, y:val, n:Z, xsh: share, ysh: share, xcont:list byte, ycont:list byte
  PRE [_x OF tptr tuchar, _y OF tptr tuchar, _n OF tint]
    PROP (readable_share xsh; readable_share ysh; 0<=n<= Int.max_unsigned)
    LOCAL (temp _x x; temp _y y; temp _n (Vint (Int.repr n)))
    SEP (data_at xsh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y)
  POST [tint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (if list_eq_dec Byte.eq_dec xcont ycont then 0 else -1))))
    SEP (data_at xsh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar n noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y).

Definition verify16_spec :=
  DECLARE _crypto_verify_16_tweet
  WITH x:val, y:val, n:Z, xsh: share, ysh: share, xcont:list byte, ycont:list byte
  PRE [_x OF tptr tuchar, _y OF tptr tuchar]
    PROP (readable_share xsh; readable_share ysh)
    LOCAL (temp _x x; temp _y y)
    SEP (data_at xsh (Tarray tuchar 16 noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar 16 noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y)
  POST [tint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (if list_eq_dec Byte.eq_dec xcont ycont then 0 else -1))))
    SEP (data_at xsh (Tarray tuchar 16 noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar 16 noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y).

Definition verify32_spec :=
  DECLARE _crypto_verify_32_tweet
  WITH x:val, y:val, n:Z, xsh: share, ysh: share, xcont:list byte, ycont:list byte
  PRE [_x OF tptr tuchar, _y OF tptr tuchar]
    PROP (readable_share xsh; readable_share ysh)
    LOCAL (temp _x x; temp _y y)
    SEP (data_at xsh (Tarray tuchar 32 noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar 32 noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y)
  POST [tint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (if list_eq_dec Byte.eq_dec xcont ycont then 0 else -1))))
    SEP (data_at xsh (Tarray tuchar 32 noattr) (map Vint (map Int.repr (map Byte.unsigned xcont))) x;
         data_at ysh (Tarray tuchar 32 noattr) (map Vint (map Int.repr (map Byte.unsigned ycont))) y).

Definition SalsaVarSpecs : varspecs := (_sigma, tarray tuchar 16)::nil.

Definition SalsaFunSpecs : funspecs :=
  ltac:(with_library prog (core_spec :: ld32_spec :: L32_spec::st32_spec::dl64_spec::ts64_spec::
                           crypto_core_salsa20_spec::crypto_core_hsalsa20_spec::
                           crypto_stream_salsa20_xor_spec::f_crypto_stream_salsa20_tweet_spec::
                           verify32_spec::verify16_spec::vn_spec::nil)).


Require Export veric.base.
Require Import veric.rmaps.
Require Import veric.compcert_rmaps.
Require Import veric.res_predicates.
Require Import veric.shares.
Require Import veric.tycontext.
Require Import veric.expr2.

Definition GHOSTspec (A: Type) (x: A) : spec :=
  fun sh loc =>
   allp (jam (eq_dec loc) (fun loc' =>
    yesat (SomeP (ConstType (A -> Prop)) (fun _ y => y = x))
             (FUN (nil,Tvoid) cc_default) sh loc') noat).

Definition ghostp {A: Type} (sh: share) (loc: address) (x: A) : mpred :=
  GHOSTspec A x sh loc.

Lemma ghostp_unique_sepcon:
    forall {A: Type} sh1 sh2 loc (x1 x2: A),
     ghostp sh1 loc x1 * ghostp sh2 loc x2 |-- |> !! (x1=x2).
Proof.
intros.
unfold ghostp, GHOSTspec.
intros w [w1 [w2 [? [? ?]]]].
intros w' ?.
simpl in H2.
apply laterR_level in H2.
generalize (join_level _ _ _ H); intros [? ?].
destruct (level w). inv H2.
hnf.
rename H2 into Hw'.
specialize (H0 loc). specialize (H1 loc).
rewrite jam_true in H0 by auto.
rewrite jam_true in H1 by auto.
destruct H0 as [p ?]. destruct H1 as [p' ?].
hnf in H0,H1.
apply (resource_at_join _ _ _ loc) in H.
rewrite H0 in H; rewrite H1 in H.
simpl in H.
(*rewrite H3 in H. rewrite H4 in H. *)
assert (SomeP (ConstType (A -> Prop))
            (fun (_ : list Type) (y : A) => y = x1) =
          SomeP (ConstType (A -> Prop))
            (fun (_ : list Type) (y : A) => y = x2))%pred.
clear - H.
match goal with |- ?B = ?C => forget B as b; forget C as c end.
inversion H; auto.
clear H.
apply SomeP_inj in H2.
pose proof (@equal_f A Prop _ _ (@equal_f (list Type) (A->Prop) _ _ H2 nil) x1).
simpl in H.
rewrite <- H; auto.
Qed.

Lemma ghostp_unique_andp:
    forall {A: Type} sh loc (x1 x2: A),
     ghostp sh loc x1 && ghostp sh loc x2 |-- |> !! (x1=x2).
Proof.
intros.
unfold ghostp, GHOSTspec.
intros w [? ?].
rename H0 into H1; rename H into H0.
specialize (H0 loc). specialize (H1 loc).
rewrite jam_true in H0 by auto.
rewrite jam_true in H1 by auto.
destruct H0 as [p H0]. destruct H1 as [p' H1].
hnf in H0,H1.
rewrite H0 in H1.
simpl in H1.
intros w' H2.
simpl in H2.
apply laterR_level in H2.
destruct (level w). inv H2.
hnf.
rename H2 into Hw'.
assert (SomeP (ConstType (A -> Prop))
            (fun (_ : list Type) (y : A) => y = x1) =
          SomeP (ConstType (A -> Prop))
            (fun (_ : list Type) (y : A) => y = x2))%pred.
clear - H1.
match goal with |- ?B = ?C => forget B as b; forget C as c end.
inversion H1; auto.
clear - H.
apply SomeP_inj in H.
pose proof (@equal_f A Prop _ _ (@equal_f (list Type) (A->Prop) _ _ H nil) x1).
rewrite <- H0; auto.
Qed.

Definition make_GHOSTspec:
  forall A (sh : share) (rsh: readable_share sh) loc (x: A) (lev: nat),
   exists m: rmap, GHOSTspec A x sh loc m /\ level m =  lev.
Proof.
 intros.
unfold GHOSTspec.
 assert (AV.valid (res_option oo
  (fun l => if eq_dec l loc
   then YES sh rsh (FUN(nil,Tvoid) cc_default)
             (SomeP (ConstType (A -> Prop))
                  (fun _ y => (y = x)))
   else NO Share.bot bot_unreadable))).
 intros b ofs.
 unfold res_option, compose.
 if_tac; auto.
 destruct (make_rmap _ H lev) as [phi [? ?]].
 extensionality l.
 unfold compose, resource_fmap; simpl.
 if_tac; auto.
 exists phi.
 split; auto.
 hnf.
 intro l.
 hnf.
 if_tac.
 subst l.
 hnf. exists rsh.
 hnf.
 rewrite H1. rewrite if_true. f_equal.
 auto.
 do 3 red. rewrite H1.
 rewrite if_false by auto.
 apply NO_identity.
Qed.

Lemma make_ghostp:
  forall A (x: A)  loc (lev: nat),
  exists m : rmap, ghostp Share.top loc x m /\ level m = lev.
Proof.
intros.
unfold ghostp.
destruct (make_GHOSTspec A Share.top readable_share_top loc x lev) as [m [? ?]].
exists m; split; auto.
Qed.


From iris.algebra Require Import excl.
From iris.base_logic.lib Require Import invariants.
From aneris.aneris_lang Require Import proofmode.
From aneris.prelude Require Import time.
From aneris.examples.rcb Require Import spec.
From aneris.examples.rcb.examples.broadcast_1_2 Require Import prog.

Section Resources.
  Context `{!anerisG Mdl Σ, inG Σ (exclR unitO), !RCB_events, !RCB_resources Mdl Σ}.

  Definition token (γ : gname) : iProp Σ := own γ (Excl ()).

  Lemma exclusive_token γ : token γ -∗ token γ -∗ False.
  Proof. iIntros "H1 H2". by iDestruct (own_valid_2 with "H1 H2") as %?. Qed.

  Definition Nsys := nroot.@"sys".

  (* The invariant satisfied by the two nodes.
     Only one node is broadcasting. The two broadcast messages are e1 and e2.
     Broadcasting each message requires tokens γS1 and γS2, respectively. *)
  Definition inv_sys γS1 γS2 : iProp Σ :=
    ∃ h, OwnGlobal h ∗
      (* Case 0: no message has been sent *)
      ((⌜ h = ∅ ⌝)
      (* Case 1: one message e1 has been sent, along with the token γS1. This token is used so that
         the message e1 is sent once. Conversely, while a user own the token, it knows that the
         message e1 has not yet been sent. *)
       ∨ (∃ e1, ⌜ h = {[ e1 ]} ⌝ ∗ ⌜ GE_payload e1 = #1 ⌝ ∗ token γS1)
      (* Case 1: another message e2 has been sent, along with the token γS2. This token is used so
         that the message e1 is sent once. Conversly, while a user own the token, it knows that the
         message e2 has not yet been sent. *)
       ∨ (∃ e1 e2, ⌜ h = {[ e1; e2 ]} ⌝ ∗
                   token γS1 ∗ token γS2 ∗
                   ⌜ GE_payload e1 = #1 ⌝ ∗ ⌜ GE_payload e2 = #2 ⌝ ∗
                   ⌜ vector_clock_lt (GE_vc e1) (GE_vc e2) ⌝)).
End Resources.


Require Export WellFormedness.
Require Import SyntaxProp.
Require Import TypesProp.
Require Import Shared.

(*
========================
Field and method lookup
========================
*)

Lemma wfProgram_wfMethodDecl :
  forall P t' c ms m mtd,
    wfProgram P t' ->
    methods P (TClass c) = Some ms ->
    methodLookup ms m = Some mtd ->
    wfMethodDecl P c mtd.
Proof with auto.
  introv wfP Hmethods mLookup.
  inv wfP.
  unfold methods in Hmethods.
  remember (classLookup (cds, ids, e) c) as cLookup.
  symmetry in HeqcLookup.
  destruct cLookup as [[c' i fs ms'] |]...
  inv_eq.
  assert (Heq : c = c') by
      (unfold classLookup in HeqcLookup;
       apply find_true in HeqcLookup;
       apply eqb_class_id_eq; auto).    (*!!changed beq_nat_eq to eqb_class_id_eq*)
  subst.
  lookup_forall as wfCls.
  inv wfCls.
  lookup_forall mtd as wfMtd...
Qed.

Corollary dyn_wfFieldLookup :
  forall P Gamma c F fs f t,
    wfFields P Gamma c F ->
    fields P (TClass c) = Some fs ->
    fieldLookup fs f = Some (Field f t) ->
    exists v, F f = Some v /\ P; Gamma |- (EVal v) \in t.
Proof with eauto.
  introv wfF Hfields fLookup.
  inv wfF. rewrite_and_invert...
Qed.

Hint Immediate dyn_wfFieldLookup.

(*
------------
Method sigs
------------
*)

Hint Constructors methodSigs.

Lemma extractSigs_sound :
  forall mtds m x t t',
    (exists e, methodLookup mtds m = Some (Method m (x, t) t' e)) <->
    methodSigLookup (extractSigs mtds) m = Some (MethodSig m (x, t) t').
Proof with eauto.
  intros. split.
  + gen t t' m x.
    induction mtds as [|[m [x t] t' e]]; simpl;
    introv H; inv H as [e' Hsigs]...
    cases_if... inv_eq.
  + gen t t' m x.
    induction mtds as [|[m [x t] t' e]]; simpl;
    introv mLookup; inv mLookup...
    cases_if; crush...
Qed.

Lemma methodSigs_deterministic :
  forall P t msigs1 msigs2,
    methodSigs P t msigs1 ->
    methodSigs P t msigs2 ->
    msigs1 = msigs2.
Proof with eauto.
  introv Hsigs1 Hsigs2.
  gen msigs2.
  induction Hsigs1; introv Hsigs2;
  inv Hsigs2; try(rewrite_and_invert)...
  rewrite IHHsigs1_1 with msigs3...
  rewrite IHHsigs1_2 with msigs4...
Qed.

Lemma methodSigs_wfType_exists :
  forall P t' t,
    wfProgram P t' ->
    (wfType P t <->
     exists msigs, methodSigs P t msigs).
Proof with eauto.
  introv [? ? ? wfCds wfIds wfExpr].
  split.
  + intros wfT.
    inv wfT as [c cLookup|i iLookup|]...
    - apply classLookup_not_none in cLookup as [i [fs [ms]]]...
    - apply interfaceLookup_not_none in iLookup.
      inv iLookup as [[msigs]|[i1 [i2]]]...
      * intros. lookup_forall as wfId. inv wfId...
  + intros Hex. destruct Hex as [msigs Hsigs].
    destruct t; inv Hsigs; constructor; crush.
Qed.

Lemma methodSigs_sub :
  forall P t t1 t2 m msigs1 msigs2 msig,
    wfProgram P t ->
    subtypeOf P t1 t2 ->
    methodSigs P t1 msigs1 ->
    methodSigs P t2 msigs2 ->
    methodSigLookup msigs2 m = Some msig ->
    methodSigLookup msigs1 m = Some msig.
Proof with eauto using
                 methodSigs_deterministic,
                 methodSigs_wfType_exists,
                 subtypeOf_wfTypeSub,
                 subtypeOf_wfTypeSup.
  introv [? ? ? ? wfCds wfIds wfExpr] Hsub
         Hsigs1 Hsigs2 Hsig.
  gen msigs1 msigs2 msig.
  subtypeOf_cases(induction Hsub) Case; intros.
  + Case "Sub_Class".
    lookup_forall as wfCd. inv wfCd.
    assert (msigs2 = (extractSigs ms))...
    subst. inv Hsigs1; rewrite_and_invert.
  + Case "Sub_InterfaceLeft".
    inv Hsigs1; rewrite_and_invert.
    assert (msigs0 = msigs2)...
    subst. apply find_app...
  + inv Hsigs1; rewrite_and_invert.
    assert (msigs2 = msigs3)...
    subst. apply find_app2...
    lookup_forall as wfId.
    inverts wfId as Hsigs3 Hsigs4 sigsDisjoint1 sigsDisjoint2.
    assert (msigs0 = msigs1)...
    assert (msigs2 = msigs3)...
    subst. fold (methodSigLookup msigs1 m).
    eapply sigsDisjoint2...
  + asserts_rewrite (msigs1 = msigs2)...
  + rename msigs2 into msigs3.
    rename Hsigs2 into Hsigs3.
    assert (wfT1: wfType (cds, ids, e) t1)...
    assert (wfT2: wfType (cds, ids, e) t2)...
    eapply methodSigs_wfType_exists in wfT2 as []...
(*  + inv Hsigs2. inv Hsig.*)
Qed.

(*
==============
Configuration
==============
*)

(*
---------
wfFields
---------
*)

Lemma wfFields_declsToFields :
  forall P t' c i fs ms Gamma,
    wfProgram P t' ->
    wfEnv P Gamma ->
    classLookup P c = Some (Cls c i fs ms) ->
    wfFields P Gamma c (declsToFields fs).
Proof with eauto using
                 fields_wfFieldDecl,
                 declsToFields_null.
  introv wfProgram wfEnv Hlookup.
  assert (fields P (TClass c) = Some fs)
    by (unfolds; rewrite Hlookup; auto).
  assert (Forall (wfFieldDecl P) fs)...
  econstructor...
  intros.
  lookup_forall as wfF. inv wfF...
Qed.

Lemma wfFields_extend :
  forall P Gamma c fs f t F v,
    fields P (TClass c) = Some fs ->
    fieldLookup fs f = Some (Field f t) ->
    wfFields P Gamma c F ->
    P; Gamma |- EVal v \in t ->
    wfFields P Gamma c (extend F f v).
Proof with eauto with env.
  introv Hfields fLookup wfF hasType.
  econstructor...
  introv fLookup'.
  inv wfF.
  case_extend; repeat rewrite_and_invert...
Qed.

Lemma wfFields_envExtend :
  forall P t' Gamma c F l c',
    wfProgram P t' ->
    wfFields P Gamma c F ->
    wfEnv P Gamma ->
    fresh Gamma (env_loc l) ->
    wfType P (TClass c') ->
    wfFields P (extend Gamma (env_loc l) (TClass c')) c F.
Proof with eauto using hasType_extend_loc.
  introv wfP wfF wfGamma Hfresh wfT.
  inverts wfF as Hfields wfFlds.
  econstructor...
  introv Hlookup.
  apply wfFlds in Hlookup as (v & Heq & hasType)...
Qed.

Lemma wfFields_invariance :
  forall P t' c Gamma Gamma' F,
    wfProgram P t' ->
    (forall l, Gamma (env_loc l) = Gamma' (env_loc l)) ->
    wfEnv P Gamma' ->
    wfFields P Gamma c F ->
    wfFields P Gamma' c F.
Proof with eauto using hasType_wfType.
  introv wfP envSub wfGamma' wfF.
  inverts wfF as Hfields wfFld.
  econstructor...
  introv fLookup.
  apply wfFld in fLookup as (v & Ff & hasType).
  exists v. split...
  destruct v...
  + inv hasType.
    econstructor...
    rewrite <- envSub...
Qed.

Lemma wfHeap_wfObject :
  forall P Gamma H l c F L,
    wfHeap P Gamma H ->
    heapLookup H l = Some (c, F, L) ->
    wfFields P Gamma c F.
Proof with eauto.
  introv wfH Hlookup.
  inverts wfH as _ envModelsHeap heapMirrorsEnv.
  assert (Hl: heapLookup H l <> None) by crush.
  apply heapMirrorsEnv in Hl.
  destruct Hl as [c' envLookup].
  apply envModelsHeap in envLookup as (F' & L' & ? & ?).
  rewrite_and_invert.
Qed.

Lemma wfHeap_wfFields :
  forall P Gamma H l c F RL,
    wfHeap P Gamma H ->
    heapLookup H l = Some (c, F, RL) ->
    wfFields P Gamma c F.
Proof with eauto.
  introv wfH Hlookup.
  eapply wfHeap_wfObject in Hlookup as []...
  constructors...
Qed.

(*
-------
wfHeap
-------
*)

Hint Constructors wfHeap.

Lemma wfHeap_fresh :
  forall P Gamma H l,
    wfHeap P Gamma H ->
    heapLookup H l = None ->
    fresh Gamma (env_loc l).
Proof with eauto.
  introv wfH Hlookup.
  inverts wfH as wfGamma envModelsHeap heapMirrorsEnv.
  unfold fresh. remember (Gamma (env_loc l)) as t...
  destruct t...
  symmetry in Heqt.
  assert (tClass: exists c, t = TClass c) by (inv wfGamma; eauto).
  inv tClass as [c''].
  apply envModelsHeap in Heqt.
  inv Heqt as [F' [RL [contra]]]. rewrite_and_invert.
Qed.

Lemma wfHeap_extend :
  forall P t' Gamma H c F L,
    wfProgram P t' ->
    wfHeap P Gamma H ->
    wfType P (TClass c) ->
    wfFields P Gamma c F ->
    wfHeap P (extend Gamma (env_loc (length H)) (TClass c)) (heapExtend H (c, F, L)).
Proof with eauto with env.
  introv wfP wfH wfT wfF.
  inverts wfH as wfGamma envModelsHeap heapMirrorsEnv.
  constructor...
  + introv envLookup.
    destruct (id_eq_dec l (length H)).
    - subst. simpl_extend_hyp. inv_eq.
      rewrite heapExtend_lookup_len.
      eexists; eexists; split...
      eapply wfFields_envExtend...
      eapply wfHeap_fresh...
      apply heapLookup_ge...
    - rewrite extend_neq in envLookup...
      rewrite heapExtend_lookup_nlen...
      apply envModelsHeap in envLookup as (F' & RL' & Hlookup & wfF')...
      eexists; eexists; split...
      eapply wfFields_envExtend...
      eapply wfHeap_fresh...
      apply heapLookup_ge...
  + introv Hlookup.
    destruct (id_eq_dec l (length H))...
    rewrite heapExtend_lookup_nlen in Hlookup...
Qed.

Lemma wfHeap_update :
  forall P Gamma H l c F RL RL' F',
    wfHeap P Gamma H ->
    heapLookup H l = Some (c, F, RL) ->
    wfFields P Gamma c F' ->
    wfHeap P Gamma (heapUpdate H l (c, F', RL')).
Proof with eauto.
  introv wfH Hlookup wfF'.
  inverts wfH as wfGamma envModelsHeap heapMirrorsEnv.
  constructor...
  + introv envLookup.
    destruct (id_eq_dec l l0).
    - subst.
      rewrite lookup_heapUpdate_eq
        by (apply heapLookup_lt; eauto).
      apply envModelsHeap in envLookup as (F'' & RL'' & Hlookup' & wfF'').
      rewrite_and_invert...
    - rewrite lookup_heapUpdate_neq...
  + introv Hlookup'.
    apply heapMirrorsEnv.
    destruct (id_eq_dec l l0).
    - subst.
      rewrite heapLookup_not_none...
    - rewrite lookup_heapUpdate_neq in Hlookup'...
Qed.

Lemma wfHeap_invariance :
  forall P t' Gamma Gamma' H,
    wfProgram P t' ->
    (forall l, Gamma (env_loc l) = Gamma' (env_loc l)) ->
    wfEnv P Gamma' ->
    wfHeap P Gamma H ->
    wfHeap P Gamma' H.
Proof with eauto using wfFields_invariance.
  introv wfP envEquiv wfGamma' wfH.
  inverts wfH as wfGamma envModelsHeap heapMirrorsEnv.
  constructor...
  + introv envLookup. rewrite <- envEquiv in envLookup.
    apply envModelsHeap in envLookup.
    inv envLookup as (F & RL & Hlookup & wfF)...
  + introv Hlookup. rewrite <- envEquiv...
Qed.

(*
--------
wfVars
--------
*)

Hint Constructors wfVars.

Lemma wfVars_invariance :
  forall P t' Gamma Gamma' fsyms V,
    wfProgram P t' ->
    (forall x, Gamma x = Gamma' x) ->
    wfEnv P Gamma' ->
    wfVars P Gamma fsyms V ->
    wfVars P Gamma' fsyms V.
Proof with eauto.
  introv wfP envEquiv wfGamma' wfV.
  inverts wfV as wfGamma envModelsVars varsMirrorEnv Hfresh.
  constructor...
  + introv Vlookup.
    rewrite <- envEquiv in Vlookup.
    apply envModelsVars in Vlookup as (v & Vlookup & hasType).
    eapply hasType_subsumption with (Gamma' := Gamma') in hasType; crush...
  + introv. rewrite <- envEquiv...
Qed.

Lemma wfVars_extend :
  forall P t' Gamma n m V v t,
    wfProgram P t' ->
    wfVars P Gamma n V ->
    P; Gamma |- EVal v \in t ->
    m < n ->
    wfVars P (extend Gamma (env_var (DV (DVar m))) t)
           n (extend V (DVar m) v).
Proof with eauto with env.
  introv wfP wfV hasType Hlt.
  inverts wfV as wfGamma envModelsVars varsMirrorEnv Hfresh.
  constructor; eauto 3 with env.
  + introv envLookup.
    destruct (id_eq_dec (DVar m) x).
    - subst. simpl_extend_hyp.
      inv_eq.
      exists v.
      split...
      inv hasType...
    - rewrite extend_neq in envLookup...
      apply envModelsVars in envLookup as (v' & Vlookup & hasType').
      exists v'.
      split...
      inv hasType'...
  + introv Hle. unfold fresh.
    assert (m < n')
        by omega.
    case_extend; [inv_eq | apply Hfresh]; omega.
Qed.

Lemma wfVars_heapExtend :
  forall Gamma P t' n V l c,
    wfProgram P t' ->
    wfVars P Gamma n V ->
    fresh Gamma (env_loc l) ->
    wfType P (TClass c) ->
    wfVars P (extend Gamma (env_loc l) (TClass c)) n V.
Proof with eauto with env.
  introv wfP wfV Hfresh wfT.
  inverts wfV as wfGamma envModelsVars varsMirrorEnv freshVars.
  constructor...
  + introv envLookup.
    simpl_extend_hyp.
    apply envModelsVars in envLookup as (v & Vlookup & hasType).
    exists v.
    split...
    inv hasType...
Qed.

Lemma wfVars_ge :
  forall P Gamma n V m,
    wfVars P Gamma n V ->
    n <= m ->
    wfVars P Gamma m V.
Proof with eauto.
  introv wfV Hge.
  inverts wfV as wfGamma envModels varsMirror Hfresh.
  econstructor...
  introv Hle.
  assert (n <= n') by omega...
Qed.

(*
----------
wfLocking
----------
*)

Hint Constructors wfHeldLocks.
Hint Constructors wfLocks.
Hint Constructors disjointLocks.
Hint Constructors wfLocking.

Lemma wfHeldLocks_heapExtend :
  forall H Ls c F RL,
    wfHeldLocks H Ls ->
    wfHeldLocks (heapExtend H (c, F, RL)) Ls.
Proof with eauto.
  introv wfLs.
  constructor.
  induction wfLs as [wfLs]...
  rewrite Forall_forall in wfLs.
  apply Forall_forall.
  introv HIn.
  apply wfLs in HIn as [].
  assert (Hlt: l < length H) by
      (eapply heapLookup_lt; eauto)...
  econstructor...
  rewrite heapExtend_lookup_nlen...
  omega.
Qed.

Lemma wfLocking_heapExtend :
  forall H T c F RL,
    wfLocking H T ->
    wfLocking (heapExtend H (c, F, RL)) T.
Proof with eauto using wfHeldLocks_heapExtend.
  introv wfL.
  induction wfL...
Qed.

Lemma wfHeldLocks_heapUpdate :
  forall H Ls l c F F' L L',
    wfHeldLocks H Ls ->
    heapLookup H l = Some (c, F, L) ->
    (In l Ls -> L' = LLocked) ->
    wfHeldLocks (heapUpdate H l (c, F', L')) Ls.
Proof with eauto.
  introv wfLs Hlookup HRL'.
  induction wfLs as [wfLs]...
  rewrite Forall_forall in wfLs.
  constructors.
  apply Forall_forall.
  introv HIn.
  assert(wfL: wfLock H x)...
  inverts wfL as Hlookup' HRL.
  destruct (id_eq_dec l x).
  + subst. rewrite_and_invert.
    apply HRL' in HIn. subst.
    apply WF_Lock with c0 F'...
    rewrite lookup_heapUpdate_eq...
    apply heapLookup_lt...
  + econstructor...
    rewrite lookup_heapUpdate_neq...
Qed.

Lemma wfLocking_heapUpdate :
  forall H T l c F F' L L',
    wfLocking H T ->
    heapLookup H l = Some (c, F, L) ->
    (In l (heldLocks T) -> L' = LLocked) ->
    wfLocking (heapUpdate H l (c, F', L')) T.
Proof with eauto using wfHeldLocks_heapUpdate.
  introv wfL Hlookup HL.
  induction wfL; simpls...
  crush.
Qed.

Lemma wfHeldLocks_taken :
  forall H Ls l c L F,
    wfHeldLocks H Ls ->
    In l Ls ->
    heapLookup H l = Some (c, F, L) ->
    L = LLocked.
Proof with eauto.
  introv wfLs HIn Hlookup.
  induction wfLs as [wfLs]...
  rewrite Forall_forall in wfLs.
  apply wfLs in HIn. inv HIn.
  rewrite_and_invert...
Qed.

Lemma wfLocks_econtext :
  forall Ls e ctx,
    is_econtext ctx ->
    wfLocks Ls (ctx e) ->
    wfLocks Ls e.
Proof with eauto using in_or_app.
  introv Hctx wfL.
  inv Hctx;
    inverts wfL as Hlocks Hdup;
    simpl in *...
  + eapply NoDup_app in Hdup as []...
  + inv Hdup...
Qed.

Lemma wfLocking_econtext :
  forall ctx H Ls e,
    is_econtext ctx ->
    wfLocking H (T_Thread Ls (ctx e)) ->
    wfLocking H (T_Thread Ls e).
Proof with eauto using wfLocks_econtext.
  introv Hctx wfL.
  inv wfL...
Qed.

Lemma wfLocking_subst :
  forall H Ls e x y,
    wfLocking H (T_Thread Ls e) ->
    wfLocking H (T_Thread Ls (subst x y e)).
Proof with eauto.
  introv wfL.
  inverts wfL as wfLs Hdup wfL wfRl.
  econstructor...
  econstructor...
  + rewrite <- locks_subst...
    inv wfL...
  + rewrite <- locks_subst...
    inv wfL...
Qed.

Lemma locks_static :
  forall e,
    exprStatic e ->
    locks e = nil.
Proof with eauto using app_eq_nil.
  introv Hstatic.
  induction Hstatic; simpl...
  apply app_eq_nil...
Qed.

Lemma wfLocking_static :
  forall H Ls e,
    wfHeldLocks H Ls ->
    NoDup Ls ->
    exprStatic e ->
    wfLocking H (T_Thread Ls e).
Proof with eauto using locks_static.
  introv wfLs Hdup Hstatic.
  assert (HL: locks e = nil)...
  econstructor...
  econstructor; rewrite HL...
  introv HIn... inv HIn.
Qed.

Lemma disjointLocks_commutative :
  forall T1 T2,
    disjointLocks T1 T2 ->
    disjointLocks T2 T1.
Proof with eauto.
  introv Hdisj.
  inv Hdisj. constructors...
Qed.

Lemma disjointLocks_async :
  forall T T1 T2 e,
    disjointLocks T1 T /\
    disjointLocks T2 T
     <->
    disjointLocks (T_Async T1 T2 e) T.
Proof with eauto using in_or_app.
  split.
  + introv Hdisj.
    inverts Hdisj as Hdisj1 Hdisj2.
    inverts Hdisj1. inverts Hdisj2.
    constructor; simpl.
    - introv HIn.
      apply in_app_or in HIn as [|HIn]...
    - introv HIn.
      apply not_in_app...
  + introv Hdisj.
    inverts Hdisj as Hdisj1 Hdisj2.
    simpls.
    splits.
    - constructor...
      introv HIn.
      apply Hdisj2 in HIn...
    - constructor...
      introv HIn.
      apply Hdisj2 in HIn.
      eapply not_in_app in HIn as []...
Qed.

Lemma disjointLocks_leftmost :
  forall T1 T2,
    disjointLocks T1 T2 ->
    disjointLocks (T_EXN (leftmost_locks T1)) T2.
Proof with eauto using in_or_app.
  introv Hdisj.
  induction T1; simpls; inv Hdisj...
  apply IHT1_1.
  econstructor; crush...
Qed.

Lemma wfHeldLocks_app :
  forall H Ls1 Ls2,
    (wfHeldLocks H Ls1 /\ wfHeldLocks H Ls2 <-> wfHeldLocks H (Ls1 ++ Ls2)).
Proof with eauto using in_eq, in_cons.
  split.
  + introv wfLs.
    inverts wfLs as wfLs1 wfLs2.
    constructor.
    apply Forall_app...
    inv wfLs1...
    inv wfLs2...
  + introv wfLs.
    induction Ls1 as [|l]; simpls...
    inverts wfLs as wfLs.
    inverts wfLs as wfL wfLs'.
    assert(wfLs: wfHeldLocks H (Ls1 ++ Ls2))...
    apply IHLs1 in wfLs as [wfLs1 wfLs2]...
    split...
    econstructor...
    econstructor...
    apply Forall_forall.
    rewrite Forall_forall in wfLs'.
    introv HIn.
    assert (HIn': In x (Ls1 ++ Ls2))
      by eauto using in_or_app...
Qed.

Lemma wfHeldLocks_cons :
  forall H Ls l,
    wfHeldLocks H Ls ->
    wfLock H l ->
    wfHeldLocks H (l :: Ls).
Proof with eauto.
  introv wfLs wfL.
  inv wfLs...
Qed.

Lemma wfHeldLocks_leftmost :
  forall H T,
    wfLocking H T ->
    wfHeldLocks H (leftmost_locks T).
Proof with eauto.
  introv wfL.
  induction T; inv wfL...
Qed.

Lemma wfHeldLocks_remove :
  forall H Ls L eq_dec,
    wfHeldLocks H Ls ->
    wfHeldLocks H (remove eq_dec L Ls).
Proof with eauto using wfHeldLocks_cons.
  introv wfLs.
  induction Ls as [| l]...
  inverts wfLs as wfLs.
  inverts wfLs.
  simpl. cases_if...
Qed.

Corollary wfLocking_wfHeldLocks :
  forall H T,
    wfLocking H T ->
    wfHeldLocks H (heldLocks T).
Proof with eauto.
  introv wfL.
  induction T; simpls; inv wfL...
  apply wfHeldLocks_app...
Qed.

(*
----------
wfThreads
----------
*)

Hint Constructors wfThreads.

Corollary wfThreads_wfEnv :
  forall P t' Gamma T t,
    wfProgram P t' ->
    wfThreads P Gamma T t ->
    wfEnv P Gamma.
Proof with eauto with env.
  introv wfP wfT. inv wfT...
Qed.

Hint Immediate wfThreads_wfEnv.

Lemma wfThreads_invariance :
  forall P t' Gamma Gamma' T t,
    wfProgram P t' ->
    (forall x, Gamma x = Gamma' x) ->
    wfThreads P Gamma T t ->
    wfThreads P Gamma' T t.
Proof with eauto using hasType_subsumption,
                       wfEnv_equiv with env.
  introv wfP Hequiv wfT.
  induction wfT...
Qed.

Lemma wfThreads_subsumption :
  forall P t' Gamma Gamma' T t,
    wfProgram P t' ->
    wfSubsumption Gamma Gamma' ->
    wfEnv P Gamma' ->
    wfThreads P Gamma T t ->
    wfThreads P Gamma' T t.
Proof with eauto using hasType_subsumption with env.
  introv wfP wfEnv' Hsub wfT.
  induction wfT...
Qed.

Lemma wfThreads_heapExtend :
  forall P t' Gamma T t c l,
    wfProgram P t' ->
    wfType P (TClass c) ->
    fresh Gamma (env_loc l) ->
    wfThreads P Gamma T t ->
    wfThreads P (extend Gamma (env_loc l) (TClass c)) T t.
Proof with eauto using hasType_extend_loc with env.
  introv wfP wfTy Hfresh wfT.
  generalize dependent t.
  induction T; intros; inv wfT...
Qed.

(*
----------------
wfConfiguration
----------------
*)

Hint Constructors wfConfiguration.

Lemma wfConfiguration_substitution :
  forall P Gamma H V n Ls e e' t,
    freeVars e' = nil ->
    P; Gamma |- e' \in t ->
    wfLocking H (T_Thread Ls e') ->
    wfConfiguration P Gamma (H, V, n, T_Thread Ls e) t ->
    wfConfiguration P Gamma (H, V, n, T_Thread Ls e') t.
Proof with eauto.
  introv Hfree hasType wfL wfCfg.
  inverts wfCfg...
Qed.

Lemma wfConfiguration_heapExtend :
  forall P t' Gamma H V n T t c F L,
    wfProgram P t' ->
    wfConfiguration P Gamma (H, V, n, T) t ->
    wfType P (TClass c) ->
    wfFields P Gamma c F ->
    wfConfiguration P (extend Gamma (env_loc (length H)) (TClass c))
                    ((heapExtend H (c, F, L)), V, n, T) t.
Proof with eauto 6 using
                 wfHeap_extend,
                 wfVars_heapExtend,
                 wfThreads_heapExtend,
                 wfLocking_heapExtend with env.
  introv wfP wfCfg wfTy wfF.
  inverts wfCfg.
  assert(fresh Gamma (env_loc (length H)))
    by eauto using wfHeap_fresh, heapLookup_ge...
Qed.

Lemma wfConfiguration_heapUpdate :
  forall P t' Gamma H V n T t l c F L L' F',
    wfProgram P t' ->
    wfConfiguration P Gamma (H, V, n, T) t ->
    heapLookup H l = Some (c, F, L) ->
    wfFields P Gamma c F' ->
    (In l (heldLocks T) -> L' = LLocked) ->
    wfConfiguration P Gamma
                    ((heapUpdate H l (c, F', L')), V, n, T) t.
Proof with eauto using
                 wfHeap_update,
                 wfLocking_heapUpdate.
  introv wfP wfCfg HLookup wfF' HL.
  inverts wfCfg...
Qed.