From Ornamental Require Import Ornaments.
Require Import Infrastructure.

Set DEVOID search prove equivalence.
Set DEVOID lift type.
Set Nonrecursive Elimination Schemes.

(*
 * This code is a minimized example from @ptival, which I use as a regression test
 * to make sure projections aren't expanded and left as applications of prod_rect,
 * and that projections/accessors lift to accessors/projections.
 *
 * The proofs here are purposely brittle, since they should break if the terms are not _exactly_ syntactically equal.
 *)

Module Pairs.

  Definition profile : Type := (bool * nat).

  Definition page : Type := (nat * (nat * (bool * ((bool * nat) * nat)))).

  Definition visible (pr : profile) (pa : page) : bool :=
    andb (fst pr) (fst (snd (snd pa))).

End Pairs.

Preprocess Module Pairs as Pairs_PP { opaque andb }.

Module Records.

  Record Profile :=
    {
      public : bool;
      age : nat;
    }.

  Definition is_public (pr : Pairs.profile) : bool := fst pr.

  Definition get_age (pr : Pairs.profile) : nat := snd pr.

End Records.

Preprocess Module Records as Records_PP.

Lift Records_PP.Profile Pairs_PP.profile in Records_PP.public as is_public.
Lift Pairs_PP.profile Records_PP.Profile in Records_PP.is_public as public.

Definition is_public_expected (h : Pairs_PP.profile) :=
  Prod.fst _ _ h.

Lemma test_is_public:
  is_public = is_public_expected.
Proof.
  unfold is_public, is_public_expected.
  test_exact_equality.
Qed.

Lemma test_public:
  public = fun h => Records_PP.public h.
Proof.
  unfold public.
  test_exact_equality.
Qed.

Lift Records_PP.Profile Pairs_PP.profile in Records_PP.age as get_age.
Lift Pairs_PP.profile Records_PP.Profile in Records_PP.get_age as age.

Definition get_age_expected (h : Pairs_PP.profile) :=
  Prod.snd _ _ h.

Lemma test_get_h_n:
  get_age = get_age_expected.
Proof.
  unfold get_age, get_age_expected.
  test_exact_equality.
Qed.

Lemma testGetHN:
  age = fun (h : Records_PP.Profile) => Records_PP.age h.
Proof.
  unfold age.
  test_exact_equality.
Qed.

Lift Pairs_PP.profile Records_PP.Profile in Pairs_PP.visible as visible_PP { opaque andb }.

Definition visible_PP_expected (pr : Records_PP.Profile) (pa : nat * (nat * (bool * (Records_PP.Profile * nat)))) : bool :=
 Records_PP.public pr
 &&
 Pairs_PP.Coq_Init_Datatypes_fst bool (Records_PP.Profile * nat)
   (Pairs_PP.Coq_Init_Datatypes_snd nat (bool * (Records_PP.Profile * nat))
      (Pairs_PP.Coq_Init_Datatypes_snd nat (nat * (bool * (Records_PP.Profile * nat))) pa)).

Lemma test_visible_PP:
  visible_PP = visible_PP_expected.
Proof.
  unfold visible_PP, visible_PP_expected.
  test_exact_equality.
Qed.

Module MoreRecords.

  Record Page :=
    {
      friends : nat;
      groups : nat;
      active  : bool;
      profile  : Records_PP.Profile;
      photos : nat;
    }.

  (* We'd like to wrap the ugly access into this: *)
  Definition is_active (pa : Pairs.page) : bool := fst (snd (snd pa)).

End MoreRecords.

Preprocess Module MoreRecords as MoreRecords_PP.

Lift Pairs_PP.profile Records_PP.Profile in Pairs_PP.page as page_PP.

Lift Pairs_PP.profile Records_PP.Profile in MoreRecords_PP.is_active as active0.
Lift page_PP MoreRecords_PP.Page in active0 as active.

Lift Pairs_PP.profile Records_PP.Profile in Pairs_PP.visible as visible0 { opaque andb }.
Lift page_PP MoreRecords_PP.Page in visible0 as visible { opaque andb }.

Definition visible_expected (pr : Records_PP.Profile) (pa : MoreRecords_PP.Page) : bool :=
  (Records_PP.public pr && MoreRecords_PP.active pa)%bool.

Lemma test_visible :
  visible = visible_expected.
Proof.
  unfold visible, visible_expected.
  test_exact_equality.
Qed.


Require Import CertiGraph.msl_application.ArrayGraph.
Require Import VST.veric.SeparationLogic.
Require Import CertiGraph.unionfind.env_unionfind_arr.
Require Import CertiGraph.floyd_ext.share.

(*I suppose this focuses SpatialArrayGraphAssum to specifically the mpred type? Have no idea what it means*)
Instance SAGA_VST: SpatialArrayGraphAssum mpred. Proof. refine (Build_SpatialArrayGraphAssum _ _ _ _ _). Defined.

(* Translation of a rank-parent pair into the C representation *)
Definition vgamma2cdata (rpa : nat * Z) : reptype vertex_type :=
  match rpa with
  | (r, pa) => (Vint (Int.repr pa), Vint (Int.repr (Z.of_nat r)))
  end.

(*Some SpatialGraph wrap over the data_at mpred stated below?*)
Instance SAG_VST (sh: share): SpatialArrayGraph pointer_val mpred.
Proof.
(*       pointer_val         mpred *)
  exact (fun pt lst => data_at sh (tarray vertex_type (Z.of_nat (length lst)))
                               (map vgamma2cdata lst) (pointer_val_val pt)).
Defined.


From sflib Require Import sflib.
From Paco Require Import paco.
Require Import Coq.Classes.RelationClasses Lia Program.
From Fairness Require Export ITreeLib WFLib FairBeh NatStructs Mod pind.
From PromisingLib Require Import Loc Event.
From PromisingSEQ Require Import Time View TView Cell Memory Local.

Set Implicit Arguments.

Module WMem.
  Program Definition init_cell: Cell.t :=
    @Cell.mk (LocMap.singleton Time.bot (Time.bot, Message.concrete (Const.of_Z (BinIntDef.Z.of_nat 0)) None)) _.
  Next Obligation.
  Proof.
    econs.
    { i. eapply LocMap.singleton_find_inv in GET. des; clarify. auto. }
    { i. eapply LocMap.singleton_find_inv in GET. des; clarify. auto. }
    { i. eapply LocMap.singleton_find_inv in GET1.
      eapply LocMap.singleton_find_inv in GET2. des; clarify.
    }
  Qed.

  Definition init_mem: Memory.t := fun _ => init_cell.

  Record t :=
    mk
      {
        memory:> Memory.t;
        sc: TimeMap.t;
      }.

  Definition init: t := mk init_mem TimeMap.bot.

  Let ident := (Loc.t * Time.t)%type.

  Definition view_to_local (vw: View.t): Local.t := Local.mk (TView.mk (fun _ => vw) vw vw) Memory.bot.

  Definition missed (m: Memory.t) (loc: Loc.t) (ts: Time.t): fmap ident :=
    fun '(loc', ts') =>
      if (Loc.eq_dec loc' loc)
      then
        if (Time.le_lt_dec ts' ts)
        then Flag.emp
        else match Memory.get loc' ts' m with
             | Some (_, Message.concrete _ (Some _)) => Flag.fail
             | _ => Flag.emp
             end
      else Flag.emp.

  Definition load_fun:
    ktree (programE ident t) (View.t * Loc.t * Ordering.t) (View.t * Const.t) :=
    fun '(vw0, loc, ord) =>
      msc <- trigger (Get id);;
      '(exist _ (lc1, val, to) _) <- trigger (Choose (sig (fun '(lc1, val, to) =>
                                                             exists released,
                                                               Local.read_step
                                                                 (view_to_local vw0)
                                                                 (msc.(memory))
                                                                 loc
                                                                 to
                                                                 val
                                                                 released
                                                                 ord
                                                                 lc1)));;
      _ <- trigger (Fair (missed msc loc to));;
      Ret (lc1.(Local.tview).(TView.cur), val)
  .

  Definition store_fun:
    ktree (programE ident t) (View.t * Loc.t * Const.t * Ordering.t) (View.t) :=
    fun '(vw0, loc, val, ord) =>
      msc <- trigger (Get id);;
      '(exist _ (lc1, to, sc1, mem1) _) <- trigger (Choose (sig (fun '(lc1, to, sc1, mem1) =>
                                                                   exists from released kind,
                                                                     Local.write_step
                                                                       (view_to_local vw0)
                                                                       (msc.(sc))
                                                                       (msc.(memory))
                                                                       loc
                                                                       from
                                                                       to
                                                                       val
                                                                       None
                                                                       released
                                                                       ord
                                                                       lc1
                                                                       sc1
                                                                       mem1
                                                                       kind)));;
      _ <- trigger (Fair (missed msc loc to));;
      _ <- trigger (Put (mk mem1 sc1));;
      Ret (lc1.(Local.tview).(TView.cur))
  .

  Definition faa_fun:
    ktree (programE ident t) (View.t * Loc.t * Const.t * Ordering.t * Ordering.t) (View.t * Const.t) :=
    fun '(vw0, loc, addendum, ordr, ordw) =>
      msc <- trigger (Get id);;
      '(exist _ (lc2, to, val, sc1, mem1) _) <-
        trigger (Choose (sig (fun '(lc2, to, val, sc1, mem1) =>
                                exists lc1 from releasedr releasedw kind,
                                  (Local.read_step
                                     (view_to_local vw0)
                                     (msc.(memory))
                                     loc
                                     from
                                     val
                                     releasedr
                                     ordr
                                     lc1) /\
                                    (Local.write_step
                                       lc1
                                       (msc.(sc))
                                       (msc.(memory))
                                       loc
                                       from
                                       to
                                       (Const.add val addendum)
                                       releasedr
                                       releasedw
                                       ordw
                                       lc2
                                       sc1
                                       mem1
                                       kind))));;
      _ <- trigger (Fair (missed msc loc to));;
      _ <- trigger (Put (mk mem1 sc1));;
      Ret (lc2.(Local.tview).(TView.cur), val)
  .

  Definition mod: Mod.t :=
    Mod.mk
      init
      (Mod.get_funs [("store", Mod.wrap_fun store_fun);
                     ("load", Mod.wrap_fun load_fun);
                     ("faa", Mod.wrap_fun faa_fun)
      ]).

End WMem.

From Fairness Require Import PCM IProp IPM FairRA StateRA MonotonePCM.
From PromisingSEQ Require Import MemoryProps.

Section MEMRA.
  Definition wmemRA: URA.t := (Loc.t ==> (Auth.t (Excl.t Cell.t)))%ra.

  Context `{WMEMRA: @GRA.inG wmemRA Σ}.

  Definition memory_resource_black (m: WMem.t): wmemRA :=
    fun loc =>
      Auth.black (Excl.just (m.(WMem.memory) loc): Excl.t Cell.t).

  Definition points_to_white (loc: Loc.t) (c: Cell.t): wmemRA :=
    fun loc' =>
      if (Loc.eq_dec loc' loc)
      then Auth.white (Excl.just c: Excl.t Cell.t)
      else URA.unit
  .

  Definition points_to (loc: Loc.t) (c: Cell.t): iProp :=
    OwnM (points_to_white loc c).

  Definition wmemory_black (m: WMem.t): iProp :=
    OwnM (memory_resource_black m).

  (* TODO: multiple locs *)
  Definition wmem_init_res (l0 l1: Loc.t): wmemRA :=
    points_to_white l0 WMem.init_cell ⋅ points_to_white l1 WMem.init_cell ⋅ memory_resource_black WMem.init.

  Lemma wmem_init_res_wf l0 l1
        (DISJ: l0 <> l1)
    :
    URA.wf (wmem_init_res l0 l1).
  Proof.
    unfold wmem_init_res, points_to_white, points_to, Auth.white.
    Local Transparent URA.unit.
    ur. i. ur. des_ifs.
    { splits.
      { eexists (URA.unit). ur. ss. }
      { ur. ss. }
    }
    { splits.
      { eexists (URA.unit). ur. ss. }
      { ur. ss. }
    }
    { splits.
      { eexists (Excl.just (WMem.init_mem k)). ur. ss. }
      { ur. ss. }
    }
  Qed.

  Lemma wmem_init_res_prop l0 l1
    :
    (OwnM (wmem_init_res l0 l1))
      -∗
      (points_to l0 WMem.init_cell ** points_to l1 WMem.init_cell ** wmemory_black WMem.init).
  Proof.
    iIntros "[[H0 H1] H2]". iFrame.
  Qed.

  (* normal points-to *)
  Definition wpoints_to (l: Loc.t) (v: Const.t) (vw: View.t): iProp :=
    ∃ c,
      (points_to l c)
        **
        (⌜exists from released,
              (<<GET: Cell.get (Cell.max_ts c) c = Some (from, Message.concrete v released)>>) /\
                (<<DEFINED: v <> Const.undef>>) /\
                (<<VIEW: View.le (View.singleton_ur l (Cell.max_ts c)) vw >>)⌝)
  .

  Lemma init_cell_max_ts
    :
    Cell.max_ts WMem.init_cell = Time.bot.
  Proof.
    auto.
  Qed.

  Lemma init_cell_get
    :
    Cell.get (Cell.max_ts WMem.init_cell) WMem.init_cell =
      Some (Time.bot, Message.concrete (BinIntDef.Z.of_nat 0) None).
  Proof.
    ss.
  Qed.

  Lemma init_cell_get_if to from msg
        (GET: Cell.get to WMem.init_cell = Some (from, msg))
    :
    (<<TO: to = Time.bot>>) /\
      (<<FROM: from = Time.bot>>) /\
      (<<MSG: msg = Message.concrete (BinIntDef.Z.of_nat 0) None>>).
  Proof.
    hexploit Cell.max_ts_spec; eauto. i. des.
    rewrite init_cell_max_ts in *. inv MAX.
    { inv H. }
    { inv H. setoid_rewrite init_cell_get in GET. clarify. }
  Qed.

  Lemma init_points_to_wpoints_to l v
    :
    (points_to l WMem.init_cell)
      -∗
      wpoints_to l (Const.of_Z (BinIntDef.Z.of_nat 0)) v.
  Proof.
    iIntros "H". iExists _. iFrame. iPureIntro. esplits.
    { rewrite init_cell_get. eauto. }
    { ss. }
    { econs.
      { ss. eapply TimeMap.singleton_spec.
        rewrite init_cell_max_ts. eapply Time.bot_spec. }
      { ss. eapply TimeMap.singleton_spec.
        rewrite init_cell_max_ts. eapply Time.bot_spec. }
    }
  Qed.

  Lemma wpoints_to_view_mon l v vw0 vw1
        (LE: View.le vw0 vw1)
    :
    (wpoints_to l v vw0)
      ⊢
      (wpoints_to l v vw1).
  Proof.
    unfold wpoints_to.
    iIntros "[% [OWN %]]". des. iExists _. iSplit; [iFrame|].
    iPureIntro. esplits; eauto.
  Qed.

  Lemma wmemory_ra_get
        m l c
    :
    (wmemory_black m)
      -∗
      (points_to l c)
      -∗
      ⌜m.(WMem.memory) l = c⌝.
  Proof.
    iIntros "BLACK WHITE".
    unfold wmemory_black, points_to.
    iCombine "BLACK WHITE" as "OWN". iOwnWf "OWN". iPureIntro.
    ur in H. specialize (H l).
    unfold memory_resource_black, points_to_white in H. des_ifs.
    ur in H. ur in H. des_ifs. des. rr in H. des. ur in H. des_ifs.
  Qed.

  Lemma pointwise_updatabable M K (a b: URA.pointwise K M)
        (POINTWISE: forall k, URA.updatable (a k) (b k))
    :
    URA.updatable a b.
  Proof.
    ii. ur. ur in H. i. eapply POINTWISE; eauto.
  Qed.

  Lemma wmemory_ra_write
        m0 m1 l c
        from to msg
        (WRITE: Memory.add m0.(WMem.memory) l from to msg m1)
    :
    (wmemory_black m0)
      -∗
      (points_to l c)
      -∗
      (#=> (wmemory_black (WMem.mk m1 m0.(WMem.sc)) ** points_to l (m1 l))).
  Proof.
    iIntros "BLACK WHITE".
    unfold wmemory_black, points_to.
    iCombine "BLACK WHITE" as "OWN". iOwnWf "OWN".
    ur in H. specialize (H l).
    unfold memory_resource_black, points_to_white in H. des_ifs.
    ur in H. ur in H. des_ifs. des. rr in H. des. ur in H. des_ifs.
    iAssert (#=> OwnM (memory_resource_black (WMem.mk m1 m0.(WMem.sc)) ⋅ points_to_white l (m1 l))) with "[OWN]" as "> [BLACK WHITE]".
    { iApply (OwnM_Upd with "OWN").
      ur. apply pointwise_updatabable. i.
      unfold memory_resource_black, points_to_white. ss.
      inv WRITE. setoid_rewrite LocFun.add_spec. des_ifs.
      eapply Auth.auth_update. ii. des. split; ss.
      { ur. ss. }
      { ur in FRAME. ur. des_ifs. rr.
        f_equal. symmetry. apply LocFun.add_spec_eq.
      }
    }
    { iModIntro. iFrame. }
  Qed.

  Lemma memory_write_max_ts m0 loc from to msg m1
        (ADD: Memory.add m0 loc from to msg m1)
        (MAX: Time.le (Memory.max_ts loc m0) to)
    :
    Memory.max_ts loc m1 = to.
  Proof.
    apply TimeFacts.antisym.
    { hexploit Memory.max_ts_spec.
      { eapply Memory.add_get0; eauto. }
      i. des. erewrite Memory.add_o in GET; eauto. des_ifs.
      { ss. des; clarify. }
      { des; ss. eapply Memory.max_ts_spec in GET. des. etrans; eauto. }
    }
    { eapply Memory.add_get0 in ADD. des.
      eapply Memory.max_ts_spec in GET0. des. auto.
    }
  Qed.

  Lemma wmemory_ra_load
        m l v0 v1 vw0 vw1
        ord lc1 to released
        (READ: Local.read_step (WMem.view_to_local vw0) m.(WMem.memory) l to v1 released ord lc1)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (ORD: ord = Ordering.plain)
    :
    (wmemory_black m)
      -∗
      (wpoints_to l v0 vw0)
      -∗
      ((wmemory_black m) ∗ (⌜(View.le vw0 vw1) /\ (v0 = v1)⌝) ∗ #=>(wpoints_to l v0 vw1)).
  Proof.
    iIntros "BLACK [% [WHITE %]]". des. subst.
    iPoseProof (wmemory_ra_get with "BLACK WHITE") as "%". subst.
    iSplitL "BLACK"; [auto|]. inv READ. ss. iSplit.
    { iPureIntro. split.
      { etrans; [|eapply View.join_l]. eapply View.join_l. }
      { assert (to = (Cell.max_ts (WMem.memory m l))).
        { eapply TimeFacts.antisym.
          { eapply Memory.max_ts_spec in GET0. des. clarify. }
          { inv READABLE. etrans; eauto.
            inv VIEW0. ss. specialize (PLN0 l).
            unfold TimeMap.singleton in PLN0.
            setoid_rewrite LocFun.add_spec_eq in PLN0. auto.
          }
        }
        subst. setoid_rewrite GET in GET0. clarify.
        inv VAL; ss.
        destruct v1, val'; ss. apply Z.eqb_eq in H0. subst. auto.
      }
    }
    { iModIntro. iExists _. iFrame. iPureIntro. esplits; eauto.
      ss. unfold View.singleton_ur_if. des_ifs.
      etrans; eauto.
      etrans; [|eapply View.join_l]. eapply View.join_l.
    }
  Qed.

  Lemma wmemory_ra_store
        m0 l v0 vw0 m1 v1 vw1
        lc1 to sc1 mem1 ord from released kind
        (WRITE: Local.write_step (WMem.view_to_local vw0) m0.(WMem.sc) m0.(WMem.memory) l from to v1 None released ord lc1 sc1 mem1 kind)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (MEM: m1 = WMem.mk mem1 sc1)
        (ORD: ord = Ordering.plain)
        (DEFINED: v1 <> Const.undef)
    :
    (wmemory_black m0)
      -∗
      (wpoints_to l v0 vw0)
      -∗
      ((⌜View.le vw0 vw1⌝) ∗ #=>((wmemory_black m1) ∗ (wpoints_to l v1 vw1))).
  Proof.
    iIntros "BLACK [% [WHITE %]]". des. subst.
    iPoseProof (wmemory_ra_get with "BLACK WHITE") as "%". subst.
    inv WRITE. ss. hexploit memory_write_bot_add; eauto. i. subst.
    inv WRITE0. inv PROMISE. clear REMOVE PROMISES ATTACH TS.
    assert (MAX: Cell.max_ts (mem1 l) = to).
    { hexploit Memory.max_ts_spec.
      { eapply Memory.add_get1; eauto. }
      i. des. erewrite Memory.add_o in GET0; eauto. des_ifs; ss.
      { des; clarify. }
      { des; ss. eapply Memory.max_ts_spec in GET0. des.
        hexploit Memory.max_ts_spec.
        { eapply Memory.add_get0; eauto. }
        i. des. inv WRITABLE.
        exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
        { eapply TS. }
        etrans; eauto.
        etrans; eauto.
        inv VIEW0. ss. specialize (RLX l).
        unfold TimeMap.singleton in RLX. setoid_rewrite LocFun.add_spec_eq in RLX. auto.
      }
    }
    subst. iSplit.
    { iPureIntro. eapply View.join_l. }
    iPoseProof (wmemory_ra_write with "BLACK WHITE") as "> [BLACK WHITE]".
    { eauto. }
    iModIntro. iSplitL "BLACK"; [auto|].
    iExists _. iSplit; [iFrame|]. iPureIntro. esplits; eauto.
    { eapply Memory.add_get0; eauto. }
    { ss. eapply View.join_r. }
  Qed.

  (* faa points-to *)
  Definition wpoints_to_faa (l: Loc.t) (v: Const.t): iProp :=
    ∃ c,
      (points_to l c)
        **
        (⌜exists from released,
              (<<GET: Cell.get (Cell.max_ts c) c = Some (from, Message.concrete v released)>>) /\
                (<<FAA: forall to from msg (GET: Cell.get to c = Some (from, msg)),
                    ((exists to' msg',
                         (<<GET: Cell.get to' c = Some (to, msg')>>) /\ (<<TS: Time.lt to to'>>)) \/
                       (<<TS: to = Cell.max_ts c>>))>>) /\
                (<<DEFINED: v <> Const.undef>>)⌝)
  .

  Lemma init_points_to_wpoints_to_faa l
    :
    (points_to l WMem.init_cell)
      -∗
      wpoints_to_faa l (Const.of_Z (BinIntDef.Z.of_nat 0)).
  Proof.
    iIntros "H". iExists _. iFrame. iPureIntro. esplits.
    { rewrite init_cell_get. eauto. }
    { i. hexploit init_cell_get_if; eauto. i. des; clarify.
      right. rewrite init_cell_max_ts. auto.
    }
    { ss. }
  Qed.

  Lemma wmemory_ra_faa
        v msc
        vw0 loc addendum ordr ordw
        lc1 from releasedr releasedw kind
        lc2 to val sc1 mem1
        (READ: Local.read_step (WMem.view_to_local vw0) (msc.(WMem.memory)) loc from val releasedr ordr lc1)
        (WRITE: Local.write_step lc1 (msc.(WMem.sc)) (msc.(WMem.memory)) loc from to (Const.add val addendum) releasedr releasedw ordw lc2 sc1 mem1 kind)
        (ORDR: ordr = Ordering.plain)
        (ORDW: ordw = Ordering.acqrel)
        (DEFINED: addendum <> Const.undef)
    :
    (wmemory_black msc)
      -∗
      (wpoints_to_faa loc v)
      -∗
      ((⌜(View.le vw0 lc2.(Local.tview).(TView.cur)) /\ (v = val)⌝)
         ∗ #=>((wmemory_black (WMem.mk mem1 sc1)) ∗ wpoints_to_faa loc (Const.add v addendum))).
  Proof.
    iIntros "BLACK [% [WHITE %]]". des. subst.
    iPoseProof (wmemory_ra_get with "BLACK WHITE") as "%". subst.
    inv READ. inv WRITE. ss.
    inv WRITE0. ss. hexploit memory_write_bot_add; eauto. i. subst.
    inv PROMISE. clear REMOVE PROMISES ATTACH TS.
    hexploit add_succeed_wf; eauto. i. des.
    assert (MAX0: from = Cell.max_ts (WMem.memory msc loc)).
    { hexploit FAA; eauto. i. des; auto.
      hexploit DISJOINT; eauto. i. exfalso. eapply H.
      { instantiate (1:=Time.meet to to'). econs; ss.
        { unfold Time.meet. des_ifs. }
        { eapply Time.meet_l. }
      }
      { econs; ss.
        { unfold Time.meet. des_ifs. }
        { eapply Time.meet_r. }
      }
    }
    subst. setoid_rewrite GET0 in GET. inv GET.
    assert (val = v).
    { inv VAL; ss. destruct val, v; ss. apply Z.eqb_eq in H0. subst. auto. }
    subst. iSplit.
    { iPureIntro. split.
      { etrans; [|eapply View.join_l].
        etrans; [|eapply View.join_l].
        eapply View.join_l.
      }
      { auto. }
    }
    assert (MAX1: to = Cell.max_ts (mem1 loc)).
    { eapply TimeFacts.antisym.
      { hexploit Memory.max_ts_spec.
        { eapply Memory.add_get0; eauto. }
        { i. des. eauto. }
      }
      { hexploit Memory.max_ts_spec.
        { eapply Memory.add_get1; eauto. }
        i. des. erewrite Memory.add_o in GET; eauto. des_ifs.
        { ss. des; subst. reflexivity. }
        { guardH o. eapply Memory.max_ts_spec in GET. des.
          etrans ;eauto. left. auto.
        }
      }
    }
    iPoseProof (wmemory_ra_write with "BLACK WHITE") as "> [BLACK WHITE]".
    { eauto. }
    iModIntro. iSplitL "BLACK"; [auto|].
    iExists _. iSplit; [iFrame|]. iPureIntro. esplits; eauto.
    { erewrite <- MAX1. eapply Memory.add_get0; eauto. }
    { i. setoid_rewrite Memory.add_o in GET; [|eauto]. des_ifs.
      { ss. des; clarify. auto. }
      { guardH o. hexploit FAA; eauto. i. des.
        { left. esplits; eauto. eapply Memory.add_get1; eauto. }
        { subst. left. esplits; eauto.
          { eapply Memory.add_get0; eauto. }
        }
      }
    }
    { ii. destruct v, addendum; ss. }
  Qed.

  (* full points-to *)
  Definition wProp := Const.t -> View.t -> Prop.
  Definition wor (P Q: wProp): wProp := fun c vw => ((P c vw) \/ (Q c vw)).
  Definition wimpl (P Q: wProp): Prop := (∀ c vw, (P c vw) -> (Q c vw)).

  Definition lift_wProp (P: wProp) (c: Const.t) (vw: View.t): iProp :=
    ∃ vw', (⌜P c vw'⌝) ∗ (⌜View.le vw' vw⌝).

  Lemma lift_wProp_mon
        P c vw0 vw1
        (LE: View.le vw0 vw1)
    :
    (lift_wProp P c vw0) -∗ (lift_wProp P c vw1).
  Proof.
    unfold lift_wProp. iIntros "[% [A %B]]". iExists vw'. iFrame.
    iPureIntro. etrans. eapply B. auto.
  Qed.

  Context `{OBLGRA: @GRA.inG ObligationRA.t Σ}.
  Context `{ARROWRA: @GRA.inG (ArrowRA (void + WMem.ident)%type) Σ}.
  Context `{IDENTTGT: @GRA.inG (identTgtRA (void + WMem.ident)%type) Σ}.
  Context `{EDGERA: @GRA.inG EdgeRA Σ}.
  Context `{ONESHOTSRA: @GRA.inG (@FiniteMap.t (OneShot.t unit)) Σ}.

  Definition wmemory_black_strong m: iProp :=
    wmemory_black m ** (FairRA.blacks (fun id => exists loc to, id = (inr (inr (loc, to))) /\ Memory.get loc to m.(WMem.memory) = None)).

  Lemma wmemory_ra_write_strong
        m0 m1 l c
        from to msg
        (WRITE: Memory.add m0.(WMem.memory) l from to msg m1)
    :
    (wmemory_black_strong m0)
      -∗
      (points_to l c)
      -∗
      (#=> (wmemory_black_strong (WMem.mk m1 m0.(WMem.sc)) ** points_to l (m1 l) ** FairRA.black_ex (inr (inr (l, to))) 1%Qp)).
  Proof.
    iIntros "[BLACK BLACKS] WHITE".
    iPoseProof (wmemory_ra_write with "BLACK WHITE") as "> [BLACK WHITE]"; [eauto|..].
    iModIntro. iFrame. iApply (FairRA.blacks_unfold with "BLACKS").
    { i. ss. des; subst.
      { erewrite Memory.add_o in IN0; eauto. des_ifs. esplits; eauto. }
      { esplits; eauto. eapply Memory.add_get0. eauto. }
    }
    { ii. des. clarify. ss. eapply Memory.add_get0 in WRITE. des; clarify. }
  Qed.

  Lemma wmemory_ra_faa_strong
        v msc
        vw0 loc addendum ordr ordw
        lc1 from releasedr releasedw kind
        lc2 to val sc1 mem1
        (READ: Local.read_step (WMem.view_to_local vw0) (msc.(WMem.memory)) loc from val releasedr ordr lc1)
        (WRITE: Local.write_step lc1 (msc.(WMem.sc)) (msc.(WMem.memory)) loc from to (Const.add val addendum) releasedr releasedw ordw lc2 sc1 mem1 kind)
        (ORDR: ordr = Ordering.plain)
        (ORDW: ordw = Ordering.acqrel)
        (DEFINED: addendum <> Const.undef)
    :
    (wmemory_black_strong msc)
      -∗
      (wpoints_to_faa loc v)
      -∗
      ((⌜(View.le vw0 lc2.(Local.tview).(TView.cur)) /\ (v = val)⌝)
         ∗ #=>((wmemory_black_strong (WMem.mk mem1 sc1)) ∗ wpoints_to_faa loc (Const.add v addendum))).
  Proof.
    iIntros "[BLACK BLACKS] WHITE".
    iPoseProof (wmemory_ra_faa with "BLACK WHITE") as "[% H]"; eauto.
    iSplitR; [auto|]. iPoseProof ("H") as "> [H0 H1]".
    iModIntro. unfold wmemory_black_strong. iFrame.
    inv READ. inv WRITE. hexploit memory_write_bot_add; eauto. i. subst. ss.
    inv WRITE0. inv PROMISE. ss.
    iPoseProof (FairRA.blacks_unfold with "BLACKS") as "[H0 H1]"; [..|iApply "H0"].
    { i. ss. des; subst.
      { erewrite Memory.add_o in IN0; eauto. des_ifs. esplits; eauto. }
      { esplits; eauto. eapply Memory.add_get0. eauto. }
    }
    { ii. des. clarify. eapply Memory.add_get0 in MEM. des; clarify. }
  Qed.

  Definition wpoints_to_full (l: Loc.t) (V: View.t) (k: nat) (P Q: wProp) : iProp :=
    ∃ c,
      (points_to l c)
        **
        (∃ v released,
            (⌜Cell.max_ts c = Time.bot⌝ ∨ ObligationRA.duty (inr (inr (l, (Cell.max_ts c)))) [(k,Ord.S Ord.O)])
              **
              (ObligationRA.pending k 1%Qp)
              **
              (⌜Q v View.bot⌝)
              **
              (⌜(<<MSGVIEW: V = View.join (View.unwrap released) (View.singleton_ur l (Cell.max_ts c))>>) /\
                 (<<DEFINED: v <> Const.undef>>) /\
                 exists from,
                   (<<GET: Cell.get (Cell.max_ts c) c = Some (from, Message.concrete v released)>>) /\
                     (<<DEFINED: v <> Const.undef>>) /\
                     (<<RELEASED: Time.lt Time.bot (Cell.max_ts c) -> released <> None>>)⌝)
              **
              (⌜forall to from' v' released' (GET: Cell.get to c = Some (from', Message.concrete v' released'))
                       (LT: Time.lt to (Cell.max_ts c)),
                    (P v' View.bot) /\ (<<DEFINED: v' <> Const.undef>>)⌝))
  .

  Lemma init_points_to_wpoints_to_full l (P Q: wProp)
        (SAT: Q (Const.of_Z (BinIntDef.Z.of_nat 0)) View.bot)
    :
    (points_to l WMem.init_cell)
      -∗
      #=>
      (∃ k, wpoints_to_full l View.bot k P Q ** ObligationRA.black k Ord.O).
  Proof.
    iIntros "H".
    iPoseProof (ObligationRA.alloc) as "> [% [[B W] PENDING]]".
    iModIntro. iExists _. iSplitR "B"; [|iApply "B"]. iExists _.
    iSplitL "H"; [iApply "H"|]. iExists _, _. iSplitL.
    { iSplitL.
      { iSplit; [|eauto]. iSplitR.
        { iLeft. iPureIntro. apply init_cell_max_ts. }
        { iApply "PENDING". }
      }
      { iPureIntro. esplits; eauto.
        { eapply View.antisym.
          { eapply View.bot_spec. }
          { ss. eapply View.join_spec.
            { reflexivity. }
            { rewrite init_cell_max_ts.
              econs; ss; eapply TimeMap.singleton_spec; eapply Time.bot_spec.
            }
          }
        }
        { i. rewrite init_cell_max_ts in H. inv H. }
      }
    }
    { iPureIntro. i. apply init_cell_get_if in GET. des. clarify.
      rewrite init_cell_max_ts in LT. inv LT.
    }
  Qed.

  Lemma wpoints_to_full_not_shot
        l V k P Q
    :
    (wpoints_to_full l V k P Q) ∗ (ObligationRA.shot k) -∗ ⌜False⌝.
  Proof.
    iIntros "[[% [? [% [% [[[[? PENDING] ?] ?] H]]]]] SHOT]".
    iApply (ObligationRA.pending_not_shot with "PENDING SHOT").
  Qed.

  Lemma wpoints_to_full_impl
        l V k P P' Q
    :
    ((⌜wimpl P P'⌝) ∗ (wpoints_to_full l V k P Q))
      -∗ (wpoints_to_full l V k P' Q).
  Proof.
    iIntros "[% [% [A [% [% [B %]]]]]]".
    iExists _. iSplitL "A"; [iFrame|]. iExists _, _. iFrame.
    iIntros (? ? ? ? ? ?). iPureIntro.
    hexploit H0; eauto. i. des. split; auto.
  Qed.

  Lemma wmemory_ra_get_strong
        m l c
    :
    (wmemory_black_strong m)
      -∗
      (points_to l c)
      -∗
      ⌜m.(WMem.memory) l = c⌝.
  Proof.
    iIntros "[BLACK _] WHITE". iApply (wmemory_ra_get with "BLACK WHITE").
  Qed.

  Lemma wmemory_ra_load_acq
        l V k (P Q: wProp)
        m val vw0 vw1
        ord lc1 to released
        (READ: Local.read_step (WMem.view_to_local vw0) m.(WMem.memory) l to val released ord lc1)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (ORD: ord = Ordering.acqrel)
    :
    (wmemory_black_strong m)
      -∗
      (wpoints_to_full l V k P Q)
      -∗
      ((⌜View.le vw0 vw1⌝)
         ∗ (wmemory_black_strong m)
         ∗ (wpoints_to_full l V k P Q)
         ∗ (((lift_wProp P val vw1)
               ∗ (∃ ts, (ObligationRA.correl (inr (inr (l, ts))) k (Ord.S Ord.O))
                          ∗ (⌜WMem.missed m.(WMem.memory) l to (l, ts) = Flag.fail⌝)))
            ∨ ((lift_wProp Q val vw1) ∗ (⌜View.le V vw1⌝)))
      ).
  Proof.
    iIntros "BLACK [% [WHITE [% [% [[[[X Y] %] %] %]]]]]". des. subst.
    iPoseProof (wmemory_ra_get_strong with "BLACK WHITE") as "%". subst.
    inv READ. ss. iSplit.
    { iPureIntro. aggrtac. }
    iAssert (⌜Cell.max_ts (WMem.memory m l) = Time.bot⌝
             ∨ (ObligationRA.correl _ _ _))%I with "[X]" as "#CORREL".
    { iPoseProof "X" as "[X|X]"; [auto|].
      iRight. iApply (ObligationRA.duty_correl with "X"). ss. eauto.
    }
    iSplitL "BLACK"; [auto|]. iSplitL.
    { iExists _. iFrame. iExists _, _. iSplit.
      { iSplit.
        { auto. }
        { iPureIntro. esplits; eauto. }
      }
      { iPureIntro. auto. }
    }
    destruct (Time.eq_dec to (Cell.max_ts (WMem.memory m l))).
    { iRight. subst. setoid_rewrite GET0 in GET. inv GET.
      assert (val = v).
      { inv VAL; ss.
        destruct v, val; ss. apply Z.eqb_eq in H2. subst. auto.
      }
      subst. iSplit.
      { unfold lift_wProp. iExists _. iSplit.
        { iPureIntro. eauto. }
        { iPureIntro. apply View.bot_spec. }
      }
      { iPureIntro. unfold View.singleton_ur_if. des_ifs.
        eapply View.join_spec.
        { aggrtac. }
        { etrans; [|eapply View.join_l]. eapply View.join_r. }
      }
    }
    { iLeft. hexploit Memory.max_ts_spec.
      { eapply GET0. }
      i. des. dup MAX. inv MAX; ss.
      hexploit H1; eauto. i. des.
      assert (val' = val).
      { inv VAL; ss. destruct val, val'; ss. apply Z.eqb_eq in H4. subst. auto. }
      subst. iSplitR.
      { unfold lift_wProp. iExists _. iSplit.
        { iPureIntro. eapply H1; eauto. }
        { iPureIntro. apply View.bot_spec. }
      }
      iExists _. iSplitR.
      { iPoseProof "CORREL" as "[%BOT|CORR]"; [|auto].
        setoid_rewrite BOT in H0. inv H0.
      }
      iPureIntro.
      destruct (LocSet.Facts.eq_dec l l); ss.
      destruct (Time.le_lt_dec (Cell.max_ts (WMem.memory m l)) to).
      { exfalso. eapply Time.lt_strorder.
        eapply TimeFacts.lt_le_lt; [|apply l0]; eauto.
      }
      setoid_rewrite GET. hexploit RELEASED; auto.
      { eapply TimeFacts.le_lt_lt; eauto. eapply Time.bot_spec. }
      { i. des_ifs. }
    }
  Qed.

  Lemma wmemory_ra_load_rlx
        l V k (P Q: wProp)
        m val vw0 vw1
        ord lc1 to released
        (READ: Local.read_step (WMem.view_to_local vw0) m.(WMem.memory) l to val released ord lc1)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (ORD: ord = Ordering.relaxed)
    :
    (wmemory_black_strong m)
      -∗
      (wpoints_to_full l V k P Q)
      -∗
      (⌜View.le V vw0⌝)
      -∗
      ((⌜View.le vw0 vw1⌝)
         ∗ (wmemory_black_strong m)
         ∗ (wpoints_to_full l V k P Q)
         ∗ (lift_wProp Q val vw1)
      ).
  Proof.
    iIntros "BLACK [% [WHITE [% [% [[[X %] %] Z]]]]] %". des. subst.
    iPoseProof (wmemory_ra_get_strong with "BLACK WHITE") as "%". subst.
    inv READ. ss.
    assert (TO: to = Cell.max_ts (WMem.memory m l)).
    { eapply TimeFacts.antisym.
      { eapply Memory.max_ts_spec in GET0. des. clarify. }
      { inv READABLE. etrans; eauto.
        inv H1. ss. specialize (PLN0 l).
        unfold TimeMap.singleton in PLN0. etrans; [|eauto].
        unfold TimeMap.join. setoid_rewrite LocFun.add_spec_eq.
        apply Time.join_r.
      }
    }
    subst. setoid_rewrite GET0 in GET. inv GET.
    assert (val = v).
    { inv VAL; ss.
      destruct v, val; ss. apply Z.eqb_eq in H2. subst. auto.
    }
    subst. iSplit.
    { iPureIntro. aggrtac. }
    iSplitL "BLACK"; [auto|]. iSplitL.
    { iExists _. iFrame. iExists _, _. iSplit; eauto. iPureIntro. esplits; eauto. }
    { unfold lift_wProp. iExists _. iPureIntro. splits; eauto. eapply View.bot_spec. }
  Qed.

  Lemma wmemory_ra_store_rel
        l V k (P Q R: wProp)
        m0 vw0 m1 val vw1
        lc1 to sc1 mem1 ord from released kind
        (WRITE: Local.write_step (WMem.view_to_local vw0) m0.(WMem.sc) m0.(WMem.memory) l from to val None released ord lc1 sc1 mem1 kind)
        (VIEW: vw1 = lc1.(Local.tview).(TView.cur))
        (MEM: m1 = WMem.mk mem1 sc1)
        (ORD: ord = Ordering.acqrel)
        (DEFINED: val <> Const.undef)
    :
    (wmemory_black_strong m0)
      -∗
      (wpoints_to_full l V k P Q)
      -∗
      (⌜View.le V vw0⌝)
      -∗
      (⌜R val View.bot⌝)
      -∗
      ((⌜View.le vw0 vw1⌝)
         ∗ #=( ObligationRA.arrows_sat (Id:=sum_tid (void + WMem.ident)%type) )=> ((wmemory_black_strong m1))
         ∗ (∃ V' k' o,
               (⌜View.le V' vw1⌝)
                 ∗
                 (⌜View.le vw0 V'⌝)
                 ∗
                 #=>((wpoints_to_full l V' k' (wor P Q) R)
                       ∗ (ObligationRA.black k' o)
                    )
           )
      ).
  Proof.
    iIntros "BLACK [% [WHITE [% [% [[[[_ Y] %] %] %]]]]] % %". des. subst.
    iPoseProof (wmemory_ra_get_strong with "BLACK WHITE") as "%". subst.
    inv WRITE. ss. iSplit.
    { iPureIntro. aggrtac. }
    hexploit memory_write_bot_add; eauto. i. subst.
    inv WRITE0. inv PROMISE. clear REMOVE PROMISES ATTACH TS.
    iPoseProof (wmemory_ra_write_strong with "BLACK WHITE") as "> [[BLACK WHITE] FAIRBLACK]".
    { eauto. }
    assert (TS: Time.lt (Cell.max_ts (WMem.memory m0 l)) to).
    { inv WRITABLE. eapply TimeFacts.le_lt_lt; [|eauto].
      inv H2. ss. etrans; [|eapply RLX].
      unfold TimeMap.join, TimeMap.singleton. setoid_rewrite LocFun.add_spec_eq.
      eapply Time.join_r.
    }
    hexploit memory_write_max_ts.
    { eauto. }
    { left. auto. }
    i. subst.
    iPoseProof (ObligationRA.alloc) as "> [% [[B W] PENDING]]".
    iPoseProof (ObligationRA.duty_alloc with "[FAIRBLACK] W") as "> DUTY".
    { unfold ObligationRA.duty. iExists [], _.  iSplit.
      { iFrame. iApply ObligationRA.duty_list_nil. }
      { ss. }
    }
    iModIntro. iSplitL "BLACK"; [auto|].
    iExists _, _, _. iSplit; cycle 1.
    { iSplitR; cycle 1.
      { iModIntro. iSplitR "B"; [|eauto].
        iExists _. iSplitL "WHITE"; [auto|].
        iExists _, _. iSplitL.
        { iSplitL.
          { iSplitL; [|eauto]. iSplitL "DUTY". eauto. iFrame. }
          { iPureIntro. splits; eauto. esplits.
            { eapply Memory.add_get0. eauto. }
            { auto. }
            { i. ss. }
          }
        }
        { iPureIntro. i. setoid_rewrite Memory.add_o in GET0; eauto. des_ifs.
          { ss. des; clarify. exfalso. eapply Time.lt_strorder. eapply LT. }
          { des; ss. hexploit Memory.max_ts_spec; eauto. i. des. inv MAX.
            { hexploit H1; eauto. i. des; ss. splits; auto. rr. auto. }
            { inv H0. clarify. setoid_rewrite GET1 in GET. clarify.
              splits; auto. rr. auto.
            }
          }
        }
      }
      { iPureIntro. unfold TView.write_released. des_ifs. ss. des_ifs.
        setoid_rewrite LocFun.add_spec_eq. aggrtac.
      }
    }
    { iPureIntro. unfold TView.write_released. des_ifs. ss. des_ifs.
      setoid_rewrite LocFun.add_spec_eq. eapply View.join_spec.
      { eapply View.join_spec.
        { eapply View.bot_spec. }
        { reflexivity. }
      }
      { eapply View.join_r. }
    }
  Qed.

End MEMRA.

Global Opaque wmemory_black wpoints_to wpoints_to_faa wpoints_to_full.


Require Import Defs Term_Defs Term StructTactics Event_system Term_system.

Require Import Lia Coq.Program.Tactics Coq.Program.Equality Coq.Arith.EqNat.

Require Import List.
Import List.ListNotations.

Set Nested Proofs Allowed.

(*
(ev_sys_remote t p q) represents (abstractly) the events that occur
at place q, originated by a request from place p for q to execute t *)
Definition ev_sys_remote (t:Term) (p:Plc) (q:Plc): EvSys Ev.
Admitted.

Fixpoint ev_sys (t: AnnoTerm) p: EvSys Ev :=
  match t with
  | aasp (i, j) lr x => leaf (i, j) (asp_event i x p)
  | aatt (i, j) lr (req_loc,rpy_loc) q x =>
    before (i, j)
      (leaf (i, S i) (req i req_loc p q (unanno x)))
      (before (S i, j)
              (* (ev_sys x q) *)
              (ev_sys_remote (unanno x) p q)
              (leaf (pred j, j) (rpy (pred j) rpy_loc p q)))
  | alseq r lr x y => before r (ev_sys x p)
                          (ev_sys y p)
 (* | abseq (i, j) lr s x y =>
    before (i, j)
           (leaf (i, S i)
                 (Term_Defs.split i p))
           (before (S i, j)
                   (before (S i, (pred j))
                           (ev_sys x p)
                           (ev_sys y p))
                   (leaf ((pred j), j)
                   (join (pred j) p)))
  | abpar (i, j) lr (xi,xi') (yi,yi') s x y =>
    before (i, j)
           (leaf (i, S i)
                 (splitp i xi yi p))
           (before (S i, j)
                   (merge (S i, (pred j))
                          (ev_sys x p)
                          (ev_sys y p))
                   (leaf ((pred j), j)
                   (joinp (pred j) xi' yi' p)))
*)
  end.

(*
Definition remote_event: Term -> Plc -> Ev.
Admitted.
*)

Inductive events: AnnoTerm -> Plc -> Ev -> Prop :=
| evtscpy:
    forall r lr i p,
      fst r = i ->
      events (aasp r lr CPY) p (copy i p)
| evtsusm:
    forall i id args r lr p,
      fst r = i ->
      events (aasp r lr (ASPC id args)) p (umeas i p id args)
| evtssig:
    forall r lr i p,
      fst r = i ->
      events (aasp r lr SIG) p (sign i p)
| evtshsh:
    forall r lr i p,
      fst r = i ->
      events (aasp r lr HSH) p (hash i p)
| evtsattreq:
    forall r lr q t i p req_loc rpy_loc,
      fst r = i ->
      events (aatt r lr (req_loc, rpy_loc) q t) p (req i req_loc p q (unanno t))
             (*
| evtsatt:
    forall r lr q t (*ev*) p locs,
      events (aatt r lr locs q t) p (remote_event (unanno t) p)
      (*events t q ev ->
      events (aatt r lr locs q t) p ev
       *)
*)

| evtsattrpy:
    forall r lr q t i p req_loc rpy_loc,
      snd r = S i ->
      events (aatt r lr (req_loc, rpy_loc) q t) p (rpy i rpy_loc p q)
| evtslseql:
    forall r lr t1 t2 ev p,
      events t1 p ev ->
      events (alseq r lr t1 t2) p ev
| evtslseqr:
    forall r lr t1 t2 ev p,
      events t2 p ev ->
      events (alseq r lr t1 t2) p ev
(* | evtsbseqsplit:
    forall r lr i s t1 t2 p,
      fst r = i ->
      events (abseq r lr s t1 t2) p
             (Term_Defs.split i p)
| evtsbseql:
    forall r lr s t1 t2 ev p,
      events t1 p ev ->
      events (abseq r lr s t1 t2) p ev
| evtsbseqr:
    forall r lr s t1 t2 ev p,
      events t2 p ev ->
      events (abseq r lr s t1 t2) p ev
| evtsbseqjoin:
    forall r lr i s t1 t2 p,
      snd r = S i ->
      events (abseq r lr s t1 t2) p
             (join i p)

| evtsbparsplit:
    forall r lr i s t1 t2 p xi xi' yi yi',
      fst r = i ->
      events (abpar r lr (xi,xi') (yi,yi') s t1 t2) p
             (splitp i xi yi p)
| evtsbparl:
    forall r lr s t1 t2 ev p xlocs ylocs,
      events t1 p ev ->
      events (abpar r lr xlocs ylocs s t1 t2) p ev
| evtsbparr:
    forall r lr s t1 t2 ev p xlocs ylocs,
      events t2 p ev ->
      events (abpar r lr xlocs ylocs s t1 t2) p ev
| evtsbparjoin:
    forall r lr i s t1 t2 p xi xi' yi yi',
      snd r = S i ->
      events (abpar r lr (xi,xi') (yi,yi') s t1 t2) p
             (joinp i (xi') (yi') p) *) .
Hint Constructors events : core.

Inductive store_event: Ev -> Plc -> Loc -> Prop :=
| put_event: forall i x p q t, store_event (req i x p q t) p x
(*| put_event_spl: forall i xi yi p, store_event (splitp i xi yi p) p xi
| put_event_spr: forall i xi yi p, store_event (splitp i xi yi p) p yi *)
| get_event: forall i x p q, store_event (rpy i x p q) p x
(*| get_event_joinpl: forall i xi yi p, store_event (joinp i xi yi p) p xi
| get_event_joinpr: forall i xi yi p, store_event (joinp i xi yi p) p yi *) .

(*
Lemma wf_mono_locs: forall t,
    well_formed t ->
    fst (lrange t) <= snd (lrange t).
Proof.
  intros.
  rewrite Term.well_formed_lrange; eauto.
  lia.
Defined.
*)

Ltac inv_wf :=
  match goal with
  | [H: well_formed (aasp _ _ _) |- _] =>
    invc H
  | [H: well_formed (alseq _ _ _ _) |- _] =>
    invc H
  | [H: well_formed (aatt _ _ _ _ ?t) |- _] =>
    invc H
  (*| [H: well_formed (abseq _ _ _ _ _) |- _] =>
    invc H
  | [H: well_formed (abpar _ _ _ _ _ _ _) |- _] =>
    invc H *)
  end.

Ltac inv_ev :=
  match goal with
  | [H: events (aasp _ _ _) _ _ |- _] =>
    invc H
  | [H: events (alseq _ _ _ _) _ _ |- _] =>
    invc H
  | [H: events (aatt _ _ _ _ _) _ _ |- _] =>
    invc H
  (*| [H: events (abseq _ _ _ _ _) _ _ |- _] =>
    invc H
  | [H: events (abpar _ _ _ _ _ _ _) _ _ |- _] =>
    invc H *)
  end.

Ltac inv_ev' :=
  match goal with
  | [H: events (aasp _ _ _) _ _ |- _] =>
    inv H
  | [H: events (alseq _ _ _ _) _ _ |- _] =>
    inv H
  | [H: events (aatt _ _ _ _ _) _ _ |- _] =>
    inv H
  (* | [H: events (abseq _ _ _ _ _) _ _ |- _] =>
    inv H
  | [H: events (abpar _ _ _ _ _ _ _) _ _ |- _] =>
    inv H *)
  end.

Ltac inv_ev2 :=
  match goal with
  | [H: events _ _ _,
     H': events _ _ _ |- _] =>
    invc H; invc H'
  end.

Ltac inv_ev2' :=
  match goal with
  | [H: events _ _ _,
     H': events _ _ _ |- _] =>
    inv H; inv H'
  end.

Ltac inv_se :=
  match goal with
  | [H: store_event (?C _) (*(req _ _ _ _ _)*) _ _ |- _] =>
    invc H
         (*
  | [H: events (alseq _ _ _ _) _ _ |- _] =>
    invc H
  | [H: events (aatt _ _ _ _ _) _ _ |- _] =>
    invc H
  | [H: events (abseq _ _ _ _ _) _ _ |- _] =>
    invc H
  | [H: events (abpar _ _ _ _ _ _ _) _ _ |- _] =>
    invc H *)
  end.

Ltac inv_store_ev2 :=
  match goal with
  | [H: store_event _ _ _,
     H': store_event _ _ _ |- _] =>
    invc H; invc H'
  end.

Lemma nodup_contra': forall ls ls' (loc:nat),
    NoDup (ls ++ ls') ->
    In loc ls ->
    In loc ls' ->
    False.
Proof.
  intros.
  generalizeEverythingElse ls.

  (*
  generalize dependent H0.
  generalize dependent H1.
  generalize dependent loc.
  dependent induction H; intros.
   *)
  induction ls; destruct ls'; intros.
  -
    solve_by_inversion.
  -
    solve_by_inversion.
  -
    solve_by_inversion.
  -
    invc H0;
      invc H1;
      try solve_by_inversion.
    +
      invc H.
      unfold not in *.
      eapply H2.
      assert (ls ++ loc :: ls' = ls ++ (loc :: ls')).
      tauto.

      eapply in_or_app.
      right.
      simpl.
      tauto.
    +
      invc H.
      unfold not in *.
      eapply H3.
      eapply in_or_app.
      right.
      right.
      eassumption.
    +
      eapply IHls with (ls' := (loc :: ls')).

      invc H.
      eassumption.
      eassumption.
      econstructor.
      tauto.
    +
      invc H.
      unfold not in *.

      assert (NoDup (ls ++ ls')).
      {
        eapply NoDup_remove_1; eauto.
      }

      eauto.
Defined.

Lemma in_app: forall ls ls' (loc:nat),
    In loc ls ->
    In loc (ls ++ ls').
Proof.
  intros.
  eapply in_or_app; eauto.
Defined.

Lemma in_app2: forall ls ls' (loc:nat),
    In loc ls' ->
    In loc (ls ++ ls').
Proof.
  intros.
  eapply in_or_app; eauto.
Defined.

Ltac in_app_facts :=
  match goal with
  | [H: In ?loc (lrange ?t1),
        H': well_formed ?t1,
            H'': well_formed ?t2 |- _] =>
    try
      (assert_new_proof_by
         (In loc ((lrange t1) ++ (lrange t2)))
         ltac:(eapply in_app; eauto));
    try (assert_new_proof_by
           (In loc ((lrange t2) ++ (lrange t1)))
           ltac:(eapply in_app2; eauto))
  end.

Ltac nodup_contra_auto :=
  match goal with
  | [H: In ?loc ?ls,
        H': In ?loc ?ls',
            H'': NoDup (?ls ++ ?ls') |- _] =>
    exfalso; eapply nodup_contra'; eauto
  end.

Lemma event_in_lrange: forall t p ev loc,
    well_formed t ->
    events t p ev ->
    store_event ev p loc ->
    In loc (lrange t).
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a;
      inv_ev;
      ff.
  -

    inv_wf.

    (*
    clear H12.
    clear H11.
     *)

    inv_ev'; ff.

    (*
    ff;
      inv_ev.
    +
      ff.
      (*
      assert (In req_loc l). admit.
      ff.
       *)

      (*
      inv H1.
      admit. *)
    +
      ff.
      (*
      assert (In rpy_loc l). admit.
      ff.
       *)

      (*
      ff.
      inv H1. *)
     *)

  -
    ff.
    inv_wf.
    (*
    clear H11.
    clear H12. *)
    inv_ev.
    +

      assert (In loc (lrange t1)) by eauto.

      (*

      assert (list_subset (lrange t1) l). admit.
       *)

      unfold list_subset in *.
      eauto.

      (*

      assert (l = (lrange t1) ++ (lrange t2)).
      admit.

      subst;
      in_app_facts; eauto. *)
    +
      assert (In loc (lrange t2)) by eauto.

      (*

      assert (list_subset (lrange t2) l). admit. *)
      unfold list_subset in *.
      eauto.

      (*

      assert (l = (lrange t1) ++ (lrange t2)).
      admit.

      subst;
        in_app_facts; eauto.
       *)

      (*

  -
    ff.
    inv_wf.
    (*
    clear H12. *)
    inv_ev;
      try solve_by_inversion.
    +
      assert (In loc (lrange t1)) by eauto.

      (*

      assert (list_subset (lrange t1) l). admit. *)
      unfold list_subset in *.
      eauto.

      (*

      assert (l = (lrange t1) ++ (lrange t2)).
      admit.

      subst;
      in_app_facts; eauto. *)
    +
      assert (In loc (lrange t2)) by eauto.

      (*

      assert (list_subset (lrange t2) l). admit.
       *)

      unfold list_subset in *.
      eauto.

      (*
      assert (l = (lrange t1) ++ (lrange t2)).
      admit.

      subst;
        in_app_facts; eauto.
       *)

  -
    ff.
    inv_wf.

    (*
    clear H19.
    clear H15.
    clear H16.
    clear H17.
    clear H18.
     *)

    inv_ev';
      try solve_by_inversion;
      try (eauto; tauto);
      try (ff; congruence).
    +
      ff.
      unfold list_subset in *.
      ff.
      repeat inv_se;
        ff'.

      (*

      assert (list_subset [xi; xi'; yi; yi'] l). admit.
      unfold list_subset in *.

      ff.
       *)

      (*
    +

      assert (list_subset (lrange t1) l). admit.

      unfold list_subset in *.
      eauto.

    +
      assert (list_subset (lrange t2) l). admit.
      unfold list_subset in *.
      eauto.
*)
    +

      (*
      assert (list_subset [xi; xi'; yi; yi'] l). admit.
       *)

      unfold list_subset in *.
      ff.

      repeat inv_se;
        ff'.

      ++
        repeat (find_apply_hyp_hyp').
        tauto.
*)
Defined.

Ltac t_in_lrange :=
  match goal with
  | [H: events ?t ?p ?ev,
        H': store_event ?ev ?p ?loc |- _] =>
    assert_new_proof_by (In loc (lrange t)) ltac:(eapply event_in_lrange; eauto)
  end.

Lemma unique_store_event_locs: forall t p ev ev' loc,
    well_formed t ->
    events t p ev ->
    events t p ev' ->
    store_event ev p loc ->
    store_event ev' p loc ->
    ev = ev'.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    inv_wf;
      inv_ev2;
      eauto.
  -
    inv_wf;
      inv_ev2;
       try (assert (req_loc = rpy_loc) by
               (repeat inv_se; congruence));
          repeat inv_se;
          ff; congruence.

  -
    inv_wf.
    (*
    clear H13.
    clear H14.
     *)

    inv_ev2;
      try solve_by_inversion;
      try eauto;
      try (
           (* unfold list_subset in *;  *)
           repeat t_in_lrange;
           nodup_contra_auto; tauto).

    (*
  -
    inv_wf.
    inv_ev2;
      try solve_by_inversion;
      try eauto;
      try (
          repeat t_in_lrange;
          nodup_contra_auto; tauto).
  -
          Ltac nodup_inv :=
        repeat
        match goal with
        | [H: NoDup (_::_) |- _] => invc H
        end.
    inv_wf.

    (* clear H21. *)
    (*clear H17; clear H18; clear H19; clear H20. *)
    inv_ev2;
      try solve_by_inversion;
      try (ff; congruence);
      try (eauto; tauto);
      try (repeat inv_se;
           repeat t_in_lrange;
           try in_app_facts;
           ff;
           nodup_inv;
           ff;
           try nodup_contra_auto;
           tauto).
*)
Defined.

(*
Lemma evsys_reps: forall t p ev,
  ev_in ev (ev_sys t p) ->
  ev_in ev (Term_system.ev_sys t p).
Proof.
Admitted.

Lemma events_reps: forall t p ev,
  events t p ev ->
  Term.events t p ev.
Proof.
Admitted.
*)

Definition store_event_evsys es p loc := exists ev, store_event ev p loc /\ ev_in ev es.

Inductive store_conflict: Plc -> EvSys Ev -> Prop :=
| store_conflict_merge: forall r p es1 es2 loc,
    store_event_evsys es1 p loc ->
    store_event_evsys es2 p loc ->
    store_conflict p (merge r es1 es2)
| store_conflict_before_l: forall r p es1 es2,
    store_conflict p es1 ->
    store_conflict p (before r es1 es2)
| store_conflict_before_r: forall r p es1 es2,
    store_conflict p es2 ->
    store_conflict p (before r es1 es2).

Axiom ev_sys_iff_remote: forall t n p0,
    (ev_sys t n = ev_sys_remote (unanno t) p0 n).

Axiom no_nested_at_store_conflict: forall t p q,
    not (store_conflict p (ev_sys_remote t p q)).

Axiom events_remote: forall t p q ev n n' l loc loc',
    ev_in ev (ev_sys_remote (unanno t) p q) ->
    events (aatt (n, n') l (loc, loc') q t) p ev.

Lemma evsys_events:
  forall t p ev,
    well_formed_r t ->
    ev_in ev (ev_sys t p) <-> events t p ev.
Proof.
    split; revert p; induction t; intros; inv H; simpl in *;
    repeat break_let; simpl in *.
  - inv H0; auto; destruct a; simpl; auto.
  - destruct p.
    rewrite H8 in H0; simpl in H0.
    repeat find_inversion.
    inv H0; auto.

    inv H3; auto. inv H3; auto.
    +
      apply events_remote; eauto.
    +
      inv H4; auto.
  - inv H0; auto.

    (*

  - rewrite H10 in H0; simpl in H0.

    inv H0.

    inv H3.
    auto.

    inv H3.

    inv H3.

    auto.

    inv H4.
    auto.

    inv H5.

    auto.
    auto.

    inv H5.

    inv H5.

    auto.

    inv H4.
    inv H4.

    auto.

  - destruct p; destruct p0.
    rewrite H12 in H0; simpl in H0.
    inv H0; auto. inv H3; auto. inv H3; auto. inv H4; auto. inv H4; auto.
*)
  - inv H0; auto.
  - rewrite H8; simpl.
    inv H0; auto.
    simpl in *.
    (*
    rewrite H11 in H8. *)
    assert (snd (range t) = i) by lia.
    subst.
    auto.
    (*
    apply Nat.succ_inj in H13; subst; auto. *)
  - inv H0; auto.

    (*
  - rewrite H10; simpl.
    inv H0; auto.
    simpl in H13.

    assert (snd (range t2) = i) by lia.
    subst.
    auto.

    (*
    rewrite H12 in H10.
    apply Nat.succ_inj in H10; subst; auto. *)

  - rewrite H12; simpl.
    inv H0; auto.
    simpl in *.
    assert (snd (range t2) = i) by lia.
    subst.
    auto.

    (*
    rewrite H15 in H12.
    apply Nat.succ_inj in H12; subst; auto. *)
*)

Qed.

Lemma wf_implies_wfr: forall t,
    well_formed t ->
    well_formed_r t.
Proof.
  induction t; intros;
    try destruct a;
    ff.
Defined.

Lemma unique_store_events': forall t p ev1 ev2 loc,
    well_formed t ->
    ev_in ev1 (ev_sys t p) ->
    ev_in ev2 (ev_sys t p) ->
    store_event ev1 p loc ->
    store_event ev2 p loc ->
    ev1 <> ev2 ->
    False.
Proof.
  intros.
  assert (ev1 = ev2).
  {
    eapply unique_store_event_locs;
      try eassumption.
    Locate evsys_events.
    eapply evsys_events; eauto.
    eapply wf_implies_wfr; eauto.
    eapply evsys_events; eauto.
    eapply wf_implies_wfr; eauto.
  }
  congruence.
Defined.

Lemma unique_store_events_corollary: forall t p ev1 ev2 loc,
    well_formed t ->
    ev_in ev1 (ev_sys t p) ->
    store_event ev1 p loc ->
    store_event ev2 p loc ->
    ev1 <> ev2 ->
    not (ev_in ev2 (ev_sys t p)).
Proof.
  intros.
  unfold not; intros.
  eapply unique_store_events'.
  eassumption.
  apply H0.
  apply H4.
  eassumption.
  eassumption.
  eassumption.
Defined.

Lemma unique_events': forall r es1 es2 ev1 ev2,
    well_structured ev (merge r es1 es2) ->
    ev_in ev1 es1 ->
    ev_in ev2 es2 ->
    ev ev1 <> ev ev2.
Proof.
  intros.
  inv H.
  assert (fst (es_range es1) <= ev ev1 < snd (es_range es1)).
  {
    eapply ws_evsys_range; eauto.
  }

  assert (fst (es_range es2) <= ev ev2 < snd (es_range es2)).
  {
    eapply ws_evsys_range; eauto.
  }

  lia.
Defined.

Lemma unqev: forall ev1 ev2,
  ev ev1 <> ev ev2 ->
  ev1 <> ev2.
Proof.
  intros.
  unfold not; intros.
  subst.
  solve_by_inversion.
Defined.

Lemma unique_events: forall r es1 es2 ev1 ev2,
    well_structured ev (merge r es1 es2) ->
    ev_in ev1 es1 ->
    ev_in ev2 es2 ->
    ev1 <> ev2.
Proof.
  intros.
  eapply unqev.
  eapply unique_events';
    eauto.
Defined.

Lemma  evsys_range
  : forall (t : AnnoTerm) (p : nat), es_range (ev_sys t p) = range t.
Proof.
  induction t; intros; simpl; auto;
    repeat break_let; simpl; auto.
Qed.

(*
Lemma ws_remote: forall t p0 ev n,
    well_structured ev (ev_sys t p0) ->
    well_structured ev (ev_sys_remote (unanno t) p0 n).
Proof.
Admitted.
*)

Lemma well_structured_evsys:
  forall t p,
    well_formed_r t ->
    well_structured ev (ev_sys t p).
Proof.
  induction t; intros; inv H; simpl;
    repeat break_let; destruct r as [i k];
      simpl in *; subst; auto.
  - apply ws_leaf_event; auto;
      destruct a; simpl; auto.
  - apply ws_before; simpl; auto.
    rewrite H6.

    assert (ev_sys t n = ev_sys_remote (unanno t) p0 n) as HH.
    {
      eapply ev_sys_iff_remote.
    }
    rewrite <- HH.

    apply ws_before; simpl; auto; rewrite evsys_range; auto.

  - apply ws_before; auto; repeat rewrite evsys_range; auto.

    (*

  - repeat (apply ws_before; simpl in *; auto; repeat rewrite evsys_range; auto).

  - repeat (apply ws_before; simpl in *; auto; repeat rewrite evsys_range; auto).
    repeat (apply ws_merge; simpl in *; auto; repeat rewrite evsys_range; auto).
*)
Qed.

Theorem no_store_conflicts: forall t p sys,
    well_formed t ->
    sys = ev_sys t p ->
    not (store_conflict p sys).
Proof.
  unfold not; intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a;
      cbn in *;
      repeat break_let;
      subst;
      solve_by_inversion.
  -
    destruct p.
    destruct r.

    (*
    assert (p0 <> n). admit.
     *)

    ff.
    subst.
    invc H1; ff.
    invc H3; ff.

    pose
      no_nested_at_store_conflict.
    unfold not in *.
    eauto.
  -
    ff.
    subst.
    invc H1;
      do_wf_pieces.
    (*
  -

      cbn in *;
      repeat break_let;
      subst.
    inv H1.
    +
      solve_by_inversion.
    +
      inv H3.
      ++
        inv H4;
          do_wf_pieces.
      ++
        solve_by_inversion.
  - assert (well_structured ev sys).
    {
      rewrite H0.
      eapply well_structured_evsys; eauto.
      eapply wf_implies_wfr; eauto.
      (*
      rewrite H0.
      eapply well_structured_evsys.
      eassumption. *)
    }

    cbn in *;
      repeat break_let;
      subst.
    inv H1;
      try solve_by_inversion.
    +
      inv H4;
        try solve_by_inversion.
      ++
        inv H5;
          try solve_by_inversion.
        +++
          unfold store_event_evsys in *.
          destruct_conjs.

          assert (ev_in H7 (merge (S n, Nat.pred n0) (ev_sys t1 p1) (ev_sys t2 p1))).
          {
            eauto.
          }

          assert (ev_in H9 (merge (S n, Nat.pred n0) (ev_sys t1 p1) (ev_sys t2 p1))).
          {
            eauto.
          }

          eapply unique_store_events' with (ev1:=H7) (ev2:=H9) (t:=(abpar (n, n0) l (n1,n2) (n3,n4) s t1 t2)) (p:=p1) (loc:=loc);
            try eassumption;
            try (simpl; eauto; tauto).
          ++++
            inv H2.
            inv H16.
            eapply unique_events; eauto.
*)
Defined.

FAILHERE

(*

Create HintDb lr.

Lemma rpy_events_lrange (t:AnnoTerm) : forall p i p1 q loc,
    well_formed t ->
    events t p (rpy i loc p1 q) ->
    fst (lrange t) <= loc < snd (lrange t).
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
      try (
        cbn in *;
        inv_wf;
        inv_ev;
        simpl in *; subst;
        try lia;
        repeat (find_eapply_hyp_hyp);
        repeat find_eapply_lem_hyp wf_mono_locs;
        lia).
Defined.
Hint Resolve rpy_events_lrange : lr.

Lemma req_events_lrange (t:AnnoTerm) : forall p i p1 q t0 loc,
    well_formed t ->
    events t p (req i loc p1 q  t0) ->
    fst (lrange t) <= loc < snd (lrange t).
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    try (
        cbn in *;
        inv_wf;
        inv_ev;
        simpl in *; subst;
        try lia;
        repeat (find_eapply_hyp_hyp);
        repeat find_eapply_lem_hyp wf_mono_locs;
        lia).
Defined.
Hint Resolve req_events_lrange : lr.

Lemma splitp_l_events_lrange (t:AnnoTerm) : forall p i p0 yi loc,
    well_formed t ->
    events t p (splitp i loc yi p0) ->
    fst (lrange t) <= loc < snd (lrange t).
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    try (
        cbn in *;
        inv_wf;
        inv_ev;
        simpl in *; subst;
        try lia;
        repeat (find_eapply_hyp_hyp);
        repeat find_eapply_lem_hyp wf_mono_locs;
        lia).
Defined.
Hint Resolve splitp_l_events_lrange : lr.

Lemma splitp_r_events_lrange (t:AnnoTerm) : forall p i p0 xi loc,
    well_formed t ->
    events t p (splitp i xi loc p0) ->
    fst (lrange t) <= loc < snd (lrange t).
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    try (
        cbn in *;
        inv_wf;
        inv_ev;
        simpl in *; subst;
        try lia;
        repeat (find_eapply_hyp_hyp);
        repeat find_eapply_lem_hyp wf_mono_locs;
        lia).
Defined.
Hint Resolve splitp_r_events_lrange : lr.

Lemma joinp_l_events_lrange (t:AnnoTerm) : forall p p0 i yi loc,
    well_formed t ->
    events t p (joinp i loc yi p0) ->
    fst (lrange t) <= loc < snd (lrange t).
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    try (
        cbn in *;
        inv_wf;
        inv_ev;
        simpl in *; subst;
        try lia;
        repeat (find_eapply_hyp_hyp);
        repeat find_eapply_lem_hyp wf_mono_locs;
        lia).
Defined.
Hint Resolve joinp_l_events_lrange : lr.

Lemma joinp_r_events_lrange (t:AnnoTerm) : forall p p0 i xi loc,
    well_formed t ->
    events t p (joinp i xi loc p0) ->
    fst (lrange t) <= loc < snd (lrange t).
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    try (
        cbn in *;
        inv_wf;
        inv_ev;
        simpl in *; subst;
        try lia;
        repeat (find_eapply_hyp_hyp);
        repeat find_eapply_lem_hyp wf_mono_locs;
        lia).
Defined.
Hint Resolve joinp_r_events_lrange : lr.

Lemma store_events_lrange (t:AnnoTerm) : forall p ev loc,
    well_formed t ->
    events t p ev ->
    store_event ev loc ->
    fst (lrange t) <= loc < snd (lrange t).
Proof.
  intros.
  inv H1;
    eauto with lr.
Defined.
*)

Ltac pose_store_events :=
  match goal with
  | [H: events _ _ ?ev,
        H': Loc |- _] =>
    assert_new_proof_by (store_event ev H') econstructor
  end.

(*
Ltac pose_new_lrange :=
  match goal with
  | [H: well_formed ?t,
        H': events ?t ?p ?ev,
            H'': store_event ?ev ?loc
     |- _] =>
    pose_new_proof (store_events_lrange t p ev loc H H' H'')
  end.
*)

Ltac pose_lrange_facts :=
  repeat pose_store_events
  (*repeat pose_new_lrange;
  repeat find_eapply_lem_hyp wf_mono_locs*) .

Ltac dest_lrange :=
  match goal with
  | [H: LocRange |- _] => destruct H
  end.

Create HintDb rl.

Set Nested Proofs Allowed.

Lemma store_event_locs: forall t p ev loc,
    store_event ev loc ->
    events t p ev ->
    well_formed t ->
    In loc (lrange t).
Proof.
Admitted.

(* TODO:  check nodup_contra call sites *)
Lemma nodup_contra: forall (x (*y*): nat) ls ls',
    In x ls  ->
    In x (* y *) ls' ->
    NoDup (ls ++ ls') ->
    False.
Proof.
Admitted.

Lemma unique_req_locs: forall t p i i0 loc q q0 t0 t1,
    well_formed t ->
    events t p (req i  loc p q t0) ->
    events t p (req i0 loc p q0 t1) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    inv_wf.
    inv_ev2.
  -

    invc H.

    invc H0.
    invc H1.

    ff.
  -
    ff.

    inv H.

    invc H0.
    +
      invc H1.
      ++
        eauto.
      ++
        eauto.

        assert (In loc (lrange t1)).
        {
          eapply store_event_locs; eauto.
          econstructor.
        }

        assert (In loc (lrange t2)).
        {
          eapply store_event_locs; eauto.
          econstructor.
        }

        (* TODO:  NoDup ((lrange t1) ++ (lrange t2)) as part of well_formed? *)
        assert (NoDup ((lrange t1) ++ (lrange t2))).
        {
          admit.
        }

        eauto.

        exfalso.
        eapply nodup_contra.
        apply H0.
        apply H1.
        eassumption.
    +
      invc H1.
      ++
                assert (In loc (lrange t1)).
        {
          eapply store_event_locs; eauto.
          econstructor.
        }

        assert (In loc (lrange t2)).
        {
          eapply store_event_locs; eauto.
          econstructor.
        }

        (* TODO:  NoDup ((lrange t1) ++ (lrange t2)) as part of well_formed? *)
        assert (NoDup ((lrange t1) ++ (lrange t2))).
        {
          admit.
        }

        eauto.

        exfalso.
        eapply nodup_contra.
        apply H0.
        apply H1.
        eassumption.

      ++

        assert (In loc t2

        ff.

      ff.

    ff.

    invc H0.
    ff.
    +
      ff.
      invc H1.
      ++
        eauto.
      ++

    inv_wf.
    inv_ev2; try eauto.

    admit.

    inv_ev2;
      try eauto.

    ff.

    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_req_locs : rl.

Lemma unique_req_splitp_l_locs:
  forall (t : AnnoTerm) (p i i0 loc p0 p1 q yi : nat) (t0: Term),
    well_formed t ->
    events t p (req i loc p0 q t0) ->
    events t p (splitp i0 loc yi p1) -> i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_req_splitp_l_locs : rl.

Lemma unique_req_splitp_r_locs:
  forall (t : AnnoTerm) (p i i0 loc p0 p1 q xi : nat) (t0: Term),
    well_formed t ->
    events t p (req i loc p0 q t0) ->
    events t p (splitp i0 xi loc p1) -> i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_req_splitp_r_locs: rl.

Lemma unique_req_rpy_locs
  : forall (t : AnnoTerm) (p i i0 loc p0 p1 q q0 : nat) (t0: Term),
    well_formed t ->
    events t p (req i loc p0 q t0) ->
    events t p (rpy i0 loc p1 q0) -> i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_req_rpy_locs: rl.

Lemma unique_splitp_splitp_ll_locs:
  forall (t : AnnoTerm) (p i i0 loc p0 p1 yi yi0 : nat),
    well_formed t ->
    events t p (splitp i  loc yi  p0) ->
    events t p (splitp i0 loc yi0 p1) -> i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_splitp_splitp_ll_locs: rl.

Lemma unique_splitp_splitp_rl_locs:
  forall (t : AnnoTerm) (p i i0 loc p0 p1 yi yi0 : nat),
    well_formed t ->
    events t p (splitp i0 loc yi0 p1) ->
    events t p (splitp i  yi loc  p0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_splitp_splitp_rl_locs: rl.

Lemma unique_rpy_splitp_l_locs:
  forall (t : AnnoTerm) (p i i0 loc p0 p1 q yi : nat),
    well_formed t ->
    events t p (rpy i loc p0 q) ->
    events t p (splitp i0 loc yi p1) -> i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_rpy_splitp_l_locs: rl.

Lemma unique_splitp_splitp_rr_locs:
  forall (t : AnnoTerm) (p i i0 loc p0 p1 xi xi0 : nat),
    well_formed t ->
    events t p (splitp i  xi loc  p0) ->
    events t p (splitp i0 xi0 loc p1) -> i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_splitp_splitp_rr_locs: rl.

Lemma unique_rpy_splitp_r_locs:
  forall (t : AnnoTerm) (p i i0 loc p0 p1 q xi : nat),
    well_formed t ->
    events t p (rpy i loc p0 q) ->
    events t p (splitp i0 xi loc p1) -> i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_rpy_splitp_r_locs: rl.

Lemma unique_rpy_locs
  : forall (t : AnnoTerm) (p i i0 loc p0 p1 q q0 : nat),
    well_formed t ->
    events t p (rpy i  loc p0 q) ->
    events t p (rpy i0 loc p1 q0) -> i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_rpy_locs: rl.

Lemma unique_splitpl_joinpl_locs
  : forall (t : AnnoTerm) (p i i0 loc p1 q0 yi yi' : nat),
    well_formed t ->
    events t p (splitp i loc yi p1) ->
    events t p (joinp i0 loc yi' q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_splitpl_joinpl_locs: rl.

Lemma unique_req_joinpl_locs
  : forall (t : AnnoTerm) (p i i0 loc p0 q q0 yi : nat) t0,
    well_formed t ->
    events t p (req i loc p0 q t0) ->
    events t p (joinp i0 loc yi q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_req_joinpl_locs: rl.

Lemma unique_splitpr_joinpl_locs
  : forall (t : AnnoTerm) (p i i0 loc p1 q0 xi yi : nat),
    well_formed t ->
    events t p (splitp i xi loc p1) ->
    events t p (joinp i0 loc yi q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_splitpr_joinpl_locs: rl.

Lemma unique_rpy_joinpl_locs
  : forall (t : AnnoTerm) (p i i0 loc p0 q q0 yi : nat),
    well_formed t ->
    events t p (rpy i loc p0 q) ->
    events t p (joinp i0 loc yi q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_rpy_joinpl_locs: rl.

Lemma unique_joinpl_joinpl_locs
  : forall (t : AnnoTerm) (p i i0 loc p1 q0 yi yi' : nat),
    well_formed t ->
    events t p (joinp i  loc yi p1) ->
    events t p (joinp i0 loc yi' q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_joinpl_joinpl_locs: rl.

Lemma unique_req_joinpr_locs
  : forall (t : AnnoTerm) (p i i0 loc p0 q q0 xi : nat) t0,
    well_formed t ->
    events t p (req i loc p0 q t0) ->
    events t p (joinp i0 xi loc q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_req_joinpr_locs: rl.

Lemma unique_splitpl_joinpr_locs
  : forall (t : AnnoTerm) (p i i0 loc p1 q0 yi xi : nat),
    well_formed t ->
    events t p (splitp i loc yi p1) ->
    events t p (joinp i0 xi loc q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_splitpl_joinpr_locs: rl.

Lemma unique_splitpr_joinpr_locs
  : forall (t : AnnoTerm) (p i i0 loc p1 q0 xi xi' : nat),
    well_formed t ->
    events t p (splitp i xi loc p1) ->
    events t p (joinp i0 xi' loc q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_splitpr_joinpr_locs: rl.

Lemma unique_rpy_joinpr_locs
  : forall (t : AnnoTerm) (p i i0 loc p0 q q0 xi : nat),
    well_formed t ->
    events t p (rpy i loc p0 q) ->
    events t p (joinp i0 xi loc q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_rpy_joinpr_locs: rl.

Lemma unique_joinpl_joinpr_locs
  : forall (t : AnnoTerm) (p i i0 loc p1 q0 xi yi : nat),
    well_formed t ->
    events t p (joinp i  xi loc p1) ->
    events t p (joinp i0 loc yi q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_joinpl_joinpr_locs: rl.

Lemma unique_joinpr_joinpr_locs
  : forall (t : AnnoTerm) (p i i0 loc p1 q0 xi xi' : nat),
    well_formed t ->
    events t p (joinp i  xi  loc p1) ->
    events t p (joinp i0 xi' loc q0) ->
    i = i0.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros;
    inv_wf;
    inv_ev2;
    try eauto;
    dest_lrange; simpl in *;
      try (pose_lrange_facts;
           lia).
Defined.
Hint Resolve unique_joinpr_joinpr_locs: rl.

Ltac flip a :=
  try (eapply a;
       eauto; tauto);
  try (symmetry;
       eapply a;
       eauto; tauto);
  tauto.

Ltac dorl' a b c d e f g h i j k l m n o p q r s t u :=
    first
      [ flip a
      | flip b
      | flip c
      | flip d
      | flip e
      | flip f
      | flip g
      | flip h
      | flip i
      | flip j
      | flip k
      | flip l
      | flip m
      | flip n
      | flip o
      | flip p
      | flip q
      | flip r
      | flip s
      | flip t
      | flip u
      ].

Ltac dorl :=
  dorl'
    unique_req_locs
    unique_req_splitp_l_locs
    unique_req_splitp_r_locs
    unique_req_rpy_locs
    unique_req_joinpl_locs
    unique_splitp_splitp_ll_locs
    unique_splitp_splitp_rl_locs
    unique_rpy_splitp_l_locs
    unique_splitpl_joinpl_locs
    unique_splitp_splitp_rr_locs
    unique_rpy_splitp_r_locs
    unique_splitpr_joinpl_locs
    unique_rpy_locs
    unique_rpy_joinpl_locs
    unique_joinpl_joinpl_locs
    unique_req_joinpr_locs
    unique_splitpl_joinpr_locs
    unique_splitpr_joinpr_locs
    unique_rpy_joinpr_locs
    unique_joinpl_joinpr_locs
    unique_joinpr_joinpr_locs.

Lemma unique_store_events: forall t p ev1 ev2 loc,
  well_formed t ->
  events t p ev1 ->
  events t p ev2 ->
  store_event ev1 loc ->
  store_event ev2 loc ->
  ev1 = ev2.
Proof.
  intros.
  eapply events_injective; eauto.
  invc H2;
    invc H3;
    simpl;
    try dorl.
Defined.

Lemma unique_store_events': forall t p ev1 ev2 loc,
    well_formed t ->
    ev_in ev1 (ev_sys t p) ->
    ev_in ev2 (ev_sys t p) ->
    store_event ev1 loc ->
    store_event ev2 loc ->
    ev1 <> ev2 ->
    False.
Proof.
  intros.
  assert (ev1 = ev2).
  {
    eapply unique_store_events;
      try eassumption.
    eapply evsys_events; eauto.
    eapply evsys_events; eauto.
  }
  congruence.
Defined.

Definition store_event_evsys es loc := exists ev, store_event ev loc /\ ev_in ev es.

Inductive store_conflict: EvSys Ev -> Prop :=
| store_conflict_merge: forall r es1 es2 loc,
    store_event_evsys es1 loc ->
    store_event_evsys es2 loc ->
    store_conflict (merge r es1 es2)
| store_conflict_before_l: forall r es1 es2,
    store_conflict es1 ->
    store_conflict (before r es1 es2)
| store_conflict_before_r: forall r es1 es2,
    store_conflict es2 ->
    store_conflict (before r es1 es2).

Lemma unique_events': forall r es1 es2 ev1 ev2,
    well_structured ev (merge r es1 es2) ->
    ev_in ev1 es1 ->
    ev_in ev2 es2 ->
    ev ev1 <> ev ev2.
Proof.
  intros.
  inv H.
  assert (fst (es_range es1) <= ev ev1 < snd (es_range es1)).
  {
    eapply ws_evsys_range; eauto.
  }

  assert (fst (es_range es2) <= ev ev2 < snd (es_range es2)).
  {
    eapply ws_evsys_range; eauto.
  }

  lia.
Defined.

Lemma unqev: forall ev1 ev2,
  ev ev1 <> ev ev2 ->
  ev1 <> ev2.
Proof.
  intros.
  unfold not; intros.
  subst.
  solve_by_inversion.
Defined.

Lemma unique_events: forall r es1 es2 ev1 ev2,
    well_structured ev (merge r es1 es2) ->
    ev_in ev1 es1 ->
    ev_in ev2 es2 ->
    ev1 <> ev2.
Proof.
  intros.
  eapply unqev.
  eapply unique_events';
    eauto.
Defined.

Definition store_event_evsys es loc := exists ev, store_event ev loc /\ ev_in ev es.

Inductive store_conflict: EvSys Ev -> Prop :=
| store_conflict_merge: forall r es1 es2 loc,
    store_event_evsys es1 loc ->
    store_event_evsys es2 loc ->
    store_conflict (merge r es1 es2)
| store_conflict_before_l: forall r es1 es2,
    store_conflict es1 ->
    store_conflict (before r es1 es2)
| store_conflict_before_r: forall r es1 es2,
    store_conflict es2 ->
    store_conflict (before r es1 es2).

Theorem no_store_conflicts: forall t p sys,
    well_formed t ->
    sys = ev_sys t p ->
    not (store_conflict sys).
Proof.
  unfold not; intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a;
      cbn in *;
      repeat break_let;
      subst;
      solve_by_inversion.
  -
    cbn in *;
      repeat break_let;
      subst.
    inv H1.
    +
      solve_by_inversion.
    +
      inv H2;
        try solve_by_inversion;
        try inv_wf; eauto.

  -
    cbn in *;
      repeat break_let;
      subst.
    inv H1;
      do_wf_pieces.
  -
    cbn in *;
      repeat break_let;
      subst.
    inv H1.
    +
      solve_by_inversion.
    +
      inv H2.
      ++
        inv H3;
          do_wf_pieces.
      ++
        solve_by_inversion.
  -

    assert (well_structured ev sys).
    {
      rewrite H0.
      eapply well_structured_evsys.
      eassumption.
    }

    cbn in *;
      repeat break_let;
      subst.
    inv H1;
      try solve_by_inversion.
    +
      inv H3;
        try solve_by_inversion.
      ++
        inv H4;
          try solve_by_inversion.
        +++
          unfold store_event_evsys in *.
          destruct_conjs.

          assert (ev_in H6 (merge (S n, Nat.pred n0) (ev_sys t1 p1) (ev_sys t2 p1))).
          {
            eauto.
          }

          assert (ev_in H8 (merge (S n, Nat.pred n0) (ev_sys t1 p1) (ev_sys t2 p1))).
          {
            eauto.
          }

          eapply unique_store_events' with (ev1:=H6) (ev2:=H8) (t:=(abpar (n, n0) l (n1,n2) (n3,n4) s t1 t2)) (p:=p1) (loc:=loc);
            try eassumption;
            try (simpl; eauto; tauto).
          ++++
            inv H2.
            inv H16.
            eapply unique_events; eauto.
Defined.


(*===========================================================================
  Auxiliary lemmas for Hoare triples on *programs*
  ===========================================================================*)
Require Import ssreflect ssrbool ssrnat eqtype seq fintype.
Require Import procstate procstatemonad bitsops bitsprops bitsopsprops.
Require Import SPred septac spec spectac safe pointsto cursor instr reader instrcodec.
Require Import Setoid RelationClasses Morphisms.
Require Import program basic antiframe.

(* Morphism for program equivalence *)
Global Instance basic_progEq_m:
Proper (lequiv ==> progEq ==> lequiv ==> lequiv) basic.
  Proof.
    move => P P' HP c c' Hc Q Q' HQ. rewrite {1}/basic.
    setoid_rewrite HQ. setoid_rewrite HP. setoid_rewrite Hc. reflexivity.
  Qed.

(* Skip rule *)
Lemma basic_skip P: |-- basic P prog_skip P.
Proof.
  rewrite /basic. specintros => i j.
  unfold_program.
  specintro => H.
  rewrite emp_unit spec_reads_eq_at; rewrite <- emp_unit.
  rewrite spec_at_emp. inversion H. subst. by apply limplValid.
Qed.

(* Sequencing rule *)
Lemma basic_seq (c1 c2: program) S P Q R:
  S |-- basic P c1 Q ->
  S |-- basic Q c2 R ->
  S |-- basic P (c1;; c2) R.
Proof.
  rewrite /basic. move=> Hc1 Hc2. specintros => i j.
  unfold_program.
  specintro => i'. rewrite -> memIsNonTop. specintros => p' EQ. subst.
  specapply Hc1. by ssimpl.
  specapply Hc2. by ssimpl.
  rewrite <-spec_reads_frame. apply: limplAdj. apply: landL2.
  by rewrite spec_at_emp.
Qed.

(* Scoped label rule *)
Lemma basic_local S P c Q:
  (forall l, S |-- basic P (c l) Q) ->
  S |-- basic P (prog_declabel c) Q.
Proof.
  move=> H. rewrite /basic. rewrite /memIs /=. specintros => i j l.
  specialize (H l). lforwardR H.
  - apply lforallL with i. apply lforallL with j. reflexivity.
  apply H.
Qed.

(* Needed to avoid problems with coercions *)
Lemma basic_instr S P i Q :
  S |-- basic P i Q ->
  S |-- basic P (prog_instr i) Q.
Proof. done. Qed.

Lemma regMissingIn_program r (i j: DWORD) (c: program):
  regMissingIn r (i -- j :-> c).
Proof.
  move: i j.
  induction c => i j; unfold_program; by eauto with reg_not_in.
Qed.
Hint Resolve regMissingIn_program : reg_not_in.

Lemma antiframe_register_basic (r: Reg) P Q c:
  regNotFree r P ->
  (forall v, |-- basic (P ** r~=v) c (Q ** r~=v)) ->
  |-- basic P c Q.
Proof.
  rewrite /basic /spec_reads => HregNotFree H.
  specintros => i j s Hs. autorewrite with push_at. apply limplValid.
  apply antiframe_register with r.
  - apply regNotFree_sepSP.
    + apply regNotFree_sepSP; last done. apply regNotFree_reg.
      by destruct r; first destruct r.
    + apply regMissingIn_regNotFree. rewrite ->Hs. auto with reg_not_in.
  - apply _.
  - move => v. specialize (H v). lforwardR H.
    { apply lforallL with i. apply lforallL with j. apply lforallL with s.
      apply lpropimplL; first done. reflexivity. }
    specapply H; first by ssimpl. autorewrite with push_at.
    rewrite spec_reads_emp. cancel1. by ssimpl.
Qed.

(* Attempts to apply "basic" lemma on a single command (basic_basic) or
   on the first of a sequence (basic_seq). Note that it attempts to use sbazooka
   to discharge subgoals, so be careful if existentials are exposed in the goal --
   they will be instantiated! *)
  Hint Unfold not : basicapply.
  Hint Rewrite eq_refl : basicapply.
  Ltac instRule R H :=
    move: (R) => H;
    repeat (autounfold with basicapply in H);
    eforalls H;
    autorewrite with push_at in H.

  (* This is all very sensitive to use of "e" versions of apply/exact. Beware! *)
  (* We ensure that we leave at most one goal remaining. *)
  Ltac basicatom R tacfin :=
  lazymatch goal with
    | |- |-- basic ?P (prog_instr ?i) ?Q =>
          (eapply basic_basic; first eapply basic_instr; [ eexact R | tacfin .. | try tacfin ])

    | _ => eapply basic_basic; [ eexact R | tacfin .. | try tacfin ]
    end.

  Ltac  basicseq R tacfin :=
  lazymatch goal with
    | |- |-- basic ?P (prog_seq ?p1 ?p2) ?Q => (eapply basic_seq; first basicatom R tacfin)
    | _ => basicatom R tacfin
    end.

  Ltac basicapply R tac tacfin :=
    let Hlem := fresh "Hlem" in
    instRule R Hlem;
    tac Hlem;
    first basicseq Hlem tacfin;
    clear Hlem.

  Tactic Notation "basicapply" open_constr(R) "using" tactic3(tac) "side" "conditions" tactic(tacfin) := basicapply R tac tacfin.
  Tactic Notation "basicapply" open_constr(R) "using" tactic3(tac) := basicapply R using (tac) side conditions by autounfold with spred; sbazooka.
  Tactic Notation "basicapply" open_constr(R) "side" "conditions" tactic(tacfin) := basicapply R using (fun Hlem => autorewrite with basicapply in Hlem) side conditions tacfin.
  Tactic Notation "basicapply" open_constr(R) := basicapply R using (fun Hlem => autorewrite with basicapply in Hlem).
  (** Variant of [basicapply] that doesn't require that the side conditions be fully solved. *)
  Tactic Notation "try_basicapply" open_constr(R) "using" tactic3(tac) := basicapply R using (tac) side conditions autounfold with spred; sbazooka.
  Tactic Notation "try_basicapply" open_constr(R) := try_basicapply R using (fun Hlem => autorewrite with basicapply in Hlem).