Require Import Omega.
Require Import RelationClasses.

Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import DenseOrder.
Require Import Language.

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

Require Import PromiseConsistent.
Require Import ReorderPromise.
Require Import MemoryReorder.
Require Import MemoryFacts.
Require Import WFConfig.
Require Import MemoryProps.

Set Implicit Arguments.

Lemma reserve_sc_nochange
      lang (e e': Thread.t lang) lo
      (RSVs: rtc (Thread.reserve_step lo) e e'):
  (Thread.sc e) = (Thread.sc e') /\ (Thread.state e) = (Thread.state e').
Proof.
  induction RSVs; ii; eauto.
  inv H. inv STEP; ss.
Qed.

Lemma reorder_reserve_promise
      prom0 mem0
      prom1 mem1
      prom2 mem2
      loc1 from1 to1
      loc2 from2 to2 msg2 kind2
      (STEP1: Memory.promise prom0 mem0 loc1 from1 to1 Message.reserve prom1 mem1 Memory.op_kind_add)
      (STEP2: Memory.promise prom1 mem1 loc2 from2 to2 msg2 prom2 mem2 kind2):
  (loc1 = loc2 /\ from1 = from2 /\ to1 = to2 /\ msg2 = Message.reserve /\ kind2 = Memory.op_kind_cancel /\
   prom0 = prom2 /\ mem0 = mem2) \/
  (exists prom1' mem1',
      <<STEP1: Memory.promise prom0 mem0 loc2 from2 to2 msg2 prom1' mem1' kind2>> /\
      <<STEP2: Memory.promise prom1' mem1' loc1 from1 to1 Message.reserve prom2 mem2 Memory.op_kind_add>>).
Proof.
  inv STEP1. inv STEP2; ss.
  - (* reserve/add *)
    exploit MemoryReorder.add_add; try exact PROMISES; try exact PROMISES0; eauto. i. des.
    exploit MemoryReorder.add_add; try exact MEM; try exact MEM0; eauto. i. des.
    right. esplits.
    + econs; eauto; try congr.
      i. exploit Memory.add_get1; try exact MEM; eauto.
    + econs; eauto. ss.
  - (* reserve/split *)
    exploit MemoryReorder.add_split; try exact PROMISES; try exact PROMISES0; eauto. i.
    des; clarify.
    + exploit MemoryReorder.add_split; try exact MEM; try exact MEM0; eauto. i. des; [congr|].
      right. esplits.
      * econs 2; eauto.
      * econs; eauto. ss.
  - (* reserve/lower *)
    des. subst.
    exploit MemoryReorder.add_lower; try exact PROMISES; try exact PROMISES0; eauto. i.
    des; clarify.
    + exploit MemoryReorder.add_lower; try exact MEM; try exact MEM0; eauto. i. des; [congr|].
      right. esplits.
      * econs; eauto.
      * econs; eauto. ss.
  - (* reserve/cancel *)
    destruct (classic ((loc1, to1) = (loc2, to2))).
    + inv H.
      exploit MemoryReorder.add_remove_same; try exact PROMISES0; eauto. i. des. subst.
      exploit MemoryReorder.add_remove_same; try exact MEM0; eauto. i. des. subst.
      left. splits; auto.
    + exploit MemoryReorder.add_remove; try exact PROMISES0; eauto. i. des.
      exploit MemoryReorder.add_remove; try exact MEM0; eauto. i. des.
      right. esplits; eauto. econs; eauto. ss.
Qed.

Lemma reorder_promise_reserve_promise
      lc0 mem0
      lc1 mem1
      lc2 mem2
      loc1 from1 to1
      loc2 from2 to2 msg2 kind2
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 Message.reserve lc1 mem1 Memory.op_kind_add)
      (STEP2: Local.promise_step lc1 mem1 loc2 from2 to2 msg2 lc2 mem2 kind2):
  (loc1 = loc2 /\ from1 = from2 /\ to1 = to2 /\ msg2 = Message.reserve /\ kind2 = Memory.op_kind_cancel /\
   lc0 = lc2 /\ mem0 = mem2) \/
  (exists lc1' mem1',
      <<STEP1: Local.promise_step lc0 mem0 loc2 from2 to2 msg2 lc1' mem1' kind2>> /\
      <<STEP2: Local.promise_step lc1' mem1' loc1 from1 to1 Message.reserve lc2 mem2 Memory.op_kind_add>>).
Proof.
  inv STEP1. inv STEP2. ss.
  exploit reorder_reserve_promise; eauto. i. des; subst.
  { left. splits; auto. destruct lc0; auto. }
  right. esplits.
  { econs; eauto. inv STEP2.

    eapply memory_concrete_le_closed_msg; try apply CLOSED0.
    ii. erewrite (@Memory.add_o mem2 mem1') in GET; eauto. des_ifs. }
  { econs; eauto. }
Qed.

Lemma add_non_synch_loc loc0 prom0 loc1 from to msg prom1
      (NONSYNCH: Memory.nonsynch_loc loc0 prom1)
      (ADD: Memory.add prom0 loc1 from to msg prom1)
  :
    Memory.nonsynch_loc loc0 prom0.
Proof.
  ii. eapply Memory.add_get1 in GET; eauto.
  des_ifs. exploit NONSYNCH; eauto.
Qed.

Lemma reserve_non_synch_loc loc0 prom0 loc1 from to prom1
      (NONSYNCH: Memory.nonsynch_loc loc0 prom0)
      (RSV: Memory.add prom0 loc1 from to Message.reserve prom1)
  :
    Memory.nonsynch_loc loc0 prom1.
Proof.
  ii. erewrite Memory.add_o in GET; eauto.
  destruct (loc_ts_eq_dec (loc0, t) (loc1, to)).
  inv GET; ss; des; subst.
  ss.
  exploit NONSYNCH; eauto.
Qed.

Lemma add_non_synch prom0 loc from to msg prom1
      (NONSYNCH: Memory.nonsynch prom1)
      (ADD: Memory.add prom0 loc from to msg prom1)
  :
    Memory.nonsynch prom0.
Proof.
  ii. eapply Memory.add_get1 in GET; eauto.
  des_ifs. exploit NONSYNCH; eauto.
Qed.

Lemma reserve_non_synch prom0 loc from to prom1
      (NONSYNCH: Memory.nonsynch prom0)
      (RSV: Memory.add prom0 loc from to Message.reserve prom1)
  :
    Memory.nonsynch prom1.
Proof.
  ii. erewrite Memory.add_o in GET; eauto.
  des_ifs; ss.
  exploit NONSYNCH; eauto.
Qed.

Lemma reorder_reserve_fence
      lc0 mem0
      lc1 mem1
      lc2
      loc1 from1 to1
      ord1 ord2 sc0 sc1
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 Message.reserve lc1 mem1 Memory.op_kind_add)
      (STEP2: Local.fence_step lc1 sc0 ord1 ord2 lc2 sc1)
  :
    exists lc1',
      (<<STEP1: Local.fence_step lc0 sc0 ord1 ord2 lc1' sc1>>) /\
      (<<STEP2: Local.promise_step lc1' mem0 loc1 from1 to1 Message.reserve lc2 mem1 Memory.op_kind_add>>).
Proof.
  inv STEP1. inv STEP2. ss. esplits.
  - econs; eauto.
    + inv PROMISE. i. eapply add_non_synch; eauto.
    + i. ss. subst. erewrite PROMISES in *; auto.
      inv PROMISE. eapply Memory.add_get0 in PROMISES0. des.
      erewrite Memory.bot_get in *. ss.
  - econs; eauto.
Qed.

Lemma reorder_reserve_read
      lc0 mem0
      lc1 mem1
      lc2
      loc1 from1 to1
      loc2 to2 val2 released2 ord2 lo
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 Message.reserve lc1 mem1 Memory.op_kind_add)
      (STEP2: Local.read_step lc1 mem1 loc2 to2 val2 released2 ord2 lc2 lo)
  :
    exists lc1',
      (<<STEP1: Local.read_step lc0 mem0 loc2 to2 val2 released2 ord2 lc1' lo>>) /\
      (<<STEP2: Local.promise_step lc1' mem0 loc1 from1 to1 Message.reserve lc2 mem1 Memory.op_kind_add>>).
Proof.
  inv STEP1. inv STEP2. esplits; eauto.
  { econs; eauto. inv PROMISE.
    erewrite Memory.add_o in GET; eauto. des_ifs. eauto. }
  { econs; eauto. }
Qed.

Lemma reorder_reserve_write
      lc0 sc0 mem0
      lc1 mem1
      lc2 sc2 mem2
      loc1 from1 to1
      loc2 from2 to2 val2 releasedm2 released2 ord2 kind2 lo
      (STEP1: Local.promise_step lc0 mem0 loc1 from1 to1 Message.reserve lc1 mem1 Memory.op_kind_add)
      (STEP2: Local.write_step lc1 sc0 mem1 loc2 from2 to2 val2 releasedm2 released2 ord2 lc2 sc2 mem2 kind2 lo)
  :
    exists lc1' mem1',
      (<<STEP1: Local.write_step lc0 sc0 mem0 loc2 from2 to2 val2 releasedm2 released2 ord2 lc1' sc2 mem1' kind2 lo>>) /\
      (<<STEP2: Local.promise_step lc1' mem1' loc1 from1 to1 Message.reserve lc2 mem2 Memory.op_kind_add>>).
Proof.
  inv STEP1. inv STEP2. ss. inv WRITE.
  exploit reorder_reserve_promise.
  { eapply PROMISE. }
  { eapply PROMISE0. }
  i. des; clarify.
  i. des; clarify.
  assert (LOCTS: (loc1, to1) <> (loc2, to2)).
  { ii. clarify. inv PROMISE.
    eapply Memory.add_get0 in MEM. des. inv PROMISE0; ss.
    { eapply Memory.add_get0 in MEM. des. clarify. }
    { des. subst. eapply Memory.split_get0 in MEM. des. clarify. }
    { des. subst. eapply Memory.lower_get0 in MEM. des. clarify. }
  }
  exploit MemoryReorder.add_remove; eauto.
  { inv STEP2. eauto. }
  i. des. esplits.
  { econs; eauto. i. inv PROMISE. eapply add_non_synch_loc; eauto. }
  { econs; eauto. ss. inv STEP2. econs; eauto. }
Qed.

Lemma reorder_promise_add_reserve
      lc1 mem1 loc1 from1 to1 val released
      lc2 mem2 loc2 from2 to2 lc3 mem3
      (PRM_ADD: Local.promise_step lc1 mem1 loc1 from1 to1 (Message.concrete val released) lc2 mem2 Memory.op_kind_add)
      (RSV: Local.promise_step lc2 mem2 loc2 from2 to2 Message.reserve lc3 mem3 Memory.op_kind_add):
  (exists lc' mem',
      Local.promise_step lc1 mem1 loc2 from2 to2 Message.reserve lc' mem' Memory.op_kind_add /\
      Local.promise_step lc' mem' loc1 from1 to1 (Message.concrete val released) lc3 mem3 Memory.op_kind_add) \/
  (loc1 = loc2 /\ to1 = from2).
Proof.
  inv PRM_ADD; inv RSV; ss.
  inv PROMISE; inv PROMISE0; ss.
  exploit MemoryReorder.add_add; [eapply PROMISES | eapply PROMISES0 | eauto..].
  ii. des.
  exploit MemoryReorder.add_add; [eapply MEM | eapply MEM0 | eauto..].
  ii; des.
  destruct (classic (to1 = from2)); subst.
  {
    destruct (classic (loc1 = loc2)); subst.
    {
      (* attach implies not reorder *)
      eauto.
    }
    {
      (* not attach implies reorder *)
      left.
      do 2 eexists.
      split.
      econstructor. econstructor; eauto.
      ii; ss.
      ss.
      ss.
      econstructor; eauto.
      econstructor; eauto.
      ii.
      inv MSG.
      clear - ATTACH ADD0 GET H.
      exploit ATTACH; eauto.
      instantiate (2 := to'); instantiate (1 := msg').
      erewrite Memory.add_o in GET; eauto.
      destruct (loc_ts_eq_dec (loc1, to') (loc2, to2)); subst; ss.
      des; ss.
      eapply Memory.add_closed_message with (mem1 := mem2); eauto.
    }
  }
  {
    (* not attach implies reorder *)
    destruct (classic (loc1 = loc2)); subst.
    {
      left.
      do 2 eexists.
      split.
      econstructor. econstructor; eauto.
      ii; ss.
      ss.
      ss.
      econstructor; eauto.
      econstructor; eauto.
      ii.
      inv MSG.
      clear - ATTACH ADD0 GET H.
      destruct (classic (to' = to2)); subst.
      {
        eapply Memory.add_get0 in ADD0; des.
        rewrite GET1 in GET; inv GET; ss.
      }
      {
        exploit ATTACH; eauto.
        instantiate (2 := to'); instantiate (1 := msg').
        erewrite Memory.add_o in GET; eauto.
        destruct (loc_ts_eq_dec (loc2, to') (loc2, to2)); subst; ss.
        des; subst; ss.
      }
      eapply Memory.add_closed_message with (mem1 := mem2); eauto.
    }
    {
      left.
      do 2 eexists.
      split.
      econstructor. econstructor; eauto.
      ii; ss.
      ss.
      ss.
      econstructor; eauto.
      econstructor; eauto.
      ii.
      inv MSG.
      clear - ATTACH ADD0 GET H.
      exploit ATTACH; eauto.
      instantiate (2 := to'); instantiate (1 := msg').
      erewrite Memory.add_o in GET; eauto.
      destruct (loc_ts_eq_dec (loc1, to') (loc2, to2)); subst; ss.
      inv GET.
      des; subst; ss.
      eapply Memory.add_closed_message with (mem1 := mem2); eauto.
    }
  }
Qed.

Lemma reorder_promise_add_reserve_step_attached
      lc1 mem1 loc from ts val released lc2 mem2
      to lc3 mem3 loc' from' to' lc4 mem4
      (PROMISE: Local.promise_step lc1 mem1 loc from ts (Message.concrete val released) lc2 mem2 Memory.op_kind_add)
      (RSV_ATTACH: Local.promise_step lc2 mem2 loc ts to Message.reserve lc3 mem3 Memory.op_kind_add)
      (RSV: Local.promise_step lc3 mem3 loc' from' to' Message.reserve lc4 mem4 Memory.op_kind_add):
  exists lc' mem' lc'' mem'',
    Local.promise_step lc1 mem1 loc' from' to' Message.reserve lc' mem' Memory.op_kind_add /\
    Local.promise_step lc' mem' loc from ts (Message.concrete val released) lc'' mem'' Memory.op_kind_add /\
    Local.promise_step lc'' mem'' loc ts to Message.reserve lc4 mem4 Memory.op_kind_add.
Proof.
  exploit reorder_promise_reserve_promise; [eapply RSV_ATTACH | eapply RSV | eauto..]. ii.
  des; ss.
  exploit reorder_promise_add_reserve; [eapply PROMISE | eapply STEP1 | eauto..]. ii.
  des; ss.
  do 4 eexists; eauto.
  subst.
  clear - RSV_ATTACH RSV.
  inv RSV_ATTACH; inv RSV.
  inv PROMISE; inv PROMISE0.
  clear - MEM MEM0.
  destruct (loc_ts_eq_dec (loc', to) (loc', to')); ss.
  {
    des; ss.
    exploit MemoryReorder.add_add; [eapply MEM | eapply MEM0 | eauto..].
    ii; des.
    subst.
    contradiction LOCTS; eauto.
  }
  {
    des; ss.
    assert(LT1: Time.lt from' to).
    {
      clear - MEM.
      inv MEM.
      inv ADD; eauto.
    }
    assert(LT2: Time.lt from' to').
    {
      clear - MEM0.
      inv MEM0.
      inv ADD; eauto.
    }
    eapply Memory.add_get0 in MEM; des.
    inv MEM0.
    inv ADD.
    unfold Memory.get in GET0.
    unfold Cell.get in GET0.
    eapply DISJOINT in GET0; eauto.
    clear - GET0 LT1 LT2.
    unfold Interval.disjoint in *.
    destruct(Time.le_lt_dec to' to).
    {
      specialize (GET0 to').
      exploit GET0; ss.
      econstructor; ss; eauto.
      eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
    }
    {
      specialize (GET0 to).
      exploit GET0; ss.
      econstructor; ss; eauto.
      eapply Time.le_lteq; eauto.
      econstructor; ss.
      eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
    }
  }
Qed.

Lemma reorder_promise_add_reservations_attached:
  forall n lang lc1 mem1 loc from ts val released lc2 mem2
    to lc3 mem3 st sc e'' lo
    (PROMISE: Local.promise_step lc1 mem1 loc from ts (Message.concrete val released) lc2 mem2 Memory.op_kind_add)
    (RSV_ATTACH: Local.promise_step lc2 mem2 loc ts to Message.reserve lc3 mem3 Memory.op_kind_add)
    (RSVs: rtcn (Thread.reserve_step lo) n (Thread.mk lang st lc3 sc mem3) e''),
  exists lc' mem' lc'' mem''  lc4 mem4,
    rtc (Thread.reserve_step lo) (Thread.mk lang st lc1 sc mem1) (Thread.mk lang st lc' sc mem') /\
    Local.promise_step lc' mem' loc from ts (Message.concrete val released) lc'' mem'' Memory.op_kind_add /\
    Local.promise_step lc'' mem'' loc ts to Message.reserve lc4 mem4 Memory.op_kind_add /\
    e'' = Thread.mk lang st lc4 sc mem4.
Proof.
  induction n; ii.
  - inv RSVs; eauto.
    do 6 eexists; eauto.
  - inv RSVs.
    inv A12.
    inv STEP.
    exploit reorder_promise_add_reserve_step_attached; [eapply PROMISE | eapply RSV_ATTACH | eapply LOCAL | eauto..].
    ii; des.
    exploit IHn; [eapply x1 | eapply x2 | eapply A23 | eauto..].
    ii; des; subst.
    do 6 eexists.
    split.
    eapply Relation_Operators.rt1n_trans; [idtac | eapply x | eauto..].
    econstructor; eauto.
    econstructor; eauto.
    split; eauto.
Qed.

Lemma reorder_promise_split_reserve
      lc1 mem1 loc1 from1 to1 val released ts msg
      lc2 mem2 loc2 from2 to2 lc3 mem3
      (PRM_ADD: Local.promise_step lc1 mem1 loc1 from1 to1 (Message.concrete val released) lc2 mem2
                                   (Memory.op_kind_split ts msg))
      (RSV: Local.promise_step lc2 mem2 loc2 from2 to2 Message.reserve lc3 mem3 Memory.op_kind_add):
  (exists lc' mem',
      Local.promise_step lc1 mem1 loc2 from2 to2 Message.reserve lc' mem' Memory.op_kind_add /\
      Local.promise_step lc' mem' loc1 from1 to1 (Message.concrete val released) lc3 mem3
                         (Memory.op_kind_split ts msg)).
Proof.
  inv PRM_ADD; inv RSV; ss.
  inv PROMISE; inv PROMISE0.
  des; subst.
  exploit MemoryReorder.split_add; [eapply PROMISES | eapply PROMISES0 | eauto..].
  ii; des; subst.
  exploit MemoryReorder.split_add; [eapply MEM | eapply MEM0 | eauto..].
  ii; des; subst.
  do 2 eexists.
  split.
  econstructor.
  econstructor.
  eapply ADD1.
  eapply ADD0.
  ss.
  ii; ss.
  ss.
  ss.
  econstructor; eauto.
  econstructor; eauto.
  eapply Memory.add_closed_message; eauto.
Qed.

Lemma reorder_promise_lower_reserve
      lc1 mem1 loc1 from1 to1 val released msg
      lc2 mem2 loc2 from2 to2 lc3 mem3
      (PRM_ADD: Local.promise_step lc1 mem1 loc1 from1 to1 (Message.concrete val released) lc2 mem2
                                   (Memory.op_kind_lower msg))
      (RSV: Local.promise_step lc2 mem2 loc2 from2 to2 Message.reserve lc3 mem3 Memory.op_kind_add):
  (exists lc' mem',
      Local.promise_step lc1 mem1 loc2 from2 to2 Message.reserve lc' mem' Memory.op_kind_add /\
      Local.promise_step lc' mem' loc1 from1 to1 (Message.concrete val released) lc3 mem3
                         (Memory.op_kind_lower msg)).
Proof.
  inv PRM_ADD; inv RSV; ss.
  inv PROMISE; inv PROMISE0.
  exploit MemoryReorder.lower_add; [eapply PROMISES | eapply PROMISES0 | eauto..].
  ii; des.
  exploit MemoryReorder.lower_add; [eapply MEM | eapply MEM0 | eauto..].
  ii; des.
  do 2 eexists.
  split.
  econstructor.
  econstructor.
  eapply ADD1. eapply ADD0. ss.
  ii; ss. ss. ss.
  econstructor; eauto.
  eapply Memory.add_closed_message; eauto.
Qed.

Lemma reorder_promise_step_reserve_steps:
  forall n lang (e e' e'': Thread.t lang) pf te lo
    (PROMISE: Thread.promise_step pf te e e')
    (RSVs: rtcn (Thread.reserve_step lo) n e' e'')
    (NO_RSV_CCL: Thread.not_rsv_ccl_scfence te = true),
    (exists e0, rtc (Thread.reserve_step lo) e e0 /\ Thread.promise_step pf te e0 e'') \/
    (exists e0 e1 loc to ts from msg,
        rtc (Thread.reserve_step lo) e e0 /\
        Thread.promise_step pf te e0 e1 /\ te = ThreadEvent.promise loc from ts msg Memory.op_kind_add /\
        Thread.promise_step false (ThreadEvent.promise loc ts to Message.reserve Memory.op_kind_add) e1 e'').
Proof.
  induction n; ii.
  - inv RSVs; eauto.
  - inv RSVs. inv A12.
    inv PROMISE; inv STEP; ss.
    destruct msg; ss.
    destruct kind; ss.
    {
      (* promise add / reserve *)
      exploit reorder_promise_add_reserve; eauto. ii.
      des.
      {
        eapply IHn with (e := Thread.mk lang st lc' sc1 mem') (pf := false)
                        (te := ThreadEvent.promise loc0 from0 to0 (Message.concrete val released) Memory.op_kind_add)
          in A23; eauto.
        des.
        {
          left.
          eexists.
          split.
          eapply Relation_Operators.rt1n_trans; eauto.
          econstructor; eauto.
          econstructor; eauto.
          eauto.
        }
        {
          inv A1; ss.
          right.
          do 7 eexists.
          split.
          eapply Relation_Operators.rt1n_trans; [|eapply A23]; eauto.
          econstructor; eauto.
          econstructor; eauto.
          split; eauto.
        }
        econstructor; eauto.
      }
      {
        subst.
        right.
        exploit reorder_promise_add_reservations_attached; [eapply LOCAL | eapply LOCAL0 | eapply A23 | eauto..].
        ii; des; subst.
        do 7 eexists.
        split.
        eapply x0.
        split.
        econstructor; eauto.
        split.
        econstructor; eauto.
        econstructor; eauto.
      }
    }
    {
      (* promise split / reserve *)
      exploit reorder_promise_split_reserve; eauto.
      ii; des.
      eapply IHn with (e := Thread.mk lang st lc' sc1 mem')
                      (te := ThreadEvent.promise loc0 from0 to0 (Message.concrete val released)
                                                 (Memory.op_kind_split ts3 msg3)) in A23; eauto.
      des.
      {
        left.
        eexists.
        split.
        eapply Relation_Operators.rt1n_trans; [idtac | eapply A23]; eauto.
        econstructor; eauto.
        econstructor; eauto.
        eauto.
      }
      {
        right.
        inv A1.
      }
      econstructor; eauto.
    }
    {
      (* promise lower / reserve *)
      exploit reorder_promise_lower_reserve; [eapply LOCAL | eapply LOCAL0 | eauto..].
      ii; des.
      eapply IHn with (e := Thread.mk lang st lc' sc1 mem')
                      (te := ThreadEvent.promise loc0 from0 to0 (Message.concrete val released)
                                                 (Memory.op_kind_lower msg1)) in A23; eauto.
      des.
      {
        left.
        eexists.
        split.
        eapply Relation_Operators.rt1n_trans; [idtac | eapply A23]; eauto.
        econstructor; eauto.
        econstructor; eauto.
        eauto.
      }
      {
        right.
        do 7 eexists.
        split.
        eapply Relation_Operators.rt1n_trans; [idtac | eapply A23]; eauto.
        econstructor; eauto.
        econstructor; eauto.
        split.
        eauto.
        split; eauto.
      }
      econstructor; eauto.
    }
    {
      (* promise reserve: contradiction *)
      destruct kind; ss.
      clear - LOCAL.
      inv LOCAL.
      inv PROMISE.
      des; ss.
      inv LOCAL.
      inv PROMISE; ss.
      des; ss; subst.
      inv PROMISES.
      inv LOWER.
      clear - MSG_LE.
      inv MSG_LE.
    }
Qed.

Lemma reorder_read_reservation
      lc1 mem1 loc to val released ord lc2 lo
      loc2 from2 to2 lc3 mem3
      (READ: Local.read_step lc1 mem1 loc to val released ord lc2 lo)
      (PROMISE: Local.promise_step lc2 mem1 loc2 from2 to2 Message.reserve lc3 mem3 Memory.op_kind_add):
  exists lc',
    Local.promise_step lc1 mem1 loc2 from2 to2 Message.reserve lc' mem3 Memory.op_kind_add /\
    Local.read_step lc' mem3 loc to val released ord lc3 lo.
Proof.
  inv READ; inv PROMISE; ss.
  inv PROMISE0.
  destruct lc1; ss.
  eexists.
  split.
  econstructor; eauto.
  econstructor; eauto.
  eapply Memory.add_get1; eauto.
Qed.

Lemma reorder_read_reserve_steps:
  forall n lang st
    lc1 mem1 loc to val released ord lo
    sc2 lc2 lc2' mem2 sc2'
    (READ: Local.read_step lc1 mem1 loc to val released ord lc2 lo)
    (RSVs: rtcn (Thread.reserve_step lo) n (Thread.mk lang st lc2 sc2 mem1) (Thread.mk lang st lc2' sc2' mem2)),
  exists lc',
    rtc (Thread.reserve_step lo) (Thread.mk lang st lc1 sc2 mem1) (Thread.mk lang st lc' sc2' mem2) /\
    Local.read_step lc' mem2 loc to val released ord lc2' lo.
Proof.
  induction n; ii.
  - inv RSVs.
    eexists. split; eauto.
  - inv RSVs.
    inv A12. inv STEP.
    eapply reorder_read_reservation in READ; eauto.
    des.
    eapply IHn in A23; eauto.
    des; eauto.
    eexists.
    split; [idtac | eapply A0].
    eapply Relation_Operators.rt1n_trans; [idtac | eapply A23]; eauto.
    econstructor; eauto.
    econstructor; eauto.
Qed.

Lemma reorder_write_reserve
      lc1 sc1 mem1 loc1 from1 to1 val releasedr releasedw ord
      lc2 sc2 mem2 kind lo
      loc2 from2 to2 lc3 mem3
      (WRITE: Local.write_step lc1 sc1 mem1 loc1 from1 to1 val releasedr releasedw ord lc2 sc2 mem2 kind lo)
      (RSV: Local.promise_step lc2 mem2 loc2 from2 to2 Message.reserve lc3 mem3 Memory.op_kind_add):
  (exists lc' mem',
      Local.promise_step lc1 mem1 loc2 from2 to2 Message.reserve lc' mem' Memory.op_kind_add /\
      Local.write_step lc' sc1 mem' loc1 from1 to1 val releasedr releasedw ord lc3 sc2 mem3 kind lo) \/
  (loc1 = loc2 /\ to1 = from2 /\ kind = Memory.op_kind_add).
Proof.
  inv WRITE; inv RSV; ss.
  inv WRITE0; inv PROMISE.
  inv PROMISE0.
  - (* add *)
    destruct (classic (loc1 = loc2)); subst.
    {
      destruct (Time.le_lt_dec to2 from1).
      {
        exploit MemoryReorder.remove_add_disjts; [eapply REMOVE | eapply PROMISES | eauto..].
        ii. des. rename mem1' into promises1'.
        exploit MemoryReorder.add_add; [eapply PROMISES0 | eapply x0 | eauto..].
        ii. des. rename mem1' into promises'.
        exploit MemoryReorder.add_add; [eapply MEM0 | eapply MEM | eauto..].
        ii. des.
        left.
        do 2 eexists. split.
        econstructor.
        econstructor.
        eapply ADD1.
        eapply ADD0.
        ss.
        ii; ss.
        ss.
        ss.
        econstructor; eauto; ss.
        econstructor.
        econstructor.
        eapply ADD2.
        eapply ADD3.
        ss.
        ii. inv MSG.
        assert(Time.lt to2 to1).
        {
          clear - l ADD3.
          inv ADD3.
          inv ADD.
          eapply DenseOrderFacts.le_lt_lt; eauto.
        }
        assert(Time.lt to2 to').
        {
          eapply Memory.get_ts in GET.
          clear - GET H. des; subst; ss.
          eapply Time.Time.lt_strorder_obligation_2; eauto.
        }
        exploit Memory.add_o; [eapply ADD0 | eauto..].
        instantiate (2 := loc2); instantiate (1 := to').
        des_if; ss.
        des; subst.
        eapply Time.Time.lt_strorder_obligation_1 in H0; ss.
        ii.
        rewrite x2 in GET.
        eapply ATTACH0 in GET; ss.
        ss.
        i.
        eapply RELEASE in H.
        eapply reserve_non_synch_loc; eauto.
      }
      {
        assert(Time.le to1 from2).
        {
          destruct (Time.le_lt_dec to1 from2); eauto.
          clear - MEM0 MEM l l0.
          inv MEM.
          inv ADD.
          dup MEM0.
          eapply Memory.add_get0 in MEM1; des.
          unfold Memory.get in GET0.
          unfold Cell.get in GET0.
          eapply DISJOINT in GET0.
          unfold Interval.disjoint in GET0.
          destruct (Time.le_lt_dec to1 to2).
          specialize (GET0 to1).
          exploit GET0; ss.
          inv MEM0.
          inv ADD.
          econstructor; eauto; ss.
          eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
          specialize (GET0 to2).
          exploit GET0; ss.
          econstructor; ss.
          eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
          econstructor; ss.
          eapply Time.le_lteq; ss; eauto.
        }
        destruct (classic (to1 = from2)); subst.
        right.
        eapply Memory.add_get0 in MEM0; des; eauto.
        exploit MemoryReorder.remove_add_disjts; [eapply REMOVE | eapply PROMISES | eauto..].
        ii. des. rename mem1' into promises1'.
        exploit MemoryReorder.add_add; [eapply PROMISES0 | eapply x0 | eauto..].
        ii. des. rename mem1' into promises'.
        exploit MemoryReorder.add_add; [eapply MEM0 | eapply MEM | eauto..].
        ii. des.
        left.
        do 2 eexists.
        split.
        econstructor.
        econstructor.
        eapply ADD1.
        eapply ADD0.
        ss.
        ii; ss.
        ss.
        ss.
        econstructor; eauto.
        econstructor; ss.
        econstructor.
        eapply ADD2.
        eapply ADD3.
        ss.
        ii.
        inv MSG.
        assert(to' <> to2).
        {
          intro; subst.
          eapply Memory.add_get0 in ADD0; des.
          rewrite GET1 in GET; inv GET; ss.
        }
        exploit Memory.add_o; [eapply ADD0 | eauto..].
        instantiate(2 := loc2); instantiate(1 := to'); eauto.
        des_if; ss; subst.
        des; subst; ss.
        ii.
        rewrite x2 in GET.
        eauto.
        ss.
        ss; i.
        eapply RELEASE in H1.
        eapply reserve_non_synch_loc; eauto.
      }
    }
    {
      exploit MemoryReorder.remove_add_disjloc; [eapply REMOVE | eapply PROMISES | eauto..].
      ii; des. rename mem1' into promises1'.
      exploit MemoryReorder.add_add; [eapply PROMISES0 | eapply x0 | eauto..].
      ii; des.
      exploit MemoryReorder.add_add; [eapply MEM0 | eapply MEM | eauto..].
      ii; des.
      left.
      do 2 eexists.
      split.
      econstructor.
      econstructor.
      eapply ADD1.
      eapply ADD0.
      ss.
      ii; ss.
      ss.
      ss.
      econstructor; eauto.
      econstructor.
      econstructor.
      eapply ADD2.
      eapply ADD3.
      ss.
      ii.
      inv MSG.
      exploit Memory.add_o; [eapply ADD0 | eauto..].
      instantiate (2 := loc1); instantiate (1 := to').
      des_if; ss.
      des; ss.
      ii.
      rewrite x2 in GET.
      eauto.
      ss.
      i; ss.
      eapply RELEASE in H0.
      eapply reserve_non_synch_loc; eauto.
    }
  - (* split *)
    des; subst; ss.
    inv RESERVE.
    destruct (classic (loc1 = loc2)); subst.
    {
      destruct (Time.le_lt_dec to2 from1).
      {
        exploit MemoryReorder.remove_add_disjts; [eapply REMOVE | eapply PROMISES | eauto..].
        ii. des. rename mem1' into promises1'.
        exploit MemoryReorder.split_add; [eapply PROMISES0 | eapply x0 | eauto..].
        ii. des. rename mem1' into promises'.
        exploit MemoryReorder.split_add; [eapply MEM0 | eapply MEM | eauto..].
        ii. des.
        left.
        do 2 eexists. split.
        econstructor.
        econstructor.
        eapply ADD1.
        eapply ADD0.
        ss.
        ii; ss.
        ss.
        ss.
        econstructor; eauto; ss.
        econstructor.
        econstructor.
        eapply SPLIT2.
        eapply SPLIT0.
        ss.
        do 2 eexists; eauto.
        do 2 eexists; eauto.
        eapply x1.
        i.
        eapply RELEASE in H.
        eapply reserve_non_synch_loc; eauto.
      }
      {
        assert(Time.lt to1 from2).
        {
          assert(Time.lt to1 ts3).
          {
            inv MEM0.
            inv SPLIT; eauto.
          }
          destruct (Time.le_lt_dec ts3 from2); eauto.
          eapply DenseOrderFacts.lt_le_lt; eauto.
          inv MEM.
          inv ADD.
          eapply Memory.split_get0 in MEM0; des.
          destruct (Time.le_lt_dec ts3 to2).
          unfold Memory.get in GET2.
          unfold Cell.get in GET2.
          eapply DISJOINT in GET2.
          unfold Interval.disjoint in GET2.
          specialize (GET2 ts3).
          exploit GET2.
          econstructor; eauto.
          econstructor; ss; eauto.
          eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
          ii; ss.
          destruct (Time.le_lt_dec to2 to1).
          unfold Memory.get in GET1.
          unfold Cell.get in GET1.
          eapply DISJOINT in GET1.
          unfold Interval.disjoint in GET1.
          specialize (GET1 to2).
          exploit GET1.
          econstructor; eauto; ss.
          eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
          econstructor; ss; eauto.
          ii; ss.
          unfold Memory.get in GET2.
          unfold Cell.get in GET2.
          eapply DISJOINT in GET2.
          unfold Interval.disjoint in GET2.
          specialize (GET2 to2).
          exploit GET2.
          econstructor; eauto; ss.
          eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
          econstructor; ss; eauto.
          eapply Time.le_lteq; ss; eauto.
          ii; ss.
        }
        exploit MemoryReorder.remove_add_disjts; [eapply REMOVE | eapply PROMISES | eauto..].
        right. eapply Time.le_lteq; eauto.
        ii; des.
        exploit MemoryReorder.split_add; [eapply PROMISES0 | eapply x0 | eauto..].
        ii; des.
        exploit MemoryReorder.split_add; [eapply MEM0 | eapply MEM | eauto..].
        ii; des.
        left.
        do 2 eexists.
        split.
        econstructor.
        econstructor.
        eapply ADD1. eapply ADD0.
        ss.
        ii; ss.
        ss.
        ss.
        econstructor; eauto.
        econstructor.
        econstructor.
        eapply SPLIT2.
        eapply SPLIT0.
        ss.
        do 2 eexists; eauto.
        do 2 eexists; eauto.
        eauto.
        i; ss.
        eapply RELEASE in H0.
        eapply reserve_non_synch_loc; eauto.
      }
    }
    {
      exploit MemoryReorder.remove_add_disjloc; [eapply REMOVE | eapply PROMISES | eauto..].
      ii; des. rename mem1' into promises1'.
      exploit MemoryReorder.split_add; [eapply PROMISES0 | eapply x0 | eauto..].
      ii; des.
      exploit MemoryReorder.split_add; [eapply MEM0 | eapply MEM | eauto..].
      ii; des.
      left.
      do 2 eexists.
      split.
      econstructor.
      econstructor.
      eapply ADD1.
      eapply ADD0.
      ss.
      ii; ss.
      ss.
      ss.
      econstructor; eauto.
      econstructor.
      econstructor.
      eapply SPLIT2.
      eapply SPLIT0.
      ss.
      do 2 eexists; eauto.
      do 2 eexists; eauto.
      eauto.
      i.
      eapply RELEASE in H0.
      eapply reserve_non_synch_loc; eauto.
    }
  - (* lower *)
    des; subst.
    destruct (classic (loc1 = loc2)); subst.
    {
      destruct (Time.le_lt_dec to2 from1).
      {
        exploit MemoryReorder.remove_add_disjts; [eapply REMOVE | eapply PROMISES | eauto..].
        ii. des. rename mem1' into promises1'.
        exploit MemoryReorder.lower_add; [eapply PROMISES0 | eapply x0 | eauto..].
        ii. des. rename mem1' into promises'.
        exploit MemoryReorder.lower_add; [eapply MEM0 | eapply MEM | eauto..].
        ii. des.
        left.
        do 2 eexists. split.
        econstructor.
        econstructor.
        eapply ADD1.
        eapply ADD0.
        ss.
        ii; ss.
        ss.
        ss.
        econstructor; eauto; ss.
        i. eapply RELEASE in H.
        eapply reserve_non_synch_loc; eauto.
      }
      {
        assert(Time.le to1 from2).
        {
          destruct (Time.le_lt_dec to1 from2); eauto.
          clear - MEM0 MEM l l0.
          inv MEM.
          inv ADD.
          dup MEM0.
          eapply Memory.lower_get0 in MEM1; des.
          unfold Memory.get in GET0.
          unfold Cell.get in GET0.
          eapply DISJOINT in GET0.
          unfold Interval.disjoint in GET0.
          destruct (Time.le_lt_dec to2 to1).
          specialize (GET0 to2).
          exploit GET0; ss.
          econstructor; ss; eauto.
          eapply Time.le_lteq; ss; eauto.
          eapply Memory.get_ts in GET.
          specialize (GET0 to1).
          exploit GET0.
          econstructor; ss; eauto.
          eapply Time.le_lteq; ss; eauto.
          des; subst.
          cut(Time.le Time.bot from2); ii.
          eapply TimeFacts.lt_le_lt in l0; eauto.
          eapply DenseOrder.DenseOrder.lt_strorder_obligation_1 in l0; ss.
          eapply Time.bot_spec.
          econstructor; ss; eauto.
          eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
          ii; ss.
        }
        exploit MemoryReorder.remove_add_disjts; [eapply REMOVE | eapply PROMISES | eauto..].
        ii. des. rename mem1' into promises1'.
        exploit MemoryReorder.lower_add; [eapply PROMISES0 | eapply x0 | eauto..].
        ii. des. rename mem1' into promises'.
        exploit MemoryReorder.lower_add; [eapply MEM0 | eapply MEM | eauto..].
        ii. des.
        left.
        do 2 eexists.
        split.
        econstructor.
        econstructor.
        eapply ADD1.
        eapply ADD0.
        ss.
        ii; ss.
        ss.
        ss.
        econstructor; eauto.
        ss; i.
        eapply RELEASE in H0.
        eapply reserve_non_synch_loc; eauto.
      }
    }
    {
      exploit MemoryReorder.remove_add_disjloc; [eapply REMOVE | eapply PROMISES | eauto..].
      ii; des. rename mem1' into promises1'.
      exploit MemoryReorder.lower_add; [eapply PROMISES0 | eapply x0 | eauto..].
      ii; des.
      exploit MemoryReorder.lower_add; [eapply MEM0 | eapply MEM | eauto..].
      ii; des.
      left.
      do 2 eexists.
      split.
      econstructor.
      econstructor.
      eapply ADD1.
      eapply ADD0.
      ss.
      ii; ss.
      ss.
      ss.
      econstructor; eauto.
      i; ss.
      eapply RELEASE in H0.
      eapply reserve_non_synch_loc; eauto.
    }
  - (* reserve contradiction *)
    ss.
Qed.

Lemma reorder_write_reserve_steps_attached:
  forall n lo
    lc1 sc1 mem1 loc from ts val releasedr releasedw ord
    lc2 sc2 to mem2 lc3 mem3 lang st st' e''
    (WRITE: Local.write_step lc1 sc1 mem1 loc from ts val releasedr releasedw ord lc2 sc2 mem2
                             Memory.op_kind_add lo)
    (RSV: Local.promise_step lc2 mem2 loc ts to Message.reserve lc3 mem3 Memory.op_kind_add)
    (RSVs: rtcn (Thread.reserve_step lo) n (Thread.mk lang st lc3 sc2 mem3) e''),
  exists lc' sc' mem' lc'' sc'' mem'',
    rtc (Thread.reserve_step lo) (Thread.mk lang st' lc1 sc1 mem1) (Thread.mk lang st' lc' sc' mem') /\
    Local.write_step lc' sc' mem' loc from ts val releasedr releasedw ord lc'' sc'' mem''
                     Memory.op_kind_add lo /\
    Local.promise_step lc'' mem'' loc ts to Message.reserve
                       (Thread.local e'') (Thread.memory e'') Memory.op_kind_add /\ (Thread.sc e'' = sc1).
Proof.
  induction n; intros.
  - inv RSVs; eauto.
    assert(SC: sc1 = sc2). { inv WRITE; ss. }
    do 6 eexists.
    split; eauto.
  - inv RSVs.
    assert(SC: sc1 = sc2). { inv WRITE; ss. }
    inv A12.
    inv STEP.
    destruct (classic (loc = loc0)); subst.
    {
      assert(Time.le to0 from \/ Time.le to from0).
      {
        clear - RSV WRITE LOCAL.
        inv RSV; inv WRITE; inv LOCAL; ss.
        inv PROMISE; inv WRITE0; inv PROMISE0.
        inv PROMISE; ss.
        assert(Time.lt ts to).
        {
          inv MEM.
          inv ADD; eauto.
        }
        exploit add_succeed_wf; [eapply MEM0 | eauto..].
        ii; des.
        eapply Memory.add_get0 in MEM1; eauto; des.
        eapply Memory.add_get1 in GET0; eauto.
        eapply Memory.add_get0 in MEM; eauto; des.
        eapply DISJOINT in GET0.
        eapply DISJOINT in GET2.
        clear - GET2 GET0 TO1 H.
        destruct(Time.le_lt_dec to0 from); eauto.
        destruct(Time.le_lt_dec to from0); eauto.
        destruct(Time.le_lt_dec to0 ts).
        {
          unfold Interval.disjoint in GET0.
          specialize (GET0 to0).
          exploit GET0.
          econstructor; ss; eauto.
          eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
          econstructor; ss; eauto.
          ii; ss.
        }
        {
          destruct(Time.le_lt_dec to0 to).
          {
            unfold Interval.disjoint in GET2.
            specialize (GET2 to0).
            exploit GET2.
            econstructor; ss; eauto.
            eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
            econstructor; ss; eauto.
            ii; ss.
          }
          {

            unfold Interval.disjoint in GET2.
            specialize (GET2 to).
            exploit GET2.
            econstructor; ss; eauto.
            eapply Time.le_lteq; ss; eauto.
            econstructor; ss; eauto.
            eapply DenseOrder.DenseOrder_le_PreOrder_obligation_1; eauto.
            ii; ss.
          }
        }
      }
      exploit reorder_promise_reserve_promise; [eapply RSV | eapply LOCAL | eauto..].
      ii; des; subst; ss.
      exploit reorder_write_reserve; [eapply WRITE | eapply STEP1 | eauto..].
      ii; des.
      {
        eapply IHn in A23.
        2: eapply x1.
        2: eapply STEP2.
        des.
        do 6 eexists.
        split.
        eapply Relation_Operators.rt1n_trans; [idtac | eapply A23].
        econstructor; eauto.
        econstructor; eauto.
        split; eauto.
      }
      {
        assert(Time.lt from0 to0).
        {
          clear - LOCAL.
          inv LOCAL. inv PROMISE.
          inv MEM. inv ADD; eauto.
        }
        assert(Time.lt from ts).
        {
          clear - WRITE.
          inv WRITE. inv WRITE0. inv PROMISE.
          inv MEM. inv ADD; eauto.
        }
        subst. clear - H H1 H0.
        eapply DenseOrderFacts.le_lt_lt in H; eauto.
        eapply DenseOrder.DenseOrder.lt_strorder_obligation_2 in H; eauto.
        eapply H in H0; eauto.
        eapply DenseOrder.DenseOrder.lt_strorder_obligation_1 in H0; ss.
      }

      exploit reorder_write_reserve; [eapply WRITE | eapply STEP1 | eauto..].
      ii; des.
      {
        eapply IHn in A23.
        2: eapply x1.
        2: eapply STEP2.
        des.
        do 6 eexists.
        split.
        eapply Relation_Operators.rt1n_trans; [idtac | eapply A23].
        econstructor; eauto.
        econstructor; eauto.
        split; eauto.
      }
      {
        assert(Time.lt ts to).
        {
          clear - STEP2.
          inv STEP2. inv PROMISE. inv MEM.
          inv ADD; eauto.
        }
        assert(Time.lt ts from0).
        {
          eapply DenseOrderFacts.lt_le_lt; eauto.
        }
        subst.
        eapply DenseOrder.DenseOrder.lt_strorder_obligation_1 in H1; ss.
      }
    }
    {
      exploit reorder_promise_reserve_promise; [eapply RSV | eapply LOCAL | eauto..].
      ii; des; subst; ss.
      exploit reorder_write_reserve; [eapply WRITE | eapply STEP1 | eauto..].
      ii; des; subst; ss.
      eapply IHn in A23.
      2: eapply x1.
      2: eapply STEP2.
      des.
      do 6 eexists.
      split.
      eapply Relation_Operators.rt1n_trans; [idtac | eapply A23].
      econstructor; eauto.
      econstructor; eauto.
      split; eauto.
    }
Qed.

Lemma reorder_fence_reserve
      lc1 sc1 mem1 ordr ordw lc2 sc2
      loc2 from2 to2 lc3 mem3
      (FENCE: Local.fence_step lc1 sc1 ordr ordw lc2 sc2)
      (NOSC: ordw <> Ordering.seqcst)
      (PROMISE: Local.promise_step lc2 mem1 loc2 from2 to2 Message.reserve lc3 mem3 Memory.op_kind_add):
  exists lc',
    Local.promise_step lc1 mem1 loc2 from2 to2 Message.reserve lc' mem3 Memory.op_kind_add /\
    Local.fence_step lc' sc1 ordr ordw lc3 sc2.
Proof.
  inv FENCE.
  inv PROMISE; ss.
  eexists.
  split.
  econstructor; eauto.
  econstructor; eauto; ss.
  intro.
  eapply RELEASE in H.
  inv PROMISE0.
  eapply reserve_non_synch; eauto.
Qed.

Lemma reorder_program_step_reserve_steps:
  forall n lang (e e' e'': Thread.t lang) te lo
    (PROG: Thread.program_step te lo e e')
    (RSVs: rtcn (Thread.reserve_step lo) n e' e'')
    (NOSC: ~(exists ordr, te = ThreadEvent.fence ordr Ordering.seqcst))
    (NO_OUT: ThreadEvent.get_machine_event te = MachineEvent.silent),
    (exists e0, rtc (Thread.reserve_step lo) e e0 /\ Thread.program_step te lo e0 e'') \/
    (exists e0 e1 loc to ts from val released ordw,
        rtc (Thread.reserve_step lo) e e0 /\
        Thread.program_step te lo e0 e1 /\ te = ThreadEvent.write loc from ts val released ordw /\
        Thread.promise_step false (ThreadEvent.promise loc ts to Message.reserve Memory.op_kind_add) e1 e'') \/
    (exists e0 e1 loc to ts from valr valw releasedr releasedw ordr ordw,
        rtc (Thread.reserve_step lo) e e0 /\
        Thread.program_step te lo e0 e1 /\
        te = ThreadEvent.update loc from ts valr valw releasedr releasedw ordr ordw /\
        Thread.promise_step false (ThreadEvent.promise loc ts to Message.reserve Memory.op_kind_add) e1 e'').
Proof.
  induction n; intros.
  - inv RSVs; eauto.
  - inv RSVs.
    inv PROG; ss.
    inv LOCAL.
    {
      (* silent *)
      left.
      inv A12.
      inv STEP.
      eapply IHn with (e := Thread.mk lang st1 lc0 sc2 mem0)
                      (te := ThreadEvent.silent) in A23; eauto.
      des.
      {
        eexists.
        split.
        eapply Relation_Operators.rt1n_trans; [idtac | eapply A23]; eauto.
        econstructor; eauto.
        econstructor; eauto.
        ss.
      }
      ss. ss.
    }
    {
      (* read *)
      inv A12.
      inv STEP.
      exploit reorder_read_reservation; [eapply LOCAL0 | eapply LOCAL | eauto..].
      ii; des.
      eapply IHn with (e := Thread.mk lang st1 lc' sc2 mem0)
                      (te := ThreadEvent.read loc ts val released ord) in A23; eauto.
      des.
      {
        left.
        eexists.
        split.
        eapply Relation_Operators.rt1n_trans; [idtac | eapply A23]; eauto.
        econstructor; eauto.
        econstructor; eauto.
        ss.
      }
      ss. ss.
    }
    {
      (* write *)
      inv A12.
      inv STEP.
      exploit reorder_write_reserve; [eapply LOCAL0 | eapply LOCAL | eauto..].
      ii; des.
      {
        eapply IHn with (e := Thread.mk lang st1 lc' sc1 mem')
                        (te := ThreadEvent.write loc from to val released ord) in A23; eauto.
        des.
        {
          left.
          eexists.
          split.
          eapply Relation_Operators.rt1n_trans; [idtac | eapply A23]; eauto.
          econstructor; eauto.
          econstructor; eauto.
          ss.
        }
        {
          right. left.
          ss.
          do 9 eexists.
          split.
          eapply Relation_Operators.rt1n_trans; [idtac | eapply A23]; eauto.
          econstructor; eauto.
          econstructor; eauto.
          split; eauto.
        }
        ss.
      }
      {
        subst.
        destruct e''.
        dup A23.
        eapply rtcn_rtc in A0.
        eapply reserve_sc_nochange in A0; ss; des; subst.
        eapply reorder_write_reserve_steps_attached with (st' := st1) in A23; eauto.
        ii; des.
        right. left.
        do 9 eexists.
        split; eauto.
        split; eauto.
        split; eauto.
        instantiate (1 := to0).
        ss; subst.
        assert(sc' = sc'').
        {
          clear - A0.
          inv A0; eauto.
        }
        subst.
        eapply reserve_sc_nochange in A23. ss; des; subst.
        econstructor; eauto.
      }
    }
    {
      (* update *)
      inv A12. inv STEP.
      exploit reorder_write_reserve; [eapply LOCAL2 | eapply LOCAL | eauto..].
      ii; des.
      {
        (* not attach *)
        exploit reorder_read_reservation; [eapply LOCAL1 | eapply x0 | eauto..].
        ii; des.
        eapply IHn with (e := Thread.mk lang st1 lc'0 sc1 mem') in A23; eauto.
        des.
        {
          left.
          eexists.
          split.
          eapply Relation_Operators.rt1n_trans; [idtac | eapply A23 | eauto..].
          econstructor; eauto.
          econstructor; eauto.
          eauto.
        }
        {
          ss.
        }
        {
          inv A1.
          right; right.
          do 12 eexists.
          split.
          eapply Relation_Operators.rt1n_trans; [idtac | eapply A23 | eauto..].
          econstructor; eauto.
          econstructor; eauto.
          eauto.
        }
      }
      {
        (* attach *)
        subst.
        exploit reorder_write_reserve_steps_attached; [eapply LOCAL2 | eapply LOCAL | eauto..].
        instantiate (1 := st1). ii; des.
        eapply rtc_rtcn in x0. destruct x0.
        exploit reorder_read_reserve_steps; [eapply LOCAL1 | eapply H | eauto..].
        ii; des.
        right; right.
        eapply rtcn_rtc in A23.
        destruct e''; ss; subst.
        eapply reserve_sc_nochange in A23.
        ss; des; subst.
        do 12 eexists.
        split; [eapply x4 | eauto..].
        split; eauto.
        split; eauto.
        instantiate (1 := to).
        eapply reserve_sc_nochange in x4; ss; des; subst.
        inv x1; ss.
      }
    }
    {
      (* fence *)
      inv A12. inv STEP.
      exploit reorder_fence_reserve; [eapply LOCAL0 | idtac | eapply LOCAL | eauto..].
      clear - NOSC; intro; subst.
      contradiction NOSC; eauto.
      ii; des.
      eapply IHn with (e := Thread.mk lang st1 lc' sc1 mem0) in A23; eauto.
      des.
      {
        left.
        eexists. split.
        eapply Relation_Operators.rt1n_trans; [idtac | eapply A23 | eauto..].
        econstructor; eauto.
        econstructor; eauto.
        eauto.
      }
      ss. ss.
    }
    {
      (* output *)
      ss.
    }
Qed.

Lemma reorder_lower_step_reserve_steps:
  forall n lang (e e' e'': Thread.t lang) te lo
    (PROG: Thread.promise_step true te e e')
    (RSVs: rtcn (Thread.reserve_step lo) n e' e'')
    (NOCCL: ~ThreadEvent.is_cancel te),
    (exists e0, rtc (Thread.reserve_step lo) e e0 /\ Thread.promise_step true te e0 e'').
Proof.
  induction n; intros.
  - inv RSVs; eauto.
  - inv RSVs.
    cut (rtcn (Thread.reserve_step lo) 1%nat e' a2). i.
    exploit reorder_promise_step_reserve_steps; [eapply PROG | eapply H | eauto ..].
    inv PROG.
    destruct kind; ss.
    destruct msg1; ss.
    destruct msg; ss.
    destruct msg; ss. inv LOCAL. inv PROMISE. ss.
    ii.
    des; ss.
    eapply IHn in x1; eauto. des.
    eexists. split.
    eapply Basic.rtc_PreOrder_obligation_2; [eapply x0 | eapply x1].
    eauto.
    subst.
    inv PROG; ss.
    econs; eauto.
Qed.


(****************************************************************************)
(* Copyright (c) Facebook, Inc. and its affiliates.                         *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License");          *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)
From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype path choice.
Require Import Eqdep.
From fcsl
Require Import pred prelude ordtype pcm finmap unionmap heap.
From LibraChain
Require Import SeqFacts Chains HashSign Blocks.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* A formalization of a block forests *)

(************************************************************)
(******************* <parameters> ***************************)
(************************************************************)
Section State.

Variable Hash : countType.
Variables (PublicKey: countType) (Signature: countType) (Address: hashType PublicKey).

Variables (Command NodeTime: countType).

(* The Block Data (w/o signatures) *)
Notation BDataType := (BlockData Hash Signature Address Command NodeTime).

Variable hashB: BDataType -> Hash.
Hypothesis inj_hashB: injective hashB.

Variable verifB: Hash -> PublicKey -> Signature -> bool.

(* Block Type : block data with signatures *)
Notation BType := (BlockType inj_hashB verifB).
Notation QC := (QuorumCert Hash Signature (Phant Address)).

Implicit Type b: BDataType.

Parameter GenesisBlock : BType.

Definition genesis_round := (round GenesisBlock).

Implicit Type (bd: BDataType).

Definition qc_of bd := (proof bd).
Definition qc_hash bd := (block_hash (qc_vote_data (qc_of bd))).
Definition qc_round bd := (block_round (qc_vote_data (qc_of bd))).
Definition qc_parent_hash bd := (parent_block_hash (qc_vote_data (qc_of bd))).
Definition qc_parent_round bd := (parent_block_round (qc_vote_data (qc_of bd))).

Definition parent b1 b2 := (hashB b1 == qc_hash b2) && (round b1 == qc_round b2) && (qc_hash b1 == qc_parent_hash b2) && (qc_round b1 == qc_parent_round b2).
Definition chained (bc: seq BType):= path [eta parent: rel BType] GenesisBlock bc.

Lemma rounds_transitive:
  transitive (fun b1 b2 => (round b1) < (round b2)).
Proof.
by move=> b1 b2 b3; apply ltn_trans.
Qed.

Lemma rounds_irreflexive:
  irreflexive (fun b1 b2 => (round b1) < (round b2)).
Proof. by move=> b; rewrite ltnn. Qed.

(************************************************************)
(** Consensus State                                        **)
(************************************************************)

Record ConsensusState := mkConsensusState {
  last_vote_round: nat;
  preferred_block_round: nat;
}.

Definition consensusstate2nats (cs: ConsensusState) :=
  let: mkConsensusState lvr pvr := cs in (lvr, pvr).

Definition nats2consensusstate (nats: nat * nat) :=
  let: (lvr, pbr) := nats in mkConsensusState lvr pbr.

Lemma can_cs_nats: ssrfun.cancel consensusstate2nats nats2consensusstate.
Proof. by move => []. Qed.

Definition cs_eqMixin := CanEqMixin can_cs_nats.
Canonical cs_eqType := EqType _ cs_eqMixin.
Definition cs_choiceMixin := CanChoiceMixin can_cs_nats.
Canonical cs_choiceType := ChoiceType _ cs_choiceMixin.
Definition cs_countMixin := CanCountMixin can_cs_nats.
Canonical cs_countType := CountType _ cs_countMixin.

Definition genesis_state := mkConsensusState genesis_round genesis_round.

Implicit Type state: ConsensusState.

Definition update state (qc: QC) :=
  let: round := (parent_block_round (qc_vote_data qc)) in
  if (round > preferred_block_round state) then
    mkConsensusState (last_vote_round state) (round)
  else
    state.

Lemma update_eq_lvr state qc :
  last_vote_round (update state qc) = last_vote_round state.
Proof.
rewrite /update.
by case (parent_block_round (qc_vote_data qc) > preferred_block_round state).
Qed.

Lemma update_pbr_geq state qc :
  preferred_block_round state <= preferred_block_round (update state qc).
Proof.
rewrite /update.
case H: (parent_block_round (qc_vote_data qc) > preferred_block_round state) => //.
by move/ltnW: H => ->.
Qed.

Lemma update_qc_gt state qc :
  parent_block_round (qc_vote_data qc) <= preferred_block_round (update state qc).
Proof.
rewrite /update; case H: (preferred_block_round state < (parent_block_round (qc_vote_data qc))) => //.
by rewrite leqNgt H.
Qed.

Lemma update_pbr_P state qc:
  reflect (preferred_block_round (update state qc) = parent_block_round (qc_vote_data qc))
          (preferred_block_round state <= parent_block_round (qc_vote_data qc)).
Proof.
apply: (iffP idP); rewrite /update;
case H: (parent_block_round (qc_vote_data qc) > preferred_block_round state);
rewrite leq_eqVlt H ?orbF ?orbT //; move/eqP=> //.
Qed.

Lemma update_maxn state qc:
  update state qc =
  mkConsensusState (last_vote_round state)
                   (maxn (preferred_block_round state) (parent_block_round (qc_vote_data qc))).
Proof.
rewrite /update /maxn; case: ((preferred_block_round state) < (parent_block_round (qc_vote_data qc))) => //=.
by case state.
Qed.

(************************************************************)
(** Voting after update with the QC                        **)
(************************************************************)

Definition votable state b :=
  let: (rd, qcr, lvr, pbr) :=
     ((round b), (qc_round b),
     (last_vote_round state),
     (preferred_block_round state)) in [&& rd > lvr & qcr >= pbr].

Lemma votable_updateP state b:
  reflect (votable (update state (qc_of b)) b)
  (votable state b && (qc_round b >= qc_parent_round b)).
Proof.
  apply: (iffP andP); rewrite /votable update_eq_lvr.
- rewrite /update; case (preferred_block_round state < parent_block_round (qc_vote_data (qc_of b)));
  move=> [H1 H2]; move/andP: H1=> [-> H1] //; rewrite ltnW //.
- move/andP => [->] //= H.
  apply/andP; rewrite (leq_trans (update_pbr_geq _ _) H) //=.
  by apply: (leq_trans (update_qc_gt state _)).
Qed.

Lemma votable_update_round_geq state b:
  (votable (update state (qc_of b)) b) =
  (votable state b && (qc_round b >= qc_parent_round b)).
Proof.
by apply/(sameP idP); apply: votable_updateP.
Qed.

Definition voting_rule state (b: BDataType) :=
  let after_update := update state (qc_of b) in
  if votable (after_update) b then
    let newState :=
        mkConsensusState (round b) (preferred_block_round after_update)
    in
    (newState, true)
  else (after_update, false).

Definition voted_on state b := (voting_rule state b).2.

Lemma voted_on_votable state b:
  voted_on state b = votable (update state (qc_of b)) b.
Proof.
rewrite /voted_on /voting_rule.
by case: (votable (update state (qc_of b)) b) => //.
Qed.

Lemma voted_br_gt_qcr state b:
  voted_on state b ->
  qc_round b >= qc_parent_round b.
Proof.
rewrite /voted_on /voting_rule.
case H: (votable (update state (qc_of b)) b).
- by move/votable_updateP: H; move/andP => [_ ->].
- by rewrite /update; case (preferred_block_round state < _).
Qed.

Lemma voted_pr_gt_qcr state b:
  voted_on state b ->
  qc_round b >= preferred_block_round state.
Proof.
rewrite /voted_on /voting_rule.
case H: (votable (update state (qc_of b)) b).
- by move/votable_updateP: H; rewrite andbC /=; move/andP=>[_]; move/andP=>[_ ->].
- by rewrite /update; case (preferred_block_round state < _).
Qed.

Lemma ineq_voted_on state b:
  (voted_on state b) = [&& (round b > last_vote_round state),
                         (qc_round b >= preferred_block_round state) &
                         (qc_round b >= qc_parent_round b)].
Proof.
by rewrite voted_on_votable votable_update_round_geq /votable -andbA.
Qed.

Lemma vote_genesis_N: voted_on genesis_state GenesisBlock = false.
Proof.
by rewrite voted_on_votable /votable update_eq_lvr /= /genesis_round ltnn.
Qed.

Definition next_state state b := (voting_rule state b).1.

Lemma next_state_pbr_update state b :
  preferred_block_round (next_state state b) = preferred_block_round (update state (qc_of b)).
Proof.
by rewrite /next_state /voting_rule; case (votable (update state (qc_of b)) b).
Qed.

Lemma next_state_pbr_geq state b:
  preferred_block_round state <= preferred_block_round (next_state state b).
Proof.
by rewrite next_state_pbr_update update_pbr_geq.
Qed.

Lemma next_state_lvr_voted state b :
  reflect (last_vote_round state < last_vote_round (next_state state b)) (voted_on state b).
Proof.
rewrite /next_state /voting_rule -voted_on_votable; apply: (iffP idP).
- move=>H; rewrite (H)=>//=; move:H; rewrite ineq_voted_on.
  by move/andP=>[-> _].
- by case: (voted_on state b); rewrite // update_eq_lvr ltnn.
Qed.

Lemma next_state_lvr_round state b:
  voted_on state b -> last_vote_round (next_state state b) = round b.
Proof.
by rewrite voted_on_votable /next_state /voting_rule=>-> /=.
Qed.

Lemma next_state_lvr_static state b:
  ~~ voted_on state b -> last_vote_round (next_state state b) = last_vote_round state.
Proof.
rewrite voted_on_votable /next_state /voting_rule.
by move/negbTE=>->; rewrite update_eq_lvr.
Qed.

Lemma next_state_lvr_if state b:
  next_state state b =
  let: pbr:= preferred_block_round (update state (qc_of b)) in
     if (voted_on state b) then
       mkConsensusState (round b) pbr
     else
       mkConsensusState (last_vote_round state) pbr.
Proof.
rewrite /next_state /voting_rule -voted_on_votable /=; case H: (voted_on state b)=> //=.
by rewrite update_maxn /=.
Qed.

Lemma next_state_lvr_leq state b:
  last_vote_round state <= last_vote_round (next_state state b).
Proof.
case H: (voted_on state b).
- by rewrite leq_eqVlt; move/next_state_lvr_voted: H=>->; rewrite orbT.
- by rewrite /next_state /voting_rule -voted_on_votable H update_eq_lvr.
Qed.

Lemma next_state_maxn state b:
  (next_state state b) =
  let: u_pbr := (maxn (preferred_block_round state) (qc_parent_round b)) in
  mkConsensusState
    (if (round b >= (last_vote_round state).+1) && (qc_round b >= u_pbr) then round b else last_vote_round state)
    u_pbr.
Proof.
rewrite /next_state /voting_rule update_maxn.
set pbr:= (maxn (preferred_block_round state) (qc_parent_round b)).
rewrite /votable /=.
by case H: ((last_vote_round state < round b) && (pbr <= qc_round b)).
Qed.

Lemma pbr_next_stateC state b c:
  preferred_block_round (next_state (next_state state b) c) =
  preferred_block_round (next_state (next_state state c) b).
Proof.
rewrite (next_state_maxn (next_state state c) b) next_state_maxn /=.
by rewrite !next_state_maxn /= maxnAC.
Qed.

Lemma voting_next_voted state b :
  voting_rule state b = (next_state state b, voted_on state b).
Proof.
by apply surjective_pairing.
Qed.

Lemma voting_next_N state b: voted_on (next_state state b) b = false.
Proof.
rewrite voted_on_votable votable_update_round_geq /votable.
rewrite {1}/next_state /voting_rule.
case H:(votable (update state (qc_of b)) b) => /=; first by rewrite ltnn.
rewrite /votable -next_state_pbr_update in H.
by rewrite H andFb.
Qed.

Lemma voting_update_progress state qc x:
  voted_on (update state qc) x -> voted_on state x.
Proof.
rewrite 2!ineq_voted_on update_maxn /= geq_max.
by move/andP=>[->]; move/andP =>[H ->]; move/andP: H=>[-> _].
Qed.

Lemma voting_progress state b x:
  voted_on (next_state state b) x -> voted_on state x.
Proof.
rewrite 2!ineq_voted_on; move/andP=> [Hlvr]; move/andP=> [Hpbr Hbr].
rewrite (leq_ltn_trans (next_state_lvr_leq _ _) Hlvr).
by rewrite (leq_trans (next_state_pbr_geq _ _) Hpbr) /=.
Qed.

Lemma voting_gt state b x:
  voted_on (next_state state b) x ->
  ~~ voted_on state b || (round b < round x).
Proof.
move=> H; move: (H); rewrite ineq_voted_on; move/andP=> [Hlvr _].
case I: (voted_on state b)=> //.
by rewrite (next_state_lvr_round I) in Hlvr.
Qed.

Lemma non_voted_on_update state b x:
  ~~ voted_on state b ->
  voted_on (next_state state b) x = voted_on (update state (qc_of b)) x.
Proof.
rewrite next_state_lvr_if; move/negbTE=>->.
by rewrite update_maxn.
Qed.

Lemma pbr_update_next state b x:
  preferred_block_round (update (next_state state b) (qc_of x)) =
  preferred_block_round (update (update state (qc_of b)) (qc_of x)).
Proof.
by rewrite next_state_maxn !update_maxn /=.
Qed.

Lemma voted_next_update state b x:
  voted_on (next_state state b) x ->
  voted_on (update state (qc_of b)) x.
Proof.
move=> H; move/voting_progress: (H); rewrite ineq_voted_on; move/andP=> [Hs _].
move: H; rewrite ineq_voted_on next_state_pbr_update.
move/andP=>[Hlvr]; move/andP=> [H1 H2].
by rewrite ineq_voted_on update_eq_lvr Hs H1 H2.
Qed.

Lemma next_state_updateC state qc x:
  voted_on (update state qc) x ->
  next_state (update state (qc)) x =
  update (next_state state x) qc.
Proof.
move => H; rewrite /next_state /voting_rule -2!voted_on_votable H.
by move/voting_update_progress: H=> -> /=; rewrite !update_maxn /= maxnAC.
Qed.

Lemma voted_on_maxn state b:
  (voted_on state b) =
  (round b >=  (last_vote_round state).+1) && (qc_round b >= maxn (preferred_block_round state)
               (qc_parent_round b)).
Proof.
by rewrite !geq_max  ineq_voted_on.
Qed.

(************************************************************)
(** Voting in Sequence                                     **)
(************************************************************)

Implicit Type bseq: seq BDataType.

(* node_processing is a slight modification on a scanleft of the voting rules
over a seq of block *)
Fixpoint process_aux state bseq res :=
  if bseq is x::s then
    let: (new_state, vote) := (voting_rule state x) in
    process_aux new_state s ((state, vote) :: res)
  else
    (state, rev res).

Definition node_processing state bseq := process_aux state bseq [::].

Lemma size_process_aux state bseq res: size (process_aux state bseq res).2 = size bseq + size res.
Proof.
elim:bseq res state => [|x xs IHs] res state.
- by rewrite size_rev add0n.
- by rewrite /= voting_next_voted IHs /= addSnnS.
Qed.

Lemma size_processing state bseq : size (node_processing state bseq).2 = size bseq.
Proof.
by rewrite /node_processing size_process_aux addn0.
Qed.

Lemma processing_aux_state_res_irrel state bseq rs1 rs2:
  (process_aux state bseq rs1).1 = (process_aux state bseq rs2).1.
Proof.
elim: bseq state rs1 rs2 => [|b bs IHb] state rs1 rs2 //=; rewrite voting_next_voted.
by apply:IHb.
Qed.

Lemma processing_aux_rcons state bseq r rs:
  (process_aux state bseq (rcons rs r)).2 =
  r :: (process_aux state bseq rs).2.
Proof.
elim: bseq r rs state =>[| b bs IHb] r rs state => /=.
- by rewrite rev_rcons.
- by rewrite voting_next_voted -IHb -rcons_cons.
Qed.

Lemma processing_aux_rev state bseq res:
  (process_aux state bseq res).2 =
  rev res ++ (process_aux state bseq [::]).2.
Proof.
move: res bseq state; apply: last_ind=> [|rs r IHr] bseq state.
- by [].
- by rewrite processing_aux_rcons IHr rev_rcons.
Qed.

Lemma processing_aux_cons state b bs:
  (process_aux state (b::bs) [::]).2 =
  (state, voted_on state b) :: (process_aux (next_state state b) bs [::]).2.
Proof.
rewrite /= voting_next_voted -[[:: (state, voted_on _ _)]]cat0s cats1.
by rewrite processing_aux_rcons.
Qed.

Lemma processing_aux_cons2 state b bs:
  (process_aux state (b::bs) [::]) =
  let: (f_state, vbs) := (process_aux (next_state state b) bs [::]) in
  (f_state, (state, voted_on state b) ::vbs).
Proof.
rewrite /= voting_next_voted -[[:: (state, voted_on _ _)]]cat0s cats1.
rewrite [process_aux _ bs [::]]surjective_pairing -processing_aux_cons /=.
rewrite (processing_aux_state_res_irrel _ _ [::] [:: (state, voted_on state b)]).
by rewrite voting_next_voted -surjective_pairing.
Qed.

Lemma node_processing_cons state b bs:
  (node_processing state (b::bs)).2 =
  (state, voted_on state b) :: (node_processing (next_state state b) bs).2.
Proof.
by rewrite processing_aux_cons.
Qed.

Lemma node_processing_cons2 state b bs:
  (node_processing state (b::bs)) =
  let: (final_state, bsvotes) := node_processing (next_state state b) bs in
  (final_state, (state, voted_on state b)::bsvotes).
Proof.
by  rewrite /node_processing processing_aux_cons2.
Qed.

Lemma node_processing_cons1 state b bs:
  (node_processing state (b::bs)).1 =
  (node_processing (next_state state b) bs).1.
Proof.
case: bs state b=>[|x s ]=>state b; rewrite node_processing_cons2 //=.
by rewrite [node_processing _ _]surjective_pairing /=.
Qed.

Lemma node_processing_cat_cps state bs1 bs2 :
  (node_processing state (bs1 ++ bs2)) =
  let: (state1, seq1) := (node_processing state bs1) in
  let: (state2, seq2) := (node_processing state1 bs2) in
  (state2, seq1 ++ seq2).
Proof.
elim: bs1 state =>[| b bs IHb] state /=.
- by rewrite {2}[node_processing _ _]surjective_pairing -surjective_pairing.
rewrite 2!node_processing_cons2 IHb [node_processing (next_state _ _) _]surjective_pairing /=.
by rewrite [node_processing _  _]surjective_pairing.
Qed.

Lemma node_processing_rcons state bs b:
  (next_state (node_processing state bs).1 b) =
  (node_processing state (rcons bs b)).1.
Proof.
rewrite -cats1 node_processing_cat_cps /=.
rewrite {2}[node_processing _ _]surjective_pairing /=.
rewrite [node_processing _ [::b]]surjective_pairing /=.
by rewrite node_processing_cons1 /=.
Qed.

Lemma voting_progress_seq state bs b:
  voted_on (node_processing state bs).1 b -> voted_on state b.
Proof.
elim: bs state b => [|x s IHs] state b //=.
rewrite node_processing_cons1.
move/IHs; apply voting_progress.
Qed.

(************************************************************)
(** Consensus State Comparators                            **)
(************************************************************)

Definition comparator state1 :=
  ((last_vote_round state1).+1, (preferred_block_round state1)).

Definition state_compare state1 state2 :=
  ((comparator state1).1 <= (comparator state2).1) && ((comparator state1).2 <= (comparator state2).2).

Declare Scope state_scope.
Delimit Scope state_scope with STATE.
Open Scope state_scope.

Notation "state1 <% state2" := (state_compare state1 state2) (at level 40) :state_scope.

Lemma comparators_reflexive:
  reflexive state_compare.
Proof.
by move => x; rewrite /state_compare 2!leqnn.
Qed.

Lemma comparators_transitive:
  transitive state_compare.
Proof.
move => s2 s1 s3 H12 H23; move/andP: H12=> [H12fst H12snd].
move/andP: H23=> [H23fst H23snd]; rewrite /state_compare (leq_trans H12fst H23fst).
by rewrite (leq_trans H12snd).
Qed.

Lemma voting_comparator state x:
  (voted_on state x) ->
  (comparator (next_state state x) = ((round x).+1, (maxn (comparator state).2 (qc_parent_round x)))).
Proof.
rewrite next_state_lvr_if fun_if /comparator /= =>H.
by rewrite H update_maxn /= maxnC.
Qed.

Lemma non_voting_comparator state x:
  ~~ voted_on state x ->
  comparator (next_state state x) = ((comparator state).1, (maxn (comparator state).2 (qc_parent_round x))).
Proof.
move=>Hnv; rewrite next_state_lvr_if; move/negbTE: (Hnv)=>->.
by rewrite /comparator update_maxn /=.
Qed.

Lemma voting_comparatorE state x:
  comparator (next_state state x) =
  if (voted_on state x) then
    ((round x).+1, (maxn (comparator state).2 (qc_parent_round x)))
  else
    ((comparator state).1, (maxn (comparator state).2 (qc_parent_round x))).
Proof.
by case H:(voted_on state x); [rewrite (voting_comparator H)| rewrite (non_voting_comparator (negbT H))].
Qed.

Lemma voting_comparator_eq state b:
    (voted_on state b) =
    ((comparator state).1 <= round b) && ((comparator state).2 <= (qc_round b)) && ((qc_parent_round b) <= qc_round b).
Proof.
by  rewrite /comparator ineq_voted_on /= andbA.
Qed.

Lemma voting_gt_compare state1 state2 x:
  state1 <% state2 -> voted_on state2 x -> voted_on state1 x.
Proof.
move=> H; rewrite 2!voted_on_maxn.
move/andP=> [Hlv2 Hpr2]; move/andP: H=> [Hlv12 Hpr12].
rewrite (leq_trans Hlv12 Hlv2) /=; move:Hpr2; rewrite 2!geq_max.
by move/andP=> [Hpr2 ->]; rewrite (leq_trans Hpr12 Hpr2).
Qed.

Lemma voting_gt_compareN state1 state2 x:
  state1 <% state2 -> ~~ voted_on state1 x -> ~~ voted_on state2 x.
Proof.
by move=>H; apply: contra; apply: voting_gt_compare.
Qed.

Lemma voting_next_gt state x:
  state <% (next_state state x).
Proof.
rewrite next_state_lvr_if.
case Hx:(voted_on state x); rewrite /state_compare /=.
- move/idP: Hx; rewrite voted_on_maxn.
  rewrite geq_max; move/andP=> [Hlv Hpr].
  by rewrite update_maxn /= leq_max leqnn orTb andbT ltnW.
by rewrite update_maxn /= leq_max 2!leqnn orTb andTb.
Qed.

Lemma node_processing_sorted state bs:
  sorted (fun s1 s2 => s1 <% s2) (unzip1 (node_processing state bs).2).
Proof.
move: state; elim: bs=>[| b bs IHb] state //.
rewrite node_processing_cons; move:(IHb (next_state state b)); rewrite /path /sorted /=.
case H: (unzip1 (node_processing (next_state state b) bs).2) =>// [x xs].
rewrite /path -/(path _ _ _)=>-> /=; move:H; case bs=> [|y ys]//=.
rewrite andbT node_processing_cons /=; move/eqP; rewrite eqseq_cons.
by move/andP=>[/eqP<- _]; apply: voting_next_gt.
Qed.

Lemma node_processing_head state bs:
  unzip1 (node_processing state bs).2 = (if bs is x::xs then state :: unzip1 (node_processing (next_state state x) xs).2 else [::]).
Proof.
by case: bs=> [|x xs]//=; rewrite node_processing_cons /=.
Qed.

Lemma node_processing_path state bs:
  path (fun s1 s2 => s1 <% s2) state (unzip1 (node_processing state bs).2).
Proof.
move: (node_processing_sorted state bs); rewrite node_processing_head.
rewrite /sorted; case: bs=>[|b bs] //=; by rewrite comparators_reflexive.
Qed.

Lemma node_processing_last s0 state bs b:
  last s0 (unzip1 (node_processing state (rcons bs b)).2) = (node_processing state bs).1.
Proof.
elim: bs state s0 =>[| x s IHs] state s0 //=; first by rewrite node_processing_cons.
rewrite node_processing_cons node_processing_cons1 /unzip1 map_cons /= -/unzip1.
by rewrite (IHs (next_state state x)).
Qed.

(************************************************************)
(** Sequence of blocks which a node voted on             **)
(************************************************************)

Definition voted_in_processing state bseq :=
  mask (unzip2 (node_processing state bseq).2) bseq.

Lemma voted_in_processing_cat_cps state bs1 bs2:
  (voted_in_processing state (bs1 ++ bs2)) =
  let: b1 := (voted_in_processing state bs1) in
  let: b2 := (voted_in_processing (node_processing state bs1).1 bs2) in
  b1 ++ b2.
Proof.
rewrite /voted_in_processing node_processing_cat_cps /=.
rewrite 2![node_processing _ _]surjective_pairing /=.
rewrite -mask_cat; last by rewrite size_map size_processing.
by rewrite -map_cat /unzip2.
Qed.

Lemma voted_in_processing_cons state b bs:
  (voted_in_processing state (b::bs)) =
  (nseq (voted_on state b) b ++ (voted_in_processing (next_state state b) bs)).
Proof.
by rewrite /voted_in_processing node_processing_cons mask_cons.
Qed.

Lemma comparator_next state1 state2 b:
  comparator state1 = comparator state2
  -> comparator (next_state state1 b) = comparator (next_state state2 b).
Proof.
move=> H12; case H1: (voted_on state1 b); move: (H1); rewrite voting_comparator_eq H12 -voting_comparator_eq=> H2.
- by rewrite (voting_comparator H1) (voting_comparator H2) /=; move/eqP: H12; rewrite xpair_eqE; move/andP =>[_]; move/eqP=>->.
by rewrite (non_voting_comparator (negbT H1)) (non_voting_comparator (negbT H2)) H12.
Qed.

Lemma comparator_processing state1 state2 bseq:
  comparator state1 = comparator state2
  -> comparator (node_processing state1 bseq).1 = comparator (node_processing state2 bseq).1.
Proof.
elim: bseq state1 state2 =>[| x s IHs] state1 state2 H12 //.
by rewrite 2!node_processing_cons1 (IHs _ _ (comparator_next x H12)).
Qed.

Lemma next_state_repeat state b:
  (next_state (next_state state b) b) = (next_state state b).
Proof.
rewrite next_state_lvr_if voting_next_N update_maxn next_state_pbr_update update_maxn  /= -maxnA maxnn.
move: (next_state_pbr_update state b); rewrite update_maxn {2}/preferred_block_round=><-.
have H: forall s, s = {| last_vote_round := (last_vote_round s);
                    preferred_block_round:= (preferred_block_round s)|}; first by case.
by rewrite {3}(H (next_state state b)).
Qed.

Lemma voted_on_already state bs1 b:
  b \in bs1 ->
  voted_on (node_processing state bs1).1 b = false.
Proof.
elim/last_ind: bs1 state b => [|s x IHs] state b //=.
rewrite mem_rcons inE -node_processing_rcons; move/orP=>[Hb|Hb].
- by rewrite (eqP Hb) voting_next_N.
- apply/negbTE; rewrite (voting_gt_compareN (voting_next_gt _ x) _) //.
  by apply/negbT; apply: IHs.
Qed.

Lemma updated_already state bs1 b:
  b \in bs1 ->
  update (node_processing state bs1).1 (qc_of b) = (node_processing state bs1).1.
Proof.
have H: forall s, s = {| last_vote_round := (last_vote_round s);
                    preferred_block_round:= (preferred_block_round s)|}; first by case.
rewrite update_maxn=> Hb.
have Hpr: (preferred_block_round (node_processing state bs1).1 >= qc_parent_round b);
  last by move/maxn_idPl: Hpr=>->; symmetry; exact:H.
move: {H} Hb; elim/last_ind: bs1 state b => [|s x IHs] state b //.
rewrite mem_rcons inE -node_processing_rcons next_state_pbr_update update_maxn leq_max.
move/orP=>[Hb|Hb]; rewrite -/(qc_parent_round _) ?(eqP Hb) ?leqnn ?orbT //.
by rewrite IHs.
Qed.

Lemma next_state_already state bs1 b:
  b \in bs1 ->
  (next_state (node_processing state bs1).1 b) = (node_processing state bs1).1.
Proof.
move=> Hb; rewrite next_state_lvr_if (voted_on_already _ Hb) updated_already //; symmetry.
have H: forall s, s = {| last_vote_round := (last_vote_round s);
                    preferred_block_round:= (preferred_block_round s)|}; first by case.
by apply H.
Qed.

Lemma comparator_repeat state b:
  comparator (next_state (next_state state b) b) =
  comparator (next_state state b).
Proof.
by rewrite next_state_repeat.
Qed.

Lemma voted_in_processing_comparison state1 state2 bs:
  comparator state1 = comparator state2 ->
  voted_in_processing state1 bs = voted_in_processing state2 bs.
Proof.
elim: bs state1 state2=>[| x s IHs] state1 state2 H12 //.
rewrite /voted_in_processing 2!node_processing_cons 2!mask_cons.
rewrite -/(map snd) -/unzip2 -2!/(voted_in_processing (next_state _ x) s).
rewrite (IHs _ _ (comparator_next x H12)) /=.
by rewrite 2!voting_comparator_eq H12.
Qed.

Lemma voted_in_processing_repeat state b bs:
  voted_in_processing (next_state state b) (b:: bs) =
  voted_in_processing (next_state state b) (bs).
Proof.
rewrite /voted_in_processing !node_processing_cons !mask_cons.
by rewrite voting_next_N next_state_repeat.
Qed.

Lemma voted_in_processing_already_cat state b bs1 bs2:
  b \in bs1 ->
  voted_in_processing state (bs1 ++ b::bs2) =
  voted_in_processing state (bs1 ++ bs2).
Proof.
rewrite voted_in_processing_cat_cps voted_in_processing_cons=> Hb.
by rewrite (next_state_already _ Hb) (voted_on_already _ Hb) /= voted_in_processing_cat_cps.
Qed.

Lemma voted_in_processing_already state b bs1 bs2:
  b \in bs1 ->
        voted_in_processing (node_processing state bs1).1 (b::bs2) =
        voted_in_processing (node_processing state bs1).1 bs2.
rewrite voted_in_processing_cons=> Hb.
by rewrite (next_state_already _ Hb) (voted_on_already _ Hb) /=.
Qed.

Lemma voted_in_pred_cat state bs1 bs2 b:
  b \in bs1 ->
        voted_in_processing (node_processing state bs1).1 bs2 =
        voted_in_processing (node_processing state bs1).1 (filter (predC1 b) bs2).
Proof.
elim: bs2 state bs1 b =>[|x xs IHs] state bs1 b Hbin //=.
case Hbx: (x == b)=>/=.
- by rewrite (voted_in_processing_already _ _ ) ?(IHs _ _ b) // (eqP Hbx).
rewrite 2!voted_in_processing_cons; apply/eqP; rewrite eqseq_cat; last by [].
rewrite eq_refl node_processing_rcons andTb; apply/eqP/IHs.
by rewrite mem_rcons inE Hbin orbT.
Qed.

Lemma voted_in_predC1 state b bs:
  voted_in_processing (next_state state b) (bs) =
  voted_in_processing (next_state state b) (filter (predC1 b) bs).
Proof.
have H: (next_state state b) = ((node_processing state [:: b]).1).
- by rewrite -[[:: b]]cat0s cats1 -node_processing_rcons /=.
rewrite H; apply: voted_in_pred_cat.
by rewrite inE.
Qed.

Lemma voted_in_rundup state bs:
  voted_in_processing state bs = voted_in_processing state (rundup bs).
Proof.
elim: bs state =>[| x s IHs] state //=.
rewrite /voted_in_processing 2!node_processing_cons /unzip2 map_cons mask_cons.
rewrite -/(voted_in_processing (next_state state x) s) IHs .
rewrite mask_cons -/(map snd) -/unzip2 -/(voted_in_processing (next_state state x) _).
by rewrite -voted_in_predC1.
Qed.

Lemma voted_in_processing_idx state bseq b:
  (b \in (voted_in_processing state bseq)) =
  (voted_on (nth state (unzip1 (node_processing state bseq).2) (index b bseq) ) b && (b \in bseq)).
Proof.
rewrite voted_in_rundup.
elim: bseq b state =>[| bb bbs IHbb] b state /=.
- by rewrite in_nil andbF.
rewrite /voted_in_processing /= 2!node_processing_cons /unzip2 mask_cons -/(map snd) /=.
case H: (bb == b).
- move/eqP: H=> ->; rewrite in_cons eqxx.
  case H2: (voted_on state b); first by rewrite in_cons eqxx orTb andbT.
  rewrite /=; apply: negbTE; apply: contraT; move/negPn=>H.
  by move: (mem_mask H); rewrite mem_filter /= eq_refl.
rewrite mem_cat mem_nseq in_cons eq_sym H andbF 2!orFb.
rewrite -/unzip2 -/(voted_in_processing (next_state state bb) _).
rewrite -voted_in_predC1 IHbb /=; case Hbbs: (b\in bbs); last by rewrite 2!andbF.
rewrite (nth_in_default_irrel (next_state state bb) state _); first by [].
by rewrite size_map size_processing index_mem.
Qed.

Lemma voted_in_processing_exists state bseq b:
  (b \in voted_in_processing state bseq) ->
  exists s, (s \in (unzip1 (node_processing state bseq).2)) && (voted_on s b) && (b \in bseq).
Proof.
rewrite voted_in_processing_idx.
move/andP => [H Hb]; exists (nth state (unzip1 (node_processing state bseq).2) (index b bseq)).
rewrite H Hb 2!andbT; apply/(nthP state); exists (index b bseq)=> //.
by rewrite size_map size_processing index_mem.
Qed.

Lemma voted_in_processing_sorted state bseq:
  (sorted (fun b1 b2 => round b1 < round b2) (voted_in_processing state bseq)).
Proof.
move: state; elim bseq => [| b bs] //; rewrite /sorted=> IHs state //.
rewrite voted_in_processing_cons.
case Hv: (voted_on state b)=> //=.
move: (IHs (next_state state b)).
  case H:((voted_in_processing (next_state state b) bs))=> //= [x xs]->.
rewrite andbT (@leq_trans (last_vote_round (next_state state b)).+1)=> //.
- by rewrite next_state_lvr_if Hv ltnS.
move: (mem_head x xs); rewrite -H; move/voted_in_processing_exists=> [s].
move/andP=> [Hs]; move/andP: Hs=> [Hs]; rewrite voting_comparator_eq; move/andP => [Hlt Hbr] Hx.
move/andP:(Hlt)=> [Hlt1 _]; apply: (leq_trans _ Hlt1); move: (node_processing_sorted (next_state state b) (bs)); rewrite /sorted.
case Hunz1: (unzip1 (node_processing (next_state state b) bs).2) => [|y ys]; first by move: Hs; rewrite Hunz1 in_nil.
move: (Hunz1); rewrite node_processing_head; case Hbs: bs => [|z zs]; first by move: Hx; rewrite Hbs in_nil.
move/eqP; rewrite eqseq_cons; move/andP=>[Hy Hys]; rewrite -(eqP Hy).
move/(order_path_min comparators_transitive); move/allP; rewrite Hunz1 in Hs.
move: Hs; rewrite in_cons; case Hsy: (s == y).
by move/eqP: Hsy=>->; move/eqP: Hy=><-.
by move/orP=>[//|] Hin Hcomp; move/andP: (Hcomp _ Hin)=>[-> _].
Qed.

Lemma voted_in_processing_qc_parent_sorted state bseq:
  (sorted (fun b1 b2 => qc_parent_round b1 <= qc_round b2)) (voted_in_processing state bseq).
Proof.
move: state; elim bseq => [| b bs] //; rewrite /sorted=> IHs state //.
rewrite voted_in_processing_cons.
case Hv: (voted_on state b)=> //=.
move: (IHs (next_state state b)).
  case H:((voted_in_processing (next_state state b) bs))=> //= [x xs]->.
rewrite andbT (@leq_trans (preferred_block_round (next_state state b)))=> //.
-  by rewrite next_state_pbr_update update_maxn leq_maxr.
move: (mem_head x xs); rewrite -H; move/voted_in_processing_exists=> [s].
move/andP=> [Hs]; move/andP: Hs=> [Hs]; rewrite voting_comparator_eq; move/andP => [Hlt Hbr] Hx.
move/andP:(Hlt)=> [_ Hleq1]; apply: (leq_trans _ Hleq1); move: (node_processing_sorted (next_state state b) (bs)); rewrite /sorted.
case Hunz1: (unzip1 (node_processing (next_state state b) bs).2) => [|y ys]; first by move: Hs; rewrite Hunz1 in_nil.
move: (Hunz1); rewrite node_processing_head; case Hbs: bs => [|z zs]; first by move: Hx; rewrite Hbs in_nil.
move/eqP; rewrite eqseq_cons; move/andP=>[Hy Hys]; rewrite -(eqP Hy).
move/(order_path_min comparators_transitive); move/allP; rewrite Hunz1 in Hs.
move: Hs; rewrite in_cons; case Hsy: (s == y).
by move/eqP: Hsy=>->; move/eqP: Hy=><-.
by move/orP=>[//|] Hin Hcomp; move/andP: (Hcomp _ Hin)=>[_ ->].
Qed.

Lemma voted_in_processing_subseq_qc_parent_rel state bseq b1 b2:
  subseq [:: b1; b2] (voted_in_processing state bseq) ->
  qc_parent_round b1 <= qc_round b2.
Proof.
move: state b1 b2; elim: bseq => [|b bs Hbs] //= state b1 b2; rewrite voted_in_processing_cons.
case Hvotb: (voted_on state b)=>/=; last by move/Hbs.
case Hb1b: (b1 == b); last by move/Hbs.
rewrite sub1seq (eqP Hb1b).
move/voted_in_processing_exists => [s /andP[/andP[Hs Hvotsb2] Hb2]].
move: (order_path_min comparators_transitive (node_processing_path (next_state state b) bs)).
move/allP; move/(_ _ Hs); move/andP=>[_]; rewrite (voting_comparator Hvotb) /= geq_max; move/andP=>[_].
move: Hvotsb2; rewrite ineq_voted_on; move/andP=>[_]; move/andP=> [H _] Hb.
apply:(leq_trans Hb H).
Qed.

Lemma voted_in_processing_uniq state bseq:
  uniq (voted_in_processing state bseq).
Proof.
apply (sorted_uniq rounds_transitive rounds_irreflexive).
apply voted_in_processing_sorted.
Qed.

Lemma voted_in_processing_both state bseq b1 b2:
  (b1 != b2) ->
  (b1 \in (voted_in_processing state bseq)) ->
  (b2 \in (voted_in_processing state bseq)) ->
  (round b1 <= round b2) ->
  subseq ([:: b1; b2]) (voted_in_processing state bseq).
Proof.
move => Hneq H1 H2 H12; move: (cat_take_drop_in H1); move/eqP=> Hsplit.
move: (H2); rewrite -{1}Hsplit; rewrite mem_cat in_cons eq_sym.
move/negbTE: Hneq=>->; rewrite orFb; move/orP=>[|].
- rewrite -sub1seq=> H13; move: (subseq_refl [:: b1])=> H24; move: {H13 H24}(cat_subseq H13 H24)=> Hpref.
  move: (subseq_trans Hpref (prefix_subseq _ (drop (index b1 (voted_in_processing state bseq)).+1 (voted_in_processing state bseq)))).
  rewrite cat1s -catA cat1s Hsplit=> Hsub; move/subseq_sorted: Hsub; move/(_ _ _ (voted_in_processing_sorted state bseq)).
  by move/(_ rounds_transitive); rewrite /= ltnNge H12.
rewrite -sub1seq=> H24; move: (subseq_refl [::b1])=> H13; move: {H13 H24}(cat_subseq H13 H24)=> Hpref.
move: (subseq_trans Hpref (suffix_subseq (take (index b1 (voted_in_processing state bseq)) (voted_in_processing state bseq)) _)).
by rewrite 2!cat1s Hsplit.
Qed.

Lemma voted_in_processing_ltn state bseq b1 b2:
  (b1 != b2) ->
  (b1 \in (voted_in_processing state bseq)) ->
  (b2 \in (voted_in_processing state bseq)) ->
  (round b1 <= round b2) ->
  round b1 < round b2.
Proof.
move => Hneq Hb1 Hb2 Hb12; move:(voted_in_processing_both Hneq Hb1 Hb2 Hb12)=> Hsub.
move/subseq_sorted: Hsub; move/(_ _ _ (voted_in_processing_sorted state bseq)).
by move/(_ rounds_transitive) => /=; rewrite andbT.
Qed.

(************************************************************)
(** Node Aggregation                                       **)
(************************************************************)

Definition node_aggregator bseq :=
  (foldl (fun stateNvote => voting_rule stateNvote.1) (genesis_state,false) bseq).1.

Definition commit_rule state (qc: QC)(bround: nat) :=
  let: potential_commit_round := (parent_block_round (qc_vote_data qc)) in
  if (potential_commit_round.+1 == (block_round (qc_vote_data qc))) &&
        ((block_round (qc_vote_data qc)).+1 == bround) then
    Some(potential_commit_round)
  else None.

End State.


From stdpp Require Import base gmap.
From mathcomp Require Import ssreflect.
From stdpp Require Import namespaces.
From iris.algebra Require Import agree auth csum gset gmap excl namespace_map frac.
From iris.heap_lang Require Import notation proofmode.
From cryptis Require Import lib term cryptis primitives tactics session.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section DH.

Context `{!cryptisG Σ, !heapG Σ}.
Notation iProp := (iProp Σ).

Implicit Types t : term.

Implicit Types Ψ : val → iProp.
Implicit Types kA kB : term.

Variable P : term → iProp.

Definition dh_publ t : iProp :=
  ∃ g a, ⌜t = TExp g [a]⌝ ∧ □ P t.

Definition dh_seed t : iProp :=
  sterm t ∧
  □ (pterm t ↔ ▷ False) ∧
  □ (∀ t', dh_pred t t' ↔ ▷ □ dh_publ t').

Lemma dh_seed_elim0 a :
  dh_seed a -∗
  pterm a -∗
  ▷ False.
Proof.
iIntros "#(_ & aP & _) #p_t".
by iApply "aP".
Qed.

Lemma dh_seed_elim1 g a :
  dh_seed a -∗
  pterm (TExp g [a]) -∗
  ▷ P (TExp g [a]).
Proof.
iIntros "#aP #p_t".
rewrite pterm_TExp1.
iDestruct "p_t" as "(_ & _ & [contra | p_t])".
  by iPoseProof (@dh_seed_elim0 with "aP contra") as ">[]".
iDestruct "aP" as "(_ & _ & #aP)".
iSpecialize ("aP" with "p_t"); iModIntro.
iDestruct "aP" as (g' a') "# [%e aP]".
by case/TExp_inj: e => _ /Permutation_singleton [] ->; eauto.
Qed.

Lemma dh_seed_elim2 g a t :
  dh_seed a -∗
  pterm (TExp g [a; t]) -∗
  ◇ (pterm (TExp g [a]) ∧ pterm t).
Proof.
iIntros "#aP #p_t".
rewrite pterm_TExp2.
iDestruct "p_t" as "[p_t|[[_ contra]|p_t]]"; eauto.
  by iPoseProof (@dh_seed_elim0 with "aP contra") as ">[]".
iDestruct "p_t" as "(_ & p_t & _)".
iDestruct "aP" as "(_ & _ & #aP)".
iPoseProof ("aP" with "p_t") as "{p_t} p_t".
iAssert (▷ False)%I as ">[]".
iModIntro.
iDestruct "p_t" as (g' a') "(%e & _)".
by case/TExp_inj: e => _ /Permutation_length.
Qed.

Lemma dh_pterm_TExp g a :
  sterm g -∗
  dh_seed a -∗
  ▷ □ P (TExp g [a]) -∗
  pterm (TExp g [a]).
Proof.
iIntros "#gP #(? & ? & aP) #P_a".
rewrite pterm_TExp1; do !iSplit => //.
by iRight; iApply "aP"; iModIntro; iExists _, _; eauto.
Qed.

Definition dh_meta `{Countable L} t N (x : L) : iProp :=
  (∃ g a, ⌜t = TExp g [a]⌝ ∧ nonce_meta a N x)%I.

Definition dh_meta_token t E : iProp :=
  (∃ g a, ⌜t = TExp g [a]⌝ ∧ nonce_meta_token a E)%I.

Program Global Instance dh_term_meta :
  TermMeta (@dh_meta) dh_meta_token.

Next Obligation.
iIntros (L ?? E t x N sub).
iDestruct 1 as (g a) "[-> token]".
iMod (term_meta_set _ _ x with "token") as "meta"; eauto.
by rewrite /dh_meta; eauto.
Qed.

Next Obligation.
iIntros (L ?? t x N E sub).
iDestruct 1 as (g a) "[-> token]".
iDestruct 1 as (??)  "[%e  meta]".
move/TExp_inj: e => [_ /Permutation_singleton [<-]].
by iApply (term_meta_meta_token with "token meta").
Qed.

Next Obligation.
iIntros (L ?? t N x1 x2).
iDestruct 1 as (g a) "[-> meta1]".
iDestruct 1 as (??)  "[%e meta2]".
move/TExp_inj: e => [_ /Permutation_singleton [<-]].
by iApply (term_meta_agree with "meta1 meta2").
Qed.

Next Obligation.
rewrite /dh_meta /dh_meta_token.
move=> t E1 E2 sub; iSplit.
- iDestruct 1 as (g a) "[-> token]".
  rewrite [nonce_meta_token _ _](term_meta_token_difference a E1 E2) //.
  by iDestruct "token" as "[token1 token2]"; iSplitL "token1"; eauto.
- iDestruct 1 as "[token1 token2]".
  iDestruct "token1" as (g a) "[-> token1]".
  iDestruct "token2" as (??) "[%e token2]".
  move/TExp_inj: e => [_ /Permutation_singleton [<-]].
  iExists _, _; iSplit => //.
  rewrite (term_meta_token_difference _ E1 E2) //.
  by iSplitL "token1".
Qed.

Definition mkdh : val := mknonce.

Lemma wp_mkdh g E (Ψ : val → iProp) :
  (∀ a, sterm a -∗
        dh_seed a -∗
        dh_meta_token (TExp g [a]) ⊤ -∗
        Ψ a) -∗
  WP mkdh #() @ E {{ Ψ }}.
Proof.
iIntros "post"; iApply (wp_mknonce _ (λ _, False%I) dh_publ).
iIntros (a) "#s_a #(aP1 & aP2) #? token"; iApply "post" => //.
do !iSplit => //.
iModIntro; iSplit.
- by iIntros "H"; iSpecialize ("aP1" with "H"); iModIntro.
- by iIntros "#?"; iApply "aP2"; iModIntro.
- by iExists g, a; eauto.
Qed.

End DH.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RunAux.Spec.
Require Import RunAux.Layer.
Require Import RunComplete.Code.complete_hvc_exit.

Require Import RunComplete.LowSpecs.complete_hvc_exit.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _get_rec_last_run_info_esr ↦ gensem get_rec_last_run_info_esr_spec
      ⊕ _set_rec_regs ↦ gensem set_rec_regs_spec
      ⊕ _get_rec_run_gprs ↦ gensem get_rec_run_gprs_spec
      ⊕ _reset_last_run_info ↦ gensem reset_last_run_info_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_get_rec_last_run_info_esr: block.
    Hypothesis h_get_rec_last_run_info_esr_s : Genv.find_symbol ge _get_rec_last_run_info_esr = Some b_get_rec_last_run_info_esr.
    Hypothesis h_get_rec_last_run_info_esr_p : Genv.find_funct_ptr ge b_get_rec_last_run_info_esr
                                               = Some (External (EF_external _get_rec_last_run_info_esr
                                                                (signature_of_type (Tcons Tptr Tnil) tulong cc_default))
                                                      (Tcons Tptr Tnil) tulong cc_default).
    Local Opaque get_rec_last_run_info_esr_spec.

    Variable b_set_rec_regs: block.
    Hypothesis h_set_rec_regs_s : Genv.find_symbol ge _set_rec_regs = Some b_set_rec_regs.
    Hypothesis h_set_rec_regs_p : Genv.find_funct_ptr ge b_set_rec_regs
                                  = Some (External (EF_external _set_rec_regs
                                                   (signature_of_type (Tcons Tptr (Tcons tuint (Tcons tulong Tnil))) tvoid cc_default))
                                         (Tcons Tptr (Tcons tuint (Tcons tulong Tnil))) tvoid cc_default).
    Local Opaque set_rec_regs_spec.

    Variable b_get_rec_run_gprs: block.
    Hypothesis h_get_rec_run_gprs_s : Genv.find_symbol ge _get_rec_run_gprs = Some b_get_rec_run_gprs.
    Hypothesis h_get_rec_run_gprs_p : Genv.find_funct_ptr ge b_get_rec_run_gprs
                                      = Some (External (EF_external _get_rec_run_gprs
                                                       (signature_of_type (Tcons tuint Tnil) tulong cc_default))
                                             (Tcons tuint Tnil) tulong cc_default).
    Local Opaque get_rec_run_gprs_spec.

    Variable b_reset_last_run_info: block.
    Hypothesis h_reset_last_run_info_s : Genv.find_symbol ge _reset_last_run_info = Some b_reset_last_run_info.
    Hypothesis h_reset_last_run_info_p : Genv.find_funct_ptr ge b_reset_last_run_info
                                         = Some (External (EF_external _reset_last_run_info
                                                          (signature_of_type (Tcons Tptr Tnil) tvoid cc_default))
                                                (Tcons Tptr Tnil) tvoid cc_default).
    Local Opaque reset_last_run_info_spec.

  End BodyProof.

End CodeProof.