Require Import RelationClasses.

From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Global.

Set Implicit Arguments.

Module ThreadEvent.
  Variant t :=
  | promise (loc: Loc.t)
  | reserve (loc: Loc.t) (from to: Time.t)
  | cancel (loc: Loc.t) (from to: Time.t)
  | silent
  | read (loc: Loc.t) (ts: Time.t) (val: Const.t) (released: option View.t) (ord: Ordering.t)
  | write (loc: Loc.t) (from to: Time.t) (val: Const.t) (released: option View.t) (ord: Ordering.t)
  | update (loc: Loc.t) (tsr tsw: Time.t) (valr valw: Const.t)
           (releasedr releasedw: option View.t) (ordr ordw: Ordering.t)
  | fence (ordr ordw: Ordering.t)
  | syscall (e: Event.t)
  | failure
  | racy_read (loc: Loc.t) (to: option Time.t) (val: Const.t) (ord: Ordering.t)
  | racy_write (loc: Loc.t) (to: option Time.t) (val: Const.t) (ord: Ordering.t)
  | racy_update (loc: Loc.t) (to: option Time.t) (valr valw: Const.t) (ordr ordw: Ordering.t)
  .
  #[global] Hint Constructors t: core.

  Definition get_event (e: t): option Event.t :=
    match e with
    | syscall e => Some e
    | _ => None
    end.

  Definition get_program_event (e: t): ProgramEvent.t :=
    match e with
    | read loc _ val _ ord => ProgramEvent.read loc val ord
    | write loc _ _ val _ ord => ProgramEvent.write loc val ord
    | update loc _ _ valr valw _ _ ordr ordw => ProgramEvent.update loc valr valw ordr ordw
    | fence ordr ordw => ProgramEvent.fence ordr ordw
    | syscall ev => ProgramEvent.syscall ev
    | failure => ProgramEvent.failure
    | racy_read loc _ val ord => ProgramEvent.read loc val ord
    | racy_write loc _ val ord => ProgramEvent.write loc val ord
    | racy_update loc _ valr valw ordr ordw => ProgramEvent.update loc valr valw ordr ordw
    | _ => ProgramEvent.silent
    end.

  Definition get_machine_event (e: t): MachineEvent.t :=
    match e with
    | syscall e => MachineEvent.syscall e
    | failure
    | racy_write _ _ _ _
    | racy_update _ _ _ _ _ _ => MachineEvent.failure
    | _ => MachineEvent.silent
    end.

  Definition get_machine_event_pf (e: t): MachineEvent.t :=
    match e with
    | syscall e => MachineEvent.syscall e
    | failure
    | racy_read _ _ _ _
    | racy_write _ _ _ _
    | racy_update _ _ _ _ _ _ => MachineEvent.failure
    | _ => MachineEvent.silent
    end.

  Definition is_reading (e:t): option (Loc.t * Time.t * Const.t * option View.t * Ordering.t) :=
    match e with
    | read loc ts val released ord => Some (loc, ts, val, released, ord)
    | update loc tsr _ valr _ releasedr _ ordr _ => Some (loc, tsr, valr, releasedr, ordr)
    | _ => None
    end.

  Definition is_writing (e:t): option (Loc.t * Time.t * Time.t * Const.t * option View.t * Ordering.t) :=
    match e with
    | write loc from to val released ord => Some (loc, from, to, val, released, ord)
    | update loc tsr tsw _ valw _ releasedw _ ordw => Some (loc, tsr, tsw, valw, releasedw, ordw)
    | _ => None
    end.

  Definition is_accessing (e:t): option (Loc.t * Time.t) :=
    match e with
    | read loc ts _ _ _ => Some (loc, ts)
    | write loc _ ts _ _ _ => Some (loc, ts)
    | update loc _ ts _ _ _ _ _ _ => Some (loc, ts)
    | _ => None
    end.

  Definition is_accessing_loc (l: Loc.t) (e: t): Prop :=
    match e with
    | read loc _ _ _ _
    | write loc _ _ _ _ _
    | update loc _ _ _ _ _ _ _ _
    | racy_read loc _ _ _
    | racy_write loc _ _ _
    | racy_update loc _ _ _ _ _ => loc = l
    | _ => False
    end.

  Definition is_racy (e: t): Prop :=
    match e with
    | racy_read _ _ _ _
    | racy_write _ _ _ _
    | racy_update _ _ _ _ _ _ => True
    | _ => False
    end.

  Definition is_racy_promise (e: t): Prop :=
    match e with
    | racy_read _ None _ _
    | racy_write _ None _ _ => True
    | racy_update _ None _ _ ordr ordw =>
        Ordering.le Ordering.plain ordr /\
        Ordering.le Ordering.plain ordw
    | _ => False
    end.

  Definition is_sc (e: t): Prop :=
    match e with
    | fence _ ordw => Ordering.le Ordering.seqcst ordw
    | syscall _ => True
    | _ => False
    end.

  Definition is_pf (e: t): Prop :=
    match e with
    | promise _
    | reserve _ _ _ => False
    | _ => True
    end.

  Definition is_internal (e: t): Prop :=
    match e with
    | promise _
    | reserve _ _ _
    | cancel _ _ _ => True
    | _ => False
    end.

  Definition is_program (e: t): Prop :=
    match e with
    | promise _
    | reserve _ _ _
    | cancel _ _ _ => False
    | _ => True
    end.

  Definition is_silent (e: t): Prop :=
    get_machine_event e = MachineEvent.silent.

  Lemma eq_program_event_eq_loc
        e1 e2 loc
        (EVENT: get_program_event e1 = get_program_event e2):
    is_accessing_loc loc e1 <-> is_accessing_loc loc e2.
  Proof.
    unfold is_accessing_loc.
    destruct e1, e2; ss; inv EVENT; ss.
  Qed.
End ThreadEvent.

Module Local.
  Structure t := mk {
    tview: TView.t;
    promises: BoolMap.t;
    reserves: Memory.t;
  }.

  Definition init := mk TView.bot BoolMap.bot Memory.bot.

  Variant is_terminal (lc:t): Prop :=
  | is_terminal_intro
      (PROMISES: promises lc = BoolMap.bot)
  .
  #[global] Hint Constructors is_terminal: core.

  Variant wf (lc: t) (gl: Global.t): Prop :=
  | wf_intro
      (TVIEW_WF: TView.wf (tview lc))
      (TVIEW_CLOSED: TView.closed (tview lc) (Global.memory gl))
      (PROMISES: BoolMap.le (promises lc) (Global.promises gl))
      (PROMISES_FINITE: BoolMap.finite (promises lc))
      (RESERVES: Memory.le (reserves lc) (Global.memory gl))
      (RESERVES_ONLY: Memory.reserve_only (reserves lc))
      (RESERVES_FINITE: Memory.finite (reserves lc))
  .
  #[global] Hint Constructors wf: core.

  Lemma init_wf: wf init Global.init.
  Proof.
    econs; ss.
    - apply TView.bot_wf.
    - apply TView.bot_closed.
    - apply BoolMap.bot_finite.
    - apply Memory.bot_le.
    - apply Memory.bot_reserve_only.
    - apply Memory.bot_finite.
  Qed.

  Lemma cap_wf
        lc gl
        (WF: wf lc gl):
    wf lc (Global.cap_of gl).
  Proof.
    inv WF. econs; ss.
    - eapply TView.cap_closed; eauto.
      apply Memory.cap_of_cap.
    - etrans; eauto. apply Memory.cap_le.
      apply Memory.cap_of_cap.
  Qed.

  Variant disjoint (lc1 lc2:t): Prop :=
  | disjoint_intro
      (PROMISES_DISJOINT: BoolMap.disjoint (promises lc1) (promises lc2))
      (RESERVES_DISJOINT: Memory.disjoint (reserves lc1) (reserves lc2))
  .
  #[global] Hint Constructors disjoint: core.

  Global Program Instance disjoint_Symmetric: Symmetric disjoint.
  Next Obligation.
    econs; symmetry; apply H.
  Qed.

  Variant promise_step (lc1: t) (gl1: Global.t) (loc: Loc.t) (lc2: t) (gl2: Global.t): Prop :=
  | promise_step_intro
      prm2 gprm2
      (PROMISE: Promises.promise (promises lc1) (Global.promises gl1) loc prm2 gprm2)
      (LC2: lc2 = mk (tview lc1) prm2 (reserves lc1))
      (GL2: gl2 = Global.mk (Global.sc gl1) gprm2 (Global.memory gl1))
  .
  #[global] Hint Constructors promise_step: core.

  Variant reserve_step (lc1: t) (gl1: Global.t) (loc: Loc.t) (from to: Time.t) (lc2: t) (gl2: Global.t): Prop :=
  | reserve_step_intro
      rsv2 mem2
      (RESERVE: Memory.reserve (reserves lc1) (Global.memory gl1) loc from to rsv2 mem2)
      (LC2: lc2 = mk (tview lc1) (promises lc1) rsv2)
      (GL2: gl2 = Global.mk (Global.sc gl1) (Global.promises gl1) mem2)
  .
  #[global] Hint Constructors reserve_step: core.

  Variant cancel_step (lc1: t) (gl1: Global.t) (loc: Loc.t) (from to: Time.t) (lc2: t) (gl2: Global.t): Prop :=
  | cancel_step_intro
      rsv2 mem2
      (CANCEL: Memory.cancel (reserves lc1) (Global.memory gl1) loc from to rsv2 mem2)
      (LC2: lc2 = mk (tview lc1) (promises lc1) rsv2)
      (GL2: gl2 = Global.mk (Global.sc gl1) (Global.promises gl1) mem2)
  .
  #[global] Hint Constructors cancel_step: core.

  Variant read_step
          (lc1: t) (gl1: Global.t)
          (loc: Loc.t) (to: Time.t) (val: Const.t) (released: option View.t) (ord: Ordering.t)
          (lc2: t): Prop :=
  | read_step_intro
      from val' na
      tview2
      (GET: Memory.get loc to (Global.memory gl1) = Some (from, Message.message val' released na))
      (VAL: Const.le val val')
      (READABLE: TView.readable (TView.cur (tview lc1)) loc to ord)
      (TVIEW: TView.read_tview (tview lc1) loc to released ord = tview2)
      (LC2: lc2 = mk tview2 (promises lc1) (reserves lc1)):
      read_step lc1 gl1 loc to val released ord lc2
  .
  #[global] Hint Constructors read_step: core.

  Variant write_step
          (lc1: t) (gl1: Global.t)
          (loc: Loc.t) (from to: Time.t)
          (val: Const.t) (releasedm released: option View.t) (ord: Ordering.t)
          (lc2: t) (gl2: Global.t): Prop :=
  | write_step_intro
      prm2 gprm2 mem2
      (RELEASED: released = TView.write_released (tview lc1) loc to releasedm ord)
      (WRITABLE: TView.writable (TView.cur (tview lc1)) loc to ord)
      (FULFILL: Promises.fulfill (promises lc1) (Global.promises gl1) loc ord prm2 gprm2)
      (WRITE: Memory.add (Global.memory gl1) loc from to
                         (Message.message val released (Ordering.le ord Ordering.na)) mem2)
      (LC2: lc2 = mk (TView.write_tview (tview lc1) loc to ord) prm2 (reserves lc1))
      (GL2: gl2 = Global.mk (Global.sc gl1) gprm2 mem2):
      write_step lc1 gl1 loc from to val releasedm released ord lc2 gl2
  .
  #[global] Hint Constructors write_step: core.

  Variant fence_step (lc1: t) (gl1: Global.t) (ordr ordw: Ordering.t) (lc2: t) (gl2: Global.t): Prop :=
  | fence_step_intro
      tview2
      (READ: TView.read_fence_tview (tview lc1) ordr = tview2)
      (LC2: lc2 = mk (TView.write_fence_tview tview2 (Global.sc gl1) ordw)
                     (promises lc1) (reserves lc1))
      (GL2: gl2 = Global.mk (TView.write_fence_sc tview2 (Global.sc gl1) ordw)
                            (Global.promises gl1) (Global.memory gl1))
      (PROMISES: Ordering.le Ordering.seqcst ordw -> promises lc1 = BoolMap.bot):
      fence_step lc1 gl1 ordr ordw lc2 gl2
  .
  #[global] Hint Constructors fence_step: core.

  Variant failure_step (lc1:t): Prop :=
  | failure_step_intro
  .
  #[global] Hint Constructors failure_step: core.

  Variant is_racy (lc1: t) (gl1: Global.t) (loc: Loc.t): forall (to: option Time.t) (ord: Ordering.t), Prop :=
  | is_racy_promise
      ord
      (GET: (Global.promises gl1) loc = true)
      (GETP: (promises lc1) loc = false):
    is_racy lc1 gl1 loc None ord
  | is_racy_message
      to from val released na ord
      (GET: Memory.get loc to (Global.memory gl1) = Some (from, Message.message val released na))
      (RACE: TView.racy_view (TView.cur (tview lc1)) loc to)
      (MSG: Ordering.le Ordering.plain ord -> na = true):
    is_racy lc1 gl1 loc (Some to) ord
  .
  #[global] Hint Constructors is_racy: core.

  Variant racy_read_step (lc1: t) (gl1: Global.t) (loc: Loc.t) (to: option Time.t) (val:Const.t) (ord:Ordering.t): Prop :=
  | racy_read_step_intro
      (RACE: is_racy lc1 gl1 loc to ord)
  .
  #[global] Hint Constructors racy_read_step: core.

  Variant racy_write_step (lc1: t) (gl1: Global.t) (loc: Loc.t) (to: option Time.t) (ord: Ordering.t): Prop :=
  | racy_write_step_intro
      (RACE: is_racy lc1 gl1 loc to ord)
  .
  #[global] Hint Constructors racy_write_step: core.

  Variant racy_update_step (lc1: t) (gl1: Global.t) (loc: Loc.t):
    forall (to: option Time.t) (ordr ordw: Ordering.t), Prop :=
  | racy_update_step_ordr
      ordr ordw
      (ORDR: Ordering.le ordr Ordering.na):
    racy_update_step lc1 gl1 loc None ordr ordw
  | racy_update_step_ordw
      ordr ordw
      (ORDW: Ordering.le ordw Ordering.na):
    racy_update_step lc1 gl1 loc None ordr ordw
  | racy_update_step_race
      to ordr ordw
      (RACE: is_racy lc1 gl1 loc to ordr):
    racy_update_step lc1 gl1 loc to ordr ordw
  .
  #[global] Hint Constructors racy_update_step: core.

  Variant internal_step:
    forall (e: ThreadEvent.t) (lc1: t) (gl1: Global.t) (lc2: t) (gl2: Global.t), Prop :=
  | internal_step_promise
      lc1 gl1
      loc lc2 gl2
      (LOCAL: promise_step lc1 gl1 loc lc2 gl2):
    internal_step (ThreadEvent.promise loc) lc1 gl1 lc2 gl2
  | internal_step_reserve
      lc1 gl1
      loc from to lc2 gl2
      (LOCAL: reserve_step lc1 gl1 loc from to lc2 gl2):
    internal_step (ThreadEvent.reserve loc from to) lc1 gl1 lc2 gl2
  | internal_step_cancel
      lc1 gl1
      loc from to lc2 gl2
      (LOCAL: cancel_step lc1 gl1 loc from to lc2 gl2):
    internal_step (ThreadEvent.cancel loc from to) lc1 gl1 lc2 gl2
  .
  #[global] Hint Constructors internal_step: core.

  Variant program_step:
    forall (e: ThreadEvent.t) (lc1: t) (gl1: Global.t) (lc2: t) (gl2: Global.t), Prop :=
  | program_step_silent
      lc1 gl1:
    program_step ThreadEvent.silent lc1 gl1 lc1 gl1
  | program_step_read
      lc1 gl1
      loc to val released ord lc2
      (LOCAL: read_step lc1 gl1 loc to val released ord lc2):
    program_step (ThreadEvent.read loc to val released ord) lc1 gl1 lc2 gl1
  | program_step_write
      lc1 gl1
      loc from to val released ord lc2 gl2
      (LOCAL: write_step lc1 gl1 loc from to val None released ord lc2 gl2):
    program_step (ThreadEvent.write loc from to val released ord) lc1 gl1 lc2 gl2
  | program_step_update
      lc1 gl1
      loc ordr ordw
      tsr valr releasedr releasedw lc2
      tsw valw lc3 gl3
      (LOCAL1: read_step lc1 gl1 loc tsr valr releasedr ordr lc2)
      (LOCAL2: write_step lc2 gl1 loc tsr tsw valw releasedr releasedw ordw lc3 gl3):
    program_step (ThreadEvent.update loc tsr tsw valr valw releasedr releasedw ordr ordw)
      lc1 gl1 lc3 gl3
  | program_step_fence
      lc1 gl1
      ordr ordw lc2 gl2
      (LOCAL: fence_step lc1 gl1 ordr ordw lc2 gl2):
    program_step (ThreadEvent.fence ordr ordw) lc1 gl1 lc2 gl2
  | program_step_syscall
      lc1 gl1
      e lc2 gl2
      (LOCAL: fence_step lc1 gl1 Ordering.seqcst Ordering.seqcst lc2 gl2):
    program_step (ThreadEvent.syscall e) lc1 gl1 lc2 gl2
  | program_step_failure
      lc1 gl1
      (LOCAL: failure_step lc1):
    program_step ThreadEvent.failure lc1 gl1 lc1 gl1
  | program_step_racy_read
      lc1 gl1
      loc to val ord
      (LOCAL: racy_read_step lc1 gl1 loc to val ord):
    program_step (ThreadEvent.racy_read loc to val ord) lc1 gl1 lc1 gl1
  | program_step_racy_write
      lc1 gl1
      loc to val ord
      (LOCAL: racy_write_step lc1 gl1 loc to ord):
    program_step (ThreadEvent.racy_write loc to val ord) lc1 gl1 lc1 gl1
  | program_step_racy_update
      lc1 gl1
      loc to valr valw ordr ordw
      (LOCAL: racy_update_step lc1 gl1 loc to ordr ordw):
    program_step (ThreadEvent.racy_update loc to valr valw ordr ordw) lc1 gl1 lc1 gl1
  .
  #[global] Hint Constructors program_step: core.

  (* step_future *)

  Lemma promise_step_future
        lc1 gl1 loc lc2 gl2
        (STEP: promise_step lc1 gl1 loc lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.future gl1 gl2>>.
  Proof.
    inv LC_WF1. inv GL_WF1. inv STEP. ss.
    hexploit Promises.promise_le; eauto. i.
    hexploit Promises.promise_finite; eauto. i.
    splits; ss; try refl. econs; refl.
  Qed.

  Lemma reserve_step_future
        lc1 gl1 loc from to lc2 gl2
        (STEP: reserve_step lc1 gl1 loc from to lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.future gl1 gl2>>.
  Proof.
    inv LC_WF1. inv GL_WF1. inv STEP. ss.
    hexploit Memory.reserve_future; eauto. i. des.
    splits; try refl.
    - econs; ss. eapply TView.future_closed; eauto.
    - econs; ss. eapply Memory.future_closed_timemap; eauto.
    - econs; ss. refl.
  Qed.

  Lemma cancel_step_future
        lc1 gl1 loc from to lc2 gl2
        (STEP: cancel_step lc1 gl1 loc from to lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.future gl1 gl2>>.
  Proof.
    inv LC_WF1. inv GL_WF1. inv STEP. ss.
    hexploit Memory.cancel_future; eauto. i. des.
    splits; try refl.
    - econs; ss. eauto using TView.future_closed.
    - econs; ss. eauto using Memory.future_closed_timemap.
    - econs; ss. refl.
  Qed.

  Lemma read_step_future
        lc1 gl1 loc ts val released ord lc2
        (STEP: read_step lc1 gl1 loc ts val released ord lc2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl1>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<REL_WF: View.opt_wf released>> /\
    <<REL_CLOSED: Memory.closed_opt_view released (Global.memory gl1)>> /\
    <<REL_TS: Time.le (View.rlx (View.unwrap released) loc) ts>>.
  Proof.
    inv LC_WF1. inv GL_WF1. inv STEP. ss.
    dup MEM_CLOSED. inv MEM_CLOSED0. exploit CLOSED; eauto. i. des.
    inv MSG_WF. inv MSG_CLOSED. inv MSG_TS.
    exploit TViewFacts.read_future; try exact GET; eauto.
    i. des. splits; auto.
    - econs; eauto.
    - apply TViewFacts.read_tview_incr.
  Qed.

  Lemma write_step_future
        lc1 gl1 loc from to val releasedm released ord lc2 gl2
        (STEP: write_step lc1 gl1 loc from to val releasedm released ord lc2 gl2)
        (REL_WF: View.opt_wf releasedm)
        (REL_CLOSED: Memory.closed_opt_view releasedm (Global.memory gl1))
        (REL_TS: Time.le (View.rlx (View.unwrap releasedm) loc) to)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.future gl1 gl2>> /\
    <<REL_WF: View.opt_wf released>> /\
    <<REL_TS: Time.le ((View.rlx (View.unwrap released)) loc) to>> /\
    <<REL_CLOSED: Memory.closed_opt_view released (Global.memory gl2)>>.
  Proof.
    inv LC_WF1. inv GL_WF1. inv STEP. ss.
    hexploit Promises.fulfill_le; try exact FULFILL; eauto. i.
    hexploit Promises.fulfill_finite; try exact FULFILL; eauto. i.
    exploit TViewFacts.write_future; eauto. s. i. des.
    exploit Memory.add_future; try apply WRITE; eauto.
    { econs. eapply TViewFacts.write_released_ts; eauto. }
    i. des.
    exploit Memory.add_get0; try apply WRITE; eauto. i. des.
    splits; eauto.
    - econs; eauto. ss.
      eapply Memory.future_closed_timemap; eauto.
    - apply TViewFacts.write_tview_incr. auto.
    - econs; ss. refl.
    - eapply TViewFacts.write_released_ts; eauto.
  Qed.

  Lemma update_step_future
        lc1 gl1 loc ts val1 released1 ordr lc2
        to val2 released2 ordw lc3 gl3
        (READ: read_step lc1 gl1 loc ts val1 released1 ordr lc2)
        (WRITE: write_step lc2 gl1 loc ts to val2 released1 released2 ordw lc3 gl3)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc3 gl3>> /\
    <<GL_WF2: Global.wf gl3>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.future gl1 gl3>> /\
    <<REL_WF: View.opt_wf released2>> /\
    <<REL_TS: Time.le ((View.rlx (View.unwrap released2)) loc) to>> /\
    <<REL_CLOSED: Memory.closed_opt_view released2 (Global.memory gl3)>>.
  Proof.
    exploit read_step_future; eauto. i. des.
    exploit write_step_future; eauto.
    { etrans; eauto. econs.
      inv WRITE. eapply Memory.add_ts; eauto.
    }
    i. des.
    esplits; eauto.
  Qed.

  Lemma fence_step_future
        lc1 gl1 ordr ordw lc2 gl2
        (STEP: fence_step lc1 gl1 ordr ordw lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.future gl1 gl2>>.
  Proof.
    inv LC_WF1. inv GL_WF1. inv STEP. ss.
    exploit TViewFacts.read_fence_future; eauto. i. des.
    exploit TViewFacts.write_fence_future; eauto. i. des.
    splits; eauto.
    - etrans.
      + apply TViewFacts.write_fence_tview_incr. auto.
      + apply TViewFacts.write_fence_tview_mon; eauto; try refl.
        apply TViewFacts.read_fence_tview_incr. auto.
    - econs; try refl.
      apply TViewFacts.write_fence_sc_incr.
  Qed.

  Lemma internal_step_future
        e lc1 gl1 lc2 gl2
        (STEP: internal_step e lc1 gl1 lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.future gl1 gl2>>.
  Proof.
    inv STEP.
    - eapply promise_step_future; eauto.
    - eapply reserve_step_future; eauto.
    - eapply cancel_step_future; eauto.
  Qed.

  Lemma program_step_future
        e lc1 gl1 lc2 gl2
        (STEP: program_step e lc1 gl1 lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.future gl1 gl2>>.
  Proof.
    inv STEP; try by (splits; eauto; try refl).
    - exploit read_step_future; eauto. i. des.
      esplits; eauto; try refl.
    - exploit write_step_future; eauto;
        (try by econs); try apply Time.bot_spec. i. des.
      esplits; eauto; try refl.
    - exploit read_step_future; eauto. i. des.
      exploit write_step_future; eauto; try by econs.
      { etrans; eauto. inv LOCAL2.
        econs. eauto using Memory.add_ts.
      }
      i. des.
      esplits; eauto. etrans; eauto.
    - exploit fence_step_future; eauto.
    - exploit fence_step_future; eauto.
  Qed.

  (* step_strong_le *)

  Lemma promise_step_strong_le
        lc1 gl1 loc lc2 gl2
        (STEP: promise_step lc1 gl1 loc lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.strong_le gl1 gl2>>.
  Proof.
    hexploit promise_step_future; eauto. i. des. esplits; eauto. econs.
    { eapply Global.future_le; eauto. }
    { econs. i. left. inv STEP. ss. inv PROMISE. inv GADD.
      change (LocFun.add loc true (Global.promises gl1) loc0) with
        (LocFun.find loc0 (LocFun.add loc true (Global.promises gl1))).
      rewrite LocFun.add_spec. des_ifs. rewrite Bool.implb_same. auto.
    }
  Qed.

  Lemma reserve_step_strong_le
        lc1 gl1 loc from to lc2 gl2
        (STEP: reserve_step lc1 gl1 loc from to lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.strong_le gl1 gl2>>.
  Proof.
    hexploit reserve_step_future; eauto. i. des. esplits; eauto. econs.
    { eapply Global.future_le; eauto. }
    { econs. i. left. inv STEP. rewrite Bool.implb_same. auto. }
  Qed.

  Lemma cancel_step_strong_le
        lc1 gl1 loc from to lc2 gl2
        (STEP: cancel_step lc1 gl1 loc from to lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.strong_le gl1 gl2>>.
  Proof.
    hexploit cancel_step_future; eauto. i. des. esplits; eauto. econs.
    { eapply Global.future_le; eauto. }
    { econs. i. left. inv STEP. rewrite Bool.implb_same. auto. }
  Qed.

  Lemma write_step_strong_le
        lc1 gl1 loc from to val releasedm released ord lc2 gl2
        (STEP: write_step lc1 gl1 loc from to val releasedm released ord lc2 gl2)
        (REL_WF: View.opt_wf releasedm)
        (REL_CLOSED: Memory.closed_opt_view releasedm (Global.memory gl1))
        (REL_TS: Time.le (View.rlx (View.unwrap releasedm) loc) to)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.strong_le gl1 gl2>> /\
    <<REL_WF: View.opt_wf released>> /\
    <<REL_TS: Time.le ((View.rlx (View.unwrap released)) loc) to>> /\
    <<REL_CLOSED: Memory.closed_opt_view released (Global.memory gl2)>>
    \/
    exists ts, <<NA: Ordering.le ord Ordering.na>> /\ <<RACE: is_racy lc1 gl1 loc ts ord>>
  .
  Proof.
    destruct (classic (exists ts, Ordering.le ord Ordering.na /\ is_racy lc1 gl1 loc ts ord)) as [RACE|SAFE]; auto.
    left. hexploit write_step_future; eauto. i. des.
    esplits; eauto. econs.
    { eapply Global.future_le; eauto. }
    { econs. i. inv STEP. ss. inv FULFILL; ss.
      { left. rewrite Bool.implb_same. auto. }
      inv GREMOVE.
      change (LocFun.add loc false (Global.promises gl1) loc0) with
        (LocFun.find loc0 (LocFun.add loc false (Global.promises gl1))).
      rewrite LocFun.add_spec. condtac.
      { subst. right. repeat red. esplits.
        { inv ORD. rewrite H0 in *. eapply Memory.add_get0; eauto. }
        i. destruct (Time.le_lt_dec to ts1); auto. exfalso.
        eapply SAFE. esplits.
        { destruct ord; ss. }
        econs 2.
        { eauto. }
        { unfold TView.racy_view.
          eapply TimeFacts.lt_le_lt; eauto.
          inv WRITABLE. eapply TimeFacts.le_lt_lt; eauto. eapply LC_WF1.
        }
        { destruct ord; ss. }
      }
      { rewrite Bool.implb_same. auto. }
    }
  Qed.

  Lemma fence_step_strong_le
        lc1 gl1 ordr ordw lc2 gl2
        (STEP: fence_step lc1 gl1 ordr ordw lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.strong_le gl1 gl2>>.
  Proof.
    hexploit fence_step_future; eauto. i. des. esplits; eauto. econs.
    { eapply Global.future_le; eauto. }
    { econs. i. left. inv STEP. rewrite Bool.implb_same. auto. }
  Qed.

  Lemma internal_step_strong_le
        e lc1 gl1 lc2 gl2
        (STEP: internal_step e lc1 gl1 lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.strong_le gl1 gl2>>.
  Proof.
    inv STEP.
    - eapply promise_step_strong_le; eauto.
    - eapply reserve_step_strong_le; eauto.
    - eapply cancel_step_strong_le; eauto.
  Qed.

  Lemma program_step_strong_le
        e lc1 gl1 lc2 gl2
        (STEP: program_step e lc1 gl1 lc2 gl2)
        (LC_WF1: wf lc1 gl1)
        (GL_WF1: Global.wf gl1):
    <<LC_WF2: wf lc2 gl2>> /\
    <<GL_WF2: Global.wf gl2>> /\
    <<TVIEW_FUTURE: TView.le (tview lc1) (tview lc2)>> /\
    <<GL_FUTURE: Global.strong_le gl1 gl2>> \/
    exists e_race,
      <<STEP: program_step e_race lc1 gl1 lc1 gl1>> /\
      <<EVENT: ThreadEvent.get_program_event e_race = ThreadEvent.get_program_event e>> /\
      <<RACE: ThreadEvent.get_machine_event e_race = MachineEvent.failure>>
  .
  Proof.
    inv STEP; try by (left; splits; eauto; try refl).
    - left. exploit read_step_future; eauto. i. des. esplits; eauto. refl.
    - exploit write_step_strong_le; eauto;
        (try by econs); try apply Time.bot_spec. i. des.
      { left. esplits; eauto; try refl. }
      { right. esplits.
        { eapply program_step_racy_write. econs; eauto. }
        { ss. }
        { ss. }
      }
    - exploit read_step_future; eauto. i. des.
      exploit write_step_strong_le; eauto; try by econs.
      { etrans; eauto. inv LOCAL2.
        econs. eauto using Memory.add_ts.
      }
      i. des.
      { left. esplits; eauto. etrans; eauto. }
      { right. esplits.
        { eapply program_step_racy_update; eauto. }
        { ss. }
        { ss. }
      }
    - left. exploit fence_step_strong_le; eauto.
    - left. exploit fence_step_strong_le; eauto.
  Qed.

  (* step_inhabited *)

  Lemma internal_step_inhabited
        e lc1 gl1 lc2 gl2
        (STEP: internal_step e lc1 gl1 lc2 gl2)
        (INHABITED1: Memory.inhabited (Global.memory gl1)):
    <<INHABITED2: Memory.inhabited (Global.memory gl2)>>.
  Proof.
    inv STEP; try inv LOCAL; ss.
    - eapply Memory.reserve_inhabited; eauto.
    - eapply Memory.cancel_inhabited; eauto.
  Qed.

  Lemma program_step_inhabited
        e lc1 gl1 lc2 gl2
        (STEP: program_step e lc1 gl1 lc2 gl2)
        (INHABITED1: Memory.inhabited (Global.memory gl1)):
    <<INHABITED2: Memory.inhabited (Global.memory gl2)>>.
  Proof.
    inv STEP; try inv LOCAL; ss.
    - eapply Memory.add_inhabited; eauto.
    - inv LOCAL2. eapply Memory.add_inhabited; eauto.
  Qed.

  (* step_disjoint *)

  Lemma promise_step_disjoint
        lc1 gl1 loc lc2 gl2 lc
        (STEP: promise_step lc1 gl1 loc lc2 gl2)
        (DISJOINT1: disjoint lc1 lc)
        (LC_WF: wf lc gl1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<LC_WF: wf lc gl2>>.
  Proof.
    inv DISJOINT1. inv LC_WF. inv STEP.
    exploit Promises.promise_disjoint; eauto. i. des.
    esplits; eauto.
  Qed.

  Lemma reserve_step_disjoint
        lc1 gl1 loc from to lc2 gl2 lc
        (STEP: reserve_step lc1 gl1 loc from to lc2 gl2)
        (DISJOINT1: disjoint lc1 lc)
        (LC_WF: wf lc gl1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<LC_WF: wf lc gl2>>.
  Proof.
    inv DISJOINT1. inv LC_WF. inv STEP.
    hexploit Memory.reserve_messages_le; eauto. i.
    exploit Memory.reserve_disjoint; eauto. i. des.
    esplits; eauto. econs; ss.
    eapply TView.le_closed; eauto.
  Qed.

  Lemma cancel_step_disjoint
        lc1 gl1 loc from to lc2 gl2 lc
        (STEP: cancel_step lc1 gl1 loc from to lc2 gl2)
        (DISJOINT1: disjoint lc1 lc)
        (LC_WF: wf lc gl1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<LC_WF: wf lc gl2>>.
  Proof.
    inv DISJOINT1. inv LC_WF. inv STEP.
    hexploit Memory.cancel_messages_le; eauto. i.
    exploit Memory.cancel_disjoint; eauto. i. des.
    esplits; eauto. econs; ss.
    eapply TView.le_closed; eauto.
  Qed.

  Lemma read_step_disjoint
        lc1 gl1 loc ts val released ord lc2 lc
        (STEP: read_step lc1 gl1 loc ts val released ord lc2)
        (DISJOINT1: disjoint lc1 lc):
    disjoint lc2 lc.
  Proof.
    inv DISJOINT1. inv STEP. ss.
  Qed.

  Lemma write_step_disjoint
        lc1 gl1 loc from to val releasedm released ord lc2 gl2 lc
        (STEP: write_step lc1 gl1 loc from to val releasedm released ord lc2 gl2)
        (DISJOINT1: disjoint lc1 lc)
        (LC_WF: wf lc gl1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<LC_WF: wf lc gl2>>.
  Proof.
    inv DISJOINT1. inv LC_WF. inv STEP.
    hexploit Memory.add_messages_le; eauto. i.
    exploit Promises.fulfill_disjoint; try exact FULFILL; eauto. i. des.
    esplits; eauto. econs; ss.
    - eapply TView.le_closed; eauto.
    - etrans; eauto. eapply Memory.add_le; eauto.
  Qed.

  Lemma fence_step_disjoint
        lc1 gl1 ordr ordw lc2 gl2 lc
        (STEP: fence_step lc1 gl1 ordr ordw lc2 gl2)
        (DISJOINT1: disjoint lc1 lc)
        (LC_WF: wf lc gl1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<LC_WF: wf lc gl2>>.
  Proof.
    inv DISJOINT1. inv LC_WF. inv STEP. splits; ss.
  Qed.

  Lemma read_step_promises
        lc1 gl1 loc to val released ord lc2
        (READ: read_step lc1 gl1 loc to val released ord lc2):
    (promises lc1) = (promises lc2).
  Proof.
    inv READ. auto.
  Qed.

  Lemma internal_step_disjoint
        e lc1 gl1 lc2 gl2 lc
        (STEP: internal_step e lc1 gl1 lc2 gl2)
        (DISJOINT1: disjoint lc1 lc)
        (LC_WF: wf lc gl1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<LC_WF: wf lc gl2>>.
  Proof.
    inv STEP.
    - eapply promise_step_disjoint; eauto.
    - eapply reserve_step_disjoint; eauto.
    - eapply cancel_step_disjoint; eauto.
  Qed.

  Lemma program_step_disjoint
        e lc1 gl1 lc2 gl2 lc
        (STEP: program_step e lc1 gl1 lc2 gl2)
        (DISJOINT1: disjoint lc1 lc)
        (LC_WF: wf lc gl1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<LC_WF: wf lc gl2>>.
  Proof.
    inv STEP; try by (splits; eauto).
    - exploit read_step_disjoint; eauto.
    - exploit write_step_disjoint; eauto.
    - exploit read_step_disjoint; eauto. i.
      exploit write_step_disjoint; eauto.
    - exploit fence_step_disjoint; eauto.
    - exploit fence_step_disjoint; eauto.
  Qed.

  Lemma program_step_promises
        e lc1 gl1 lc2 gl2
        (STEP: program_step e lc1 gl1 lc2 gl2):
    BoolMap.le (promises lc2) (promises lc1) /\
    BoolMap.le (Global.promises gl2) (Global.promises gl1).
  Proof.
    inv STEP; ss; try by (inv LOCAL; ss).
    - inv LOCAL. inv FULFILL; ss.
      split; eauto using BoolMap.remove_le.
    - inv LOCAL1. inv LOCAL2. inv FULFILL; ss.
      split; eauto using BoolMap.remove_le.
  Qed.

  Lemma program_step_reserves
        e lc1 gl1 lc2 gl2
        (STEP: program_step e lc1 gl1 lc2 gl2):
    reserves lc1 = reserves lc2.
  Proof.
    inv STEP; ss; try by (inv LOCAL; ss).
    inv LOCAL1. inv LOCAL2. ss.
  Qed.

  Lemma internal_step_promises_minus
        e lc1 gl1 lc2 gl2
        (STEP: internal_step e lc1 gl1 lc2 gl2):
    BoolMap.minus (Global.promises gl1) (promises lc1) =
    BoolMap.minus (Global.promises gl2) (promises lc2).
  Proof.
    inv STEP; inv LOCAL; ss.
    eapply Promises.promise_minus; eauto.
  Qed.

  Lemma program_step_promises_minus
        e lc1 gl1 lc2 gl2
        (STEP: program_step e lc1 gl1 lc2 gl2):
    BoolMap.minus (Global.promises gl1) (promises lc1) =
    BoolMap.minus (Global.promises gl2) (promises lc2).
  Proof.
    inv STEP; ss; try by (inv LOCAL; ss).
    - inv LOCAL. ss.
      eapply Promises.fulfill_minus; eauto.
    - inv LOCAL1. inv LOCAL2. ss.
      eapply Promises.fulfill_minus; eauto.
  Qed.

  Lemma write_max_exists
        lc1 gl1
        loc val releasedm ord
        (LC_WF: Local.wf lc1 gl1)
        (RELEASEDM_WF: View.opt_wf releasedm):
    exists from to released lc2 gl2,
      (<<WRITE: write_step lc1 gl1 loc from to val releasedm released ord lc2 gl2>>) /\
      (<<FROM: Time.lt (Memory.max_ts loc (Global.memory gl1)) from>>).
  Proof.
    exploit Memory.add_exists_max; try eapply Time.incr_spec; cycle 1.
    { i. des. esplits; try exact FROM.
      econs; try exact ADD; eauto. econs.
      eapply TimeFacts.le_lt_lt; [|apply Time.incr_spec].
      inv LC_WF. inv TVIEW_CLOSED. inv CUR. specialize (RLX loc). des.
      eapply Memory.max_ts_spec. eauto.
    }
    econs. unfold TView.write_released. condtac; econs.
    repeat (try condtac; aggrtac; try apply LC_WF).
  Qed.

  Lemma fence_step_non_sc
        lc1 gl1 or ow lc2 gl2
        (STEP: fence_step lc1 gl1 or ow lc2 gl2)
        (SC: Ordering.le ow Ordering.acqrel):
    gl2 = gl1.
  Proof.
    destruct gl1. inv STEP. ss. f_equal.
    apply TViewFacts.write_fence_sc_acqrel. ss.
  Qed.
End Local.


Require Import Coq.Program.Equality.
Require Import Coq.Sets.Ensembles.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.Arith.Peano_dec.
Require Import Ascii String.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.Mult.
Require Import Coq.Arith.Plus.
Require Import Coq.Arith.Minus.
Require Import Coq.Lists.List.
Require Import Coq.Arith.Compare_dec.
Require Import Keys.
Require Import Heap.
Require Import Effects.
Require Import Environment.
Require Import TypeSystem.
Require Import Determinism.
Require Import Definitions2.
Require Import CorrectnessLemmas.

Import TypeSoundness.
Import EffectSoundness.

Definition Correctness_1 (ea : Expr) (ee : Expr) :
  forall (h h' h'' : Heap) (env : Env) (rho : Rho) (p p' : Phi) (v : Val) (eff : Theta),
    (h, env, rho, ea) ⇓ (h', v, p) ->
    ReadOnlyPhi p' ->
    (h, env, rho, ee) ⇓ (h'', Eff eff, p') ->
    forall stty ctxt rgns ty static,
      TcEnv (stty, rho, env, ctxt) ->
      TcExp (stty, ctxt, rgns, ea, ty, static) ->
      TcHeap (h, stty) ->
      TcRho (rho, rgns) ->
      BackTriangle (stty, ctxt, rgns, ea, ee) -> p ⊑ eff.
Proof.
  intros h h' h'' env rho p p' v eff Exprs.
  generalize dependent eff.
  generalize dependent p'.
  generalize dependent ee.
  dependent induction Exprs;
  intros edesc p' eff HReadOnly Specs stty ctxt rgns ty static Henv Hexp Hheap HRho Back;
  inversion Specs; subst; inversion Back; inversion Hexp; subst; try (solve [apply PTS_Nil | apply PhiInThetaTop]).
  (*- assert (facts ⊑ Some empty_set) by (eapply IHExprs1  with (ee:=∅); eauto; constructor).
    apply EmptyIsNil in H. rewrite H. rewrite Phi_Seq_Nil_L.
    assert (aacts ⊑ Some empty_set).
    eapply IHExprs2 with (ee:=∅) (p':=Phi_Nil); eauto.
    + assert (h''=fheap) by (eapply ReadOnlyTracePreservesHeap_2; eauto).
      subst; constructor.
    + assert (h''=fheap) by (eapply ReadOnlyTracePreservesHeap_2; eauto).
      subst; assumption.
    + inversion H1; subst.  rewrite Phi_Seq_Nil_L.

      assert (clsTcVal : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
               /\ TcHeap (fheap, stty')
               /\ TcVal (stty', Cls (env', rho', Mu f x ec' ee'), subst_rho rho (Ty2_Arrow tya effc1 ty effe1 Ty2_Effect)))
        by (eapply ty_sound; eauto).
      destruct clsTcVal as [sttyb [Weakb [TcHeapb TcVal_cls]]]; eauto.

      assert (argTcVal : exists stty',
             (forall l t', ST.find l sttyb = Some t' -> ST.find l stty' = Some t')
               /\ TcHeap (aheap, stty')
               /\ TcVal (stty', v0, subst_rho rho tya))
        by (eapply ty_sound; eauto using update_env, ext_stores__env, ext_stores__exp).
      destruct argTcVal as [sttya [Weaka [TcHeapa TcVal_v']]]; eauto.

      inversion TcVal_cls as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcEnv_env' TcExp_abs | | ]; subst.
      inversion TcExp_abs as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | |  | | | | | | | | | | |  ]; subst.
      rewrite <- H12 in TcVal_cls.
      do 2 rewrite subst_rho_arrow in H12. inversion H12.
      rewrite <- H2 in TcVal_v'.

      eapply IHExprs3 with (ee:=ee') (stty := sttya); eauto.
      * admit.
      * apply update_env; simpl.
        eapply ext_stores__env; eauto.
        { apply update_env; eauto. }
        { eassumption. }
      * eapply ext_stores__exp; eauto.
      * eapply ext_stores__bt; eauto.
      * { inversion H2; subst.
          - admit.
          - admit.
          - admit.
          - admit.
          - admit.
          - admit.
          - admit. }
      * apply PTS_Seq.
        { apply PTS_Seq; apply EmptyInAnyTheta; assumption. }
        { assert (clsTcVal : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
               /\ TcHeap (fheap, stty')
               /\ TcVal (stty', Cls (env', rho', Mu f x ec' ee'), subst_rho rho (Ty2_Arrow tya effc1 ty effe1 Ty2_Effect)))
            by (eapply ty_sound; eauto).
          destruct clsTcVal as [sttyb [Weakb [TcHeapb TcVal_cls]]]; eauto.

          assert (argTcVal : exists stty',
                               (forall l t', ST.find l sttyb = Some t' -> ST.find l stty' = Some t')
                               /\ TcHeap (aheap, stty')
                               /\ TcVal (stty', v0, subst_rho rho tya))
            by (eapply ty_sound; eauto using update_env, ext_stores__env, ext_stores__exp).
          destruct argTcVal as [sttya [Weaka [TcHeapa TcVal_v']]]; eauto.

          inversion TcVal_cls as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcEnv_env' TcExp_abs | | ]; subst.
          inversion TcExp_abs as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | |  | | | | | | | | | | |  ]; subst.
          rewrite <- H14 in TcVal_cls.
          do 2 rewrite subst_rho_arrow in H14. inversion H14.
          rewrite <- H4 in TcVal_v'.

          eapply IHExprs3 with (ee:=ee') (stty := sttya); eauto.
          - admit.
          - apply update_env; simpl.
            eapply ext_stores__env; eauto.
            { apply update_env; eauto. }
            { eassumption. }
          - eapply ext_stores__exp; eauto.
          - eapply ext_stores__bt; eauto. }
      * admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit. *)
  - inversion HReadOnly; subst.
    assert (facts ⊑ effa) by (eapply IHExprs1 with (p':=phia); eauto).
    apply PTS_Seq.
    + apply PTS_Seq.
      * apply Theta_introl. assumption.
      * inversion H7; subst.
        assert (aacts ⊑ effa2)
          by (eapply IHExprs2 with (p':=phia0); eauto;
              inversion HReadOnly; inversion H13; auto;
              assert (h'' = fheap) by (eapply ReadOnlyTracePreservesHeap_2; eauto); subst; assumption).
        apply Theta_intror. apply Theta_introl. assumption.
    + assert (clsTcVal : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
               /\ TcHeap (fheap, stty')
               /\ TcVal (stty', Cls (env', rho', Mu f x ec' ee'), subst_rho rho (Ty2_Arrow tya effc ty effe Ty2_Effect)))
        by (eapply ty_sound; eauto).
      destruct clsTcVal as [sttyb [Weakb [TcHeapb TcVal_cls]]]; eauto.

      assert (argTcVal : exists stty',
             (forall l t', ST.find l sttyb = Some t' -> ST.find l stty' = Some t')
               /\ TcHeap (aheap, stty')
               /\ TcVal (stty', v0, subst_rho rho tya))
        by (eapply ty_sound; eauto using update_env, ext_stores__env, ext_stores__exp).
      destruct argTcVal as [sttya [Weaka [TcHeapa TcVal_v']]]; eauto.

      inversion TcVal_cls as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcEnv_env' TcExp_abs | | ]; subst.
      inversion TcExp_abs as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | |  | | | | | | | | | | |  ]; subst.
      rewrite <- H14 in TcVal_cls.
      do 2 rewrite subst_rho_arrow in H14. inversion H14.
      rewrite <- H4 in TcVal_v'.
      inversion H7; subst.
      eapply IHExprs3 with (stty := sttya) (ee:=ee') (p' := phib0); eauto;
      inversion H3; subst; auto.
      * admit.
      * apply update_env; simpl.
        eapply ext_stores__env; eauto.
        { apply update_env; eauto. }
        { eassumption. }
      * eapply ext_stores__exp; eauto.
      * eapply ext_stores__bt; eauto.
  - admit.
Admitted.


Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Require Import ProD3.examples.sbf.p4ast.
Require Import ProD3.examples.sbf.ConFilter.
Require Import ProD3.examples.sbf.common.
Require Import ProD3.examples.sbf.FilterRepr.
Require Import ProD3.examples.sbf.verif_Win1.
Require Import ProD3.examples.sbf.verif_Win2.
Require Import ProD3.examples.sbf.verif_Win3.
Require Import ProD3.examples.sbf.verif_Win4.
Require Import ProD3.examples.sbf.verif_Filter.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_1_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_2_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_3_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_clear_index_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_clear_window_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_1_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_2_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_3_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_4_body) : func_specs.

Definition P4_bf2_win_md_t_query (f cf if' : Z) (new_clear_index : Sval) (is : list Sval) :=
  if f=? cf then
    P4_bf2_win_md_t (P4Bit 8 CLEAR) (Zrepeat new_clear_index 3)
  else
    P4_bf2_win_md_t (P4Bit 8 QUERY) is.

Definition tbl_set_win_query_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"];
               ["act_set_clear_win_1"; "api_1"];
               ["act_set_clear_win_1"; "api_2"];
               ["act_set_clear_win_1"; "api_3"];
               ["act_set_clear_win_1"; "api_4"];
               ["act_set_clear_win_2"; "api_1"];
               ["act_set_clear_win_2"; "api_2"];
               ["act_set_clear_win_2"; "api_3"];
               ["act_set_clear_win_2"; "api_4"];
               ["act_set_clear_win_3"; "api_1"];
               ["act_set_clear_win_3"; "api_2"];
               ["act_set_clear_win_3"; "api_3"];
               ["act_set_clear_win_3"; "api_4"];
               ["act_set_clear_win_2"; "api_1"];
               ["act_set_clear_win_4"; "api_1"];
               ["act_set_clear_win_4"; "api_2"];
               ["act_set_clear_win_4"; "api_3"];
               ["act_set_clear_win_4"; "api_4"]]) []
    WITH (timer : Z * bool) (clear_index_1 hash_index_1 hash_index_2 hash_index_3: Sval)
      (H_timer : 0 <= fst timer < frame_tick_tocks * num_frames),
      PRE
        (ARG []
        (MEM [(["api"], P4Bit 8 QUERY);
              (["ds_md"], ValBaseStruct
                 [("clear_window", P4Bit 16 (fst timer));
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t_);
                  ("win_2", P4_bf2_win_md_t_);
                  ("win_3", P4_bf2_win_md_t_);
                  ("win_4", P4_bf2_win_md_t_)])]
        (EXT [])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (let cf := get_clear_frame timer in
        let if' := get_insert_frame cf in
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", P4Bit 16 (fst timer));
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t_query 0 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_2", P4_bf2_win_md_t_query 1 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_3", P4_bf2_win_md_t_query 2 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_4", P4_bf2_win_md_t_query 3 cf if' clear_index_1
                        [hash_index_1; hash_index_2; hash_index_3])])]
        (EXT [])))))%arg_ret_assr.

Lemma tbl_set_win_query_body :
  func_sound ge tbl_set_win_fd nil tbl_set_win_query_spec.
Proof.
  start_function; elim_trivial_cases.
  - replace (get_clear_frame timer) with 0. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_1_body.
    { entailer. }
    { entailer. }
  - replace (get_clear_frame timer) with 1. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_2_body.
    { entailer. }
    { entailer. }
  - replace (get_clear_frame timer) with 2. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_3_body.
    { entailer. }
    { entailer. }
  - replace (get_clear_frame timer) with 3. 2 : {
      symmetry; eapply Z_div_squeeze'; eauto.
    }
    table_action act_set_clear_win_4_body.
    { entailer. }
    { entailer. }
  - lia.
Qed.

Definition act_merge_wins_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_merge_wins"] ge).

Definition act_merge_wins_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["query_res"]]) []
    WITH,
      PRE
        (ARG []
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["query_res"], (P4Bit 8 1))]
        (EXT []))).

Lemma act_merge_wins_body :
  func_sound ge act_merge_wins_fd nil act_merge_wins_spec.
Proof.
  start_function.
  step.
  step.
  entailer.
Qed.

Definition act_merge_default_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_merge_default"] ge).

Definition act_merge_default_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["query_res"]]) []
    WITH,
      PRE
        (ARG []
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["query_res"], (P4Bit 8 0))]
        (EXT []))).

Lemma act_merge_default_body :
  func_sound ge act_merge_default_fd nil act_merge_default_spec.
Proof.
  start_function.
  step.
  step.
  entailer.
Qed.

Definition tbl_merge_wins_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "tbl_merge_wins"; "apply"] ge).

Definition P4_bf2_win_md_t_rw rw1 rw2 rw3 :=
  ValBaseStruct
    [("api", P4Bit_ 8);
     ("index_1", P4Bit_ index_w);
     ("index_2", P4Bit_ index_w);
     ("index_3", P4Bit_ index_w);
     ("rw_1", P4Bit 8 (Z.b2z rw1));
     ("rw_2", P4Bit 8 (Z.b2z rw2));
     ("rw_3", P4Bit 8 (Z.b2z rw3))].

(* Because this function doesn't modify ds_md, so we can describe it in this way.
But if it does modify ds_md, we don't have a really good way to isolate the unchanged part.
But on the other hand, the get/update system doesn't work very well, either. *)
Definition tbl_merge_wins_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["query_res"]]) []
    WITH rw11 rw12 rw13 rw21 rw22 rw23 rw31 rw32 rw33 rw41 rw42 rw43,
      PRE
        (ARG []
        (MEM [(["api"], P4Bit 8 QUERY);
              (["ds_md"], ValBaseStruct
                 [("clear_window", P4Bit_ 16);
                  ("clear_index_1", P4Bit_ index_w);
                  ("hash_index_1", P4Bit_ index_w);
                  ("hash_index_2", P4Bit_ index_w);
                  ("hash_index_3", P4Bit_ index_w);
                  ("win_1", P4_bf2_win_md_t_rw rw11 rw12 rw13);
                  ("win_2", P4_bf2_win_md_t_rw rw21 rw22 rw23);
                  ("win_3", P4_bf2_win_md_t_rw rw31 rw32 rw33);
                  ("win_4", P4_bf2_win_md_t_rw rw41 rw42 rw43)])]
        (EXT [])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (MEM [(["query_res"], (P4Bit 8 (Z.b2z (
          fold_orb (map fold_andb
            [[rw11; rw12; rw13];
             [rw21; rw22; rw23];
             [rw31; rw32; rw33];
             [rw41; rw42; rw43]])))))]
        (EXT []))))%arg_ret_assr.

Lemma b2z_one : forall b,
  Z.b2z b =? 1 = b.
Proof.
  destruct b; auto.
Qed.

Lemma tbl_merge_wins_body :
  func_sound ge tbl_merge_wins_fd nil tbl_merge_wins_spec.
Proof.
  unfold tbl_merge_wins_spec, P4_bf2_win_md_t_rw.
  start_function;
    repeat rewrite b2z_one in *;
    repeat lazymatch goal with
    | H : is_true (_ && _) |- _ =>
        apply Reflect.andE in H;
        destruct H
    end;
    repeat match goal with
    | H : is_true ?b |- _ =>
        is_var b;
        unfold is_true in H;
        subst b
    end.
  - table_action act_merge_wins_body.
    { entailer. }
    { entailer. }

#[export] Hint Rewrite Bool.orb_true_l Bool.orb_true_r Bool.orb_false_l Bool.orb_false_r : simpl_orb.

  - table_action act_merge_wins_body.
    { entailer. }
    { entailer.
      unfold map, fold_andb, fold_orb, fold_left.
      autorewrite with simpl_andb simpl_orb.
      apply sval_refine_refl.
    }
  - table_action act_merge_wins_body.
    { entailer. }
    { entailer.
      unfold map, fold_andb, fold_orb, fold_left.
      autorewrite with simpl_andb simpl_orb.
      apply sval_refine_refl.
    }
  - table_action act_merge_wins_body.
    { entailer. }
    { entailer.
      unfold map, fold_andb, fold_orb, fold_left.
      autorewrite with simpl_andb simpl_orb.
      apply sval_refine_refl.
    }
  - table_action act_merge_default_body.
    { entailer. }
    { entailer.
      unfold map, fold_andb, fold_orb, fold_left.
      autorewrite with simpl_andb simpl_orb.
      replace (rw11 && rw12 && rw13) with false by (destruct (rw11 && rw12 && rw13); auto).
      replace (rw21 && rw22 && rw23) with false by (destruct (rw21 && rw22 && rw23); auto).
      replace (rw31 && rw32 && rw33) with false by (destruct (rw31 && rw32 && rw33); auto).
      replace (rw41 && rw42 && rw43) with false by (destruct (rw41 && rw42 && rw43); auto).
      apply sval_refine_refl.
    }
  - elim_trivial_cases.
  - elim_trivial_cases.
Qed.

Definition filter_query := @filter_query num_frames num_rows num_slots H_num_frames H_num_rows H_num_slots
  frame_tick_tocks.

Definition Filter_query_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD None [p]
    WITH (key : Val) (tstamp : Z) (cf : filter num_frames num_rows num_slots),
      PRE
        (ARG [eval_val_to_sval key; P4Bit 8 QUERY; P4Bit 48 tstamp; P4Bit_ 8]
        (MEM []
        (EXT [filter_repr p index_w panes rows cf])))
      POST
        (ARG_RET [P4Bit 8 (Z.b2z (snd (filter_query cf (Z.odd (tstamp/2097152)) (hashes key))))] ValBaseNull
        (MEM []
        (EXT [filter_repr p index_w panes rows (fst (filter_query cf (Z.odd (tstamp/2097152)) (hashes key)))]))).

Ltac destruct_listn l :=
  destruct l as [l ?H];
  destruct_list l.

Lemma Filter_query_body :
  func_sound ge Filter_fd nil Filter_query_spec.
Proof.
  start_function.
  destruct cf as [[ps ?H] ? ?].
  unfold filter_repr.
  cbn [proj1_sig] in *.
  destruct_list ps.
  normalize_EXT.
  step.
  step_call tbl_hash_index_1_body.
  { entailer. }
  Intros _.
  step_call tbl_hash_index_2_body.
  { entailer. }
  Intros _.
  step_call tbl_hash_index_3_body.
  { entailer. }
  Intros _.
  set (is := (exist _ [hash1 key; hash2 key; hash3 key] eq_refl : listn Z 3)).
  set (clear_is := (exist _ (Zrepeat fil_clear_index 3) eq_refl : listn Z 3)).
  assert (Forall (fun i : Z => 0 <= i < num_slots) (`is)). {
    repeat first [apply Forall_cons | apply Forall_nil].
    all : unfold hash1, hash2, hash3;
      apply Z.mod_pos_bound; lia.
  }
  P4assert (0 <= fil_clear_index < num_slots). {
    unfold fil_clear_index_repr.
    Intros i'.
    normalize_EXT.
    Intros_prop.
    apply ext_implies_prop_intro.
    subst.
    apply Z.mod_pos_bound.
    lia.
  }
  assert (Forall (fun i : Z => 0 <= i < num_slots) (`clear_is)). {
    repeat first [
      assumption
    | constructor
    ].
  }
  step_call tbl_clear_index_body.
  { entailer. }
  Intros _.
  step_call tbl_clear_window_body.
  { entailer. }
  Intros _.
  set (new_timer := update_timer fil_timer (Z.odd (tstamp / 2097152))).
  P4assert (0 <= fst new_timer < num_frames * frame_tick_tocks).
  { unfold timer_repr.
    normalize_EXT.
    Intros_prop.
    apply ext_implies_prop_intro.
    auto.
  }
  step_call tbl_set_win_query_body.
  { entailer. }
  { auto. }
  Intros _.
  (* unfold and fold in the post condition *)
  unfold filter_query, ConFilter.filter_query.
  (* cbn [proj1_sig fst snd]. *)
  unfold proj1_sig. unfold fst. unfold snd.
  fold new_timer.
  replace (exist (fun i : list Z => Zlength i = num_rows) (Zrepeat fil_clear_index num_rows) _) with clear_is. 2 : {
    apply subset_eq_compat. auto.
  }
  assert (0 <= get_clear_frame new_timer < num_frames). {
    unfold ConFilter.get_clear_frame.
    split.
    - apply Z.div_le_lower_bound; lia.
    - apply Z.div_lt_upper_bound; lia.
  }
  destruct (get_clear_frame new_timer =? 0) eqn:?.
  { replace (get_clear_frame new_timer) with 0 by lia.
    step_call verif_Win1.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win4.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_call tbl_merge_wins_body.
    { unfold P4_bf2_win_md_t_rw.
      entailer.
      replace (P4Bit 8 0) with (P4Bit 8 (Z.b2z false)) by auto.
      repeat first [
        apply sval_refine_refl
      | constructor
      ].
    }
    Intros _.
    step.
    entailer.
    destruct_listn x.
    destruct_listn x0.
    destruct_listn x1.
    destruct_listn x2.
    apply sval_refine_refl.
  }
  destruct (get_clear_frame new_timer =? 1) eqn:?.
  { replace (get_clear_frame new_timer) with 1 by lia.
    step_call verif_Win1.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win4.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_call tbl_merge_wins_body.
    { unfold P4_bf2_win_md_t_rw.
      entailer.
      replace (P4Bit 8 0) with (P4Bit 8 (Z.b2z false)) by auto.
      repeat first [
        apply sval_refine_refl
      | constructor
      ].
    }
    Intros _.
    step.
    entailer.
    destruct_listn x.
    destruct_listn x0.
    destruct_listn x1.
    destruct_listn x2.
    apply sval_refine_refl.
  }
  destruct (get_clear_frame new_timer =? 2) eqn:?.
  { replace (get_clear_frame new_timer) with 2 by lia.
    step_call verif_Win1.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win4.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_call tbl_merge_wins_body.
    { unfold P4_bf2_win_md_t_rw.
      entailer.
      replace (P4Bit 8 0) with (P4Bit 8 (Z.b2z false)) by auto.
      repeat first [
        apply sval_refine_refl
      | constructor
      ].
    }
    Intros _.
    step.
    entailer.
    destruct_listn x.
    destruct_listn x0.
    destruct_listn x1.
    destruct_listn x2.
    apply sval_refine_refl.
  }
  destruct (get_clear_frame new_timer =? 3) eqn:?.
  { replace (get_clear_frame new_timer) with 3 by lia.
    step_call verif_Win1.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win2.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win3.Win_body _ _ is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    step_call verif_Win4.Win_body _ _ clear_is.
    { entailer. }
    { solve [repeat constructor]. }
    { auto. }
    simpl Z.eqb. cbn match.
    step_call tbl_merge_wins_body.
    { unfold P4_bf2_win_md_t_rw.
      entailer.
      replace (P4Bit 8 0) with (P4Bit 8 (Z.b2z false)) by auto.
      repeat first [
        apply sval_refine_refl
      | constructor
      ].
    }
    Intros _.
    step.
    entailer.
    destruct_listn x.
    destruct_listn x0.
    destruct_listn x1.
    destruct_listn x2.
    apply sval_refine_refl.
  }
  lia.
(* This is slow. I can understand it but I don't know the direct reason. *)
Time Qed.


Require Import Program SepAlg SepAlgInsts AssertionLogic SpecLogic SepAlgMap.
Require Import MapInterface MapFacts.

Require Import Charge.Logics.ILInsts.
Require Import Charge.Logics.ILogic.
Require Import Charge.Logics.ILEmbed.
Require Import Charge.Logics.BILogic.
Require Import Charge.Open.OpenILogic.
Require Import Charge.Open.Open.
Require Import Charge.Open.Subst.
Require Import Charge.Open.Stack.
Require Import Charge.Tactics.ILEmbedTac.
Require Import Charge.Tactics.ILQuantTac.

Require Import Java.Language.Lang.
Require Import Java.Semantics.SemCmd.
Require Import Java.Semantics.SemCmdRules.
Require Import Java.Logic.HeapArr.

Import SepAlgNotations.

Set Implicit Arguments.
Unset Strict Implicit.

Section Commands.

  Inductive assign_sem (x : Lang.var) (e : dexpr) : semCmdType :=
  | assign_ok : forall P s h v
                       (He: eval e s = v),
      assign_sem x e P 1 s h (Some (stack_add x v s, h)).
  Program Definition assign_cmd x e := Build_semCmd (assign_sem x e) _ _.
  Next Obligation.
    intros H; inversion H.
  Qed.
  Next Obligation with eauto using assign_sem.
    unfold frame_property; intros.
    inversion HSem; subst; clear HSem; exists h...
  Qed.

  Inductive read_sem (x y : Lang.var) (f : field) : semCmdType :=
  | read_ok : forall ref v P (s : stack) (h : heap)
      (Rref  : s y = vptr ref)
      (Rmaps : MapsTo (ref,f) v (fst h)),
      read_sem x y f P 1 s h (Some (stack_add x v s, h))
  | read_fail : forall ref P s (h : heap_ptr) (h' : heap_arr)
      (Sref   : s y = vptr ref)
      (Snotin : ~ In (ref,f) h),
      read_sem x y f P 1 s (h, h') None.
  Program Definition read_cmd x y f := Build_semCmd (read_sem x y f) _ _.
  Next Obligation.
    intros H; inversion H.
  Qed.
  Next Obligation with eauto using read_sem.
    unfold frame_property; intros.
    inversion HSem; subst n s0 h0 s' big'; clear HSem; exists h; intuition.
    apply read_ok with ref; [assumption |]; specialize (HSafe _ (le_n _)).
    destruct h, big, frame; simpl in *; subst.
    apply sa_mul_split in HFrame.
    destruct HFrame as [HFrame _].
    destruct (sa_mul_mapstoR HFrame Rmaps) as [[H1 H2] | [H1 H2]]; [assumption|].
    contradiction HSafe; apply read_fail with ref; assumption.
  Qed.

Require Import Compare_dec.

  Lemma in_list_fresh (lst : list nat) :
    exists n, ~ List.In n lst.
  Proof.
    assert (exists n, forall x, List.In x lst -> n > x). {
      induction lst.
      + exists 0; intros x H. destruct H.
      + destruct IHlst as [n IHlst].
        destruct (gt_dec n a).
        * exists n; intros. simpl in H.
          destruct H. subst. assumption.
          apply IHlst. apply H.
        * assert (n <= a) by omega; clear n0.
          exists (S a); intros. simpl in H0.
          destruct H0. subst. omega.
          specialize (IHlst x H0). omega.
    }
    destruct H as [n H].
    exists n. intros Hn.
    specialize (H n Hn). omega.
  Qed.

  Lemma heap_arr_exists_fresh (h : heap_arr) :
    exists k, forall i, ~ In (k, i) h.
  Proof.
    assert (forall lst, exists k, forall i, ~ In (k, i) h /\ ~List.In k lst).
    generalize dependent h.
    apply (@map_induction (arrptr * nat) _ _ _ val
                          (fun (h : heap_arr) => forall lst, exists k : arrptr,
                                                   forall i : nat, ~ In (k, i) h /\
                                                                   ~ List.In k lst)).
    + intros.
      destruct (in_list_fresh lst) as [x H1].
      exists x; intros. split; [|assumption].
      intros H2.
      rewrite elements_Empty in H.
      rewrite elements_in_iff in H2.
      destruct H2 as [e H2]; rewrite H in H2.
      inversion H2.
    + intros. destruct x; simpl in *.
      specialize (H (a::lst)).
      destruct H as [k H].
      exists k; intros.
      specialize (H i). destruct H as [H2 H3].
      simpl in H3.
      assert (a <> k /\ ~ List.In k lst). {
        split. intros H4. apply H3. left. assumption.
        intros H. apply H3. right. apply H.
      }
      destruct H as [H4 H5].
      split; [|assumption].
      unfold Add in H1.
      specialize (H1 (k, i)).
      rewrite add_neq_o in H1.
      intros H. apply H2.
      rewrite in_find_iff; rewrite in_find_iff in H.
      intros H6.
      apply H. rewrite H1. apply H6.
      unfold Equivalence.equiv, complement; simpl.
      intros. inversion H; subst. apply H4. reflexivity.
    + destruct (H nil) as [k H1]; clear H.
      exists k; intros. destruct (H1 i) as [H _].
      apply H.
  Qed.

(*
  Require Import ZArith.
  Definition valid_path (vpath : list val) :=
    List.Forall (fun v => exists a, v = vint a /\ (a >= 0)%Z) vpath.
*)
  Inductive read_arr_sem (x y : Lang.var) (path : list dexpr) : semCmdType :=
  | read_arr_ok P arr s hp ha v vpath
                (Sref : s y = varr arr)
                (Smap : List.map (fun e => eval e s) path = vpath)
(*                (Sarr : valid_path vpath)*)
                (Sfind : find_heap_arr arr (List.map val_to_nat vpath) ha = Some v) :
      read_arr_sem x y path P 1 s (hp, ha) (Some (stack_add x v s, (hp, ha)))
  | read_arr_fail P arr s h vpath
                  (Sref : s y = varr arr)
                  (Smap : List.map (fun e => eval e s) path = vpath)
                  (Sarr : ~ in_heap_arr arr (List.map val_to_nat vpath) (snd h)) :
      read_arr_sem x y path P 1 s h None.
  Program Definition read_arr_cmd x y path := Build_semCmd (read_arr_sem x y path) _ _.
  Next Obligation.
    intros H. inversion H.
  Qed.
  Next Obligation.
    unfold frame_property; intros; exists h.
    inversion HSem; subst; specialize (HSafe _ (le_n _)).
    split; [assumption|].
    destruct h as [hp' ha'].
    apply read_arr_ok with (arr := arr) (vpath := (List.map (fun e : dexpr => eval e s)) path);
      try assumption; try reflexivity.
    destruct frame.
    apply sa_mul_split in HFrame as [_ HFrame].

    assert (in_heap_arr arr (List.map val_to_nat (List.map (fun e : dexpr => eval e s) path)) ha').
    apply dec_double_neg; [apply in_heap_arr_dec | intro H].
    apply HSafe.
    eapply read_arr_fail; try eassumption; try reflexivity.
    eapply find_heap_arr_frame; eauto.
  Qed.

  Inductive write_arr_sem (x : Lang.var) (path : list dexpr) (e : dexpr) : semCmdType :=
  | write_arr_ok P arr s hp ha ha' vpath
                 (Sref : s x = varr arr)
                 (Smap : List.map (fun e' => eval e' s) path = vpath)
                 (Sin  : in_heap_arr arr (List.map val_to_nat vpath) ha)
                 (Sha  : add_heap_arr arr (List.map val_to_nat vpath) ha (eval e s) = Some ha') :
      write_arr_sem x path e P 1 s (hp, ha) (Some (s, (hp, ha')))
  | write_arr_fail P arr s h vpath
                   (Sref : s x = varr arr)
                   (Smap : List.map (fun e' => eval e' s) path = vpath)
                   (Sin  : ~ in_heap_arr arr (List.map val_to_nat vpath) (snd h)) :
      write_arr_sem x path e P 1 s h None.
  Program Definition write_arr_cmd x path e := Build_semCmd (write_arr_sem x path e) _ _.
  Next Obligation.
    intros H. inversion H.
  Qed.
  Next Obligation.
    unfold frame_property; intros; inversion HSem; subst; clear HSem.
    destruct h, frame.
    apply sa_mul_split in HFrame as [Hhp Hha].
    specialize (HSafe _ (le_n _)).
    assert (in_heap_arr arr
          (List.map val_to_nat (List.map (fun e' : dexpr => eval e' s') path))
          h0). {
      apply dec_double_neg; [apply in_heap_arr_dec | intro H].
      apply HSafe; eapply write_arr_fail; try eassumption; reflexivity.
    }

    destruct (add_heap_arr_frame _ _ _ _ _ _ _ Hha Sha H) as [ha'' [H1 H2]].
    exists (h, ha'').
    split.
    split; simpl. apply Hhp. apply H1.
    eapply write_arr_ok; try eassumption; reflexivity.
  Qed.

  Inductive alloc_arr_sem (x : Lang.var) (e : dexpr) : semCmdType :=
  | alloc_arr_ok (P : Program) (s s' : stack) (hp : heap_ptr) (ha ha' : heap_arr) (n : nat)
                 (Sfresh_ha : forall i, ~ In (n, i) ha)
                 (Sha : alloc_heap_arr n (val_to_nat (eval e s)) ha === ha')
                 (Ss : s' = stack_add x (varr n) s) :
      alloc_arr_sem x e P 1 s (hp, ha) (Some (s', (hp, ha'))).
  Program Definition alloc_arr_cmd x e := Build_semCmd (alloc_arr_sem x e) _ _.
  Next Obligation.
    intros H; inversion H.
  Qed.
  Next Obligation.
    unfold frame_property; intros; inversion HSem; subst P n s s' big big'.
    destruct h, frame.
    apply sa_mul_split in HFrame as [Hhp Hha].
    specialize (HSafe _ (le_n _)).
    Lemma alloc_heap_arr_frame (n m : nat) (h frame h' h'' : heap_arr)
          (Hfresh : forall i, ~ In (n, i) frame)
          (Hh : alloc_heap_arr n m h === h')
          (HFrame : sa_mul h'' frame h) :
      exists h''', alloc_heap_arr n m h'' === h''' /\ sa_mul h''' frame h'.
    Proof.
      admit.
      (*
      generalize dependent h'; induction m; simpl in *; intros.
      + setoid_rewrite <- Hh.
        exists (add (n, 0) null h''); split; [reflexivity|].
        apply sa_mul_add; [assumption | apply Hfresh].
      + assert (alloc_heap_arr n m h === alloc_heap_arr n m h) by reflexivity.
        destruct (IHm _ H) as [h'''' [H1 H2]].
        exists (add (n, m) null h'''').
        split.
        rewrite H1. reflexivity.
        rewrite <- Hh.
        apply sa_mul_add. assumption.
        apply Hfresh.
*)
    Qed.

    assert (forall i : nat, ~ In (n0, i) h2) as Sfresh_frame. {
      intros i H; apply Sfresh_ha with i.
      apply sa_mulC in Hha; destruct (sa_mul_inL Hha H); assumption.
    }
    destruct (alloc_heap_arr_frame Sfresh_frame Sha Hha) as [ha'' [H1 H2]].
    exists (h, ha''). split. split; simpl; assumption.
    apply alloc_arr_ok with n0; try assumption.
    intros i H.
    specialize (Sfresh_ha i). apply Sfresh_ha.
    destruct (sa_mul_inL Hha H). apply H3.
  Qed.

  Inductive alloc_sem (x : Lang.var) (C : class) : semCmdType :=
  | alloc_ok : forall (P : Program) (s s0 : stack) (h h0 : heap_ptr) (h' : heap_arr) n fields
      (Snotnull : (n, C) <> pnull)
      (Sfresh_h : forall f, ~ In ((n, C), f) h)
      (Sfields  : field_lookup P C fields)
      (Sh0      : sa_mul h
        (fold_right (fun f h' => add ((n, C), f) (pnull : val) h') heap_ptr_unit fields) h0)
      (Ss0      : s0 = stack_add x (vptr (n, C)) s),
      alloc_sem x C P 1 s (h, h') (Some (s0, (h0, h'))).
  Program Definition alloc_cmd x C := Build_semCmd (alloc_sem x C) _ _.
  Next Obligation.
    intros H; inversion H.
  Qed.
  Next Obligation.
    unfold frame_property; intros.
    inversion HSem; subst; clear HSem.
    destruct h, frame; simpl in *.
    apply sa_mul_split in HFrame. destruct HFrame as [HFrame HFrameArr].
    destruct (sa_mulA HFrame Sh0) as [h5 [H1 H2]].
    apply sa_mulC in H2; destruct (sa_mulA H1 H2) as [h6 [H3 H5]].
    exists (h6, h2).
    split; [split; simpl; [apply sa_mulC|]; assumption|].
    eapply alloc_ok; [eassumption | | eassumption | apply sa_mulC; assumption | reflexivity].
    intros f H6; apply (Sfresh_h f).
    apply sa_mulC in H2.
    destruct (sa_mul_inL H2 H6) as [H8 H9].
    destruct (sa_mul_inR Sh0 H9) as [[H10 H11] | [H10 H11]]; [assumption|].
    apply sa_mulC in H1; destruct (sa_mul_inL H1 H10); intuition.
  Qed.

  Inductive write_sem (x:Lang.var) (f:field) (e:dexpr) : semCmdType :=
  | write_ok : forall P (s: stack) (h h' : heap_ptr) (h'' : heap_arr) ref v
      (Sref: s x = vptr ref)
      (Sin:  In (ref,f) h )
      (Heval : eval e s = v)
      (Sadd: h' = add (ref,f) v h ),
      write_sem x f e P 1 s (h, h'') (Some (s, (h', h'')))
  | write_fail : forall P (s: stack) h h'' ref
      (Sref:   s x = vptr ref)
      (Sin : ~ In (ref, f) h),
      write_sem x f e P 1 s (h, h'') None.
  Program Definition write_cmd x f e := Build_semCmd (write_sem x f e) _ _.
  Next Obligation.
    intros H; inversion H.
  Qed.
  Next Obligation.
    unfold frame_property; intros.
    inversion HSem. subst; clear HSem.
    destruct h, frame; simpl in *.
    apply sa_mul_split in HFrame as [HFrame HFramePtr].
    assert (~ In (ref, f) h2).
    intros H.
    apply (HSafe 1); [omega |].
    eapply write_fail; [eassumption|].
    destruct (sa_mul_inR HFrame Sin); intuition.
    exists ((add (ref, f) (eval e s') h, h1)). split.
    split.
    apply sa_mul_add; assumption. simpl. assumption.
    eapply write_ok; try eassumption; try reflexivity.
    destruct (sa_mul_inR HFrame Sin); intuition.
  Qed.

  Fixpoint create_stack (ps : list Lang.var) (vs : list val) : stack :=
    match ps, vs with
      | nil, nil => stack_empty Lang.var val
      | p :: ps, v :: vs =>
        stack_add p v (create_stack ps vs)
      | _, _ => stack_empty Lang.var val
    end.

  Inductive call_sem (rvar : Lang.var) (C : open class) m es (c : cmd) (sc : semCmd)
    : semCmdType :=
  | call_failS : forall (P : Program) s h
      (HLFail  : forall mrec, ~ method_lookup P (C s) m mrec),
      call_sem rvar C m es c sc P 1 s h None
  | call_failC : forall (P : Program) ps rexpr (s : stack) h n
      (HLookup : method_lookup P (C s) m (Build_Method ps c rexpr))
      (HLen    : length ps = length es)
      (HFail   : sc P n (create_stack ps (eval_exprs s es)) h None),
      call_sem rvar C m es c sc P (S n) s h None
  | call_failL : forall (P : Program) ps rexpr s h
      (HLookup : method_lookup P (C s) m (Build_Method ps c rexpr))
      (HLen    : length ps <> length es),
      call_sem rvar C m es c sc P 1 s h None
  | call_ok    : forall (P : Program) ps rexpr (s sr : stack) h hr n
      (HLookup : method_lookup P (C s) m (Build_Method ps c rexpr))
      (HLen    : length ps = length es)
      (HSem    : sc P n (create_stack ps (eval_exprs s es)) h (Some (sr, hr))),
      call_sem rvar C m es c sc P (S n) s h
        (Some (stack_add rvar (eval rexpr sr) s, hr)).
  Program Definition call_cmd rvar C m es c sc := Build_semCmd (call_sem rvar C m es c sc) _ _.
  Next Obligation.
    intros H; inversion H.
  Qed.
  Next Obligation with eauto using call_sem.
    unfold frame_property; intros.
    inversion HSem; subst; clear HSem.
    edestruct (@cmd_frame sc) as [h1 [HFrame1 HSem1]]...
    intros k HLe HFail; apply HSafe with (S k); [omega |]...
  Qed.

  Inductive semantics : cmd -> semCmd -> Prop :=
  | semassign : forall x e,
      semantics (cassign x e) (assign_cmd x e)
  | semread   : forall x y f,
      semantics (cread x y f) (read_cmd x y f)
  | semalloc  : forall x C,
      semantics (calloc x C) (alloc_cmd x C)
  | semwrite  : forall x f e,
      semantics (cwrite x f e) (write_cmd x f e)
  | semarrread : forall x y es,
                   semantics (carrread x y es) (read_arr_cmd x y es)
  | semarrwrite : forall x es e,
                   semantics (carrwrite x es e) (write_arr_cmd x es e)
  | semarralloc : forall x (e : dexpr),
                    semantics (carralloc x e) (alloc_arr_cmd x e)
  | semskip   : semantics cskip skip_cmd
  | semseq    : forall c1 c2 sc1 sc2
      (HL : semantics c1 sc1)
      (HR : semantics c2 sc2),
      semantics (cseq c1 c2) (seq_cmd sc1 sc2)
  | semif     : forall e cl cr scl scr
      (HL : semantics cl scl)
      (HR : semantics cr scr),
      semantics (cif e cl cr) (nondet_cmd
        (seq_cmd (assume_cmd (vlogic_eval e)) scl)
        (seq_cmd (assume_cmd (vlogic_eval (E_not e))) scr))
  | semwhile  : forall e c sc
      (HS : semantics c sc),
      semantics (cwhile e c) (seq_cmd (kleene_cmd
        (seq_cmd (assume_cmd (vlogic_eval e)) sc)) (assume_cmd (vlogic_eval (E_not e))))
  | semdcall  : forall (x y : Lang.var) m es c sc
      (HSem     : semantics c sc),
      semantics (cdcall x y m es) (call_cmd x ((liftn val_class) (var_expr y)) m ((E_var y) :: es) c sc)
  | semscall  : forall (x : Lang.var) (C : class) m es c sc
      (HSem     : semantics c sc),
      semantics (cscall x C m es) (call_cmd x (open_const C) m es c sc)
  | semassert : forall e,
      semantics (cassert e) (assert_cmd (vlogic_eval e)).

  Definition c_not_modifies c x :=
    forall sc, semantics c sc -> not_modifies sc x.

  Lemma modifies_syn_sem c x :
     ~ List.In x (modifies c) -> c_not_modifies c x.
  Proof.
    induction c; simpl in *; intros HNM; intros sc HSem; inversion_clear HSem.
    + intros P s s0 h h0 n HAsgn;
      simpl in *; inversion HAsgn; subst.
      rewrite stack_lookup_add2; trivial.
      intuition congruence.
    + intros P s s0 h h0 n HSkip; simpl in *; inversion HSkip; subst; trivial.
    + intros P s s0 h h0 n HSeq; simpl in *; inversion HSeq; subst.
      transitivity (s2 x).
      * eapply IHc1; [| eassumption | eassumption]; intros HIn; apply HNM;
        rewrite in_app_iff; auto.
      * eapply IHc2; [| eassumption | eassumption]; intros HIn; apply HNM;
        rewrite in_app_iff; auto.
    + intros P s s0 h h0 n HND; simpl in *; inversion HND; subst; clear HND.
      * inversion H4; subst.
        apply assume_inv in H6; destruct H6; subst.
        eapply IHc1; [| eassumption | eassumption]; intros HIn; apply HNM;
          rewrite in_app_iff; auto.
      * inversion H4; subst.
        apply assume_inv in H6; destruct H6; subst.
        eapply IHc2; [| eassumption | eassumption]; intros HIn; apply HNM;
        rewrite in_app_iff; auto.
    + intros P s s0 h h0 n HKl; simpl in *; inversion HKl; subst; clear HKl.
      apply assume_inv in H6; destruct H6; subst; simpl in *.
      remember (Some (s0, h0)); induction H5; subst;
        [inversion Heqo; trivial | discriminate | discriminate |].
      transitivity (s1 x); simpl in *.
      * inversion H; subst; clear H.
        apply assume_inv in H7; destruct H7; subst.
        eapply IHc; eassumption.
      * apply IHkleene_sem; assumption.
    + intros P s s0 h h0 n HWr; simpl in *; inversion HWr; subst; reflexivity.
    + intros P s s0 h h0 n HRd; simpl in *;
      inversion HRd; subst; rewrite stack_lookup_add2; trivial;
      intuition congruence.
    + intros P s s0 h h0 n Hrd; simpl in *.
      inversion Hrd; subst. rewrite stack_lookup_add2; [reflexivity | intuition congruence ].
    + intros P s s0 h h0 n Hrd; simpl in *; inversion Hrd; reflexivity.
    + intros P s s0 h h0 n Hrd; simpl in *.
      inversion Hrd; subst. rewrite stack_lookup_add2; [reflexivity | intuition congruence].
    + intros P s s0 h h0 n HCl; simpl in *;
      inversion HCl; subst; rewrite stack_lookup_add2; trivial;
      intuition congruence.
    + intros P s s0 h h0 n HCl; simpl in *;
      inversion HCl; subst; rewrite stack_lookup_add2; trivial;
      intuition congruence.
    + intros P s s0 h h0 n HCl; simpl in *;
      inversion HCl; subst; rewrite stack_lookup_add2; trivial;
      intuition congruence.
    + intros P s s0 h h0 n HAs; inversion HAs; subst; reflexivity.
  Qed.

  (* A reasonable alternative definition would be
   * [ [E] sc, [pure] semantics c sc [/\] triple _ P Q sc ]
   *
   * The two definitions should really be equivalent, but proving that to be
   * the case requires proving that [semantics] is a total and functional
   * relation. This might not be straightforward since it requires induction
   * over some number of steps, either by indexing [semantics] with [nat] or by
   * somehow using the number that's in the semCmd parameter.
   *
   * The definition chosen here allows us to lift all the proof rules about
   * triples that we care about into c_triple. The proof rules that cannot be
   * lifted here but could be lifted with the other definition seem to be more
   * obscure. For example, {true} c {true} |= [E]s,[E]h, safe c s h. Here, the
   * witness for the existential depends on the triple, but the triple cannot
   * be taken apart without guessing a semantic command.
   *)

End Commands.

  Local Transparent ILPre_Ops.
  Local Transparent ILFun_Ops.

  Definition triple (P Q : sasn) (c : cmd) :=
    Forall sc : semCmd, (semantics c sc) ->> {{P}} sc {{Q}}.

  Notation " '{[' P ']}' c '{[' Q ']}' " := (triple P Q c) (at level 89,
    format " {[ P ]} '/' c '/' {[ Q ]} ").

  Add Parametric Morphism : triple with signature
    lentails --> lentails ++> eq ==> lentails
    as triple_entails_m.
  Proof.
    intros p p' Hp q q' Hq c.
    unfold triple.
    setoid_rewrite Hq; setoid_rewrite <- Hp. reflexivity.
  Qed.

Open Scope open_scope.

  Definition method_spec C m (ps : list Lang.var) (rn : Lang.var) (P Q : sasn) := (
    NoDup (rn :: ps) /\\
    Exists ps' : (list Lang.var), Exists c : cmd, Exists re : dexpr,
      [prog] (fun X : Program => method_lookup X C m (Build_Method ps' c re)
        /\ length ps = length ps' /\
        (forall x, List.In x ps' -> ~ List.In x (modifies c)))
      //\\ {[ P //! zip ps (List.map var_expr ps') ]}
         c {[ Q //! zip (rn :: ps) (eval re :: (List.map var_expr ps'))]}
    ).

  Notation " C ':.:' m |-> ps {{ P }}-{{ r , Q }} " :=
    (method_spec C m ps r P Q) (at level 60).

  Add Parametric Morphism : method_spec with signature
    eq ==> eq ==> eq ==> eq ==>
      lentails --> lentails ++> lentails
    as method_spec_entails_m.
  Proof.
    intros C m ps rn P P' HP Q Q' HQ. unfold method_spec.
    (* Unravel the two almost identical sides of the entailment first because
        setoid_rewrite doesn't seem to go under these binders. *)
    apply lpropandL; intro H. apply lpropandR; [assumption|].
    lexistsL ps' c re. lexistsR ps' c re.
    apply landR; [apply landL1; reflexivity | apply landL2].
    admit.
(*    setoid_rewrite HP. setoid_rewrite HQ. reflexivity.*)
  Qed.

  Add Parametric Morphism : method_spec with signature
    eq ==> eq ==> eq ==> eq ==>
      lequiv ==> lequiv ==> lequiv
    as method_spec_bientails_m.
  Proof.
    split; apply method_spec_entails_m; try rewrite ?H, ?H0; reflexivity.
  Qed.

  Lemma c_triple_zero P (p q : sasn) (c : cmd) :
    ({[ p ]} c {[ q ]}) P 0.
  Proof.
    intros sc n Hn Q HPQ sem R k m s h HQR Hk Hv Hp.
    assert (m = 0) by omega.
    assert (k = 0) by omega.
    subst. split.
    + apply safe_zero.
    + intros h' s'' Hc. apply cmd_zero in Hc. contradiction.
  Qed.

(* Arguments swapped to please the type classes *)

  Definition typeof (C : class) (v : val) : Prop := exists p, v = vptr p /\ snd p = C.
(*
  Notation " x ':::' C " :=
    (@coerce _ _ (@lift2_C _ _ _ _) typeof (@coerce _ _ (@lift0_C _ _) C) (var_expr x)) (at level 60).

  (* TODO: should P,Q be allowed to reference stack vars from the outside? *)
  Definition expr_spec x m (ps: list var) (r: var) (P Q: hasn) : hasn :=
    (<E> C, <pure> x:::C </\> lift0 (FunI (C:.:m |-> ps {{P}}-{{r,Q}})))
    %asn.

  Arguments Scope expr_spec [_ _ _ _ asn_scope asn_scope].

  Notation " x ':..:' m |-> ps {{ P }}-{{ r , Q }} " :=
    (expr_spec x m ps r P Q) (at level 60).
*)

Section StructuralRules.

  Lemma triple_false (G : spec) (Q : sasn) c :
    G |-- {[lfalse]} c {[Q]}.
  Proof.
    intros n; simpl in *; intros; destruct H4.
  Qed.

  Lemma roc (P P' Q Q' : sasn) c (G : spec)
    (HPre  : P  |-- P')
    (HPost : Q' |-- Q)
    (Hc    : G  |-- {[P']} c {[Q']}) :
    G |-- {[P]} c {[Q]}.
  Proof.
    rewrite Hc.
    unfold triple. lforallR sc. apply lpropimplR; intros Hsc.
    lforallL sc. apply lpropimplL; [assumption|]. apply rule_of_consequence; assumption.
  Qed.

  Lemma roc_pre (P P' Q : sasn) c G
    (HPre : P |-- P')
    (Hc   : G |-- {[P']} c {[Q]}) :
    G |-- {[P]} c {[Q]}.
  Proof.
  	eapply roc; eassumption || reflexivity.
  Qed.

  Lemma roc_post (P Q Q' : sasn) c G
    (Hc : G  |-- {[P]} c {[Q']})
    (HPost : Q' |-- Q) :
    G |-- {[P]} c {[Q]}.
  Proof.
    eapply roc; eassumption || reflexivity.
  Qed.

  Lemma rule_frame_ax_list P Q R c (xs: list Lang.var)
    (HMod : forall x, ~ List.In x xs -> c_not_modifies c x) :
    {[ P ]} c {[ Q ]} |--
    {[ P ** R ]} c {[ Q ** Exists vs, apply_subst R (subst_fresh vs xs) ]}.
  Proof.
    unfold triple. lforallR sc; apply lpropimplR; intro Hsc. lforallL sc.
    apply lpropimplL; [assumption|].
    apply frame_rule. unfold c_not_modifies in HMod. intros. apply HMod; auto.
  Qed.

  Definition subst_mod_asn (R: sasn) (c: cmd) : sasn :=
    Exists vs, apply_subst R (subst_fresh vs (modifies c)).

  Lemma rule_frame_ax P Q R c :
    {[ P ]} c {[ Q ]} |--
    {[ P ** R ]} c {[ Q ** subst_mod_asn R c ]}.
  Proof.
    apply rule_frame_ax_list. intros x HnotIn. apply modifies_syn_sem.
    assumption.
  Qed.

  Lemma rule_frame P Q R c G
    (HPre : G |-- {[P]} c {[Q]}) :
    G |-- {[ P ** R ]} c {[ Q ** subst_mod_asn R c ]}.
  Proof.
    intros; rewrite <- rule_frame_ax; assumption.
  Qed.
  Implicit Arguments rule_frame [[P] [Q] [R] [c] [G]].

  Lemma exists_into_precond2 {A} (P: A -> sasn) c q :
    (Forall x, {[P x]} c {[q]}) -|- {[Exists x, P x]} c {[q]}.
  Proof.
    unfold triple; setoid_rewrite <- exists_into_precond; split.
    + lforallR sc. apply lpropimplR; intro Hsc; lforallR x.
      lforallL x sc. apply lpropimplL; [assumption | reflexivity].
    + lforallR x sc. apply lpropimplR; intro Hsc.
      lforallL sc. apply lpropimplL; [assumption | lforallL x; reflexivity].
  Qed.

  Lemma existentialise_triple (x : Lang.var) (P Q : sasn) c (G : spec)
	(H : forall (v : val), G |-- {[@lembedand vlogic sasn _ _ (open_eq (x/V) (`v)) P]} c {[Q]}) :
    G |-- {[P]} c {[Q]}.
  Proof.
    eapply roc_pre; [apply existentialise_var with (x0 := x)|].
    rewrite <- exists_into_precond2. lforallR y. apply H.
  Qed.

End StructuralRules.