Require Import Recdef.
Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.

(* TODO remove this line and update proof (should become simpler) *)
Ltac canon_load_result ::= idtac.

Require Import tweetnacl20140427.split_array_lemmas.
Require Import ZArith.
Require Import tweetnacl20140427.tweetNaclBase.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.verif_salsa_base.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.spec_salsa. Opaque Snuffle.Snuffle.
Require Import VST.floyd.library.

Opaque littleendian.
    Opaque littleendian_invert. Opaque Snuffle20. Opaque prepare_data.
    Opaque QuadByte2ValList. Opaque fcore_result.

Definition wlistJ' (wlist:list val) (j: Z) (t0 t1 t2 t3:int) (l: list val): Prop :=
  Zlength l = 16 /\
  l = upd_Znth (4 * j + (j + 3) mod 4)
       (upd_Znth (4 * j + (j + 2) mod 4)
         (upd_Znth (4 * j + (j + 1) mod 4)
          (upd_Znth (4 * j + (j + 0) mod 4) wlist (Vint t0))
          (Vint t1)) (Vint t2)) (Vint t3).

Fixpoint WLIST' (wlist : list val) (tlist: list int) (j:Z) m l :=
  match m with
    O => l=wlist
  | S m' => exists l' tm,
            Zlength l = Zlength wlist /\
            WLIST' wlist tlist j m' l' /\
            Znth (Z.of_nat m') (map Vint tlist) Vundef = Vint tm /\
            l = upd_Znth (4*j+ ((j+Z.of_nat m') mod 4)) l' (Vint tm)
  end.

Lemma WLIST'_length wlist tlist j : forall m l, WLIST' wlist tlist j m l -> Zlength l=Zlength wlist.
Proof. induction m; simpl; intros; subst; trivial.
  destruct H as [l' [tm [ L [W [ZZ LL]]]]]. subst. apply IHm in W; trivial.
Qed.

Definition Wcopyspec (t0 t1 t2 t3: int):=
(Int.xor t0
        (Int.rol
           (Int.add
              (Int.xor t3
                 (Int.rol
                    (Int.add
                       (Int.xor t2
                          (Int.rol
                             (Int.add
                                (Int.xor t1
                                   (Int.rol (Int.add t0 t3) (Int.repr 7))) t0)
                             (Int.repr 9)))
                       (Int.xor t1 (Int.rol (Int.add t0 t3) (Int.repr 7))))
                    (Int.repr 13)))
              (Int.xor t2
                 (Int.rol
                    (Int.add
                       (Int.xor t1 (Int.rol (Int.add t0 t3) (Int.repr 7))) t0)
                    (Int.repr 9)))) (Int.repr 18)),
  Int.xor t1 (Int.rol (Int.add t0 t3) (Int.repr 7)),
  Int.xor t2
       (Int.rol
          (Int.add (Int.xor t1 (Int.rol (Int.add t0 t3) (Int.repr 7))) t0)
          (Int.repr 9)),
  Int.xor t3
       (Int.rol
          (Int.add
             (Int.xor t2
                (Int.rol
                   (Int.add
                      (Int.xor t1 (Int.rol (Int.add t0 t3) (Int.repr 7))) t0)
                   (Int.repr 9)))
             (Int.xor t1 (Int.rol (Int.add t0 t3) (Int.repr 7))))
          (Int.repr 13))).

Lemma SixteenWR_Znth_int' s i:
  0 <= i < 16 -> exists ii : int, Znth i (SixteenWordRep s) Vundef = Vint ii.
Proof. apply SixteenWR_Znth_int. Qed.

Definition array_copy1_statement :=
  (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
     (Ebinop Olt (Etempvar _m tint) (Econst_int (Int.repr 4) tint) tint)
     (Ssequence
        (Sset _t'33
           (Ederef
              (Ebinop Oadd (Evar _x (tarray tuint 16))
                 (Ebinop Omod
                    (Ebinop Oadd
                       (Ebinop Omul (Econst_int (Int.repr 5) tint)
                          (Etempvar _j tint) tint)
                       (Ebinop Omul (Econst_int (Int.repr 4) tint)
                          (Etempvar _m tint) tint) tint)
                    (Econst_int (Int.repr 16) tint) tint) (tptr tuint)) tuint))
        (Sassign
           (Ederef
              (Ebinop Oadd (Evar _t (tarray tuint 4)) (Etempvar _m tint)
                 (tptr tuint)) tuint) (Etempvar _t'33 tuint)))
     (Sset _m
        (Ebinop Oadd (Etempvar _m tint) (Econst_int (Int.repr 1) tint) tint))).
Lemma array_copy1: forall (Espec: OracleKind) j t x (xs:list int)
  (J:0<=j<4),
 semax (initialized_list [_i; _j]
     (func_tycontext f_core SalsaVarSpecs SalsaFunSpecs))
  (PROP  ()
   LOCAL  (temp _j (Vint (Int.repr j));
   lvar _t (tarray tuint 4) t;
   lvar _x (tarray tuint 16) x)
   SEP  (data_at_ Tsh (tarray tuint 4) t;
           data_at Tsh (tarray tuint 16) (@map int val Vint xs) x))
   array_copy1_statement
  (normal_ret_assert
  (PROP  ()
   LOCAL  (temp _m (Vint (Int.repr 4)); temp _j (Vint (Int.repr j));
   lvar _t (tarray tuint 4) t;
   lvar _x (tarray tuint 16) x)
   SEP  (data_at Tsh (tarray tuint 16) (map Vint xs) x;
     EX  l : list val,
     !!(forall mm : Z,
         0 <= mm < 4 ->
         Znth mm l Vundef =
         Znth ((5 * j + 4 * mm) mod 16) (map Vint xs) Vundef)
        && data_at Tsh (tarray tuint 4) l t))).
Proof. intros. unfold array_copy1_statement. abbreviate_semax.
  assert_PROP (Zlength (map Vint xs) = 16) as XL by entailer!. (*1*)
  forward_for_simple_bound 4
 (EX m:Z,
  (PROP  ()
   LOCAL  (temp _j (Vint (Int.repr j)); lvar _t (tarray tuint 4) t;
   lvar _x (tarray tuint 16) x)
   SEP  (EX l:_, !!(forall mm, 0<=mm<m -> Znth mm l Vundef =
                  Znth ((5*j+4*mm) mod 16) (map Vint xs) Vundef)
            && data_at Tsh (tarray tuint 4) l t;
       data_at Tsh (tarray tuint 16) (map Vint xs) x))).
  (*1.3*)
  { Exists (list_repeat 4 Vundef). (*Time*) entailer!. (*2.2*)  intros; omega. }
  { rename i into m. rename H into M. Intros T.
    rename H into HT.
    (*Time*) assert_PROP (Zlength T = 4) as TL by entailer!. (*2.2 versus 5.7*)
    destruct (Z_mod_lt (5 * j + 4 * m) 16) as [M1 M2]. omega.
    destruct (Znth_mapVint xs ((5 * j + 4 * m) mod 16) Vundef) as [v NV].
       simpl in XL. rewrite <- (Zlength_map _ _ Vint xs), XL. split; assumption.
    forward.
    { apply prop_right. unfold Int.mods. (* rewrite ! mul_repr, add_repr.*)
      rewrite ! Int.signed_repr.
      2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
      2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
      rewrite Z.rem_mod_nonneg; try omega.
      rewrite Int.unsigned_repr. omega.
      rewrite int_max_unsigned_eq; omega. }
    { unfold Int.mods.
      rewrite ! Int.signed_repr.
      2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
      2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
      rewrite Z.rem_mod_nonneg; try omega.
      rewrite Int.unsigned_repr, NV. 2: rewrite int_max_unsigned_eq; omega.
      entailer!.
      rewrite andb_false_intro2. simpl; trivial. cbv; trivial. }
    unfold Int.mods.
    rewrite ! Int.signed_repr.
    2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
    2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
    rewrite Z.rem_mod_nonneg; try omega.
    forward.
    { entailer!. rewrite NV. simpl. Exists (upd_Znth m T (Vint v)). entailer!.
      intros mm ?.
      destruct (zeq mm m); subst.
      + rewrite upd_Znth_same; try omega. rewrite NV; trivial.
      + rewrite upd_Znth_diff; try omega. apply HT; omega. }
  }
  entailer!.
Qed.

Definition Jbody_statement :=
  (Ssequence
     (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
        (Ebinop Olt (Etempvar _m tint) (Econst_int (Int.repr 4) tint) tint)
        (Ssequence
           (Sset _t'33
              (Ederef
                 (Ebinop Oadd (Evar _x (tarray tuint 16))
                    (Ebinop Omod
                       (Ebinop Oadd
                          (Ebinop Omul (Econst_int (Int.repr 5) tint)
                             (Etempvar _j tint) tint)
                          (Ebinop Omul (Econst_int (Int.repr 4) tint)
                             (Etempvar _m tint) tint) tint)
                       (Econst_int (Int.repr 16) tint) tint) (tptr tuint))
                 tuint))
           (Sassign
              (Ederef
                 (Ebinop Oadd (Evar _t (tarray tuint 4)) (Etempvar _m tint)
                    (tptr tuint)) tuint) (Etempvar _t'33 tuint)))
        (Sset _m
           (Ebinop Oadd (Etempvar _m tint) (Econst_int (Int.repr 1) tint)
              tint)))
     (Ssequence
        (Ssequence
           (Ssequence
              (Sset _t'31
                 (Ederef
                    (Ebinop Oadd (Evar _t (tarray tuint 4))
                       (Econst_int (Int.repr 0) tint) (tptr tuint)) tuint))
              (Ssequence
                 (Sset _t'32
                    (Ederef
                       (Ebinop Oadd (Evar _t (tarray tuint 4))
                          (Econst_int (Int.repr 3) tint) (tptr tuint)) tuint))
                 (Scall (Some _t'5)
                    (Evar _L32
                       (Tfunction (Tcons tuint (Tcons tint Tnil)) tuint
                          cc_default))
                    [Ebinop Oadd (Etempvar _t'31 tuint)
                       (Etempvar _t'32 tuint) tuint;
                    Econst_int (Int.repr 7) tint])))
           (Ssequence
              (Sset _t'30
                 (Ederef
                    (Ebinop Oadd (Evar _t (tarray tuint 4))
                       (Econst_int (Int.repr 1) tint) (tptr tuint)) tuint))
              (Sassign
                 (Ederef
                    (Ebinop Oadd (Evar _t (tarray tuint 4))
                       (Econst_int (Int.repr 1) tint) (tptr tuint)) tuint)
                 (Ebinop Oxor (Etempvar _t'30 tuint) (Etempvar _t'5 tuint)
                    tuint))))
        (Ssequence
           (Ssequence
              (Ssequence
                 (Sset _t'28
                    (Ederef
                       (Ebinop Oadd (Evar _t (tarray tuint 4))
                          (Econst_int (Int.repr 1) tint) (tptr tuint)) tuint))
                 (Ssequence
                    (Sset _t'29
                       (Ederef
                          (Ebinop Oadd (Evar _t (tarray tuint 4))
                             (Econst_int (Int.repr 0) tint) (tptr tuint))
                          tuint))
                    (Scall (Some _t'6)
                       (Evar _L32
                          (Tfunction (Tcons tuint (Tcons tint Tnil)) tuint
                             cc_default))
                       [Ebinop Oadd (Etempvar _t'28 tuint)
                          (Etempvar _t'29 tuint) tuint;
                       Econst_int (Int.repr 9) tint])))
              (Ssequence
                 (Sset _t'27
                    (Ederef
                       (Ebinop Oadd (Evar _t (tarray tuint 4))
                          (Econst_int (Int.repr 2) tint) (tptr tuint)) tuint))
                 (Sassign
                    (Ederef
                       (Ebinop Oadd (Evar _t (tarray tuint 4))
                          (Econst_int (Int.repr 2) tint) (tptr tuint)) tuint)
                    (Ebinop Oxor (Etempvar _t'27 tuint) (Etempvar _t'6 tuint)
                       tuint))))
           (Ssequence
              (Ssequence
                 (Ssequence
                    (Sset _t'25
                       (Ederef
                          (Ebinop Oadd (Evar _t (tarray tuint 4))
                             (Econst_int (Int.repr 2) tint) (tptr tuint))
                          tuint))
                    (Ssequence
                       (Sset _t'26
                          (Ederef
                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                (Econst_int (Int.repr 1) tint) (tptr tuint))
                             tuint))
                       (Scall (Some _t'7)
                          (Evar _L32
                             (Tfunction (Tcons tuint (Tcons tint Tnil)) tuint
                                cc_default))
                          [Ebinop Oadd (Etempvar _t'25 tuint)
                             (Etempvar _t'26 tuint) tuint;
                          Econst_int (Int.repr 13) tint])))
                 (Ssequence
                    (Sset _t'24
                       (Ederef
                          (Ebinop Oadd (Evar _t (tarray tuint 4))
                             (Econst_int (Int.repr 3) tint) (tptr tuint))
                          tuint))
                    (Sassign
                       (Ederef
                          (Ebinop Oadd (Evar _t (tarray tuint 4))
                             (Econst_int (Int.repr 3) tint) (tptr tuint))
                          tuint)
                       (Ebinop Oxor (Etempvar _t'24 tuint)
                          (Etempvar _t'7 tuint) tuint))))
              (Ssequence
                 (Ssequence
                    (Ssequence
                       (Sset _t'22
                          (Ederef
                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                (Econst_int (Int.repr 3) tint) (tptr tuint))
                             tuint))
                       (Ssequence
                          (Sset _t'23
                             (Ederef
                                (Ebinop Oadd (Evar _t (tarray tuint 4))
                                   (Econst_int (Int.repr 2) tint)
                                   (tptr tuint)) tuint))
                          (Scall (Some _t'8)
                             (Evar _L32
                                (Tfunction (Tcons tuint (Tcons tint Tnil))
                                   tuint cc_default))
                             [Ebinop Oadd (Etempvar _t'22 tuint)
                                (Etempvar _t'23 tuint) tuint;
                             Econst_int (Int.repr 18) tint])))
                    (Ssequence
                       (Sset _t'21
                          (Ederef
                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                (Econst_int (Int.repr 0) tint) (tptr tuint))
                             tuint))
                       (Sassign
                          (Ederef
                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                (Econst_int (Int.repr 0) tint) (tptr tuint))
                             tuint)
                          (Ebinop Oxor (Etempvar _t'21 tuint)
                             (Etempvar _t'8 tuint) tuint))))
                 (Sfor (Sset _m (Econst_int (Int.repr 0) tint))
                    (Ebinop Olt (Etempvar _m tint)
                       (Econst_int (Int.repr 4) tint) tint)
                    (Ssequence
                       (Sset _t'20
                          (Ederef
                             (Ebinop Oadd (Evar _t (tarray tuint 4))
                                (Etempvar _m tint) (tptr tuint)) tuint))
                       (Sassign
                          (Ederef
                             (Ebinop Oadd (Evar _w (tarray tuint 16))
                                (Ebinop Oadd
                                   (Ebinop Omul
                                      (Econst_int (Int.repr 4) tint)
                                      (Etempvar _j tint) tint)
                                   (Ebinop Omod
                                      (Ebinop Oadd (Etempvar _j tint)
                                         (Etempvar _m tint) tint)
                                      (Econst_int (Int.repr 4) tint) tint)
                                   tint) (tptr tuint)) tuint)
                          (Etempvar _t'20 tuint)))
                    (Sset _m
                       (Ebinop Oadd (Etempvar _m tint)
                          (Econst_int (Int.repr 1) tint) tint)))))))).

Lemma Jbody (Espec : OracleKind) FR c k h nonce out w x y t i j xs
  (I : 0 <= i < 20)
  (J : 0 <= j < 4)
  wlist
  t0 t1 t2 t3
  (T0: Znth ((5*j+4*0) mod 16) (map Vint xs) Vundef = Vint t0)
  (T1: Znth ((5*j+4*1) mod 16) (map Vint  xs) Vundef = Vint t1)
  (T2: Znth ((5*j+4*2) mod 16) (map Vint xs) Vundef = Vint t2)
  (T3: Znth ((5*j+4*3) mod 16) (map Vint xs) Vundef = Vint t3):
@semax CompSpecs Espec
  (initialized_list [_i; _j]
     (func_tycontext f_core SalsaVarSpecs SalsaFunSpecs))
  (PROP  ()
   LOCAL  (temp _j (Vint (Int.repr j)); temp _i (Vint (Int.repr i));
   lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
   lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w; temp _in nonce;
   temp _out out; temp _c c; temp _k k; temp _h (Vint (Int.repr h)))
   SEP  (FR; data_at_ Tsh (tarray tuint 4) t;
         data_at Tsh (tarray tuint 16) (*(map Vint wlist)*) wlist w;
         data_at Tsh (tarray tuint 16) (map Vint xs) x))
  Jbody_statement
  (normal_ret_assert
     (PROP  (0 <= j + 1 <= 4)
      LOCAL  (temp _j (Vint (Int.repr j)); temp _i (Vint (Int.repr i));
      lvar _t (tarray tuint 4) t; lvar _y (tarray tuint 16) y;
      lvar _x (tarray tuint 16) x; lvar _w (tarray tuint 16) w;
      temp _in nonce; temp _out out; temp _c c; temp _k k;
      temp _h (Vint (Int.repr h)))
      SEP  (FR; data_at Tsh (tarray tuint 16) (map Vint xs) x;
          data_at_ Tsh (tarray tuint 4) t;
          EX W:_,
             !!(match Wcopyspec t0 t1 t2 t3 with
                 (s0,s1,s2,s3) => wlistJ' wlist j s0 s1 s2 s3 W
                end)
             && data_at Tsh (tarray tuint 16) (*(map Vint W)*)W w))).
Proof. intros. abbreviate_semax.
  semax_frame [ ] [ FR ].
  forward_seq.
 {
  semax_frame [   temp _i (Vint (Int.repr i));  lvar _y (tarray tuint 16) y;
     lvar _w (tarray tuint 16) w; temp _in nonce;
     temp _out out; temp _c c; temp _k k; temp _h (Vint (Int.repr h))]
    [ data_at Tsh (tarray tuint 16) wlist w ].
  apply array_copy1; trivial. }
  abbreviate_semax. simpl app.
  Intros tlist.
  rename H into HT.

  assert_PROP (tlist = map Vint [t0; t1;t2;t3]) as TLI. {
   entailer!.
   clear - HT H3 T0 T1 T2 T3. rename H3 into TL.
   rewrite Zlength_correct in TL. change 4 with (Z.of_nat 4) in TL.
   apply Nat2Z.inj in TL.
   destruct tlist as [ | x0 [ | x1 [ | x2 [ | x3 [ | ]]]]]; inv TL.
   rewrite <- HT in T0,T1,T2,T3 by omega.
   rewrite <- T0, <- T1, <- T2, <- T3. reflexivity.
 }
  subst tlist.
  clear T0 T1 T2 T3 HT.

Ltac compute_Znth :=
 let xx := fresh in
   set (xx := (Znth _ (map Vint (_::_)) _));
   compute in xx;
   subst xx.

Ltac compute_upd_Znth :=
 let xx := fresh "xx" in
   set (xx := (upd_Znth _ (map Vint (_::_)) (Vint _)));
   pattern xx;
  match goal with |- ?G xx =>
  let g := fresh "G" in set (g:=G);
  revert xx;
  unfold upd_Znth, Zlength, sublist;
  simpl; rewrite <- (map_nil Vint), <- ?map_cons;
  subst g; cbv beta
 end.

deadvars!.
  (*pattern1*)
  forward. compute_Znth.
  forward. compute_Znth.
  forward_call (Int.add t0 t3, Int.repr 7).
  forward. compute_Znth.
  forward.
  remember (Int.xor t1 (Int.rol (Int.add t0 t3) (Int.repr 7))) as tt0.
  forward. compute_upd_Znth.

deadvars!.
  (*VST Issue: mkConciseDelta SalsaVarSpecs SalsaFunSpecs f_core Delta. doesn't work any longer*)
  (*pattern2*)
  forward. compute_Znth.
  forward_call (Int.add tt0 t0, Int.repr 9).
  forward. compute_Znth.
  forward.
  remember (Int.xor t2 (Int.rol (Int.add tt0 t0) (Int.repr 9))) as tt1.
  forward. compute_upd_Znth.

deadvars!.
  (*pattern3*)
  forward. compute_Znth.
  forward_call (Int.add tt1 tt0, Int.repr 13).
  forward. compute_Znth.
  forward.
  remember (Int.xor t3 (Int.rol (Int.add tt1 tt0) (Int.repr 13))) as tt2.
  forward. compute_upd_Znth.

deadvars!.
  (*pattern4*)
  forward. compute_Znth.
  forward_call (Int.add tt2 tt1, Int.repr 18).
  forward. compute_Znth.
  forward.
  remember (Int.xor t0 (Int.rol (Int.add tt2 tt1) (Int.repr 18))) as tt3.

deadvars!.
(*  forward. compute_upd_Znth.

(* delete _aux1*) drop_LOCAL 0%nat.
(* delete _aux*) drop_LOCAL 0%nat.
(* delete old m*) drop_LOCAL 0%nat.*)
(*Time*) assert_PROP (Zlength wlist=16) as WL by entailer!. (*1.6 versus 4.4*)

  subst POSTCONDITION; unfold abbreviate.

  semax_frame [
   lvar _x (tarray tuint 16) x;
   temp _i (Vint (Int.repr i));
   lvar _y (tarray tuint 16) y; temp _in nonce;
   temp _out out; temp _c c; temp _k k;
   temp _h (Vint (Int.repr h))]
    [ data_at Tsh (tarray tuint 16) (map Vint xs) x ].

 forward_for_simple_bound 4 (EX m:Z, EX l: list val,
  (PROP  (WLIST' wlist [tt3; tt0; tt1; tt2] j (Z.to_nat m) l)
   LOCAL  (temp _j (Vint (Int.repr j)); lvar _t (tarray tuint 4) t; lvar _w (tarray tuint 16) w )
   SEP  (data_at Tsh (tarray tuint 4) (map Vint [tt3; tt0; tt1; tt2]) t;
           data_at Tsh (tarray tuint 16) l w))).
   (*1.2 versus 6.3*)
{ Exists wlist. (*Time*) entailer!. (*2.4 versus 6.3*) }
{ rename H into M; rename i0 into m.
  rename x0 into wlist1. Intros. rename H into WLIST1.
  assert (TM: exists tm, Znth m [Vint tt3; Vint tt0; Vint tt1; Vint tt2] Vundef = Vint tm).
    destruct (zeq m 0); subst; simpl. eexists; reflexivity.
    destruct (zeq m 1); subst; simpl. eexists; reflexivity.
    destruct (zeq m 2); subst; simpl. eexists; reflexivity.
    destruct (zeq m 3); subst; simpl. eexists; reflexivity. omega.
  destruct TM as [tm TM].
  forward.
  { entailer!. rewrite TM; simpl; trivial. }
  assert (JM: 0 <= Z.rem (j + m) 4 < 4) by (apply Zquot.Zrem_lt_pos_pos; omega).
  assert (JM2: 0<= (j + m) mod 4 < 4) by (apply Z_mod_lt; omega).
  deadvars!.
  forward.
  { entailer!. rewrite andb_false_r; simpl; trivial.
   clear H1. clear WLIST1. clear TM. clear H.
   rewrite and_True.
   unfold Int.mods. rewrite (Int.signed_repr (j+m)) by rep_omega.
   change (Int.signed (Int.repr 4)) with 4.
   rewrite Int.signed_repr by rep_omega. rep_omega.  }
  { apply prop_right.
    unfold Int.mods. (*rewrite ! mul_repr, add_repr.*)
    rewrite ! Int.signed_repr(*, add_repr, Int.signed_repr*).
      2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
      2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
    rewrite Int.unsigned_repr. 2: rewrite int_max_unsigned_eq; omega.
    rewrite Int.unsigned_repr. 2: rewrite int_max_unsigned_eq; omega.
    omega. }
  { Exists (upd_Znth (4 * j + (j + m) mod 4) wlist1 (Vint tm)). (*_id0)). *)
    go_lower. rewrite TM. simpl.
    apply andp_right.
    + apply prop_right. split. omega. split; trivial.
      assert (AP: 0 <= (j + m) mod 4 < 4) by (apply Z_mod_lt; omega).
      rewrite Z.add_comm. rewrite Z2Nat.inj_add; try omega.
      assert (SS: (Z.to_nat 1 + Z.to_nat m)%nat = S (Z.to_nat m)) by reflexivity.
      rewrite SS; simpl.
      exists wlist1, tm.
      assert (WL1: Zlength wlist1 = 16). erewrite WLIST'_length. 2: eassumption. assumption.
      split. rewrite upd_Znth_Zlength. eapply WLIST'_length; eassumption.
             rewrite WL1. omega.
             split. trivial.
             rewrite Z2Nat.id. split; trivial. omega.
    + unfold Int.mods. (*rewrite ! mul_repr, add_repr.*)
      rewrite ! Int.signed_repr(*, add_repr, Int.signed_repr*).
        2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
        2: rewrite int_max_signed_eq, int_min_signed_eq; omega.
      rewrite Int.unsigned_repr. 2: rewrite int_max_unsigned_eq; omega.
      rewrite Int.unsigned_repr. 2: rewrite int_max_unsigned_eq; omega.
      rewrite Z.rem_mod_nonneg; try omega. entailer!. }
  }

Intros l. Exists l.
entailer!.
split. assumption.
destruct H as [l1 [tm1 [ZL1 [XX1 [Z3 HL1]]]]].
destruct XX1 as [l2 [tm2 [ZL2 [XX2 [Z2 HL2]]]]].
destruct XX2 as [l3 [tm3 [ZL3 [XX3 [Z1 HL3]]]]].
destruct XX3 as [l4 [tm4 [ZL4 [XX4 [Z0 HL4]]]]].
simpl in *.
subst.
rewrite <- Z0, <- Z1, <- Z2, <- Z3.
reflexivity.
Time Qed. (*June 4th,2017 (laptop):Finished transaction in 9.528 secs (8.024u,0.02s) (successful)*)


Require Import ExtLib.Structures.Monads.

Set Implicit Arguments.
Set Strict Implicit.

Import MonadNotation.
Local Open Scope monad_scope.

Global Instance Monad_option : Monad option :=
{ ret  := @Some
; bind := fun _ _ c1 c2 => match c1 with
                             | None => None
                             | Some v => c2 v
                           end
}.

Global Instance Zero_option : MonadZero option :=
{ mzero := @None }.

Global Instance Plus_option : MonadPlus option :=
{ mplus _A _B aM bM :=
    match aM with
    | None => liftM inr bM
    | Some a => Some (inl a)
    end
}.

Section Trans.
  Variable m : Type -> Type.

  Inductive optionT a := mkOptionT { unOptionT : m (option a) }.

  Context {M : Monad m}.

  Global Instance Monad_optionT : Monad optionT :=
  { ret _A := fun x => mkOptionT (ret (Some x))
  ; bind _A _B aMM f := mkOptionT
      (aM <- unOptionT aMM ;;
       match aM with
       | None => ret None
       | Some a => unOptionT (f a)
       end)
  }.

  Global Instance Zero_optionT : MonadZero optionT :=
  { mzero _A := mkOptionT (ret None) }.

  Global Instance MonadT_optionT : MonadT optionT m :=
  { lift _A aM := mkOptionT (liftM ret aM) }.

  Global Instance State_optionT {T} (SM : MonadState T m) : MonadState T optionT :=
  { get := lift get
  ; put v := lift (put v)
  }.

  Instance Plus_optionT_right : MonadPlus optionT :=
  { mplus _A _B a b :=
      mkOptionT (bind (unOptionT b) (fun b =>
        match b with
          | None =>
            bind (unOptionT a) (fun a =>
                                  match a with
                                    | None => ret None
                                    | Some a => ret (Some (inl a))
                                  end)
          | Some b => ret (Some (inr b))
        end))
  }.

  Instance Plus_optionT_left : MonadPlus optionT :=
  { mplus _A _B a b :=
      mkOptionT (bind (unOptionT a) (fun a =>
        match a with
          | None =>
            bind (unOptionT b) (fun b =>
                                  match b with
                                    | None => ret None
                                    | Some b => ret (Some (inr b))
                                  end)
          | Some a => ret (Some (inl a))
        end))
  }.

  Global Instance Plus_optionT : MonadPlus optionT := Plus_optionT_left.

  Global Instance Reader_optionT {T} (SM : MonadReader T m) : MonadReader T optionT :=
  { ask := lift ask
  ; local _T v cmd := mkOptionT (local v (unOptionT cmd))
  }.

  Instance OptionTError : MonadExc unit optionT :=
  { raise _u _A := mzero
  ; catch _A aMM f := mkOptionT
      (aM <- unOptionT aMM ;;
       match aM with
       | None => unOptionT (f tt)
       | Some x => ret (Some x)
       end)
  }.

End Trans.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext machine_int uniq_tac.
Import MachineInt.
Require Import mips_cmd mips_tactics mips_contrib.
Import expr_m.
Require Import copy_u_u_prg.

Local Open Scope machine_int_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope uniq_scope.

Lemma copy_u_u_termination st h rk ru rx a0 a1 a2 :
  uniq(rk, ru, rx, a0, a1, a2, r0) ->
  {si | Some (st, h) -- copy_u_u rk ru rx a0 a1 a2 ---> si}%mips_cmd.
Proof.
move=> Hset.
rewrite /copy_u_u.
apply exists_addiu_seq.
rewrite sext_Z2u // addi0.
apply exists_addiu_seq.
rewrite sext_Z2u // addi0.
repeat Reg_upd.
set s0 := store.upd _ _ _.
have [na2 Ha2] : { na2 | u2Z [rk]_s0 - u2Z [a2]_s0 = Z_of_nat na2 }%mips_expr.
  have [va2 Hva2] : { va2 | u2Z [rk]_s0 - u2Z [a2]_s0 = va2}%mips_expr by eapply exist; reflexivity.
  have : 0 <= va2.
    move: Hva2.
    rewrite /s0.
    repeat Reg_upd.
    rewrite Z2uK // subZ0 => <-.
    by apply min_u2Z.
  case/Z_of_nat_complete_inf => na2 va2_na2.
  by exists na2; rewrite Hva2.
move: na2 s0 Ha2 h; elim.
- move=> s0 Ha2 h.
  exists (Some (s0, h)).
  apply while.exec_while_false => /=.
  rewrite negbK.
  rewrite /= in Ha2.
  apply/eqP.
  lia.
- move=> na2 IH s0 Hna2 h.
  apply exists_while.
  + rewrite /=.
    apply/eqP => abs.
    rewrite abs Z_S subZZ in Hna2;lia.
  + apply exists_seq_P2 with (fun st => u2Z [rk]_(fst st) - u2Z [a2]_(fst st) = Z_of_nat na2)%mips_expr.
    * exists_lwxs l_idx H_l_idx z_idx H_z_idx.
      exists_sw_P l_idx2 H_l_idx2 z_idx2 H_z_idx2.
      repeat Reg_upd.
      apply exists_addiu_seq_P.
      repeat Reg_upd.
      apply exists_addiu_P.
      rewrite /=.
      repeat Reg_upd.
      rewrite Z_S in Hna2.
      rewrite sext_Z2u // u2Z_add_Z2u //.
      lia.
      move: (min_u2Z ([rk ]_ s0)%mips_expr) => ?.
      move: (min_u2Z ([a2 ]_ s0)%mips_expr) => ?.
      move: (max_u2Z ([rk ]_ s0)%mips_expr) => ?.
      move: (max_u2Z ([a2 ]_ s0)%mips_expr) => ?.
      lia.
    * move=> [si hi] Hna2'.
      by apply IH.
Qed.


Require Import ZArith.
Require Import Coq.Strings.String.
Require Import List. Import ListNotations.

Set Warnings "-extraction-reserved-identifier".

From QuickChick Require Import QuickChick.

Require Import IFC.Rules.
Require Import IFC.TestingCommon.
Require Import IFC.Generation.
Require Import IFC.Shrinking.
Require Import IFC.SSNI.
Require Import IFC.Reachability.
Require Import IFC.SingleStateArb.

Require Import IFC.SanityChecks.

(* Testing well-formedness first *)

QuickCheck prop_stamp_generation.

QuickCheck prop_generate_indist.

QuickCheck (prop_fstep_preserves_well_formed default_table).

(* Testing non-interference second (default table) *)

Definition testSSNI t := quickCheck (propSSNI_smart exp_result_normal t).

QuickCheck (propSSNI_smart exp_result_normal default_table).

(* Testing mutants third *)

Require Import Mutate.
From QuickChick Require Import MutateCheck.

Instance mutateable_table : Mutateable table :=
{|
  mutate := mutate_table
|}.

Definition testMutantX_  n :Checker :=
  propSSNI_smart  exp_result_normal (nth n (mutate_table default_table) default_table).

QuickChick (testMutantX_ 0).
(* FuzzChick (testMutantX_ 0).*)
(*
Eval simpl in (nth 24 (mutate_table default_table) default_table).
*)
MutateCheckMany default_table (fun t => [propSSNI_smart exp_result_normal t;
    prop_fstep_preserves_well_formed t]).

(* The rest of this file is mostly garbage *)

(*
Eval lazy -[labelCount helper] in
  nth 26 (mutate_table default_table) default_table.
*)

Definition testMutantX x y :=
  let mutant := fun o' =>
    (helper x y o' (default_table o'))  in
  testSSNI mutant.

FuzzChick

Definition testMutant7 := testMutantX
  OpBCall (≪TRUE, JOIN Lab2 LabPC, Lab1 ≫).
(* CH: most often we catch this one; but sometimes it escapes *)

Definition testMutant9 := testMutantX
  OpBRet (≪LE Lab1 (JOIN Lab2 Lab3), Lab2, Lab3 ≫).
(* Problem: we weren't generating _any_ HIGH -> LOW cases;
            doing a very bad job at generating stacks!
("Some OpBRet, Failed",484),
("Some OpBRet, HIGH -> HIGH",206),
("Some OpBRet, LOW -> *",224),
("Some OpBRet, Second failed H",28),
("Some OpBRet, Second not low",83),
   After expedient fix this finds the bug and looks like this:
("Some OpBRet, Failed",85),
("Some OpBRet, HIGH -> HIGH",23),
("Some OpBRet, LOW -> *",40),
("Some OpBRet, Second failed H",6),
("Some OpBRet, HIGH -> LOW",7), <---- this case was missing
*)

Definition testMutant26 := testMutantX
  OpBNZ (≪TRUE, __ , LabPC ≫).
(* This was found, just not often enough (once in 20000-30000 tests)
   We weren't generating zeroes often enough (1 in 200)
   Changed to 1 in 10 and we're finding this just fine. *)

Definition testMutant29 := testMutantX
  OpLoad (≪TRUE, Lab3, JOIN Lab1 Lab2 ≫).
(* CH: this one is at the limit (with 10000 tests sometimes we catch
       it and sometimes we don't)*)

Definition testMutant36 := testMutantX
  OpAlloc (≪TRUE, Lab2, LabPC ≫).
(* XXX: this and the next mutants break well-formedness;
   but we don't test that as a precondition to SSNI
   DONE: for each mutant we should also test well-formedness
   and if that fails the mutant is also killed *)

Definition testMutantWF x y :=
  let mutant := fun o' =>
    (helper x y o' (default_table o'))  in
  quickCheck (prop_fstep_preserves_well_formed mutant).

Definition testMutant36wf := testMutantWF
  OpAlloc (≪TRUE, Lab2, LabPC ≫).
(* XXX: this sometimes fails, and otherwise gives stack overflow
   during shrinking (probably an infinite loop of some sort) *)

Definition testMutant37 := testMutantX
  OpAlloc (≪TRUE, Lab1, LabPC ≫).

Definition testMutant37wf := testMutantWF
  OpAlloc (≪TRUE, Lab1, LabPC ≫).
(* XXX: this sometimes fails, and otherwise gives stack overflow
   during shrinking (probably an infinite loop of some sort) *)

(* Definition testNI := testMutant37wf. *)

(* QuickCheck testMutants.*)
(* Definition testNI := testMutant9.*)
(* Definition testNI := testSSNI default_table. *)
(* Definition testNI := quickCheck prop_stamp_generation. *)
(* Definition testNI :=
  quickCheck (prop_preserves_well_formed default_table). *)
(* Definition testNI := quickCheck prop_generate_indist. *)
(*(forAllShrink (fun _ => "implement me!")
                           genSingleExecState
                           (fun _ => nil)
                           (propWellFormednessPreserved default_table)).*)

(*Definition testNI :=
  let l := lab_of_list [Pos.of_nat 1] in
  let h := lab_of_list [Pos.of_nat 1; Pos.of_nat 2] in
  match alloc 2%Z l bot (Vint Z0 @ bot) (Mem.empty Atom Label) with
    | Some (mf, m') =>
      map (Mem.get_frame m') (Mem.get_all_blocks h m')
    | _ => []
  end.
*)


Set Implicit Arguments.

Require Import Bedrock.Platform.Cito.ADT.

Module Make (Import E : ADT).

  Require Import Bedrock.Platform.Cito.Semantics.
  Module Import SemanticsMake := Make E.

  Section TopSection.

    Require Import Bedrock.Platform.Cito.GoodModule.
    Require Import Bedrock.Platform.Cito.GLabelMap.
    Import GLabelMap.

    Open Scope bool_scope.
    Notation "! b" := (negb b) (at level 35).

    Require Import Coq.Arith.Compare_dec.

    Definition to_bool A B (b : {A} + {B}) := if b then true else false.

    Notation fst2 := (fun x => @fst _ _ (@fst _ _ x)).

    Require Import Bedrock.Platform.Cito.ListFacts3.
    Require Import Bedrock.Platform.Cito.NameDecoration.

    Definition GoodToLink_bool (modules : list GoodModule) (imports : t ForeignFuncSpec) :=
      let imported_module_names := List.map fst2 (elements imports) in
      let module_names := List.map Name modules in
      ! sumbool_to_bool (zerop (length modules)) &&
        is_no_dup module_names &&
        forallb (fun s => ! sumbool_to_bool (in_dec string_dec s module_names)) imported_module_names &&
        forallb is_good_module_name imported_module_names.

    Require Import Bedrock.Platform.Cito.GeneralTactics.
    Require Import Bedrock.Platform.Cito.ListFacts1.
    Require Import Bedrock.Platform.Cito.GeneralTactics.
    Require Import Coq.Bool.Bool.
    Require Import Bedrock.Platform.Cito.GLabelMapFacts.

    Lemma GoodToLink_bool_sound :
      forall modules imports,
        GoodToLink_bool modules imports = true ->
        modules <> nil /\
        List.NoDup (List.map Name modules) /\
        ListFacts1.Disjoint (List.map Name modules) (List.map fst2 (elements imports)) /\
        forall l, In l imports -> IsGoodModuleName (fst l).
    Proof.
      intros.
      unfold GoodToLink_bool in *; simpl in *.
      repeat (eapply andb_true_iff in H; openhyp).
      split.
      eapply negb_true_iff in H.
      unfold sumbool_to_bool in *.
      destruct (zerop _); intuition.
      subst; simpl in *; intuition.
      split.
      eapply is_no_dup_sound; eauto.
      split.
      unfold ListFacts1.Disjoint; intuition.
      eapply forallb_forall in H1; eauto.
      eapply negb_true_iff in H1.
      unfold sumbool_to_bool in *.
      destruct (in_dec _ _ _); intuition.
      intros.
      eapply forallb_forall in H0; eauto.
      rewrite <- map_map.
      eapply in_map.
      eapply In_fst_elements_In; eauto.
    Qed.

  End TopSection.
(*
  Require Import RepInv.

  Module Make (Import M : RepInv E).

    Require Import Link.
    Module Import LinkMake := Make E M.
    Require Import GoodOptimizer.
    Module Import GoodOptimizerMake := Make E.
    Require Import AutoSep.

    Lemma result_ok_2 :
      forall modules imports,
        GoodToLink_bool modules imports = true ->
        forall opt (opt_g: GoodOptimizer opt),
          moduleOk (result modules imports opt_g).
    Proof.
      intros.
      eapply GoodToLink_bool_sound in H.
      Require Import GeneralTactics.
      openhyp.
      eapply result_ok; eauto.
    Qed.

  End Make.
*)
End Make.


Require Import String.
Require Import Relations Decidable.
Require Import FFJ.Base.
Require Import FFJ.Syntax.
Require Import FFJ.ClassTable.

Fixpoint subst (e: Exp) (ds: [Exp]) (xs: [Var]): Exp :=
  match e with
  | ExpVar var => match find_where var xs with
                  | Some i => match nth_error ds i with
                                   | None => e | Some di => di end
                  | None => e end
  | ExpFieldAccess exp i => ExpFieldAccess (subst exp ds xs) i
  | ExpMethodInvoc exp i exps =>
      ExpMethodInvoc (subst exp ds xs) i (map (fun x => subst x ds xs) exps)
  | ExpCast cname exp => ExpCast cname (subst exp ds xs)
  | ExpNew cname exps => ExpNew cname (map (fun x => subst x ds xs) exps)
  end.
Notation " [; ds '\' xs ;] e " := (subst e ds xs) (at level 30).

Inductive Warning (s: string) : Prop :=
  | w_str : Warning s.
Notation stupid_warning := (Warning "stupid warning").

(* We can make a stupid cast at anytime, but that rule must be flagged. *)
Axiom STUPID_STEP : stupid_warning.

Reserved Notation "Gamma '|--' x ':' C" (at level 60, x at next level).
Inductive ExpTyping (Gamma: env ClassName) : Exp -> ClassName -> Prop :=
  | T_Var : forall x C, get Gamma x = Some C ->
                Gamma |-- ExpVar x : C
  | T_Field: forall e0 C0 fs i Fi Ci fi,
                Gamma |-- e0 : C0 ->
                fields C0 fs ->
                nth_error fs i = Some Fi ->
                Ci = fieldType Fi ->
                fi = ref Fi ->
                Gamma |-- ExpFieldAccess e0 fi : Ci
  | T_Invk : forall e0 C Cs C0 Ds m es,
                Gamma |-- e0 : C0 ->
                mtype(m, C0) = Ds ~> C ->
                Forall2 (ExpTyping Gamma) es Cs ->
                Forall2 Subtype Cs Ds ->
                Gamma |-- ExpMethodInvoc e0 m es : C
  | T_New : forall C Ds Cs fs es,
                fields C fs ->
                Ds = map fieldType fs ->
                Forall2 (ExpTyping Gamma) es Cs ->
                Forall2 Subtype Cs Ds ->
                Gamma |-- ExpNew C es : C
  | T_UCast : forall e0 D C,
                Gamma |-- e0 : D ->
                D <: C ->
                Gamma |-- ExpCast C e0 : C
  | T_DCast : forall e0 C D,
                Gamma |-- e0 : D ->
                C <: D ->
                C <> D ->
                Gamma |-- ExpCast C e0 : C
  | T_SCast : forall e0 D C,
                Gamma |-- e0 : D ->
                ~ D <: C ->
                ~ C <: D ->
                stupid_warning ->
                Gamma |-- ExpCast C e0 : C
  where " Gamma '|--' e ':' C " := (ExpTyping Gamma e C).

Tactic Notation "typing_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Field"
  | Case_aux c "T_Invk" | Case_aux c "T_New"
  | Case_aux c "T_UCast" | Case_aux c "T_DCast"
  | Case_aux c "T_SCast"].

Reserved Notation "e '~>!' e1" (at level 59).
Inductive Computation_step : Exp -> Exp -> Prop :=
  | R_Field : forall C Fs es fi ei i,
            fields C Fs ->
            nth_error Fs i = Some fi ->
            nth_error es i = Some ei->
            ExpFieldAccess (ExpNew C es) (ref fi) ~>! ei
  | R_Invk : forall C m xs ds es e0,
            mbody(m, C) = xs o e0 ->
            NoDup (this :: xs) ->
            List.length ds = List.length xs ->
            ExpMethodInvoc (ExpNew C es) m ds ~>! [; ExpNew C es :: ds \ this :: xs;] e0
  | R_Cast : forall C D es,
            C <: D ->
            ExpCast D (ExpNew C es) ~>! ExpNew C es
  where "e '~>!' e1" := (Computation_step e e1).
Tactic Notation "computation_step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "R_Field" | Case_aux c "R_Invk"
  | Case_aux c "R_Cast" ].

Reserved Notation "e '~>' e1" (at level 60).
Inductive Computation : Exp -> Exp -> Prop :=
  | R_Step : forall e e1, e ~>! e1 -> e ~> e1
  | RC_Field : forall e0 e0' f,
            e0 ~> e0' ->
            ExpFieldAccess e0 f ~> ExpFieldAccess e0' f
  | RC_Invk_Recv : forall e0 e0' m es,
            e0 ~> e0' ->
            ExpMethodInvoc e0 m es ~> ExpMethodInvoc e0' m es
  | RC_Invk_Arg : forall e0 ei' m es es' ei i,
            ei ~> ei' ->
            nth_error es i = Some ei ->
            nth_error es' i = Some ei' ->
            (forall j, j <> i -> nth_error es j = nth_error es' j) ->
            length es = length es' ->
            ExpMethodInvoc e0 m es ~> ExpMethodInvoc e0 m es'
  | RC_New_Arg : forall C ei' es es' ei i,
            ei ~> ei' ->
            nth_error es i = Some ei ->
            nth_error es' i = Some ei' ->
            (forall j, j <> i -> nth_error es j = nth_error es' j) ->
            length es = length es' ->
            ExpNew C es ~> ExpNew C es'
  | RC_Cast : forall C e0 e0',
            e0 ~> e0' ->
            ExpCast C e0 ~> ExpCast C e0'
  where "e '~>' e1" := (Computation e e1).

Tactic Notation "computation_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "R_Step" | Case_aux c "RC_Field"
  | Case_aux c "RC_Invk_Recv" | Case_aux c "RC_Invk_Arg"
  | Case_aux c "RC_New_Arg" | Case_aux c "RC_Cast"].

Inductive Value : Exp -> Prop :=
  v_new: forall C es, Value (ExpNew C es).

Reserved Notation "e '~>*' e1" (at level 59).
Inductive ComputationStar : Exp -> Exp -> Prop :=
  | Comp_Refl : forall e,
    e ~>* e
  | Comp_Trans: forall e1 e2 e3,
    e1 ~>* e2 ->
    e2 ~>* e3 ->
    e1 ~>* e3
  where "e '~>*' e1" := (ComputationStar e e1).
Hint Constructors Computation ExpTyping Value ComputationStar.
Definition normal_form {X:Type} (R: relation X) (t: X) :=
  ~exists t', R t t'.

Definition override (m: id) (D: ClassName) (Cs: [ClassName]) (C0: ClassName) :=
    (forall Ds D0, mtype(m, D) = Ds ~> D0 -> (Ds = Cs /\ C0 = D0)).

(* We cut off introduce in this rule, because our definition of introduce only checks backwards,
  hence no need to check on a Class Declaration *)
Inductive MType_OK : ClassName -> MethodDecl -> Prop :=
  | T_Method : forall C D C0 E0 xs Cs e0 Fs noDupfs K Ms noDupMds fargs m noDupFargs,
            nil extds (this :: xs) : (C :: Cs) |-- e0 : E0 ->
            E0 <: C0 ->
            find C CT = Some (CDecl C D Fs noDupfs K Ms noDupMds) ->
            override m D Cs C0 ->
            map fargType fargs = Cs ->
            refs fargs = xs ->
            find m Ms = Some (MDecl C0 m fargs noDupFargs e0) ->
            MType_OK C (MDecl C0 m fargs noDupFargs e0).

(*In the paper there is no override in this rule, but if you don't need it here
then you wouldn't need it in MType_OK also *)
Inductive MType_r_OK : RefinementName -> MethodDecl -> Prop :=
  | TCR_Method : forall R C D C0 E0 xs Cs e0 feat fs noDupfDecls K Ms noDupmDecls mRefines noDupmRefines m fargs noDupFargs fs' noDupfDecls' K' Ms' noDupMds',
            nil extds (this :: xs) : (C :: Cs) |-- e0 : E0 ->
            E0 <: C0 ->
            R = C @ feat ->
            find C CT = Some (CDecl C D fs' noDupfDecls' K' Ms' noDupMds') ->
            find_refinement R (CRefine R fs noDupfDecls K Ms noDupmDecls mRefines noDupmRefines) ->
            override m D Cs C0 ->
            map fargType fargs = Cs ->
            refs fargs = xs ->
            find m Ms = Some (MDecl C0 m fargs noDupFargs e0) ->
            introduce m R ->
            MType_r_OK R (MDecl C0 m fargs noDupFargs e0).

Inductive MRType_r_OK: RefinementName -> MethodRefinement -> Prop :=
  | TR_Method : forall R C C0 E0 xs Cs e0 feat fs noDupfDecls K Ms noDupmDecls mRefines noDupmRefines m fargs noDupFargs,
            nil extds (this :: xs) : (C :: Cs) |-- e0 : E0 ->
            E0 <: C0 ->
            R = C @ feat ->
            find_refinement R (CRefine R fs noDupfDecls K Ms noDupmDecls mRefines noDupmRefines) ->
            map fargType fargs = Cs ->
            refs fargs = xs ->
            find m mRefines = Some (MRefine C0 m fargs noDupFargs e0) ->
            find m Ms = None ->
            override_r m R Cs C0 ->
            MRType_r_OK R (MRefine C0 m fargs noDupFargs e0).

Inductive CType_OK: ClassDecl -> Prop :=
  | T_Class : forall C D Fs noDupfs K Ms noDupMds Cfargs Dfargs fdecl,
            K = KDecl C (Cfargs ++ Dfargs) (map Arg (refs Cfargs)) (zipWith Assgnmt (map (ExpFieldAccess (ExpVar this)) (refs Fs)) (map ExpVar (refs Fs))) ->
            fields D fdecl ->
            NoDup (refs (fdecl ++ Fs)) ->
            Forall (MType_OK C) (Ms) ->
            find C CT = Some (CDecl C D Fs noDupfs K Ms noDupMds) ->
            (forall R fs',  last_refinement C = Some R ->
                            fields_r R fs' ->
                            NoDup (refs (fdecl ++ Fs ++ fs'))) ->
            NoDup (refs (fdecl ++ Fs)) ->
            CType_OK (CDecl C D Fs noDupfs K Ms noDupMds).

Inductive NoDup_fields: RefinementName -> Prop :=
  | NoDup_Pred: forall R fs noDupfs K Ms noDupMds mRefines noDupmRefines P fs',
    find_refinement R (CRefine R fs noDupfs K Ms noDupMds mRefines noDupmRefines) ->
    pred R P ->
    fields_r P fs' ->
    NoDup (refs (fs' ++ fs))->
    NoDup_fields R
  | NoDup_First: forall R fs noDupfs K Ms noDupMds mRefines noDupmRefines fs',
    find_refinement R (CRefine R fs noDupfs K Ms noDupMds mRefines noDupmRefines) ->
    first_refinement R ->
    fields (class_name R) fs' ->
    NoDup (refs (fs' ++ fs))->
    NoDup_fields R.

Inductive CRType_OK: ClassRefinement -> Prop :=
  | TR_Refinement : forall R fs noDupfs K Ms noDupMds mRefines noDupmRefines,
      find_refinement R (CRefine R fs noDupfs K Ms noDupMds mRefines noDupmRefines) ->
      NoDup_fields R ->
      Forall (MType_r_OK R) Ms ->
      Forall (MRType_r_OK R) (mRefines) ->
      CRType_OK (CRefine R fs noDupfs K Ms noDupMds mRefines noDupmRefines).

(* Hypothesis for ClassTable sanity *)
Module CTSanity.

Hypothesis obj_notin_dom: find Object CT = None.
Hint Rewrite obj_notin_dom.

Hypothesis dec_subtype: forall C D,
  decidable (Subtype C D).

Hypothesis antisym_subtype:
  antisymmetric _ Subtype.

Hypothesis superClass_in_dom: forall C D Fs noDupfs K Ms noDupMds,
  find C CT = Some (CDecl C D Fs noDupfs K Ms noDupMds) ->
  D <> Object ->
  exists D0 Fs0 noDupfs0 K0 Ms0 noDupMds0, find D CT = Some (CDecl D D0 Fs0 noDupfs0 K0 Ms0 noDupMds0).

Hypothesis RT_wellformed:
  Forall (fun CR => CRType_OK CR) RT.

(*TODO: Not use Excluded middle *)
Hypothesis em : forall A:Prop, A \/ ~ A.

Lemma ClassesRefinementOK': forall R,
  In R RT ->
  CRType_OK R.
Proof.
  apply Forall_forall.
  exact RT_wellformed.
Qed.

Lemma pred_in_dom': forall Cl S,
  pred S Cl ->
  exists CD, find_refinement Cl CD.
Proof.
  intros. destruct S. destruct Cl. inversion H. destruct CR. destruct r. subst.
  unfold refinements_of in *.
  apply nth_error_In in H6. apply filter_In in H6. destruct H6.
  apply ClassesRefinementOK' in H0. inversion H0; eauto.
Qed.

Lemma ClassesRefinementOK: forall R RD,
  find_refinement R RD ->
  CRType_OK RD.
Proof.
  intros. inversion H. subst.
  apply find_in in H2.
  unfold refinements_of in H2.
  apply filter_In in H2. destruct H2.
  eapply ClassesRefinementOK'; eauto.
Qed.
Hint Resolve ClassesRefinementOK  ClassesRefinementOK' pred_in_dom'.

Hypothesis ClassesOK: forall C CD,
  find C CT = Some CD->
  CType_OK CD.
Hint Resolve ClassesOK.

Lemma subtype_obj_obj: forall C,
  Object <: C ->
  Object = C.
Proof.
  intros_all. remember Object as Obj.
  induction H; crush.
Qed.

Lemma sub_not_obj: forall C,
  Object <> C ->
  ~ Object <: C.
Proof.
  Hint Resolve subtype_obj_obj.
  intros_all. remember Object as Obj.
  induction H; crush.
Qed.

End CTSanity.

Definition ExpTyping_ind' :=
  fun (Gamma : env ClassName) (P : Exp -> ClassName -> Prop)
  (f : forall (x : id) (C : ClassName), get Gamma x = Some C -> P (ExpVar x) C)
  (f0 : forall (e0 : Exp) (C0 : ClassName) (fs : [FieldDecl]) (i : nat) (Fi : FieldDecl)
          (Ci : ClassName) (fi : id),
        Gamma |-- e0 : C0 ->
        P e0 C0 ->
        fields C0 fs ->
        nth_error fs i = Some Fi -> Ci = fieldType Fi -> fi = ref Fi -> P (ExpFieldAccess e0 fi) Ci)
  (f1 : forall (e0 : Exp) (C : ClassName) (Cs : [ClassName]) (C0 : ClassName) (Ds : [ClassName])
          (m : id) (es : [Exp]),
        Gamma |-- e0 : C0 ->
        P e0 C0 ->
        mtype( m, C0)= Ds ~> C ->
        Forall2 (ExpTyping Gamma) es Cs ->
        Forall2 Subtype Cs Ds ->
        Forall2 P es Cs ->
        P (ExpMethodInvoc e0 m es) C)
  (f2 : forall (C : id) (Ds Cs : [ClassName]) (fs : [FieldDecl]) (es : [Exp]),
        fields C fs ->
        Ds = map fieldType fs ->
        Forall2 (ExpTyping Gamma) es Cs ->
        Forall2 Subtype Cs Ds ->
        Forall2 P es Cs ->
        P (ExpNew C es) C)
  (f3 : forall (e0 : Exp) (D C : ClassName), Gamma |-- e0 : D -> P e0 D -> D <: C -> P (ExpCast C e0) C)
  (f4 : forall (e0 : Exp) (C : id) (D : ClassName),
        Gamma |-- e0 : D -> P e0 D -> C <: D -> C <> D -> P (ExpCast C e0) C)
  (f5 : forall (e0 : Exp) (D C : ClassName),
        Gamma |-- e0 : D -> P e0 D -> ~ D <: C -> ~ C <: D -> stupid_warning -> P (ExpCast C e0) C) =>
fix F (e : Exp) (c : ClassName) (e0 : Gamma |-- e : c) {struct e0} : P e c :=
  match e0 in (_ |-- e1 : c0) return (P e1 c0) with
  | T_Var _ x C e1 => f x C e1
  | T_Field _ e1 C0 fs i Fi Ci fi e2 f6 e3 e4 e5 => f0 e1 C0 fs i Fi Ci fi e2 (F e1 C0 e2) f6 e3 e4 e5
  | T_Invk _ e1 C Cs C0 Ds m es e2 m0 f6 f7 => f1 e1 C Cs C0 Ds m es e2 (F e1 C0 e2) m0 f6 f7
          ((fix list_Forall_ind (es' : [Exp]) (Cs' : [ClassName])
            (map : Forall2 (ExpTyping Gamma) es' Cs'):
               Forall2 P es' Cs' :=
            match map with
            | Forall2_nil _ => Forall2_nil P
            | (@Forall2_cons _ _ _ ex cx ees ccs H1 H2) => Forall2_cons ex cx (F ex cx H1) (list_Forall_ind ees ccs H2)
          end) es Cs f6)
  | T_New _ C Ds Cs fs es f6 e1 f7 f8 => f2 C Ds Cs fs es f6 e1 f7 f8
          ((fix list_Forall_ind (es' : [Exp]) (Cs' : [ClassName])
            (map : Forall2 (ExpTyping Gamma) es' Cs'):
               Forall2 P es' Cs' :=
            match map with
            | Forall2_nil _ => Forall2_nil P
            | (@Forall2_cons _ _ _ ex cx ees ccs H1 H2) => Forall2_cons ex cx (F ex cx H1) (list_Forall_ind ees ccs H2)
          end) es Cs f7)
  | T_UCast _ e1 D C e2 s => f3 e1 D C e2 (F e1 D e2) s
  | T_DCast _ e1 C D e2 s n => f4 e1 C D e2 (F e1 D e2) s n
  | T_SCast _ e1 D C e2 s s0 w => f5 e1 D C e2 (F e1 D e2) s s0 w
  end.


Require Import Coq.Strings.String.
Require Import Coq.ZArith.BinInt.
Require Import coqutil.Map.Interface.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.LittleEndian.
Require Import riscv.Spec.Decode.
Require Import riscv.Platform.Memory.
Require Import riscv.Utility.Utility.

Section Machine.

  Context {width: Z} {word: word width} {word_ok: word.ok word}.
  Context {Registers: map.map Register word}.
  Context {Mem: map.map word byte}.

  (* (memory before call, call name, arg values) and (memory after call, return values) *)
  Definition LogItem{_: Bitwidth width}: Type := (Mem * string * list word) * (Mem * list word).

  (* set of executable addresses. On some processors, this could be the whole address range,
     while on others, only a specific range. And when an address is written, we might
     conservatively remove it from that set if we want to prove that our software does not
     depend on self-modifying code being possible.
     The ifence instruction will flush the instruction cache and therefore put back the
     set of executable addresses to the whole range. *)
  Definition XAddrs: Type := list word.

  Definition isXAddr1B(a: word)(xAddrs: XAddrs): bool :=
    match List.find (word.eqb a) xAddrs with
    | Some _ => true
    | None => false
    end.

  Definition isXAddr4B(a: word)(xAddrs: XAddrs): bool :=
    isXAddr1B a xAddrs &&
    isXAddr1B (word.add a (word.of_Z 1)) xAddrs &&
    isXAddr1B (word.add a (word.of_Z 2)) xAddrs &&
    isXAddr1B (word.add a (word.of_Z 3)) xAddrs.

  Definition isXAddr1: word -> XAddrs -> Prop := @List.In word.

  Definition isXAddr4(a: word)(xAddrs: XAddrs): Prop :=
    isXAddr1 a xAddrs /\
    isXAddr1 (word.add a (word.of_Z 1)) xAddrs /\
    isXAddr1 (word.add a (word.of_Z 2)) xAddrs /\
    isXAddr1 (word.add a (word.of_Z 3)) xAddrs.

  Lemma isXAddr1B_holds: forall a xAddrs,
      isXAddr1B a xAddrs = true -> isXAddr1 a xAddrs.
  Proof.
    unfold isXAddr1B, isXAddr1. intros.
    destruct (List.find (word.eqb a) xAddrs) eqn: E; [|discriminate].
    apply List.find_some in E. destruct E.
    apply Word.Properties.word.eqb_true in H1.
    subst. assumption.
  Qed.

  Lemma isXAddr1B_not: forall a xAddrs,
      isXAddr1B a xAddrs = false -> ~ isXAddr1 a xAddrs.
  Proof.
    unfold isXAddr1B, isXAddr1. intros.
    destruct (List.find (word.eqb a) xAddrs) eqn: E; [discriminate|].
    intro C.
    pose proof (List.find_none _ _ E _ C) as P.
    rewrite Word.Properties.word.eqb_eq in P by reflexivity.
    discriminate.
  Qed.

  Lemma isXAddr1B_true: forall a xAddrs,
      isXAddr1 a xAddrs -> isXAddr1B a xAddrs = true.
  Proof.
    intros. destruct (isXAddr1B a xAddrs) eqn: E; [reflexivity|exfalso].
    eapply isXAddr1B_not; eassumption.
  Qed.

  Lemma isXAddr1B_false: forall a xAddrs,
      ~ isXAddr1 a xAddrs -> isXAddr1B a xAddrs = false.
  Proof.
    intros. destruct (isXAddr1B a xAddrs) eqn: E; [exfalso|reflexivity].
    apply isXAddr1B_holds in E. contradiction.
  Qed.

  Lemma isXAddr4B_holds: forall a xAddrs,
      isXAddr4B a xAddrs = true -> isXAddr4 a xAddrs.
  Proof.
    unfold isXAddr4B, isXAddr4. intros.
    apply andb_prop in H. destruct H as [H ?].
    apply andb_prop in H. destruct H as [H ?].
    apply andb_prop in H. destruct H as [H ?].
    apply isXAddr1B_holds in H.
    apply isXAddr1B_holds in H0.
    apply isXAddr1B_holds in H1.
    apply isXAddr1B_holds in H2.
    auto.
  Qed.

  Lemma isXAddr4B_not: forall a xAddrs,
      isXAddr4B a xAddrs = false -> ~ isXAddr4 a xAddrs.
  Proof.
    unfold isXAddr4B, isXAddr4. intros.
    intros [C0 [C1 [C2 C3]]].
    apply isXAddr1B_true in C0. rewrite C0 in H.
    apply isXAddr1B_true in C1. rewrite C1 in H.
    apply isXAddr1B_true in C2. rewrite C2 in H.
    apply isXAddr1B_true in C3. rewrite C3 in H.
    discriminate H.
  Qed.

  Lemma isXAddr4B_true: forall a xAddrs,
      isXAddr4 a xAddrs -> isXAddr4B a xAddrs = true.
  Proof.
    intros. destruct (isXAddr4B a xAddrs) eqn: E; [reflexivity|exfalso].
    eapply isXAddr4B_not; eassumption.
  Qed.

  Lemma isXAddr4B_false: forall a xAddrs,
      ~ isXAddr4 a xAddrs -> isXAddr4B a xAddrs = false.
  Proof.
    intros. destruct (isXAddr4B a xAddrs) eqn: E; [exfalso|reflexivity].
    apply isXAddr4B_holds in E. contradiction.
  Qed.

  Definition removeXAddr(a: word): XAddrs -> XAddrs :=
    List.filter (fun a' => negb (word.eqb a a')).

  Definition addXAddr: word -> XAddrs -> XAddrs := List.cons.

  Fixpoint addXAddrRange(a: word)(nBytes: nat)(xAddrs: XAddrs): XAddrs :=
    match nBytes with
    | O => xAddrs
    | S n => addXAddr a (addXAddrRange (word.add a (word.of_Z 1)) n xAddrs)
    end.

  Section WithBitwidth.
    Context {BW: Bitwidth width}.

    Record RiscvMachine := mkRiscvMachine {
      getRegs: Registers;
      getPc: word;
      getNextPc: word;
      getMem: Mem;
      getXAddrs: XAddrs;
      getLog: list LogItem;
    }.

    Definition withRegs: Registers -> RiscvMachine -> RiscvMachine :=
      fun regs2 '(mkRiscvMachine regs1 pc nextPC mem xAddrs log) =>
                  mkRiscvMachine regs2 pc nextPC mem xAddrs log.

    Definition withPc: word -> RiscvMachine -> RiscvMachine :=
      fun pc2 '(mkRiscvMachine regs pc1 nextPC mem xAddrs log) =>
                mkRiscvMachine regs pc2 nextPC mem xAddrs log.

    Definition withNextPc: word -> RiscvMachine -> RiscvMachine :=
      fun nextPC2 '(mkRiscvMachine regs pc nextPC1 mem xAddrs log) =>
                    mkRiscvMachine regs pc nextPC2 mem xAddrs log.

    Definition withMem: Mem -> RiscvMachine -> RiscvMachine :=
      fun mem2 '(mkRiscvMachine regs pc nextPC mem1 xAddrs log)  =>
                 mkRiscvMachine regs pc nextPC mem2 xAddrs log.

    Definition withXAddrs: XAddrs -> RiscvMachine -> RiscvMachine :=
      fun xAddrs2 '(mkRiscvMachine regs pc nextPC mem xAddrs1 log)  =>
                    mkRiscvMachine regs pc nextPC mem xAddrs2 log.

    Definition withLog: list LogItem -> RiscvMachine -> RiscvMachine :=
      fun log2 '(mkRiscvMachine regs pc nextPC mem xAddrs log1) =>
                 mkRiscvMachine regs pc nextPC mem xAddrs log2.

    Definition withLogItem: LogItem -> RiscvMachine -> RiscvMachine :=
      fun item '(mkRiscvMachine regs pc nextPC mem xAddrs log) =>
                 mkRiscvMachine regs pc nextPC mem xAddrs (item :: log).

    Definition withLogItems: list LogItem -> RiscvMachine -> RiscvMachine :=
      fun items '(mkRiscvMachine regs pc nextPC mem xAddrs log) =>
                  mkRiscvMachine regs pc nextPC mem xAddrs (items ++ log).

    Definition Z32s_to_bytes(l: list Z): list byte :=
      List.flat_map (fun z => HList.tuple.to_list (LittleEndian.split 4 z)) l.

    Definition putProgram(prog: list MachineInt)(addr: word)(ma: RiscvMachine): RiscvMachine :=
      (withPc addr
      (withNextPc (word.add addr (word.of_Z 4))
      (withXAddrs (addXAddrRange addr (4 * List.length prog) ma.(getXAddrs))
      (withMem (unchecked_store_byte_list addr (Z32s_to_bytes prog) ma.(getMem)) ma)))).

  End WithBitwidth.
End Machine.


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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimThread.
Require Import Simulation.

Set Implicit Arguments.

Lemma singleton_consistent
      tid lang st lc sc mem
      (WF: Local.wf lc mem)
      (SC: Memory.closed_timemap sc mem)
      (MEM: Memory.closed mem)
      (CONSISTENT: Thread.consistent (Thread.mk lang st lc sc mem)):
  <<WF: Configuration.wf (Configuration.mk (IdentMap.singleton tid (existT _ _ st, lc)) sc mem)>> /\
  <<CONSISTENT: Configuration.consistent (Configuration.mk (IdentMap.singleton tid (existT _ _ st, lc)) sc mem)>>.
Proof.
  econs; ss.
  - econs; ss. econs.
    + i.
      apply IdentMap.singleton_find_inv in TH1.
      apply IdentMap.singleton_find_inv in TH2.
      des. Configuration.simplify.
    + i. apply IdentMap.singleton_find_inv in TH. des.
      Configuration.simplify.
  - ii. apply IdentMap.singleton_find_inv in TH. des.
    Configuration.simplify.
    apply CONSISTENT; eauto.
Qed.

Lemma singleton_consistent_inv
      tid lang st lc sc mem
      (WF: Configuration.wf (Configuration.mk (IdentMap.singleton tid (existT _ _ st, lc)) sc mem))
      (CONSISTENT: Configuration.consistent (Configuration.mk (IdentMap.singleton tid (existT _ _ st, lc)) sc mem)):
  <<WF: Local.wf lc mem>> /\
  <<SC: Memory.closed_timemap sc mem>> /\
  <<MEM: Memory.closed mem>> /\
  <<CONSISTENT: Thread.consistent (Thread.mk lang st lc sc mem)>>.
Proof.
  inv WF. inv WF0. exploit THREADS; eauto.
  { apply IdentMap.singleton_eq. }
  i. splits; eauto.
  eapply CONSISTENT. apply IdentMap.singleton_eq.
Qed.

Lemma singleton_is_terminal
      tid lang st lc:
  Threads.is_terminal (IdentMap.singleton tid (existT _ _ st, lc)) <->
  <<STATE: lang.(Language.is_terminal) st>> /\
  <<THREAD: Local.is_terminal lc>>.
Proof.
  econs; intro X.
  - eapply X. apply IdentMap.singleton_eq.
  - ii. apply IdentMap.singleton_find_inv in FIND. i. des.
    Configuration.simplify.
Qed.

Lemma sim_thread_sim
      lang_src lang_tgt
      sim_terminal
      st1_src lc1_src sc0_src mem0_src
      st1_tgt lc1_tgt sc0_tgt mem0_tgt
      tid
      (SIM: @sim_thread lang_src lang_tgt sim_terminal
                        st1_src lc1_src sc0_src mem0_src
                        st1_tgt lc1_tgt sc0_tgt mem0_tgt):
  sim
    (IdentMap.singleton tid (existT _ _ st1_src, lc1_src)) sc0_src mem0_src
    (IdentMap.singleton tid (existT _ _ st1_tgt, lc1_tgt)) sc0_tgt mem0_tgt.
Proof.
  revert st1_src lc1_src sc0_src mem0_src st1_tgt lc1_tgt sc0_tgt mem0_tgt SIM. pcofix CIH. i. pfold. ii.
  exploit singleton_consistent_inv; try apply WF_SRC; eauto. i. des.
  exploit singleton_consistent_inv; try apply WF_TGT; eauto. i. des.
  splits.
  - i. apply (singleton_is_terminal tid) in TERMINAL_TGT. des.
    punfold SIM. exploit SIM; try apply SC1; eauto. i. des.
    exploit TERMINAL; eauto. i. des.
    esplits; [|eauto|eauto|].
    + generalize (rtc_tail STEPS). intro X. des.
      * inv X0. inv TSTEP. destruct a2. econs 2; [|econs 1].
        econs. rewrite <- EVENT. econs; ss; eauto.
        { eapply IdentMap.singleton_eq. }
        { ii. eexists. splits; eauto. ss.
          eapply SimPromises.sem_bot_inv.
          inv THREAD. rewrite <- PROMISES0. apply LOCAL.
        }
      * inv X. s. erewrite IdentMap.singleton_add. econs.
    + ii. ss. rewrite IdentMap.singleton_add in *.
      apply IdentMap.singleton_find_inv in FIND. des. subst.
      splits; Configuration.simplify. econs; eauto.
      eapply SimPromises.sem_bot_inv.
      inv THREAD. rewrite <- PROMISES0. apply LOCAL.
  - i. inv STEP_TGT. ss.
    apply IdentMap.singleton_find_inv in TID. des.
    Configuration.simplify.
    exploit sim_thread_rtc_step; try apply STEPS; try apply SC1; eauto.
    { eapply sim_thread_future; eauto. }
    i. des. destruct e2. ss.
    exploit sim_thread_opt_step; try apply MEMORY; eauto.
    { econs 2. eauto. }
    i. des. rewrite STEPS1 in STEPS0. inv STEP0.
    { generalize (rtc_tail STEPS0). intro X. des.
      - inv X0. inv TSTEP. esplits; eauto.
        + rewrite <- EVENT. s. rewrite <- EVENT0.
          econs 2. econs; s.
          * apply IdentMap.singleton_eq.
          * etrans; eauto.
          * eauto.
          * eapply sim_thread_consistent; eauto.
        + right. s. rewrite ? IdentMap.singleton_add.
          apply CIH. ss.
      - inv X. esplits; eauto.
        + rewrite <- EVENT. s. instantiate (2 := tid). econs 1.
        + right. s. rewrite ? IdentMap.singleton_add.
          apply CIH. eauto.
    }
    esplits; eauto.
    + rewrite <- EVENT.
      econs 2. econs; s.
      * apply IdentMap.singleton_eq.
      * etrans; eauto.
      * eauto.
      * eapply sim_thread_consistent; eauto.
    + right. s. rewrite ? IdentMap.singleton_add.
      apply CIH. ss.
Qed.


Fail Fixpoint F (u : unit) : Prop :=
  (fun p : {P : Prop & _} => match p with existT _ _ P => P end)
  (existT (fun P => False -> P) (F tt) _).
(* Anomaly: A universe comparison can only happen between variables.
Please report. *)

Definition g (x : Prop) := x.

Definition h (y : Type) := y.

Definition eq_hf : h = g :> (Prop -> Type) :=
  @eq_refl (Prop -> Type) g.

Set Printing All.
Set Printing Universes.
Fail Definition eq_hf : h = g :> (Prop -> Type) :=
  eq_refl g.
(* Originally an anomaly, now says
Toplevel input, characters 48-57:
Error:
The term "@eq_refl (forall _ : Prop, Prop) g" has type
 "@eq (forall _ : Prop, Prop) g g" while it is expected to have type
 "@eq (forall _ : Prop, Type (* Top.16 *)) (fun y : Prop => h y) g"
(Universe inconsistency: Cannot enforce Prop = Top.16)). *)


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

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

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

Require Import FulfillStep.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import SimThread.
Require Import Compatibility.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Definition local_acquired (lc:Local.t) :=
  (Local.mk (TView.read_fence_tview (Local.tview lc) Ordering.acqrel) (Local.promises lc)).

Lemma sim_local_promise_acquired
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt mem2_tgt
      loc from to msg kind
      (STEP_TGT: Local.promise_step lc1_tgt mem1_tgt loc from to msg lc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src (local_acquired lc1_tgt))
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src mem2_src,
    <<STEP_SRC: Local.promise_step lc1_src mem1_src loc from to msg lc2_src mem2_src kind>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acquired lc2_tgt)>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit SimPromises.promise_bot; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  i. des.
  exploit Memory.promise_future; try apply PROMISE_SRC; try apply WF1_SRC; eauto.
  { destruct msg; ss. inv CLOSED. econs.
    eapply sim_memory_closed_opt_view; eauto. }
  i. des.
  esplits; eauto.
  - econs; eauto.
    destruct msg; ss. inv CLOSED. econs.
    eapply sim_memory_closed_opt_view; eauto.
  - econs; eauto.
Qed.

Lemma sim_local_fulfill_acquired
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      loc from to val releasedm_src releasedm_tgt released ord_src ord_tgt
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF: View.opt_wf releasedm_src)
      (RELM_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT: Time.le (View.rlx (View.unwrap releasedm_tgt) loc) from)
      (WF_RELM_TGT: View.opt_wf releasedm_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (ORD_TGT: Ordering.le ord_tgt Ordering.strong_relaxed)
      (STEP_TGT: fulfill_step lc1_tgt sc1_tgt loc from to val releasedm_tgt released ord_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_local SimPromises.bot lc1_src (local_acquired lc1_tgt))
      (ACQUIRED1: View.le (TView.cur (Local.tview lc1_src))
                          (View.join (TView.cur (Local.tview lc1_tgt)) (View.unwrap releasedm_tgt)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: fulfill_step lc1_src sc1_src loc from to val releasedm_src released ord_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acquired lc2_tgt)>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  inv STEP_TGT.
  assert (RELT_LE:
   View.opt_le
     (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src ord_src)
     (TView.write_released (Local.tview lc1_tgt) sc2_tgt loc to releasedm_tgt ord_tgt)).
  { unfold TView.write_released, TView.write_tview. ss. viewtac.
    repeat (condtac; aggrtac;
            try match goal with
                | [|- View.opt_le _ _] => econs
                end);
      try apply WF1_TGT.
    - etrans; eauto. aggrtac.
    - etrans; [apply WF1_SRC|]. etrans; eauto. aggrtac.
    - etrans; [apply LOCAL1|]. aggrtac.
  }
  assert (RELT_WF:
   View.opt_wf (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src ord_src)).
  { unfold TView.write_released. condtac; econs.
    repeat (try condtac; viewtac; try apply WF1_SRC).
  }
  exploit SimPromises.remove_bot; try exact REMOVE;
    try exact MEM1; try apply LOCAL1; eauto.
  { econs. ss. }
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  { apply WF1_TGT. }
  i. des. esplits.
  - econs; eauto.
    inv WRITABLE. econs.
    eapply TimeFacts.le_lt_lt; [apply ACQUIRED1|]. viewtac.
    eapply TimeFacts.le_lt_lt; eauto.
  - econs; eauto. s. unfold TView.write_tview, TView.read_fence_tview. ss.
    econs; ss; repeat (try condtac; aggrtac).
    all: try by destruct ord_src, ord_tgt.
    all: try by apply WF1_TGT.
    + etrans; [apply LOCAL1|]. aggrtac.
    + etrans; [apply LOCAL1|]. aggrtac.
    + etrans; [apply WF1_SRC|]. etrans; [apply LOCAL1|]. aggrtac.
    + etrans; [apply LOCAL1|]. aggrtac.
  - ss.
Qed.

Lemma sim_local_write_acquired
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt ord_src ord_tgt kind
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_SRC_WF: View.opt_wf releasedm_src)
      (RELM_SRC_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT_WF: View.opt_wf releasedm_tgt)
      (RELM_TGT_CLOSED: Memory.closed_opt_view releasedm_tgt mem1_tgt)
      (RELM_TGT: Time.le (View.rlx (View.unwrap releasedm_tgt) loc) from)
      (ORD: Ordering.le ord_src ord_tgt)
      (ORD_TGT: Ordering.le ord_tgt Ordering.strong_relaxed)
      (STEP_TGT: Local.write_step lc1_tgt sc1_tgt mem1_tgt loc from to val releasedm_tgt released_tgt ord_tgt lc2_tgt sc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src (local_acquired lc1_tgt))
      (ACQUIRED1: View.le (TView.cur (Local.tview lc1_src))
                          (View.join (TView.cur (Local.tview lc1_tgt)) (View.unwrap releasedm_tgt)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_step lc1_src sc1_src mem1_src loc from to val releasedm_src released_src ord_src lc2_src sc2_src mem2_src kind>> /\
    <<REL2: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acquired lc2_tgt)>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  exploit write_promise_fulfill; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_promise_acquired; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  hexploit sim_local_fulfill_acquired; try apply STEP2;
    try apply LOCAL2; try apply MEM2; eauto.
  { eapply Memory.future_closed_opt_view; eauto. }
  { inv STEP_SRC. inv STEP1. ss. }
  i. des.
  exploit promise_fulfill_write_sim_memory; try exact STEP_SRC; try exact STEP_SRC0; eauto.
  { i. hexploit ORD0; eauto.
    i. des. splits; auto. eapply sim_local_nonsynch_loc; eauto.
  }
  i. des. esplits; eauto. etrans; eauto.
Qed.

Inductive split_acquire: forall (i1 i2:Instr.t), Prop :=
| split_acquire_load
    r l:
    split_acquire (Instr.load r l Ordering.acqrel) (Instr.load r l Ordering.relaxed)
| split_acquire_update
    r l rmw ow
    (OW: Ordering.le ow Ordering.strong_relaxed):
    split_acquire (Instr.update r l rmw Ordering.acqrel ow) (Instr.update r l rmw Ordering.relaxed ow)
.

Inductive sim_acquired: forall (st_src:(Language.state lang)) (lc_src:Local.t) (sc1_src:TimeMap.t) (mem1_src:Memory.t)
                          (st_tgt:(Language.state lang)) (lc_tgt:Local.t) (sc1_tgt:TimeMap.t) (mem1_tgt:Memory.t), Prop :=
| sim_acquired_intro
    rs
    lc1_src sc1_src mem1_src
    lc1_tgt sc1_tgt mem1_tgt
    (LOCAL: sim_local SimPromises.bot lc1_src (local_acquired lc1_tgt))
    (SC: TimeMap.le sc1_src sc1_tgt)
    (MEMORY: sim_memory mem1_src mem1_tgt)
    (WF_SRC: Local.wf lc1_src mem1_src)
    (WF_TGT: Local.wf lc1_tgt mem1_tgt)
    (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
    (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
    (MEM_SRC: Memory.closed mem1_src)
    (MEM_TGT: Memory.closed mem1_tgt):
    sim_acquired
      (State.mk rs []) lc1_src sc1_src mem1_src
      (State.mk rs [Stmt.instr (Instr.fence Ordering.acqrel Ordering.plain)]) lc1_tgt sc1_tgt mem1_tgt
.

Lemma sim_acquired_mon
      st_src lc_src sc1_src mem1_src
      st_tgt lc_tgt sc1_tgt mem1_tgt
      sc2_src mem2_src
      sc2_tgt mem2_tgt
      (SIM1: sim_acquired st_src lc_src sc1_src mem1_src
                          st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future_weak mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future_weak mem1_tgt mem2_tgt)
      (SC1: TimeMap.le sc2_src sc2_tgt)
      (MEM1: sim_memory mem2_src mem2_tgt)
      (WF_SRC: Local.wf lc_src mem2_src)
      (WF_TGT: Local.wf lc_tgt mem2_tgt)
      (SC_SRC: Memory.closed_timemap sc2_src mem2_src)
      (SC_TGT: Memory.closed_timemap sc2_tgt mem2_tgt)
      (MEM_SRC: Memory.closed mem2_src)
      (MEM_TGT: Memory.closed mem2_tgt):
  sim_acquired st_src lc_src sc2_src mem2_src
               st_tgt lc_tgt sc2_tgt mem2_tgt.
Proof.
  inv SIM1. econs; eauto.
Qed.

Lemma sim_acquired_step
      st1_src lc1_src sc1_src mem1_src
      st1_tgt lc1_tgt sc1_tgt mem1_tgt
      (SIM: sim_acquired st1_src lc1_src sc1_src mem1_src
                         st1_tgt lc1_tgt sc1_tgt mem1_tgt):
  _sim_thread_step lang lang ((sim_thread (sim_terminal eq)) \8/ sim_acquired)
                   st1_src lc1_src sc1_src mem1_src
                   st1_tgt lc1_tgt sc1_tgt mem1_tgt.
Proof.
  inv SIM. ii.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv SPLIT); ss.
  - (* promise *)
    right.
    exploit Local.promise_step_future; eauto. i. des.
    exploit sim_local_promise_acquired; try exact LOCAL; eauto. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs. econs; eauto.
    + eauto.
    + right. econs; eauto.
  - (* fence *)
    right.
    exploit Local.fence_step_future; eauto. i. des.
    inv STATE. inv INSTR. inv LOCAL1. ss.
    esplits; (try by econs 1); eauto; ss.
    left. eapply paco9_mon; [apply sim_stmts_nil|]; ss. econs; ss.
    + rewrite TViewFacts.write_fence_tview_strong_relaxed; ss. apply LOCAL.
    + apply LOCAL.
Qed.

Lemma sim_acquired_sim_thread:
  sim_acquired <8= (sim_thread (sim_terminal eq)).
Proof.
  pcofix CIH. i. pfold. ii. ss. splits; ss; ii.
  - inv TERMINAL_TGT. inv PR; ss.
  - right. esplits; eauto.
    inv PR. eapply sim_local_memory_bot; eauto.
  - exploit sim_acquired_mon; eauto. i.
    exploit sim_acquired_step; eauto. i. des; eauto.
    + right. esplits; eauto.
      left. eapply paco9_mon; eauto. ss.
    + right. esplits; eauto.
Qed.

Lemma sim_local_read_acquired
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt
      loc ts val released_tgt
      (STEP_TGT: Local.read_step lc1_tgt mem1_tgt loc ts val released_tgt Ordering.relaxed lc2_tgt)
      (LOCAL1: sim_local SimPromises.bot lc1_src lc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src,
    <<REL: View.opt_le released_src released_tgt>> /\
    <<STEP_SRC: Local.read_step lc1_src mem1_src loc ts val released_src Ordering.acqrel lc2_src>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acquired lc2_tgt)>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit sim_memory_get; try apply GET; try apply MEM1. i. des. inv MSG.
  esplits; eauto.
  - econs; eauto. inv READABLE. econs; ss; i.
    + rewrite <- PLN. apply TVIEW.
    + rewrite <- RLX; ss. apply TVIEW.
  - econs; eauto. s.
    unfold TView.read_tview, TView.read_fence_tview. ss.
    econs; repeat (condtac; aggrtac).
    all: try by apply TVIEW.
    all: try by apply WF1_TGT.
    + rewrite <- ? View.join_l. etrans; [apply TVIEW|]. apply WF1_TGT.
    + inv MEM1_TGT. exploit CLOSED; eauto. i. des.
      apply View.unwrap_opt_wf. inv MSG_WF. ss.
    + rewrite <- ? View.join_l. apply TVIEW.
    + inv MEM1_TGT. exploit CLOSED; eauto. i. des.
      apply View.unwrap_opt_wf. inv MSG_WF. ss.
Qed.

Lemma split_acquire_sim_stmts
      i_src i_tgt
      (SPLIT: split_acquire i_src i_tgt):
  sim_stmts eq
            [Stmt.instr i_src]
            [Stmt.instr i_tgt; Stmt.instr (Instr.fence Ordering.acqrel Ordering.plain)]
            eq.
Proof.
  pcofix CIH. ii. subst. pfold. ii. splits; ii.
  { inv TERMINAL_TGT. }
  { right. esplits; eauto.
    inv LOCAL. apply SimPromises.sem_bot_inv in PROMISES; auto. rewrite PROMISES. auto.
  }
  right.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv SPLIT); ss.
  - (* promise *)
    exploit sim_local_promise; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    econs 2. econs 1; eauto. econs; eauto. eauto.
  - (* load *)
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 2. eauto.
      * econs. econs.
    + auto.
    + left. eapply paco9_mon; [apply sim_acquired_sim_thread|]; ss.
  - (* update-load *)
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 2. eauto.
      * econs. econs. eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_acquired_sim_thread|]; ss.
  - (* update *)
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    exploit Local.write_step_future; eauto. i. des.
    hexploit sim_local_write_acquired; try exact LOCAL2; try exact SC; eauto; try refl.
    { inv LOCAL1. inv MEM_TGT. exploit CLOSED; eauto. i. des.
      inv MSG_TS. ss. }
    { inv STEP_SRC. inv LOCAL1. ss. repeat (condtac; aggrtac).
      - rewrite <- ? View.join_l. apply LOCAL.
      - apply WF_TGT.
      - unfold TimeMap.join. rewrite <- Time.join_l. rewrite <- Time.join_l. rewrite <- Time.join_r.
        unfold View.singleton_ur_if. condtac; ss. unfold TimeMap.singleton, LocFun.add.
        condtac; ss. refl.
    }
    i. des.
    exploit Local.write_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 2. econs; cycle 1.
      * econs 4; eauto.
      * econs. econs. eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_acquired_sim_thread|]; ss.
Qed.


Require Import List.
Require Import Arith.
Require Import Omega.
Import ListNotations.
Require Import Sorting.Permutation.
Require Import FunctionalExtensionality.
Require Import Relations.Relation_Operators.
Require Import Relations.Operators_Properties.
Require Import Util.
Require Import VerdiTactics.

Require Import String.

Set Implicit Arguments.

Class BaseParams :=
  {
    data : Type;
    input : Type;
    output : Type;

    sigPK : string -> string
  }.

Class OneNodeParams (P : BaseParams) :=
  {
    init : data;
    handler : input -> data -> (list output * data)
  }.

Inductive cryptoEvent {name : Type} :=
| Sign : string -> string -> cryptoEvent
| Verify : string -> string -> cryptoEvent
| Leak : string -> cryptoEvent
| LeakEncrytped : string -> string -> cryptoEvent
| Random : string -> cryptoEvent
.

Class MultiParams (P : BaseParams) :=
  {
    name : Type ;
    msg : Type ;
    msg_eq_dec : forall x y : msg, {x = y} + {x <> y} ;
    name_eq_dec : forall x y : name, {x = y} + {x <> y} ;
    nodes : list name ;
    all_names_nodes : forall n, In n nodes ;
    no_dup_nodes : NoDup nodes ;
    init_handlers : name -> data;
    net_handlers : name -> name -> msg -> data -> (list output) * data * list
    (name * msg) * (list (@cryptoEvent name)) ;
    input_handlers : name -> input -> data -> (list output) * data * list (name
    * msg) * (list (@cryptoEvent name))
  }.

Class FailureParams `(P : MultiParams) :=
  {
    reboot : data -> data
  }.

Section StepRelations.
  Variable A : Type.
  Variable trace : Type.

  Definition step_relation := A -> A -> list trace -> Prop.

  Inductive refl_trans_1n_trace (step : step_relation) : step_relation :=
  | RT1nTBase : forall x, refl_trans_1n_trace step x x []
  | RT1nTStep : forall x x' x'' cs cs',
                   step x x' cs ->
                   refl_trans_1n_trace step x' x'' cs' ->
                   refl_trans_1n_trace step x x'' (cs ++ cs').

  Theorem refl_trans_1n_trace_trans : forall step (a b c : A) (os os' : list trace),
                                        refl_trans_1n_trace step a b os ->
                                        refl_trans_1n_trace step b c os' ->
                                        refl_trans_1n_trace step a c (os ++ os').
  Proof.
    intros.
    induction H; simpl; auto.
    concludes.
    rewrite app_ass.
    constructor 2 with x'; auto.
  Qed.

  Definition inductive (step : step_relation) (P : A -> Prop)  :=
    forall (a a': A) (os : list trace),
      P a ->
      step a a' os ->
      P a'.

  Theorem step_star_inductive :
    forall step P,
      inductive step P ->
      forall (a : A) a' os,
        P a ->
        (refl_trans_1n_trace step) a a' os ->
        P a'.
  Proof.
    unfold inductive. intros.
    induction H1; auto.
    forwards; eauto.
  Qed.

  Definition inductive_invariant (step : step_relation) (init : A) (P : A -> Prop) :=
    P init /\ inductive step P.

  Definition reachable step init a :=
    exists out, refl_trans_1n_trace step init a out.

  Definition true_in_reachable step init (P : A -> Prop) :=
    forall a,
      reachable step init a ->
      P a.

  Theorem true_in_reachable_reqs :
    forall (step : step_relation) init (P : A -> Prop),
      (P init) ->
      (forall a a' out,
         step a a' out ->
         reachable step init a ->
         P a ->
         P a') ->
      true_in_reachable step init P.
  Proof.
    intros. unfold true_in_reachable, reachable in *.
    intros. break_exists.
    match goal with H : refl_trans_1n_trace _ _ _ _ |- _ => induction H end;
      intuition eauto.
    match goal with H : P _ -> _ |- _ => apply H end;
      intros; break_exists;
      match goal with H : forall _ _ _, step _ _ _ -> _ |- _ => eapply H end;
      eauto; eexists; econstructor; eauto.
  Qed.

  Theorem inductive_invariant_true_in_reachable :
    forall step init P,
      inductive_invariant step init P ->
      true_in_reachable step init P.
  Proof.
    unfold inductive_invariant, true_in_reachable, reachable, inductive in *. intros.
    break_exists.
    match goal with H : refl_trans_1n_trace _ _ _ _ |- _ => induction H end;
      intuition eauto.
  Qed.

  Inductive refl_trans_n1_trace (step : step_relation) : step_relation :=
  | RTn1TBase : forall x, refl_trans_n1_trace step x x []
  | RTn1TStep : forall x x' x'' cs cs',
                  refl_trans_n1_trace step x x' cs ->
                  step x' x'' cs' ->
                  refl_trans_n1_trace step x x'' (cs ++ cs').

  Lemma RTn1_step :
    forall (step : step_relation) x y z l l',
      step x y l ->
      refl_trans_n1_trace step y z l' ->
      refl_trans_n1_trace step x z (l ++ l').
  Proof.
    intros.
    induction H0.
    - rewrite app_nil_r. rewrite <- app_nil_l.
      econstructor.
      constructor.
      auto.
    - concludes.
      rewrite <- app_ass.
      econstructor; eauto.
  Qed.

  Lemma refl_trans_1n_n1_trace :
    forall step x y l,
      refl_trans_1n_trace step x y l ->
      refl_trans_n1_trace step x y l.
  Proof.
    intros.
    induction H.
    - constructor.
    - eapply RTn1_step; eauto.
  Qed.

  Lemma RT1n_step :
    forall (step : step_relation) x y z l l',
      refl_trans_1n_trace step x y l ->
      step y z l' ->
      refl_trans_1n_trace step x z (l ++ l').
  Proof.
    intros.
    induction H.
    - simpl. rewrite <- app_nil_r. econstructor; eauto. constructor.
    - concludes. rewrite app_ass.
      econstructor; eauto.
  Qed.

  Lemma refl_trans_n1_1n_trace :
    forall step x y l,
      refl_trans_n1_trace step x y l ->
      refl_trans_1n_trace step x y l.
  Proof.
    intros.
    induction H.
    - constructor.
    - eapply RT1n_step; eauto.
  Qed.

  Lemma refl_trans_1n_trace_n1_ind :
    forall (step : step_relation) (P : A -> A -> list trace -> Prop),
      (forall x, P x x []) ->
      (forall x x' x'' tr1 tr2,
         refl_trans_1n_trace step x x' tr1 ->
         step x' x'' tr2 ->
         P x x' tr1 ->
         refl_trans_1n_trace step x x'' (tr1 ++ tr2) ->
         P x x'' (tr1 ++ tr2)) ->
      forall x y l,
        refl_trans_1n_trace step x y l -> P x y l.
  Proof.
    intros.
    find_apply_lem_hyp refl_trans_1n_n1_trace.
    eapply refl_trans_n1_trace_ind; eauto.
    intros. eapply H0; eauto using refl_trans_n1_1n_trace, RT1n_step.
  Qed.

  Theorem true_in_reachable_elim :
    forall (step : step_relation) init (P : A -> Prop),
      true_in_reachable step init P ->
      (P init) /\
      (forall a a' out,
         step a a' out ->
         reachable step init a ->
         P a ->
         P a').
  Proof.
    intros. unfold true_in_reachable, reachable in *.
    intros. intuition.
    - apply H; eexists; econstructor.
    - apply H.
      break_exists.
      eexists. apply refl_trans_n1_1n_trace.
      find_apply_lem_hyp refl_trans_1n_n1_trace.
      econstructor; eauto.
  Qed.
End StepRelations.

Section Step1.
  Context `{params : OneNodeParams}.

  Inductive step_1 : (step_relation data (input * list output)) :=
  | S1T_deliver : forall (i : input) s s' (out : list output),
                    handler i s = (out, s') ->
                    step_1 s s' [(i, out)].

  Definition step_1_star := refl_trans_1n_trace step_1.
End Step1.

Section StepAsync.

  Context `{params : MultiParams}.

  Definition update {A : Type} st h (v : A) := (fun nm => if name_eq_dec nm h then v else st nm).

  Record packet := mkPacket { pSrc  : name;
                              pDst  : name;
                              pBody : msg }.

  Definition send_packets src ps := (map (fun m => mkPacket src (fst m) (snd m)) ps).

  Definition mark_cevents_src (src : name) := (map (fun (m : (@cryptoEvent name)) => (src, m) )).

  Record network := mkNetwork {
                                nwState   : name -> data;
                                nwCrypto  : list (name * (@cryptoEvent name)) }.

  Definition step_m_init : network :=
    mkNetwork init_handlers [].

  Inductive secret : string -> network -> Prop :=
  | Secret : forall (v:string) (net:network),
    (~ exists them, In (them, Leak v) (nwCrypto net))
    -> (forall them sk, In (them, LeakEncrytped v sk) (nwCrypto net) -> secret sk net)
    -> secret v net.

  Inductive step_m : step_relation network (name * (input + list output)) :=
  (* just like step_m *)
  | SM_deliver : forall net net' p out d l cEvents,
                     net_handlers (pDst p) (pSrc p) (pBody p) (nwState net (pDst
                     p)) = (out, d, l, cEvents) ->
                     net' = mkNetwork (update (nwState net) (pDst p) d)
                                      ((mark_cevents_src (pDst p) cEvents) ++
                                      (nwCrypto net))
                                      ->
                     (forall sk msg, (In (Verify (sigPK sk) msg) cEvents) ->
                       secret sk net' ->
                       (exists them, In (them, Random sk) (nwCrypto net')) ->
                       (exists them, In (them, Sign sk msg) (nwCrypto net'))) ->
                     step_m net net' [(pDst p, inr out)]
  (* inject a message (f inp) into host h *)
  | SM_input : forall h net net' out inp d l cEvents,
                   input_handlers h inp (nwState net h) = (out, d, l, cEvents) ->
                   net' = mkNetwork (update (nwState net) h d)
                                    (nwCrypto net) ->
                   step_m net net' [(h, inl inp)]. (* note: we throw away the immediate output!*)

  Definition step_m_star := refl_trans_1n_trace step_m.
End StepAsync.

Arguments update _ _ _ _ _ _ / _.
Arguments send_packets _ _ _ _ /.

Section packet_eta.
  Context {P : BaseParams}.
  Context {M : @MultiParams P}.

  Lemma packet_eta :
    forall p : @packet P M,
      {| pSrc := pSrc p; pDst := pDst p; pBody := pBody p |} = p.
  Proof.
    destruct p; auto.
  Qed.
End packet_eta.

Ltac map_id :=
  rewrite map_ext with (g := (fun x => x)); [eauto using map_id|simpl; intros; apply packet_eta].


From iris.proofmode Require Import proofmode.
From lrust.typing Require Export type.
From iris.prelude Require Import options.

Section util.
  Context `{!typeGS Σ}.

  (* Delayed sharing is used by various types; in particular own and uniq.
     It comes in two flavors: Borrows of "later something" and borrows of
     "borrowed something".
     TODO: Figure out a nice way to generalize that; the two proofs below are too
     similar. *)

  (* This is somewhat the general pattern here... but it doesn't seem
     easy to make this usable in Coq, with the arbitrary quantifiers
     and things.  Also, it actually works not just for borrows but for
     anything that you can split into a timeless and a persistent
     part.

  Lemma delay_borrow_step :
    lfeE ⊆ N → (∀ x, Persistent (Post x)) →
    lft_ctx -∗ &{κ} P -∗
      □ (∀ x, &{κ} P -∗ Pre x -∗ Frame x ={F1 x}[F2 x]▷=∗ Post x ∗ Frame x) ={N}=∗
      □ (∀ x, Pre x -∗ Frame x ={F1 x}[F2 x]▷=∗ Post x ∗ Frame x).
   *)

  Lemma delay_sharing_later N κ l ty tid :
    ↑lftN ⊆ N →
    lft_ctx -∗ &{κ}(▷ l ↦∗: ty_own ty tid) ={N}=∗
       □ ∀ (F : coPset) (q : Qp),
       ⌜↑shrN ∪ ↑lftN ⊆ F⌝ -∗ (q).[κ] ={F}[F ∖ ↑shrN]▷=∗ ty.(ty_shr) κ tid l ∗ (q).[κ].
  Proof.
    iIntros (?) "#LFT Hbor". rewrite bor_unfold_idx.
    iDestruct "Hbor" as (i) "(#Hpb&Hpbown)".
    iMod (inv_alloc shrN _ (idx_bor_own 1 i ∨ ty_shr ty κ tid l)%I
          with "[Hpbown]") as "#Hinv"; first by eauto.
    iIntros "!> !> * % Htok".
    iMod (inv_acc with "Hinv") as "[INV Hclose]"; first solve_ndisj.
    iDestruct "INV" as "[>Hbtok|#Hshr]".
    - iMod (bor_later_tok with "LFT [Hbtok] Htok") as "Hdelay"; first solve_ndisj.
      { rewrite bor_unfold_idx. eauto. }
      iModIntro. iNext. iMod "Hdelay" as "[Hb Htok]".
      iMod (ty.(ty_share) with "LFT Hb Htok") as "[#$ $]"; first solve_ndisj.
      iApply "Hclose". auto.
    - iMod fupd_mask_subseteq as "Hclose'"; first solve_ndisj. iModIntro.
      iNext. iMod "Hclose'" as "_". iMod ("Hclose" with "[]") as "_"; by eauto.
  Qed.

  Lemma delay_sharing_nested N κ κ' κ'' l ty tid :
    ↑lftN ⊆ N →
    lft_ctx -∗ ▷ (κ'' ⊑ κ ⊓ κ') -∗ &{κ'}(&{κ}(l ↦∗: ty_own ty tid)) ={N}=∗
       □ ∀ (F : coPset) (q : Qp),
       ⌜↑shrN ∪ ↑lftN ⊆ F⌝ -∗ (q).[κ''] ={F}[F ∖ ↑shrN]▷=∗ ty.(ty_shr) κ'' tid l ∗ (q).[κ''].
  Proof.
    iIntros (?) "#LFT #Hincl Hbor". rewrite bor_unfold_idx.
    iDestruct "Hbor" as (i) "(#Hpb&Hpbown)".
    iMod (inv_alloc shrN _ (idx_bor_own 1 i ∨ ty_shr ty κ'' tid l)%I
          with "[Hpbown]") as "#Hinv"; first by eauto.
    iIntros "!> !> * % Htok".
    iMod (inv_acc with "Hinv") as "[INV Hclose]"; first solve_ndisj.
    iDestruct "INV" as "[>Hbtok|#Hshr]".
    - iMod (bor_unnest with "LFT [Hbtok]") as "Hb"; first solve_ndisj.
      { iApply bor_unfold_idx. eauto. }
      iModIntro. iNext. iMod "Hb".
      iMod (ty.(ty_share) with "LFT [Hb] Htok") as "[#Hshr $]"; first solve_ndisj.
      { iApply bor_shorten; done. }
      iMod ("Hclose" with "[]") as "_"; auto.
    - iMod fupd_mask_subseteq as "Hclose'"; last iModIntro; first solve_ndisj.
      iNext. iMod "Hclose'" as "_". iMod ("Hclose" with "[]") as "_"; by eauto.
  Qed.
End util.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

   Lemmas about static semantics kinding.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export CpdtTactics.
Require Export TacticNotations.
Require Export GetLemmasRelation.
Require Export ContextExtensionRelation.
Require Export ContextExtensionLemmas.

Lemma K_weakening:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      WFD d ->
      K d tau k ->
      forall (d' : Delta),
        WFD d' ->
        ExtendedByD d d' ->
        K d' tau k.
Proof.
 intros d tau k WFDder Kder.
 K_ind_cases (induction Kder) Case.

 Case "K d cint B".
  intros.
  constructor.
 Case "K d (tv_t alpha) B".
  intros.
  apply getD_extension_agreement with (d:= d) (d':=d') (alpha:= alpha) (k:= B)
    in WFDder;
    try assumption.
  apply K_B; try assumption.
 Case "K d (ptype (tv_t alpha)) B".
  intros.
  constructor.
  apply getD_extension_agreement with (d':= d') in H; try assumption.
 Case "K d tau A".
  intros.
  apply IHKder with (d':= d') in WFDder; try assumption.
  constructor; try assumption.
 Case "K d (cross t0 t1) A".
  intros.
  pose proof WFDder as WFDder2.
  apply IHKder1 with (d':= d') in WFDder; try assumption.
  apply IHKder2 with (d':= d') in WFDder2; try assumption.
  apply K_cross; try assumption.
 Case "K d (arrow t0 t1) A".
  intros.
  pose proof WFDder as WFDder2.
  apply IHKder1 with (d':= d') in WFDder; try assumption.
  apply IHKder2 with (d':= d') in WFDder2; try assumption.
  apply K_arrow; try assumption.
 Case "K d (ptype tau) B".
  intros.
  apply IHKder with (d':= d') in WFDder; try assumption.
  constructor.
  assumption.
 Case "K d (utype alpha k tau) A".
  intros.
  assert (Z: getD d' alpha = None).
  AdmitAlphaConversion.
  apply IHKder with (d':= ([(alpha, k)] ++ d')) in H; try assumption.
  apply K_utype; try assumption.
  constructor; try  assumption.
  constructor; try assumption.
  apply ExtendedByD_preserved_under_add_alpha_k; try assumption.
 Case "K d (etype p alpha k tau) A)".
  intros.
  assert (Z: getD d' alpha = None).
  AdmitAlphaConversion.
  apply IHKder with (d':= ([(alpha, k)] ++ d')) in H; try assumption.
  apply K_etype; try assumption.
  constructor; try  assumption.
  constructor; try assumption.
  apply ExtendedByD_preserved_under_add_alpha_k; try assumption.
Qed.

Lemma AK_weakening:
  forall (d : Delta) (tau : Tau) (k : Kappa),
      WFD d ->
      AK d tau k ->
      forall (d' : Delta),
        WFD d' ->
        ExtendedByD d d' ->
        AK d' tau k.
Proof.
 intros d tau k WFDder AKder.
 inversion AKder.
 intros.
 constructor.
 apply K_weakening with (d:= d); try assumption.
 intros.
 rewrite <- H2 in *.
 rewrite <- H1 in *.
 assert (Z: getD d' alpha = Some A).
 apply getD_extension_agreement with (d':= d') in H; try assumption.
 apply AK_A; try assumption.
Qed.