Require Import Relations.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import Lia.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import EquivDec.
From sflib Require Import sflib.
Require Import PacoNotation.
Require Import HahnRelationsBasic.
Require Import HahnSets.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.HahnRelationsMore.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.

Set Implicit Arguments.

Module Label.
  Inductive t :=
  | read (ex:bool) (ord:OrdR.t) (loc:Loc.t) (val:Val.t)
  | write (ex:bool) (ord:OrdW.t) (loc:Loc.t) (val:Val.t)
  | barrier (b:Barrier.t)
  | ctrl
  .
  #[global]
  Hint Constructors t: core.

  Definition is_ex (label:t): bool :=
    match label with
    | read ex _ _ _ => ex
    | write ex _ _ _ => ex
    | _ => false
    end.

  Definition is_read (label:t): bool :=
    match label with
    | read _ _ _ _ => true
    | _ => false
    end.

  Definition is_reading (loc:Loc.t) (label:t): bool :=
    match label with
    | read _ _ loc' _ => loc' == loc
    | _ => false
    end.

  Definition is_acquire_pc (label:t): bool :=
    match label with
    | read _ ord _ _ => OrdR.ge ord OrdR.acquire_pc
    | _ => false
    end.

  Definition is_acquire (label:t): bool :=
    match label with
    | read _ ord _ _ => OrdR.ge ord OrdR.acquire
    | _ => false
    end.

  Definition is_release_pc (label:t): bool :=
    match label with
    | write _ ord _ _ => OrdW.ge ord OrdW.release_pc
    | _ => false
    end.

  Definition is_release (label:t): bool :=
    match label with
    | write _ ord _ _ => OrdW.ge ord OrdW.release
    | _ => false
    end.

  Definition is_write (label:t): bool :=
    match label with
    | write _ _ _ _ => true
    | _ => false
    end.

  Definition is_writing (loc:Loc.t) (label:t): bool :=
    match label with
    | write _ _ loc' _ => loc' == loc
    | _ => false
    end.

  Definition is_access (label:t): bool :=
    match label with
    | read _ _ _ _ => true
    | write _ _ _ _ => true
    | _ => false
    end.

  Definition is_accessing (loc:Loc.t) (label:t): bool :=
    match label with
    | read _ _ loc' _ => loc' == loc
    | write _ _ loc' _ => loc' == loc
    | _ => false
    end.

  Definition is_ctrl (label:t): bool :=
    match label with
    | ctrl => true
    | _ => false
    end.

  Definition is_barrier (label:t): bool :=
    match label with
    | barrier b => true
    | _ => false
    end.

  Definition is_barrier_c (c:Barrier.t -> bool) (label:t): bool :=
    match label with
    | barrier b => c b
    | _ => false
    end.

  Lemma read_is_reading ex ord loc val:
    is_reading loc (read ex ord loc val).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma write_is_writing ex ord loc val:
    is_writing loc (write ex ord loc val).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma read_is_accessing ex ord loc val:
    is_accessing loc (read ex ord loc val).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma write_is_accessing ex ord loc val:
    is_accessing loc (write ex ord loc val).
  Proof.
    s. destruct (equiv_dec loc loc); ss. exfalso. apply c. ss.
  Qed.

  Lemma is_writing_inv
        loc l
        (WRITING: is_writing loc l):
    exists ex ord val,
      l = write ex ord loc val.
  Proof.
    destruct l; ss. destruct (equiv_dec loc0 loc); ss. inv e. eauto.
  Qed.

  Lemma is_reading_inv
        loc l
        (READING: is_reading loc l):
    exists ex ord val,
      l = read ex ord loc val.
  Proof.
    destruct l; ss. destruct (equiv_dec loc0 loc); ss. inv e. eauto.
  Qed.
End Label.

Module ALocal.
  Inductive t := mk {
    labels: list Label.t;
    addr: relation nat;
    data: relation nat;
    ctrl: relation nat;
    rmw: relation nat;
    exbank: option nat;
  }.
  #[global]
  Hint Constructors t: core.

  Definition init: t := mk [] bot bot bot bot None.

  Definition next_eid (eu:t): nat :=
    List.length eu.(labels).

  Inductive step (event:Event.t (A:=nat -> Prop)) (alocal1:t) (alocal2:t): Prop :=
  | step_internal
      (EVENT: event = Event.internal)
      (ALOCAL: alocal2 =
               mk
                 alocal1.(labels)
                 alocal1.(addr)
                 alocal1.(data)
                 alocal1.(ctrl)
                 alocal1.(rmw)
                 alocal1.(exbank))
  | step_read
      ex ord vloc res
      (EVENT: event = Event.read ex ord vloc (ValA.mk _ res (eq (next_eid alocal1))))
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.read ex ord vloc.(ValA.val) res])
                 (alocal1.(addr) ∪ (vloc.(ValA.annot) × (eq (next_eid alocal1))))
                 alocal1.(data)
                 alocal1.(ctrl)
                 alocal1.(rmw)
                 (if ex then Some (next_eid alocal1) else alocal1.(exbank)))
  | step_write
      ex ord vloc vval
      (EVENT: event = Event.write ex ord vloc vval (ValA.mk _ 0 (ifc (ex && (arch == riscv)) (eq (next_eid alocal1)))))
      (EX: ex -> exists n,
           alocal1.(exbank) = Some n /\
           opt_pred (fun l => Label.is_read l /\ Label.is_ex l) (List.nth_error alocal1.(labels) n))
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.write ex ord vloc.(ValA.val) vval.(ValA.val)])
                 (alocal1.(addr) ∪ (vloc.(ValA.annot) × (eq (next_eid alocal1))))
                 (alocal1.(data) ∪ (vval.(ValA.annot) × (eq (next_eid alocal1))))
                 alocal1.(ctrl)
                 (alocal1.(rmw) ∪ (if ex then (fun n => alocal1.(exbank) = Some n) × (eq (next_eid alocal1)) else bot))
                 (if ex then None else alocal1.(exbank)))
  | step_write_failure
      ord vloc vval
      (EVENT: event = Event.write true ord vloc vval (ValA.mk _ 1 bot))
      (ALOCAL: alocal2 =
               mk
                 alocal1.(labels)
                 alocal1.(addr)
                 alocal1.(data)
                 alocal1.(ctrl)
                 alocal1.(rmw)
                 None)
  | step_barrier
      b
      (EVENT: event = Event.barrier b)
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.barrier b])
                 alocal1.(addr)
                 alocal1.(data)
                 alocal1.(ctrl)
                 alocal1.(rmw)
                 alocal1.(exbank))
  | step_control
      ctrl_e
      (EVENT: event = (Event.control ctrl_e))
      (ALOCAL: alocal2 =
               mk
                 (alocal1.(labels) ++ [Label.ctrl])
                 alocal1.(addr)
                 alocal1.(data)
                 (alocal1.(ctrl) ∪ (ctrl_e × (eq (next_eid alocal1))))
                 alocal1.(rmw)
                 alocal1.(exbank))
  .
  #[global]
  Hint Constructors step: core.

  Inductive le (alocal1 alocal2:t): Prop :=
  | le_intro
      (LABELS: exists l, alocal2.(labels) = alocal1.(labels) ++ l)
      (ADDR: alocal1.(addr) ⊆ alocal2.(addr))
      (DATA: alocal1.(data) ⊆ alocal2.(data))
      (CTRL: alocal1.(ctrl) ⊆ alocal2.(ctrl))
      (RMW: alocal1.(rmw) ⊆ alocal2.(rmw))
  .
  #[global]
  Hint Constructors le: core.

  Global Program Instance le_preorder: PreOrder le.
  Next Obligation.
    ii. econs.
    all: try by exists []; rewrite List.app_nil_r.
    all: try by apply inclusion_refl.
  Qed.
  Next Obligation.
    ii. inv H; inv H0. econs.
    all: try by eapply inclusion_trans; eauto.
    des. rewrite LABELS0, LABELS. rewrite <- List.app_assoc. eexists; eauto.
  Qed.
End ALocal.

Module AExecUnit.
  Inductive t := mk {
    state: State.t (A:=nat -> Prop);
    local: ALocal.t;
  }.
  #[global]
  Hint Constructors t: core.

  Inductive step (eu1 eu2:t): Prop :=
  | step_intro
      e
      (STATE: State.step e eu1.(state) eu2.(state))
      (LOCAL: ALocal.step e eu1.(local) eu2.(local))
  .
  #[global]
  Hint Constructors step: core.

  Inductive label_is (labels:list Label.t) (pred:Label.t -> Prop) (iid:nat): Prop :=
  | label_is_intro
      l
      (EID: List.nth_error labels iid = Some l)
      (LABEL: pred l)
  .
  #[global]
  Hint Constructors label_is: core.

  Definition wf_rmap (rmap: RMap.t (A:=nat -> Prop)) (labels:list Label.t): Prop :=
    forall r n
      (N: (RMap.find r rmap).(ValA.annot) n),
      label_is labels Label.is_access n.
  #[global]
  Hint Unfold wf_rmap: core.

  Lemma wf_rmap_expr
        rmap labels e n
        (WF: wf_rmap rmap labels)
        (N: (sem_expr rmap e).(ValA.annot) n):
    label_is labels Label.is_access n.
  Proof.
    revert n N. induction e; ss.
    - i. eapply WF. eauto.
    - i. inv N; eauto.
  Qed.

  Inductive wf (aeu:t): Prop :=
  | wf_intro
      (REG: wf_rmap aeu.(state).(State.rmap) aeu.(local).(ALocal.labels))
      (ADDR: aeu.(local).(ALocal.addr) ⊆ lt)
      (ADDR_LIMIT: forall e1 e2 (REL: aeu.(local).(ALocal.addr) e1 e2), e2 < List.length aeu.(local).(ALocal.labels))
      (ADDR_LABEL: aeu.(local).(ALocal.addr) ⊆ (label_is aeu.(local).(ALocal.labels) Label.is_access) × (label_is aeu.(local).(ALocal.labels) Label.is_access))
      (DATA: aeu.(local).(ALocal.data) ⊆ lt)
      (DATA_LIMIT: forall e1 e2 (REL: aeu.(local).(ALocal.data) e1 e2), e2 < List.length aeu.(local).(ALocal.labels))
      (DATA_LABEL: aeu.(local).(ALocal.data) ⊆ (label_is aeu.(local).(ALocal.labels) Label.is_access) × (label_is aeu.(local).(ALocal.labels) Label.is_write))
      (CTRL: aeu.(local).(ALocal.ctrl) ⊆ lt)
      (CTRL_LIMIT: forall e1 e2 (REL: aeu.(local).(ALocal.ctrl) e1 e2), e2 < List.length aeu.(local).(ALocal.labels))
      (CTRL_LABEL: aeu.(local).(ALocal.ctrl) ⊆ (label_is aeu.(local).(ALocal.labels) Label.is_access) × (label_is aeu.(local).(ALocal.labels) Label.is_ctrl))
      (RMW: aeu.(local).(ALocal.rmw) ⊆ lt)
      (RMW_LIMIT: forall e1 e2 (REL: aeu.(local).(ALocal.rmw) e1 e2), e2 < List.length aeu.(local).(ALocal.labels))
      (RMW1: forall n ord loc val
               (LABEL: List.nth_error aeu.(local).(ALocal.labels) n = Some (Label.write true ord loc val)),
          codom_rel aeu.(local).(ALocal.rmw) n)
      (RMW2: forall a b
               (RMW: aeu.(local).(ALocal.rmw) a b),
          exists ord1 loc1 val1 ord2 loc2 val2,
            <<LABEL1: List.nth_error aeu.(local).(ALocal.labels) a = Some (Label.read true ord1 loc1 val1)>> /\
            <<LABEL2: List.nth_error aeu.(local).(ALocal.labels) b = Some (Label.write true ord2 loc2 val2)>> /\
            <<BETWEEN: forall c ord3 loc3 val3 (C: a < c < b), List.nth_error aeu.(local).(ALocal.labels) c <> Some (Label.read true ord3 loc3 val3)>>)
      (EXBANK': forall eb (EB: aeu.(local).(ALocal.exbank) = Some eb),
          eb < List.length aeu.(local).(ALocal.labels))
      (EXBANK: forall eb c ord3 loc3 val3
                 (EB: aeu.(local).(ALocal.exbank) = Some eb)
                 (C: eb < c),
          List.nth_error aeu.(local).(ALocal.labels) c <> Some (Label.read true ord3 loc3 val3))
  .
  #[global]
  Hint Constructors wf: core.

  Lemma label_is_lt
        labels pred iid
        (LABEL: label_is labels pred iid):
    iid < length labels.
  Proof.
    inv LABEL. apply List.nth_error_Some. congr.
  Qed.

  Lemma label_is_mon
        labels1 labels2 pred:
    label_is labels1 pred <1= label_is (labels1 ++ labels2) pred.
  Proof.
    ii. inv PR. econs; eauto.
    rewrite List.nth_error_app1; ss.
    apply List.nth_error_Some. congr.
  Qed.

  Lemma union_mon
        A
        (p1 p2 q1 q2: A -> Prop)
        (P: p1 <1= p2)
        (Q: q1 <1= q2):
    (p1 ∪₁ q1) <1= (p2 ∪₁ q2).
  Proof.
    ii. inv PR.
    - left. eauto.
    - right. eauto.
  Qed.

  Lemma times_mon
        A
        (p1 p2 q1 q2: A -> Prop)
        (P: p1 <1= p2)
        (Q: q1 <1= q2):
    p1 × q1 <2= p2 × q2.
  Proof.
    ii. inv PR. econs; eauto.
  Qed.

  Lemma wf_init stmts: wf (mk (State.init stmts) ALocal.init).
  Proof.
    econs; ss.
    - ii. unfold RMap.find, RMap.init in *. rewrite IdMap.gempty in *. inv N.
    - i. destruct n; ss.
  Qed.

  Lemma step_future
        eu1 eu2
        (WF: wf eu1)
        (STEP: step eu1 eu2):
    <<WF: wf eu2>> /\
    <<LE: ALocal.le eu1.(local) eu2.(local)>>.
  Proof.
    destruct eu1 as [state1 local1].
    destruct eu2 as [state2 local2].
    inv STEP. ss.
    inv STATE; inv LOCAL; inv EVENT; ss;
      repeat match goal with
             | [|- context[bot × _]] => rewrite cross_bot_l
             | [|- context[_ ∪ bot]] => rewrite union_bot_r
             end.
    - splits.
      + inv WF. econs; ss.
      + destruct local1. refl.
    - splits.
      + inv WF. econs; ss.
        ii. revert N. unfold RMap.find, RMap.add. rewrite IdMap.add_spec. condtac; eauto.
        inversion e. subst. apply wf_rmap_expr. ss.
      + destruct local1. refl.
    - splits.
      + inv WF. econs; ss.
        all: try rewrite List.app_length; s.
        all: unfold ALocal.next_eid in *.
        * ii. revert N. unfold RMap.find, RMap.add. rewrite IdMap.add_spec. condtac.
          { inversion e. subst. i. inv N.
            econs.
            - unfold ALocal.next_eid. rewrite List.nth_error_app2, Nat.sub_diag; ss.
            - ss.
          }
          { i. apply label_is_mon. exploit REG; eauto. }
        * ii. inv H.
          { exploit ADDR_LIMIT; eauto. }
          { inv H0. splits; eauto using label_is_lt, wf_rmap_expr. }
        * i. inv REL.
          { exploit ADDR_LIMIT; eauto. lia. }
          { inv H. lia. }
        * ii. inv H.
          { eapply times_mon; [| |by apply ADDR_LABEL].
            - apply label_is_mon.
            - i. apply label_is_mon. ss.
          }
          { inv H0. econs.
            - apply label_is_mon. eapply wf_rmap_expr; eauto.
            - econs.
              + unfold ALocal.next_eid. rewrite List.nth_error_app2, Nat.sub_diag; ss.
              + ss.
          }
        * ii. exploit DATA_LIMIT; eauto. lia.
        * ii. eapply times_mon; [| |by apply DATA_LABEL].
          { apply label_is_mon. }
          { apply label_is_mon. }
        * ii. exploit CTRL_LIMIT; eauto. lia.
        * ii. econs; ss.
          { apply label_is_mon. eapply CTRL_LABEL. eauto. }
          { apply label_is_mon. eapply CTRL_LABEL. eauto. }
        * ii. exploit RMW_LIMIT; eauto. lia.
        * i. apply nth_error_snoc_inv in LABEL. des; ss.
          eapply RMW1. eauto.
        * i. exploit RMW2; eauto. i. des. esplits; eauto using nth_error_app_mon.
          i. rewrite List.nth_error_app1; eauto. etrans; [apply C|]. apply List.nth_error_Some. congr.
        * i. destruct ex0; ss.
          { inv EB. lia. }
          { exploit EXBANK'; eauto. lia. }
        * ii. apply nth_error_snoc_inv in H. des; ss.
          { destruct ex0.
            { inv EB. unfold ALocal.next_eid in *. lia. }
            eapply EXBANK; eauto.
          }
          { subst. inv H0. inv EB. unfold ALocal.next_eid in *. lia. }
      + econs; ss.
        * esplits; eauto.
        * left. ss.
    - splits.
      + inv WF. econs; ss.
        all: try rewrite List.app_length; s.
        all: unfold ALocal.next_eid in *.
        * ii. revert N. unfold RMap.find, RMap.add. rewrite IdMap.add_spec. condtac.
          { inversion e. subst. s. unfold ifc. condtac; ss. i. subst. econs.
            - unfold ALocal.next_eid. rewrite List.nth_error_app2, Nat.sub_diag; ss.
            - ss.
          }
          { i. apply label_is_mon. exploit REG; eauto. }
        * ii. inv H.
          { exploit ADDR_LIMIT; eauto. }
          { inv H0. splits; eauto using label_is_lt, wf_rmap_expr. }
        * i. inv REL.
          { exploit ADDR_LIMIT; eauto. lia. }
          { inv H. lia. }
        * ii. inv H.
          { eapply times_mon; [| |by apply ADDR_LABEL].
            - apply label_is_mon.
            - apply label_is_mon.
          }
          { inv H0. econs.
            - apply label_is_mon. eapply wf_rmap_expr; eauto.
            - econs.
              + unfold ALocal.next_eid. rewrite List.nth_error_app2, Nat.sub_diag; ss.
              + ss.
          }
        * ii. inv H.
          { exploit DATA_LIMIT; eauto. }
          { inv H0. splits; eauto using label_is_lt, wf_rmap_expr. }
        * i. inv REL.
          { exploit DATA_LIMIT; eauto. lia. }
          { inv H. lia. }
        * ii. inv H.
          { eapply times_mon; [| |by apply DATA_LABEL].
            - apply label_is_mon.
            - apply label_is_mon.
          }
          { inv H0. econs.
            - apply label_is_mon. eapply wf_rmap_expr; eauto.
            - econs.
              + unfold ALocal.next_eid. rewrite List.nth_error_app2, Nat.sub_diag; ss.
              + ss.
          }
        * i. exploit CTRL_LIMIT; eauto. lia.
        * ii. econs; ss.
          { apply label_is_mon. eapply CTRL_LABEL. eauto. }
          { apply label_is_mon. eapply CTRL_LABEL. eauto. }
        * ii. inv H.
          { exploit RMW_LIMIT; eauto. }
          { destruct ex0; ss. inv H0. splits; eauto using label_is_lt, wf_rmap_expr. }
        * i. inv REL.
          { exploit RMW_LIMIT; eauto. lia. }
          { destruct ex0; ss. inv H. lia. }
        * i. apply nth_error_snoc_inv in LABEL. des.
          { exploit RMW1; eauto. intro x. inv x. econs. left. eauto. }
          { subst. inv LABEL0. exploit EX; eauto. i. des. econs. right. econs; eauto. }
        * i. inv RMW0.
          { exploit RMW2; eauto. i. des. esplits.
            - apply nth_error_app_mon. eauto.
            - apply nth_error_app_mon. eauto.
            - i. rewrite List.nth_error_app1; eauto. etrans; [apply C|]. apply List.nth_error_Some. congr.
          }
          { destruct ex0; ss. inv H. exploit EX; eauto. intro x. des. inv x0. des.
            destruct a0; ss. destruct ex; ss.
            rewrite H0 in x. inv x. symmetry in H1.
            esplits.
            - apply nth_error_app_mon. eauto.
            - rewrite List.nth_error_app2, Nat.sub_diag; ss.
            - ii. apply nth_error_snoc_inv in H. des.
              + eapply EXBANK; eauto.
              + unfold ALocal.next_eid in *. lia.
          }
        * i. destruct ex0; ss. exploit EXBANK'; eauto. lia.
        * ii. destruct ex0; ss. apply nth_error_snoc_inv in H. des; ss.
          eapply EXBANK; eauto.
      + econs; ss.
        * esplits; eauto.
        * left. ss.
        * left. ss.
        * left. ss.
    - splits.
      + inv WF. econs; ss.
        ii. revert N. unfold RMap.find, RMap.add. rewrite IdMap.add_spec. condtac; eauto.
        inversion e. subst. i. inv N.
      + econs; ss. eexists. rewrite List.app_nil_r. ss.
    - splits.
      + inv WF. econs; ss.
        all: try rewrite List.app_length; s.
        all: unfold ALocal.next_eid in *.
        * ii. apply label_is_mon. exploit REG; eauto.
        * i. exploit ADDR_LIMIT; eauto. lia.
        * ii. eapply times_mon; [| |by apply ADDR_LABEL].
          { apply label_is_mon. }
          { apply label_is_mon. }
        * i. exploit DATA_LIMIT; eauto. lia.
        * ii. eapply times_mon; [| |by apply DATA_LABEL].
          { apply label_is_mon. }
          { apply label_is_mon. }
        * i. exploit CTRL_LIMIT; eauto. lia.
        * ii. econs; ss.
          { apply label_is_mon. eapply CTRL_LABEL. eauto. }
          { apply label_is_mon. eapply CTRL_LABEL. eauto. }
        * i. exploit RMW_LIMIT; eauto. lia.
        * i. apply nth_error_snoc_inv in LABEL. des; eauto. inv LABEL0.
        * i. exploit RMW2; eauto. i. des. esplits.
          { apply nth_error_app_mon. eauto. }
          { apply nth_error_app_mon. eauto. }
          { i. rewrite List.nth_error_app1; eauto. etrans; [apply C|]. apply List.nth_error_Some. congr. }
        * i. exploit EXBANK'; eauto. lia.
        * ii. apply nth_error_snoc_inv in H. des; ss.
          eapply EXBANK; eauto.
      + econs; ss. eexists; eauto.
    - splits.
      + inv WF. econs; ss.
        all: try rewrite List.app_length; s.
        all: unfold ALocal.next_eid in *.
        * ii. apply label_is_mon. exploit REG; eauto.
        * i. exploit ADDR_LIMIT; eauto. lia.
        * ii. eapply times_mon; [| |by apply ADDR_LABEL].
          { apply label_is_mon. }
          { apply label_is_mon. }
        * i. exploit DATA_LIMIT; eauto. lia.
        * ii. eapply times_mon; [| |by apply DATA_LABEL].
          { apply label_is_mon. }
          { apply label_is_mon. }
        * ii. inv H.
          { exploit CTRL_LIMIT; eauto. }
          { inv H0. splits; eauto using label_is_lt, wf_rmap_expr. }
        * i. inv REL.
          { exploit CTRL_LIMIT; eauto. lia. }
          { inv H. lia. }
        * ii. inv H.
          { eapply times_mon; [| |by apply CTRL_LABEL].
            - apply label_is_mon.
            - apply label_is_mon.
          }
          { inv H0. econs.
            - apply label_is_mon. eapply wf_rmap_expr; eauto.
            - econs.
              + unfold ALocal.next_eid. rewrite List.nth_error_app2, Nat.sub_diag; ss.
              + ss.
          }
        * i. exploit RMW_LIMIT; eauto. lia.
        * i. apply nth_error_snoc_inv in LABEL. des; eauto. inv LABEL0.
        * i. exploit RMW2; eauto. i. des. esplits.
          { apply nth_error_app_mon. eauto. }
          { apply nth_error_app_mon. eauto. }
          { i. rewrite List.nth_error_app1; eauto. etrans; [apply C|]. apply List.nth_error_Some. congr. }
        * i. exploit EXBANK'; eauto. lia.
        * ii. apply nth_error_snoc_inv in H. des; ss.
          eapply EXBANK; eauto.
      + econs; ss; eauto. left. ss.
    - splits.
      + inv WF. econs; ss.
      + destruct local1. refl.
  Qed.

  Lemma rtc_step_future
        eu1 eu2
        (WF: wf eu1)
        (STEP: rtc step eu1 eu2):
    <<WF: wf eu2>> /\
    <<LE: ALocal.le eu1.(local) eu2.(local)>>.
  Proof.
    revert WF. induction STEP; eauto.
    - esplits; eauto. refl.
    - i. exploit step_future; eauto. i. des.
      exploit IHSTEP; eauto. i. des.
      esplits; ss. etrans; eauto.
  Qed.
End AExecUnit.

Definition eidT := (Id.t * nat)%type.

Module Execution.
  Inductive t := mk {
    labels: IdMap.t (list Label.t);
    addr: relation eidT;
    data: relation eidT;
    ctrl0: relation eidT;
    rmw: relation eidT;
    co: relation eidT;
    rf: relation eidT;
  }.
  #[global]
  Hint Constructors t: core.

  Definition label (eid:eidT) (ex:t): option Label.t :=
    match IdMap.find (fst eid) ex.(labels) with
    | None => None
    | Some labels => List.nth_error labels (snd eid)
    end.

  Definition eids (ex:t): list eidT :=
    IdMap.fold
      (fun tid local eids => (List.map (fun i => (tid, i)) (List.seq 0 (List.length local))) ++ eids)
      ex.(labels)
      [].

  Lemma eids_spec ex:
    <<LABEL: forall eid, label eid ex <> None <-> List.In eid (eids ex)>> /\
    <<NODUP: List.NoDup (eids ex)>>.
  Proof.
    generalize (PositiveMap.elements_3w (labels ex)). intro NODUP.
    hexploit SetoidList.NoDupA_rev; eauto.
    { apply IdMap.eqk_equiv. }
    intro NODUP_REV. splits.
    - (* LABEL *)
      i. destruct eid. unfold label, eids. s.
      rewrite IdMap.fold_1, <- List.fold_left_rev_right, IdMap.elements_spec.
      rewrite SetoidList_findA_rev; eauto; cycle 1.
      { apply eq_equivalence. }
      { apply []. }
      revert NODUP_REV. induction (List.rev (IdMap.elements (labels ex))); ss.
      destruct a. i. inv NODUP_REV. s. rewrite List.in_app_iff, <- IHl; ss.
      match goal with
      | [|- context[if ?c then true else false]] => destruct c
      end; ss; i; cycle 1.
      { econs; eauto. i. des; ss.
        apply List.in_map_iff in H. des. inv H. congr.
      }
      inv e. rewrite List.nth_error_Some, List.in_map_iff.
      econs; i; des.
      + left. esplits; eauto. apply HahnList.in_seq0_iff. ss.
      + inv H. apply HahnList.in_seq0_iff. ss.
      + revert H.
        match goal with
        | [|- context[match ?f with Some _ => _ | None => _ end]] => destruct f eqn:FIND
        end; ss.
        apply SetoidList.findA_NoDupA in FIND; ss; cycle 1.
        { apply eq_equivalence. }
        exfalso. apply H1. revert FIND. clear. induction l; i; inv FIND.
        * destruct a. ss. des. inv H0. left. ss.
        * right. apply IHl. ss.
    - (* NODUP *)
      unfold eids. rewrite IdMap.fold_1, <- List.fold_left_rev_right.
      revert NODUP_REV. induction (List.rev (IdMap.elements (labels ex))); ss. i.
      inv NODUP_REV. destruct a. s.
      apply HahnList.nodup_app. splits; eauto.
      + apply FinFun.Injective_map_NoDup.
        * ii. inv H. ss.
        * apply List.seq_NoDup.
      + ii. apply List.in_map_iff in IN1. des. subst.
        apply H1. revert IN2. clear. induction l; ss.
        i. apply List.in_app_iff in IN2. des.
        * apply List.in_map_iff in IN2. des. inv IN2. left. ss.
        * right. eauto.
  Qed.

  Inductive label_is (ex:t) (pred:Label.t -> Prop) (eid:eidT): Prop :=
  | label_is_intro
      l
      (EID: label eid ex = Some l)
      (LABEL: pred l)
  .
  #[global]
  Hint Constructors label_is: core.

  Inductive label_rel (ex:t) (rel:relation Label.t) (eid1 eid2:eidT): Prop :=
  | label_rel_intro
      l1 l2
      (EID1: label eid1 ex = Some l1)
      (EID2: label eid2 ex = Some l2)
      (LABEL: rel l1 l2)
  .
  #[global]
  Hint Constructors label_rel: core.

  Inductive label_is_rel (ex: t) (pred: Label.t -> Prop) (eid1 eid2: eidT): Prop :=
  | label_is_rel_intro
      l1 l2
      (EID1: label eid1 ex = Some l1)
      (EID2: label eid2 ex = Some l2)
      (LABEL1: pred l1)
      (LABEL2: pred l2)
  .
  #[global]
  Hint Constructors label_is_rel: core.

  Inductive label_loc (x y:Label.t): Prop :=
  | label_loc_intro
      loc
      (X: Label.is_accessing loc x)
      (Y: Label.is_accessing loc y)
  .
  #[global]
  Hint Constructors label_loc: core.

  (* let obs = rfe | fr | co *)

  (* let dob = *)
  (* 	| (addr | data); rfi? *)
  (* 	| (ctrl | (addr; po)); ([W] | [ISB]; po; [R]) *)

  (* let aob = [range(rmw)]; rfi; [A | Q] *)

  (* let bob = *)
  (* 	| [R|W]; po; [dmb.full]; po; [R|W] *)
  (* 	| [L]; po; [A] *)
  (* 	| [R]; po; [dmb.ld]; po; [R|W] *)
  (* 	| [A | Q]; po; [R|W] *)
  (* 	| [W]; po; [dmb.st]; po; [W] *)
  (* 	| [R|W]; po; [L] *)

  (* let ob = obs | dob | aob | bob *)

  (* acyclic po-loc | fr | co | rf as internal *)
  (* acyclic ob as external *)
  (* empty rmw & (fre; coe) as atomic *)

  Inductive po (eid1 eid2:eidT): Prop :=
  | po_intro
      (TID: fst eid1 = fst eid2)
      (N: snd eid1 < snd eid2)
  .
  #[global]
  Hint Constructors po: core.

  Global Program Instance po_trans: Transitive po.
  Next Obligation.
    ii. destruct x, y, z. inv H. inv H0. ss. subst. econs; ss. lia.
  Qed.

  Inductive po_adj (eid1 eid2:eidT): Prop :=
  | po_adj_intro
      (TID: fst eid1 = fst eid2)
      (N: snd eid2 = S (snd eid1))
  .
  #[global]
  Hint Constructors po_adj: core.

  Lemma po_adj_po:
    po_adj ⊆ po.
  Proof.
    ii. destruct x, y. inv H. ss. subst. econs; ss.
  Qed.

  Lemma po_po_adj:
    po = po^? ⨾ po_adj.
  Proof.
    funext. i. funext. i. propext. econs; i.
    - inv H. destruct x, x0. ss. subst.
      destruct n0; [lia|].
      exists (t1, n0). splits; ss. inv N; [left|right]; eauto.
    - inv H. des. inv H0.
      + apply po_adj_po. ss.
      + etrans; eauto. apply po_adj_po. ss.
  Qed.

  Lemma po_po_adj_weak:
    (Execution.po ⨾ Execution.po_adj) ⊆ Execution.po.
  Proof.
    rewrite po_po_adj at 2. apply inclusion_seq_mon; ss.
    econs 2. ss.
  Qed.

  Inductive i (eid1 eid2:eidT): Prop :=
  | i_intro
      (TID: fst eid1 = fst eid2)
  .
  #[global]
  Hint Constructors i: core.

  Inductive e (eid1 eid2:eidT): Prop :=
  | e_intro
      (TID: fst eid1 <> fst eid2)
  .
  #[global]
  Hint Constructors e: core.

  Definition ctrl (ex: t): relation eidT := ex.(ctrl0) ⨾ po.
  Definition po_loc (ex:t): relation eidT := po ∩ ex.(label_rel) label_loc.
  Definition fr (ex:t): relation eidT :=
    (ex.(rf)⁻¹ ⨾ ex.(co)) ∪
    ((ex.(label_rel) label_loc) ∩
     ((ex.(label_is) Label.is_read) \₁ codom_rel ex.(rf)) × (ex.(label_is) Label.is_write)).
  Definition rfi (ex:t): relation eidT := ex.(rf) ∩ i.
  Definition rfe (ex:t): relation eidT := ex.(rf) ∩ e.
  Definition fre (ex:t): relation eidT := (fr ex) ∩ e.
  Definition coe (ex:t): relation eidT := ex.(co) ∩ e.

  Definition internal (ex:t): relation eidT := (po_loc ex) ∪ (fr ex) ∪ ex.(co) ∪ ex.(rf).

  Definition obs (ex:t): relation eidT := (rfe ex) ∪ (fr ex) ∪ ex.(co).

  Definition dob (ex:t): relation eidT :=
    ((ex.(addr) ∪ ex.(data)) ⨾ (rfi ex)^?) ∪
    (((ctrl ex) ∪ (ex.(addr) ⨾ po)) ⨾
     (⦗ex.(label_is) Label.is_write⦘ ∪
      (⦗ex.(label_is) (eq (Label.barrier Barrier.isb))⦘ ⨾ po ⨾ ⦗ex.(label_is) Label.is_read⦘))).

  Definition aob (ex:t): relation eidT :=
    ⦗codom_rel ex.(rmw)⦘ ⨾ (rfi ex) ⨾ ⦗fun eid => arch = riscv \/ ex.(label_is) Label.is_acquire_pc eid⦘.

  Definition bob (ex:t): relation eidT :=
    (⦗ex.(label_is) Label.is_read⦘ ⨾
     po ⨾
     ⦗ex.(label_is) (Label.is_barrier_c Barrier.is_dmb_rr)⦘ ⨾
     po ⨾
     ⦗ex.(label_is) Label.is_read⦘) ∪

    (⦗ex.(label_is) Label.is_read⦘ ⨾
     po ⨾
     ⦗ex.(label_is) (Label.is_barrier_c Barrier.is_dmb_rw)⦘ ⨾
     po ⨾
     ⦗ex.(label_is) Label.is_write⦘) ∪

    (⦗ex.(label_is) Label.is_write⦘ ⨾
     po ⨾
     ⦗ex.(label_is) (Label.is_barrier_c Barrier.is_dmb_wr)⦘ ⨾
     po ⨾
     ⦗ex.(label_is) Label.is_read⦘) ∪

    (⦗ex.(label_is) Label.is_write⦘ ⨾
     po ⨾
     ⦗ex.(label_is) (Label.is_barrier_c Barrier.is_dmb_ww)⦘ ⨾
     po ⨾
     ⦗ex.(label_is) Label.is_write⦘) ∪

    (⦗ex.(label_is) Label.is_release⦘ ⨾
     po ⨾
     ⦗ex.(label_is) Label.is_acquire⦘) ∪

    (⦗ex.(label_is) Label.is_acquire_pc⦘ ⨾
     po) ∪

    (po ⨾
     ⦗ex.(label_is) Label.is_release_pc⦘) ∪

    (ifc (arch == riscv) ex.(rmw)).

  Definition ob (ex:t): relation eidT :=
    (obs ex) ∪ (dob ex) ∪ (aob ex) ∪ (bob ex).
End Execution.

Inductive tid_lift (tid:Id.t) (rel:relation nat) (eid1 eid2:eidT): Prop :=
| tid_lift_intro
    (TID1: fst eid1 = tid)
    (TID1: fst eid2 = tid)
    (REL: rel (snd eid1) (snd eid2))
.
#[export]
Hint Constructors tid_lift: core.

Lemma tid_lift_incl
      tid rel1 rel2
      (REL: rel1 ⊆ rel2):
  tid_lift tid rel1 ⊆ tid_lift tid rel2.
Proof.
  ii. inv H. econs; eauto.
Qed.

Inductive tid_join (rels: IdMap.t (relation nat)) (eid1 eid2:eidT): Prop :=
| tid_join_intro
    tid rel
    (RELS: IdMap.find tid rels = Some rel)
    (REL: tid_lift tid rel eid1 eid2)
.
#[export]
Hint Constructors tid_join: core.

Module Valid.
  Inductive pre_ex (p:program) (ex:Execution.t) := mk_pre_ex {
    aeus: IdMap.t AExecUnit.t;

    AEUS: IdMap.Forall2
            (fun tid stmts aeu =>
               rtc AExecUnit.step
                   (AExecUnit.mk (State.init stmts) ALocal.init)
                   aeu)
            p aeus;
    LABELS: ex.(Execution.labels) = IdMap.map (fun aeu => aeu.(AExecUnit.local).(ALocal.labels)) aeus;
    ADDR: ex.(Execution.addr) = tid_join (IdMap.map (fun aeu => aeu.(AExecUnit.local).(ALocal.addr)) aeus);
    DATA: ex.(Execution.data) = tid_join (IdMap.map (fun aeu => aeu.(AExecUnit.local).(ALocal.data)) aeus);
    CTRL: ex.(Execution.ctrl0) = tid_join (IdMap.map (fun aeu => aeu.(AExecUnit.local).(ALocal.ctrl)) aeus);
    RMW: ex.(Execution.rmw) = tid_join (IdMap.map (fun aeu => aeu.(AExecUnit.local).(ALocal.rmw)) aeus);
  }.
  #[global]
  Hint Constructors pre_ex: core.

  Definition co1 (ex: Execution.t) :=
    forall eid1 eid2,
      (exists loc
          ex1 ord1 val1
          ex2 ord2 val2,
          <<LABEL: Execution.label eid1 ex = Some (Label.write ex1 ord1 loc val1)>> /\
          <<LABEL: Execution.label eid2 ex = Some (Label.write ex2 ord2 loc val2)>>) ->
      (eid1 = eid2 \/ ex.(Execution.co) eid1 eid2 \/ ex.(Execution.co) eid2 eid1).

  Definition co2 (ex: Execution.t) :=
    forall eid1 eid2,
      ex.(Execution.co) eid1 eid2 ->
      exists loc
         ex1 ord1 val1
         ex2 ord2 val2,
        <<LABEL: Execution.label eid1 ex = Some (Label.write ex1 ord1 loc val1)>> /\
        <<LABEL: Execution.label eid2 ex = Some (Label.write ex2 ord2 loc val2)>>.

  Definition rf1 (ex: Execution.t) :=
    forall eid1 ex1 ord1 loc val
       (LABEL: Execution.label eid1 ex = Some (Label.read ex1 ord1 loc val)),
      (<<NORF: ~ codom_rel ex.(Execution.rf) eid1>> /\ <<VAL: val = Val.default>>) \/
      (exists eid2 ex2 ord2,
          <<LABEL: Execution.label eid2 ex = Some (Label.write ex2 ord2 loc val)>> /\
          <<RF: ex.(Execution.rf) eid2 eid1>>).

  Definition rf2 (ex: Execution.t) :=
    forall eid1 eid2 (RF: ex.(Execution.rf) eid2 eid1),
    exists ex1 ex2 ord1 ord2 loc val,
      <<READ: Execution.label eid1 ex = Some (Label.read ex1 ord1 loc val)>> /\
      <<WRITE: Execution.label eid2 ex = Some (Label.write ex2 ord2 loc val)>>.

  Definition rf_wf (ex: Execution.t) := functional (ex.(Execution.rf))⁻¹.

  Inductive ex (p:program) (ex:Execution.t) := mk_ex {
    PRE: pre_ex p ex;
    CO1: co1 ex;
    CO2: co2 ex;
    RF1: rf1 ex;
    RF2: rf2 ex;
    RF_WF: rf_wf ex;
    INTERNAL: acyclic (Execution.internal ex);
    EXTERNAL: acyclic (Execution.ob ex);
    ATOMIC: le (ex.(Execution.rmw) ∩ ((Execution.fre ex) ⨾ (Execution.coe ex))) bot;
  }.
  #[global]
  Hint Constructors ex: core.
  Coercion PRE: ex >-> pre_ex.

  Definition is_terminal
             p ex (EX: pre_ex p ex): Prop :=
    forall tid aeu (FIND: IdMap.find tid EX.(aeus) = Some aeu),
      State.is_terminal aeu.(AExecUnit.state).

  Lemma data_is_po
        p exec
        (EX: pre_ex p exec):
    exec.(Execution.data) ⊆ Execution.po.
  Proof.
    rewrite EX.(DATA).
    ii. inv H. inv REL. destruct x, y. ss. subst. rewrite IdMap.map_spec in RELS.
    destruct (IdMap.find t EX.(aeus)) eqn:LOCAL; ss. inv RELS.
    generalize (EX.(AEUS) t). rewrite LOCAL. intro X. inv X. des.
    exploit AExecUnit.rtc_step_future; eauto.
    { apply AExecUnit.wf_init. }
    s. i. des. econs; ss.
    inv WF. apply DATA0. ss.
  Qed.

  Lemma ctrl0_is_po
        p exec
        (EX: pre_ex p exec):
    exec.(Execution.ctrl0) ⊆ Execution.po.
  Proof.
    rewrite EX.(CTRL).
    ii. inv H. inv REL. destruct x, y. ss. subst. rewrite IdMap.map_spec in RELS.
    destruct (IdMap.find t EX.(aeus)) eqn:LOCAL; ss. inv RELS.
    generalize (EX.(AEUS) t). rewrite LOCAL. intro X. inv X. des.
    exploit AExecUnit.rtc_step_future; eauto.
    { apply AExecUnit.wf_init. }
    s. i. des. econs; ss.
    inv WF. apply CTRL0. ss.
  Qed.

  Lemma ctrl_is_po
        p exec
        (EX: pre_ex p exec):
    Execution.ctrl exec ⊆ Execution.po.
  Proof.
    ii. inv H. des. etrans; eauto.
    eapply ctrl0_is_po; eauto.
  Qed.

  Lemma addr_is_po
        p exec
        (EX: pre_ex p exec):
    exec.(Execution.addr) ⊆ Execution.po.
  Proof.
    rewrite EX.(ADDR).
    ii. inv H. inv REL. destruct x, y. ss. subst. rewrite IdMap.map_spec in RELS.
    destruct (IdMap.find t EX.(aeus)) eqn:LOCAL; ss. inv RELS.
    generalize (EX.(AEUS) t). rewrite LOCAL. intro X. inv X. des.
    exploit AExecUnit.rtc_step_future; eauto.
    { apply AExecUnit.wf_init. }
    s. i. des. econs; ss.
    inv WF. apply ADDR0. ss.
  Qed.

  Lemma rmw_is_po
        p exec
        (EX: pre_ex p exec):
    exec.(Execution.rmw) ⊆ Execution.po.
  Proof.
    rewrite EX.(RMW).
    ii. inv H. inv REL. destruct x, y. ss. subst. rewrite IdMap.map_spec in RELS.
    destruct (IdMap.find t EX.(aeus)) eqn:LOCAL; ss. inv RELS.
    generalize (EX.(AEUS) t). rewrite LOCAL. intro X. inv X. des.
    exploit AExecUnit.rtc_step_future; eauto.
    { apply AExecUnit.wf_init. }
    s. i. des. econs; ss.
    inv WF. apply RMW0. ss.
  Qed.

  Lemma write_ex_codom_rmw
        p exec
        (EX: pre_ex p exec)
        eid
        (WRITE: exec.(Execution.label_is) (fun l => Label.is_write l /\ Label.is_ex l) eid):
    codom_rel exec.(Execution.rmw) eid.
  Proof.
    destruct eid as [tid n]. rewrite EX.(RMW).
    inv WRITE. des. destruct l; ss. destruct ex0; ss. revert EID. unfold Execution.label.
    rewrite EX.(LABELS), IdMap.map_spec. s.
    destruct (IdMap.find tid EX.(aeus)) eqn:LOCAL; ss. i.
    generalize (EX.(AEUS) tid). rewrite LOCAL. intro X. inv X. des.
    exploit AExecUnit.rtc_step_future; eauto.
    { apply AExecUnit.wf_init. }
    s. i. des. inv WF. exploit RMW1; eauto. intro X. inv X.
    econs. econs.
    - rewrite IdMap.map_spec, LOCAL. ss.
    - instantiate (1 := (_, _)). econs; ss; eauto.
  Qed.

  Lemma rmw_spec
        p exec eid1 eid2
        (EX: pre_ex p exec)
        (RMW: exec.(Execution.rmw) eid1 eid2):
    <<PO: Execution.po eid1 eid2>> /\
    <<LABEL1: exec.(Execution.label_is) (fun l => Label.is_read l /\ Label.is_ex l) eid1>> /\
    <<LABEL2: exec.(Execution.label_is) (fun l => Label.is_write l /\ Label.is_ex l) eid2>> /\
    <<BETWEEN: forall eid3 (AC: Execution.po eid1 eid3) (AC: Execution.po eid3 eid2),
        ~ exec.(Execution.label_is) (fun l => Label.is_read l /\ Label.is_ex l) eid3>>.
  Proof.
    revert RMW. rewrite EX.(RMW).
    i. inv RMW0. inv REL. destruct eid1, eid2. ss. subst. rewrite IdMap.map_spec in RELS.
    destruct (IdMap.find t EX.(aeus)) eqn:LOCAL; ss. inv RELS.
    generalize (EX.(AEUS) t). rewrite LOCAL. intro X. inv X. des.
    exploit AExecUnit.rtc_step_future; eauto.
    { apply AExecUnit.wf_init. }
    s. i. des. inv WF. exploit RMW2; eauto. i. des. splits; eauto.
    - econs.
      + unfold Execution.label. rewrite EX.(LABELS), IdMap.map_spec. s. rewrite LOCAL. eauto.
      + ss.
    - econs.
      + unfold Execution.label. rewrite EX.(LABELS), IdMap.map_spec. s. rewrite LOCAL. eauto.
      + ss.
    - ii. inv AC. inv AC0. ss. subst. inv H. revert EID.
      unfold Execution.label. rewrite EX.(LABELS), IdMap.map_spec, LOCAL. s. i.
      des. destruct l; ss. destruct ex0; ss.
      eapply BETWEEN; eauto.
  Qed.

  Lemma po_label_pre
        p exec
        eid1 eid2 label2
        (PRE: pre_ex p exec)
        (PO: Execution.po eid1 eid2)
        (LABEL: Execution.label eid2 exec = Some label2):
    exists label1, <<LABEL: Execution.label eid1 exec = Some label1>>.
  Proof.
    destruct eid1, eid2. inv PO. ss. subst.
    revert LABEL. unfold Execution.label.
    rewrite PRE.(LABELS), ? IdMap.map_spec. s.
    destruct (IdMap.find t0 PRE.(aeus)) eqn:LOCAL; ss.
    generalize (PRE.(AEUS) t0). rewrite LOCAL. intro X. inv X. des.
    i. exploit List.nth_error_Some. rewrite LABEL. intros [X _]. exploit X; [congr|]. clear X. i.
    generalize (List.nth_error_Some t.(AExecUnit.local).(ALocal.labels) n). intros [_ X]. hexploit X; [lia|]. i.
    destruct (List.nth_error t.(AExecUnit.local).(ALocal.labels) n); ss. eauto.
  Qed.

  Lemma po_label
        p exec
        eid1 eid2 label2
        (EX: ex p exec)
        (PO: Execution.po eid1 eid2)
        (LABEL: Execution.label eid2 exec = Some label2):
    exists label1, <<LABEL: Execution.label eid1 exec = Some label1>>.
  Proof.
    inv EX. eapply po_label_pre; eauto.
  Qed.

  Lemma coherence_rw
        p exec
        eid1 eid2 eid3 loc
        (EX: ex p exec)
        (EID1: exec.(Execution.label_is) (Label.is_reading loc) eid1)
        (EID2: exec.(Execution.label_is) (Label.is_writing loc) eid2)
        (EID3: exec.(Execution.label_is) (Label.is_writing loc) eid3)
        (RF1: exec.(Execution.rf) eid3 eid1)
        (PO: Execution.po eid1 eid2):
    exec.(Execution.co) eid3 eid2.
  Proof.
    inv EID1. apply Label.is_reading_inv in LABEL. des. subst.
    inv EID2. apply Label.is_writing_inv in LABEL. des. subst.
    inv EID3. apply Label.is_writing_inv in LABEL. des. subst.
    exploit EX.(CO1).
    { rewrite EID0, EID1. esplits; eauto. }
    i. des.
    - subst. exfalso. eapply EX.(INTERNAL). econs 2; econs.
      + left. left. left. econs; eauto. econs; eauto.
        econs; eauto using Label.read_is_accessing, Label.write_is_accessing.
      + right. eauto.
    - exfalso. eapply EX.(INTERNAL). econs 2; [econs|econs 2; econs].
      + left. left. left. econs; eauto. econs; eauto.
        econs; eauto using Label.read_is_accessing, Label.write_is_accessing.
      + left. right. eauto.
      + right. eauto.
    - ss.
  Qed.

  Lemma coherence_ww
        p exec
        eid1 eid2 loc
        (EX: ex p exec)
        (EID1: exec.(Execution.label_is) (Label.is_writing loc) eid1)
        (EID2: exec.(Execution.label_is) (Label.is_writing loc) eid2)
        (PO: Execution.po eid1 eid2):
    exec.(Execution.co) eid1 eid2.
  Proof.
    inv EID1. apply Label.is_writing_inv in LABEL. des. subst.
    inv EID2. apply Label.is_writing_inv in LABEL. des. subst.
    exploit EX.(CO1).
    { rewrite EID, EID0. esplits; eauto. }
    i. des.
    - subst. inv PO. lia.
    - ss.
    - exfalso. eapply EX.(INTERNAL). econs 2; econs.
      + left. left. left. econs; eauto. econs; eauto.
        econs; eauto using Label.read_is_accessing, Label.write_is_accessing.
      + left. right. eauto.
  Qed.

  Lemma coherence_rr
        p exec
        eid1 eid2 eid3 loc
        (EX: ex p exec)
        (EID1: exec.(Execution.label_is) (Label.is_reading loc) eid1)
        (EID2: exec.(Execution.label_is) (Label.is_reading loc) eid2)
        (EID3: exec.(Execution.label_is) (Label.is_writing loc) eid3)
        (RF: exec.(Execution.rf) eid3 eid1)
        (PO: Execution.po eid1 eid2):
    exists eid4,
      <<RF: exec.(Execution.rf) eid4 eid2>> /\
      <<CO: exec.(Execution.co)^? eid3 eid4>>.
  Proof.
    inv EID1. apply Label.is_reading_inv in LABEL. des. subst.
    inv EID2. apply Label.is_reading_inv in LABEL. des. subst.
    inv EID3. apply Label.is_writing_inv in LABEL. des. subst.
    exploit EX.(RF1); eauto. i. des.
    { exfalso. eapply EX.(INTERNAL). econs 2; [econs|econs 2; econs].
      - left. left. right. econs 2. econs; cycle 1.
        + econs; eauto. econs; eauto.
        + econs; eauto. econs; eauto using Label.read_is_accessing, Label.write_is_accessing.
      - right. eauto.
      - left. left. left. econs; eauto. econs; eauto.
        econs; eauto using Label.read_is_accessing, Label.write_is_accessing.
    }
    esplits; eauto.
    exploit EX.(CO1).
    { rewrite EID1, LABEL. esplits; eauto. }
    i. des.
    - subst. eauto.
    - econs 2. ss.
    - exfalso. eapply EX.(INTERNAL). econs 2; [econs|econs 2; econs].
      + left. left. left. econs; eauto. econs; eauto.
        econs; eauto using Label.read_is_accessing, Label.write_is_accessing.
      + left. left. right. left. econs; eauto.
      + right. ss.
  Qed.

  Lemma coherence_wr
        p exec
        eid1 eid2 loc
        (EX: ex p exec)
        (EID1: exec.(Execution.label_is) (Label.is_writing loc) eid1)
        (EID2: exec.(Execution.label_is) (Label.is_reading loc) eid2)
        (PO: Execution.po eid1 eid2):
    exists eid3,
      <<RF: exec.(Execution.rf) eid3 eid2>> /\
      <<CO: exec.(Execution.co)^? eid1 eid3>>.
  Proof.
    inv EID1. apply Label.is_writing_inv in LABEL. des. subst.
    inv EID2. apply Label.is_reading_inv in LABEL. des. subst.
    exploit EX.(RF1); eauto. i. des.
    { exfalso. eapply EX.(INTERNAL). econs 2; econs.
      - left. left. right. econs 2. econs; cycle 1.
        + econs; eauto. econs; eauto.
        + econs; eauto. econs; eauto using Label.read_is_accessing, Label.write_is_accessing.
      - left. left. left. econs; eauto. econs; eauto.
        econs; eauto using Label.read_is_accessing, Label.write_is_accessing.
    }
    esplits; eauto.
    exploit EX.(CO1).
    { rewrite EID, LABEL. esplits; eauto. }
    i. des.
    - subst. eauto.
    - econs 2. ss.
    - exfalso. eapply EX.(INTERNAL). econs 2; econs.
      + left. left. left. econs; eauto. econs; eauto.
        econs; eauto using Label.read_is_accessing, Label.write_is_accessing.
      + left. left. right. left. econs; eauto.
  Qed.

  Lemma rf_inv_write
        p exec
        eid1 eid2 ex1 ord1 loc val
        (EX: ex p exec)
        (EID2: Execution.label eid2 exec = Some (Label.read ex1 ord1 loc val))
        (RF3: exec.(Execution.rf) eid1 eid2):
    exists ex2 ord2,
      <<LABEL: Execution.label eid1 exec = Some (Label.write ex2 ord2 loc val)>>.
  Proof.
    exploit EX.(RF1); eauto. i. des.
    - contradict NORF. econs. eauto.
    - exploit EX.(RF_WF); [exact RF3|exact RF|]. i. subst. eauto.
  Qed.

  Ltac obtac :=
    repeat
      (try match goal with
           | [H: Execution.ob _ _ _ |- _] => inv H
           | [H: Execution.obs _ _ _ |- _] => inv H
           | [H: Execution.dob _ _ _ |- _] => inv H
           | [H: Execution.aob _ _ _ |- _] => inv H
           | [H: Execution.bob _ _ _ |- _] => inv H
           | [H: Execution.fr _ _ _ |- _] => inv H
           | [H: Execution.rfe _ _ _ |- _] => inv H
           | [H: Execution.rfi _ _ _ |- _] => inv H
           | [H: (_⨾ _) _ _ |- _] => inv H
           | [H: ⦗_⦘ _ _ |- _] => inv H
           | [H: (_ ∪ _) _ _ |- _] => inv H
           | [H: (_ ∩ _) _ _ |- _] => inv H
           | [H: (_ × _) _ _ |- _] => inv H
           | [H: (minus_rel _ _) _ |- _] => inv H
           | [H: Execution.label_is _ _ _ |- _] => inv H
           | [H: Execution.label_rel _ _ _ _ |- _] => inv H
           | [H: Execution.label_loc _ _ |- _] => inv H
           end;
       des).

  Lemma addr_label
        p exec
        eid1 eid2
        (EX: pre_ex p exec)
        (ADDR: exec.(Execution.addr) eid1 eid2):
    <<EID1: Execution.label_is exec (Label.is_access) eid1>> /\
    <<EID2: Execution.label_is exec (Label.is_access) eid2>>.
  Proof.
    rewrite EX.(Valid.ADDR) in ADDR. inv ADDR.
    destruct eid1 as [tid1 iid1].
    destruct eid2 as [tid2 iid2].
    inv REL. ss. subst.
    rewrite IdMap.map_spec in RELS.
    destruct (IdMap.find tid1 EX.(aeus)) eqn:LOCAL; ss. inv RELS.
    generalize (EX.(AEUS) tid1). rewrite LOCAL. intro X. inv X.
    exploit AExecUnit.rtc_step_future; eauto.
    { apply AExecUnit.wf_init. }
    s. i. des.
    inv WF. exploit ADDR_LABEL; eauto. intro X. inv X.
    esplits.
    - inv H. econs; eauto.
      unfold Execution.label. s.
      rewrite EX.(LABELS), IdMap.map_spec, LOCAL. ss.
    - inv H1. econs; eauto. unfold Execution.label. s. rewrite EX.(LABELS), IdMap.map_spec, LOCAL. ss.
  Qed.

  Lemma data_label
        p exec
        eid1 eid2
        (EX: pre_ex p exec)
        (DATA: exec.(Execution.data) eid1 eid2):
    <<EID1: Execution.label_is exec (Label.is_access) eid1>> /\
    <<EID2: Execution.label_is exec (Label.is_write) eid2>>.
  Proof.
    rewrite EX.(Valid.DATA) in DATA. inv DATA.
    destruct eid1 as [tid1 iid1].
    destruct eid2 as [tid2 iid2].
    inv REL. ss. subst.
    rewrite IdMap.map_spec in RELS.
    destruct (IdMap.find tid1 EX.(aeus)) eqn:LOCAL; ss. inv RELS.
    generalize (EX.(AEUS) tid1). rewrite LOCAL. intro X. inv X.
    exploit AExecUnit.rtc_step_future; eauto.
    { apply AExecUnit.wf_init. }
    s. i. des.
    inv WF. exploit DATA_LABEL; eauto. intro X. inv X.
    esplits.
    - inv H. econs; eauto.
      unfold Execution.label. s.
      rewrite EX.(LABELS), IdMap.map_spec, LOCAL. ss.
    - inv H1. econs; eauto.
      unfold Execution.label. s.
      rewrite EX.(LABELS), IdMap.map_spec, LOCAL. ss.
  Qed.

  Lemma ctrl0_label
        p exec
        eid1 eid2
        (EX: pre_ex p exec)
        (CTRL: exec.(Execution.ctrl0) eid1 eid2):
    <<EID1: Execution.label_is exec (Label.is_access) eid1>> /\
    <<EID2: Execution.label_is exec (Label.is_ctrl) eid2>>.
  Proof.
    rewrite EX.(Valid.CTRL) in CTRL. inv CTRL.
    destruct eid1 as [tid1 iid1].
    destruct eid2 as [tid2 iid2].
    inv REL. ss. subst.
    rewrite IdMap.map_spec in RELS.
    destruct (IdMap.find tid1 EX.(aeus)) eqn:LOCAL; ss. inv RELS.
    generalize (EX.(AEUS) tid1). rewrite LOCAL. intro X. inv X.
    exploit AExecUnit.rtc_step_future; eauto.
    { apply AExecUnit.wf_init. }
    s. i. des.
    inv WF. exploit CTRL_LABEL; eauto. intro X. inv X.
    splits.
    - inv H. econs; eauto.
      unfold Execution.label. s.
      rewrite EX.(LABELS), IdMap.map_spec, LOCAL. ss.
    - inv H1. econs; eauto.
      unfold Execution.label. s.
      rewrite EX.(LABELS), IdMap.map_spec, LOCAL. ss.
  Qed.

  Lemma ctrl_label
        p exec
        eid1 eid2
        (EX: pre_ex p exec)
        (CTRL: Execution.ctrl exec eid1 eid2):
    <<EID1: Execution.label_is exec (Label.is_access) eid1>>.
  Proof.
    inv CTRL. des. exploit ctrl0_label; eauto. i. des. auto.
  Qed.

  Lemma barrier_ob_po
        p exec
        eid1 eid2
        (EX: pre_ex p exec)
        (CO2: co2 exec)
        (RF2: rf2 exec)
        (EID1: Execution.label_is exec Label.is_barrier eid1)
        (OB: Execution.ob exec eid1 eid2):
    Execution.po eid1 eid2.
  Proof.
    inv EID1. destruct l; ss. unfold co2, rf2 in *.
    obtac; ss.
    all: try by etrans; eauto.
    - exploit RF2; eauto. i. des. congr.
    - exploit RF2; eauto. i. des. congr.
    - destruct l1; try congr; ss.
    - exploit CO2; eauto. i. des. congr.
    - eapply addr_label in H1; eauto. des. inv EID1. destruct l; ss; congr.
    - eapply data_label in H1; eauto. des. inv EID1. destruct l; ss; congr.
    - eapply ctrl_is_po; eauto.
    - etrans; eauto. eapply addr_is_po; eauto.
    - etrans; eauto. eapply ctrl_is_po; eauto.
    - etrans; eauto. etrans; eauto. eapply addr_is_po; eauto.
    - exploit RF2; eauto. i. des. congr.
    - exploit RF2; eauto. i. des. congr.
    - revert H0. unfold ifc. condtac; ss. eapply rmw_spec. eauto.
  Qed.

  Lemma ob_barrier_ob
        p exec
        eid1 eid2 eid3
        (PRE: pre_ex p exec)
        (CO2: co2 exec)
        (RF2: rf2 exec)
        (EID2: Execution.label_is exec Label.is_barrier eid2)
        (OB1: Execution.ob exec eid1 eid2)
        (OB2: Execution.ob exec eid2 eid3):
    <<OB: Execution.ob exec eid1 eid3>>.
  Proof.
    inv EID2. destruct l; ss. exploit barrier_ob_po; eauto. i.
    unfold co2, rf2 in *. clear OB2.
    obtac.
    all: try by rewrite EID in EID1; inv EID1; ss.
    all: try by rewrite EID in EID2; inv EID2; ss.
    all: try by destruct l; try congr; ss.
    - exploit RF2; eauto. i. des. congr.
    - exploit CO2; eauto. i. des. congr.
    - exploit CO2; eauto. i. des. congr.
    - inv H0.
      + eapply addr_label in H1; eauto. des. inv EID2. destruct l; ss; try congr.
      + inv H. exploit RF2; eauto. i. des. congr.
    - inv H0.
      + eapply data_label in H1; eauto. des. inv EID2. destruct l; ss. congr.
      + inv H. exploit RF2; eauto. i. des. congr.
    - exploit RF2; eauto. i. des. congr.
    - right. left. left. right. econs. splits; [by econs; eauto|]. etrans; eauto.
    - revert H0. unfold ifc. condtac; ss. i. exploit rmw_spec; eauto. i. des.
      inv LABEL2. rewrite EID in EID0. inv EID0. des. ss.
  Qed.

  Lemma ctrl_ob_po
        p exec
        eid1 eid2
        (EX: pre_ex p exec)
        (CO2: co2 exec)
        (RF2: rf2 exec)
        (EID1: Execution.label_is exec Label.is_ctrl eid1)
        (OB: Execution.ob exec eid1 eid2):
    Execution.po eid1 eid2.
  Proof.
    inv EID1. destruct l; ss. unfold co2, rf2 in *.
    obtac; ss.
    all: try by etrans; eauto.
    - exploit RF2; eauto. i. des. congr.
    - exploit RF2; eauto. i. des. congr.
    - destruct l1; try congr; ss.
    - exploit CO2; eauto. i. des. congr.
    - eapply addr_label in H1; eauto. des. inv EID1. destruct l; ss; congr.
    - eapply data_label in H1; eauto. des. inv EID1. destruct l; ss; congr.
    - eapply ctrl_is_po; eauto.
    - etrans; eauto. eapply addr_is_po; eauto.
    - etrans; eauto. eapply ctrl_is_po; eauto.
    - etrans; eauto. etrans; eauto. eapply addr_is_po; eauto.
    - exploit RF2; eauto. i. des. congr.
    - exploit RF2; eauto. i. des. congr.
    - revert H0. unfold ifc. condtac; ss. eapply rmw_spec. eauto.
  Qed.

  Lemma ob_ctrl_ob
        p exec
        eid1 eid2 eid3
        (PRE: pre_ex p exec)
        (CO2: co2 exec)
        (RF2: rf2 exec)
        (EID2: Execution.label_is exec Label.is_ctrl eid2)
        (OB1: Execution.ob exec eid1 eid2)
        (OB2: Execution.ob exec eid2 eid3):
    <<OB: Execution.ob exec eid1 eid3>>.
  Proof.
    inv EID2. destruct l; ss. exploit ctrl_ob_po; eauto. i.
    unfold co2, rf2 in *. clear OB2.
    obtac.
    all: try by rewrite EID in EID1; inv EID1; ss.
    all: try by rewrite EID in EID2; inv EID2; ss.
    all: try by destruct l; try congr; ss.
    - exploit RF2; eauto. i. des. congr.
    - exploit CO2; eauto. i. des. congr.
    - exploit CO2; eauto. i. des. congr.
    - inv H0.
      + eapply addr_label in H1; eauto. des. inv EID2. destruct l; ss; try congr.
      + inv H. exploit RF2; eauto. i. des. congr.
    - inv H0.
      + eapply data_label in H1; eauto. des. inv EID2. destruct l; ss. congr.
      + inv H. exploit RF2; eauto. i. des. congr.
    - exploit RF2; eauto. i. des. congr.
    - right. left. left. right. econs. splits; [by econs; eauto|]. etrans; eauto.
    - revert H0. unfold ifc. condtac; ss. i. exploit rmw_spec; eauto. i. des.
      inv LABEL2. rewrite EID in EID0. inv EID0. des. ss.
  Qed.

  Lemma ob_label
        p exec
        eid1 eid2
        (PRE: pre_ex p exec)
        (CO2: co2 exec)
        (RF2: rf2 exec)
        (OB: Execution.ob exec eid1 eid2)
        (EID1: Execution.label eid1 exec = None):
    False.
  Proof.
    unfold co2, rf2 in *.
    obtac.
    all: try congr.
    all: try by exploit RF2; eauto; i; des; congr.
    all: try by exploit CO2; eauto; i; des; congr.
    - exploit addr_label; eauto. i. des. inv EID0. congr.
    - exploit data_label; eauto. i. des. inv EID0. congr.
    - exploit ctrl_label; eauto. i. des. inv x0. congr.
    - exploit addr_label; eauto. i. des. inv EID0. congr.
    - exploit ctrl_label; eauto. i. des. inv x1. congr.
    - exploit addr_label; eauto. i. des. inv EID2. congr.
    - exploit po_label_pre; try exact EID; eauto. i. des. congr.
    - revert H0. unfold ifc. condtac; ss. i. exploit rmw_spec; eauto. i. des. inv LABEL1. congr.
  Qed.

  Lemma ob_cycle
        p exec eid
        (PRE: pre_ex p exec)
        (CO2: co2 exec)
        (RF2: rf2 exec)
        (CYCLE: (Execution.ob exec)⁺ eid eid):
    exists eid_nb,
      (Execution.ob exec ∩ (Execution.label_is_rel exec Label.is_access))⁺ eid_nb eid_nb.
  Proof.
    exploit minimalize_cycle; eauto.
    { instantiate (1 := Execution.label_is exec Label.is_access).
      i. destruct (Execution.label b exec) eqn:LABEL.
      - destruct t; try by contradict H1; econs; eauto.
        + eapply ob_barrier_ob; eauto.
        + eapply ob_ctrl_ob; eauto.
      - exfalso. eapply ob_label; eauto.
    }
    i. des.
    - esplits. eapply clos_trans_mon; eauto. s. i. des.
      econs; ss. inv H0. inv H1. econs; eauto.
    - destruct (Execution.label a exec) eqn:LABEL.
      + destruct t; try by contradict x0; econs; eauto.
        * exploit barrier_ob_po; eauto. i. inv x2. lia.
        * exploit ctrl_ob_po; eauto. i. inv x2. lia.
      + exfalso. eapply ob_label; eauto.
  Qed.

  Lemma internal_rw
        p ex
        eid1 eid2
        (PRE: pre_ex p ex)
        (CO2: co2 ex)
        (RF2: rf2 ex)
        (INTERNAL: Execution.internal ex eid1 eid2):
    <<EID1: ex.(Execution.label_is) Label.is_access eid1>> /\
    <<EID2: ex.(Execution.label_is) Label.is_access eid2>>.
  Proof.
    unfold Execution.internal in *. obtac.
    - inv H. inv H1. inv LABEL. splits.
      + destruct l1; ss; econs; eauto.
      + destruct l2; ss; econs; eauto.
    - exploit CO2; eauto. i. des.
      exploit RF2; eauto. i. des.
      splits; econs; eauto.
    - splits.
      + destruct l1; ss; econs; eauto.
      + destruct l2; ss; econs; eauto.
    - exploit CO2; eauto. i. des.
      splits; econs; eauto.
    - exploit RF2; eauto. i. des.
      splits; econs; eauto.
  Qed.

  Lemma internal_read_read_po
        p ex
        eid1 eid2
        (PRE: pre_ex p ex)
        (CO2: co2 ex)
        (RF2: rf2 ex)
        (INTERNAL: Execution.internal ex eid1 eid2)
        (EID1: ex.(Execution.label_is) Label.is_read eid1)
        (EID2: ex.(Execution.label_is) Label.is_read eid2):
    Execution.po eid1 eid2.
  Proof.
    unfold Execution.internal in *. obtac.
    - inv H. ss.
    - exploit CO2; eauto. i. des.
      destruct l; ss. congr.
    - rewrite EID in EID0. inv EID0. destruct l0; ss.
    - exploit CO2; eauto. i. des.
      destruct l; ss. congr.
    - exploit RF2; eauto. i. des.
      destruct l0; ss. congr.
  Qed.

  Lemma ob_read_read_po
        p ex
        eid1 eid2
        (PRE: pre_ex p ex)
        (CO1: co1 ex)
        (CO2: co2 ex)
        (RF1: rf1 ex)
        (RF2: rf2 ex)
        (RF_WF: rf_wf ex)
        (INTERNAL: acyclic (Execution.internal ex))
        (OB: Execution.ob ex eid1 eid2)
        (EID1: ex.(Execution.label_is) Label.is_read eid1)
        (EID2: ex.(Execution.label_is) Label.is_read eid2):
    Execution.po eid1 eid2.
  Proof.
    inv EID1. inv EID2. destruct l; ss. destruct l0; ss.
    unfold Execution.ob in *. obtac; try congr.
    all: try by etrans; eauto.
    all: try by exploit RF2; eauto; i; des; congr.
    all: try by exploit CO2; eauto; i; des; congr.
    - inv H0. rewrite EID0 in EID1. inv EID1. inv LABEL1.
    - exploit addr_is_po; eauto. i. inv H0; ss. etrans; eauto.
      cut (Execution.po x eid2 \/ Execution.po eid2 x).
      { i. inv H. des; auto.
        exfalso. eapply INTERNAL. econs 2.
        - econs. right. eauto.
        - exploit RF2; eauto. i. des.
          econs. repeat left. repeat (econs; eauto); ss.
          + instantiate (1 := loc1).
            unfold equiv_dec. unfold Z_eqdec. unfold proj_sumbool.
            des_ifs; ss.
          + unfold equiv_dec. unfold Z_eqdec. unfold proj_sumbool.
            des_ifs; ss. }
      inv H. inv H2. destruct x as [t1 e1], eid2 as [t2 e2]. ss.
      exploit RF2; eauto. i. des.
      generalize (Nat.lt_trichotomy e1 e2). i. des; try congr.
      + left. econs; eauto.
      + right. econs; eauto.
    - exploit data_is_po; eauto. i. inv H0; ss. etrans; eauto.
      cut (Execution.po x eid2 \/ Execution.po eid2 x).
      { i. inv H. des; auto.
        exfalso. eapply INTERNAL. econs 2.
        - econs. right. eauto.
        - exploit RF2; eauto. i. des.
          econs. repeat left. repeat (econs; eauto); ss.
          + instantiate (1 := loc1).
            unfold equiv_dec. unfold Z_eqdec. unfold proj_sumbool.
            des_ifs; ss.
          + unfold equiv_dec. unfold Z_eqdec. unfold proj_sumbool.
            des_ifs; ss. }
      inv H. inv H2. destruct x as [t1 e1], eid2 as [t2 e2]. ss.
      exploit RF2; eauto. i. des.
      generalize (Nat.lt_trichotomy e1 e2). i. des; try congr.
      + left. econs; eauto.
      + right. econs; eauto.
    - eapply ctrl_is_po; eauto.
    - etrans; eauto. eapply addr_is_po; eauto.
    - rewrite <- H2. eapply ctrl_is_po; eauto.
    - rewrite <- H2, <- H0. eapply addr_is_po; eauto.
    - revert H0. unfold ifc. condtac; ss. eapply rmw_spec. eauto.
  Qed.

  Lemma rfi_is_po
        ex eid1 eid2
        (RF2: Valid.rf2 ex)
        (INTERNAL: acyclic (Execution.internal ex))
        (RFI: Execution.rfi ex eid1 eid2):
    Execution.po eid1 eid2.
  Proof.
    destruct eid1 as [tid1 eid1], eid2 as [tid2 eid2].
    inv RFI. inv H0. ss. subst.
    exploit RF2; eauto. i. des.
    generalize (Nat.lt_trichotomy eid1 eid2). i. des.
    - econs; ss.
    - subst. congr.
    - exfalso. eapply INTERNAL. econs 2.
      + econs 1. right. eauto.
      + econs 1. left. left. left. econs; eauto.
        econs; eauto. econs; unfold Label.is_accessing; eauto.
        * instantiate (1 := loc).
          destruct (equiv_dec loc loc); ss.
          exfalso. apply c. ss.
        * destruct (equiv_dec loc loc); ss.
          exfalso. apply c. ss.
  Qed.

  Lemma po_loc_write_is_co
        ex eid1 eid2 loc
        (CO1: Valid.co1 ex)
        (INTERNAL: acyclic (Execution.internal ex))
        (PO: Execution.po eid1 eid2)
        (LABEL1: ex.(Execution.label_is) (Label.is_writing loc) eid1)
        (LABEL2: ex.(Execution.label_is) (Label.is_writing loc) eid2):
    ex.(Execution.co) eid1 eid2.
  Proof.
    destruct eid1 as [tid1 eid1], eid2 as [tid2 eid2].
    inv LABEL1. inv LABEL2. destruct l, l0; ss.
    destruct (equiv_dec loc0 loc) eqn:Heq1; ss.
    destruct (equiv_dec loc1 loc) eqn:Heq2; ss.
    rewrite e, e0 in *.
    exploit CO1; eauto.
    { esplits; [exact EID|exact EID0]. }
    intro x. des; eauto.
    - inv x. inv PO. ss. lia.
    - exfalso. eapply INTERNAL. econs 2.
      + econs 1. left. left. left. econs; eauto.
        econs; eauto. econs; unfold Label.is_accessing; eauto.
        * instantiate (1 := loc).
          destruct (equiv_dec loc loc); ss.
        * destruct (equiv_dec loc loc); ss.
      + econs 1. left. right. eauto.
  Qed.
End Valid.

Coercion Valid.PRE: Valid.ex >-> Valid.pre_ex.


From mathcomp Require Import all_ssreflect.
From mathcomp Require Import finmap multiset.
From Coq Require Import Reals Relation_Definitions Relation_Operators Lra.
From mathcomp Require Import boolp Rstruct.
From Algorand Require Import fmap_ext algorand_model safety_helpers quorums safety.

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

Open Scope mset_scope.
Open Scope fmap_scope.
Open Scope fset_scope.

(** NOTE: This is only an initial attempt at specifying liveness
properties for the transition system. This part is still
work-in-progress and thus the file contains incomplete
(admitted) proofs. *)

Definition users_at ix path : {fmap UserId -> UState} :=
  match drop ix path with
  | g1 :: _ => g1.(users)
  | _ => [fmap]
  end.

Definition user_stv_val (uid:UserId) (g:GState) (p:nat) (stv':option Value) : bool :=
  if g.(users).[? uid] is Some ustate then ustate.(stv).[? p] == stv' else false.

Definition user_stv_val_at ix path uid p stv : bool :=
  match drop ix path with
  | g1 :: _ => user_stv_val uid g1 p stv
  | _ => false
  end.

(** ** Sensible states *)

(** This notion specifies what states can be considered valid states. The idea
is that we only consider execution traces that begin at sensible states,
since sensibility is preserved by the transition system (to be shown), the
set of reachable states will also be sensible (to be shown). This means that
it is not important which specific state is assumed as the initial state as
long as the state is sensible.
Note: the traditional operational notion of an initial state is a now a
special case of sensibility. *)
Definition sensible_ustate (us : UState) : Prop :=
  (us.(p_start) >= 0)%R /\
  (0 <= us.(timer) <= us.(deadline))%R .

Definition sensible_gstate (gs : GState) : Prop :=
  (gs.(now) >= 0)%R /\
  ~ gs.(users) = [fmap] /\
  domf gs.(msg_in_transit) `<=` domf gs.(users) /\ (* needed? *)
  forall uid (k:uid \in gs.(users)), sensible_ustate gs.(users).[k].
  (* more constraints if we add corrupt users map and total message history *)

Lemma step_later_deadlines : forall s,
    s > 3 -> next_deadline s = (lambda + big_lambda + (INR s - 3) * L)%R.
Proof.
  intros s H_s; clear -H_s.
  unfold next_deadline.
  do 3 (destruct s;[exfalso;apply not_false_is_true;assumption|]).
  reflexivity.
Qed.

(** The user transition relation preserves sensibility of user states. *)
Lemma utr_msg_preserves_sensibility : forall uid us us' m ms,
  sensible_ustate us -> uid # us ; m ~> (us', ms) ->
  sensible_ustate us'.
Proof.
  intros uid us us' m ms H_sensible Hstep;
  remember (us',ms) as ustep_output eqn:H_output;
  destruct Hstep; injection H_output; intros; subst;
  match goal with
  | [H_sensible : sensible_ustate ?s |- _] => is_var s;
     destruct s;unfold sensible_ustate in * |- *;
     decompose record H_sensible;clear H_sensible;simpl in * |- *
  end;
  autounfold with utransition_unfold in * |- *;
  match goal with
  | [H : context C [valid_rps] |- _] => unfold valid_rps in H;simpl in H;decompose record H
  | _ => idtac
  end;
  try by intuition lra.
  (* deliver nonvote msg needs some custom steps *)
  clear H_output.
  destruct msg as [mtype ex_val ? ? ?];
    destruct ex_val;simpl;[destruct mtype;simpl|..];intuition lra.
Qed.

Lemma utr_nomsg_preserves_sensibility : forall uid us us' ms,
  sensible_ustate us -> uid # us ~> (us', ms) ->
  sensible_ustate us'.
Proof.
  let use_hyp H := (unfold valid_rps in H;simpl in H; decompose record H) in
  let tidy _ :=
  (match goal with
    | [ |- context C [ next_deadline (?s + 1 - 1) ] ] =>
      replace (s + 1 - 1) with s by (rewrite addn1;rewrite subn1;symmetry;apply Nat.pred_succ)
    | [ H : is_true (3 < ?s) |- context C [next_deadline ?s] ] =>
      rewrite (step_later_deadlines H)
  end) in
  intros uid us us' ms H_sensible Hstep;
  remember (us',ms) as ustep_output eqn:H_output;
  destruct Hstep; injection H_output; intros; subst;
  match goal with
  | [H_sensible : sensible_ustate ?s |- _] => is_var s;
     destruct s;unfold sensible_ustate in * |- *;
     decompose record H_sensible;clear H_sensible;simpl in * |- *
  end;
  try (
    match goal with
    | [H: propose_ok _ _ _ _ _ _ |- _] => unfold propose_ok in H; use_hyp H
    | [H: repropose_ok _ _ _ _ _ |- _] => unfold repropose_ok in H; use_hyp H
    | [H: no_propose_ok _ _ _ _ |- _] => unfold no_propose_ok in H; use_hyp H
    | [H: softvote_new_ok _ _ _ _ _ |- _] => unfold softvote_new_ok in H; use_hyp H
    | [H: softvote_repr_ok _ _ _ _ _ |- _] => unfold softvote_repr_ok in H; use_hyp H
    | [H: no_softvote_ok _ _ _ _ |- _] => unfold no_softvote_ok in H; use_hyp H
    | [H: certvote_ok _ _ _ _ _ _ |- _] => unfold certvote_ok in H; use_hyp H
    | [H: no_certvote_ok _ _ _ _ |- _] => unfold no_certvote_ok in H; use_hyp H
    | [H: nextvote_val_ok _ _ _ _ _ _ _ |- _] => unfold nextvote_val_ok in H; use_hyp H
    | [H: nextvote_open_ok _ _ _ _ _ _ _ |- _] => unfold nextvote_open_ok in H; use_hyp H
    | [H: nextvote_stv_ok _ _ _ _ _ _ _ /\ _ |- _] => destruct H as [H Hs]; unfold nextvote_stv_ok in H; use_hyp H
    | [H: no_nextvote_ok _ _ _ _ _ |- _] => unfold no_nextvote_ok in H; use_hyp H
    | [H: set_softvotes _ _ _ _ |- _] => unfold set_softvotes in H; use_hyp H
    | [H: certvote_timeout_ok _ _ _ _ |- _] => unfold timout_ok in H; use_hyp H
    | _ => idtac
    end;
    repeat (tidy ());intuition lra).
   - split => //; split => //.
     by admit.
   - split => //; split => //.
     by admit.
   - split => //; split => //.
     by admit.
   - split => //; split => //.
     by admit.
Admitted.

(** The global transition relation preserves sensibility of global states. *)
Lemma gtr_preserves_sensibility : forall gs gs',
  sensible_gstate gs -> GTransition gs gs' ->
  sensible_gstate gs'.
Proof.
  let use_hyp H := (unfold valid_rps in H;simpl in H; decompose record H) in
  intros gs gs' H_sensible Hstep;
  destruct Hstep.

  * destruct pre. unfold tick_update, tick_users. simpl.
    admit.
  * apply utr_msg_preserves_sensibility in H1;
      [|unfold sensible_gstate in H_sensible;decompose record H_sensible;done].
    destruct pre;unfold sensible_gstate in * |- *.
    unfold delivery_result;simpl in * |- *.
    { intuition.
      * move :H5. clear.
        move/(f_equal (fun f => uid \in f)).
        change (uid \in ?f) with (uid \in domf f).
          by rewrite dom_setf fset1U1 in_fset0.
      * admit.
      * rewrite ffunE. simpl.
        set test := (uid0 == uid);destruct test eqn:H_eq;subst test.
        assumption.
        change (uid0 \in ?f) with (uid0 \in domf f) in k.
        rewrite dom_setf in_fset1U H_eq /= in k.
        by rewrite in_fnd;apply H6.
    }
  * apply utr_nomsg_preserves_sensibility in H0;
      [|unfold sensible_gstate in H_sensible;decompose record H_sensible;done].
    destruct pre;unfold sensible_gstate in * |- *.
    unfold step_result;simpl in * |- *.
    { intuition.
      * move:H4; clear.
        move/(f_equal (fun f => uid \in f)).
        change (uid \in ?f) with (uid \in domf f).
          by rewrite dom_setf fset1U1 in_fset0.
      * admit.
      * rewrite ffunE. simpl.
        set test := (uid0 == uid);destruct test eqn:H_eq;subst test.
        assumption.
        change (uid0 \in ?f) with (uid0 \in domf f) in k.
        rewrite dom_setf in_fset1U H_eq /= in k.
        by rewrite in_fnd;apply H5.
    }
  * (* recover from partition *)
    admit.
  * (* make partitioned *)
    admit.
  * (* corrupt user *)
    admit.
  * (* replay message *)
    admit.
  * (* forge message *)
Admitted.

(* Generalization of preservation of sensibility to paths *)
Lemma greachable_preserves_sensibility : forall g0 g,
  greachable g0 g -> sensible_gstate g0 -> sensible_gstate g.
Proof.
  move => g0 g [p Hp] Hg.
  destruct p. inversion Hp.
  unfold is_trace in Hp.
  destruct Hp as [Hg' Hpath].
  subst g1.
  elim: p g0 g Hg Hpath => /= [g g0 Hg|]; first by rewrite Hg.
  move => g p IH g1 g0 Hl.
  move/andP => [Ht Hp] Hs.
  move/IH: Hp => Hp.
  move/Hp: Hl; apply.
  move: Ht.
  move/asboolP.
  exact: gtr_preserves_sensibility.
Qed.

Lemma at_most_one_certval_in_p
      g0 trace (H_path: is_trace g0 trace)
      r0 (H_start: state_before_round r0 g0):
  forall ix g, onth trace ix = Some g ->
  forall uid u, g.(users).[? uid] = Some u ->
  forall r, r0 <= r ->
  forall p v1 v2,
    v1 \in certvals u r p -> v2 \in certvals u r p -> v1 = v2.
Proof.
  clear -H_path H_start.
  move => ix g H_onth uid u H_lookup r H_round p v1 v2.
  unfold certvals, vote_values, soft_weight.
  rewrite !mem_filter.
  move => /andP [Hv1_q Hv1in].
  move => /andP [Hv2_q Hv2in].
  have H_votes_checked := (softvote_credentials_checked H_path H_start H_onth H_lookup H_round).

  have Hq := quorums_s_honest_overlap trace.
  specialize (Hq r p 2 _ _ (H_votes_checked _ _) Hv1_q (H_votes_checked _ _) Hv2_q).

  move: Hq => [softvoter [H_voted_v1 [H_voted_v2 H_softvoter_honest]]].
  assert (softvoted_in_path trace softvoter r p v1) as H_sent_v1. {
  apply (softvotes_sent H_path H_start H_onth H_lookup H_round).
  move:H_voted_v1 => /imfsetP /= [] x /andP [H_x_in].
  unfold matchValue. destruct x. move => /eqP ? /= ?;subst.
  assumption.
  assumption.
  }
  assert (softvoted_in_path trace softvoter r p v2) as H_sent_v2. {
  apply (softvotes_sent H_path H_start H_onth H_lookup H_round).
  move:H_voted_v2 => /imfsetP /= [] x /andP [H_x_in].
  unfold matchValue. destruct x. move => /eqP ? /= ?;subst.
  assumption.
  assumption.
  }
  move: H_sent_v1 => [ix_v1 H_sent_v1].
  move: H_sent_v2 => [ix_v2 H_sent_v2].

  by case:(no_two_softvotes_in_p H_path H_sent_v1 H_sent_v2).
Qed.

(** A user has (re-)proposed a value/block for a given round/period
along a given path. *)
Definition proposed_in_path_at ix path uid r p v b : Prop :=
  exists g1 g2, step_in_path_at g1 g2 ix path /\
    (user_sent uid (mkMsg Proposal (val v) r p uid) g1 g2 /\
     user_sent uid (mkMsg Block (val b) r p uid) g1 g2 \/
     user_sent uid (mkMsg Reproposal (repr_val v uid p) r p uid) g1 g2).

(** A block proposer (potential leader) for a given round/period along a path. *)
Definition block_proposer_in_path_at ix path uid r p v b : Prop :=
  uid \in committee r p 1 /\
  valid_block_and_hash b v /\
  proposed_in_path_at ix path uid r p v b.

(** The block proposer (the leader) for a given round/period along a path. *)
Definition leader_in_path_at ix path uid r p v b : Prop :=
  block_proposer_in_path_at ix path uid r p v b /\
  forall id, id \in committee r p 1 /\ id <> uid ->
    (credential uid r p 1 < credential id r p 1)%O.

(** A trace is partition-free if it is either empty or it is a valid trace that
starts at an unparitioned state and does not involve a partitioning
transition -- Note: not compatible with [is_trace] above. *)

Definition partition_free g0 trace : Prop :=
  is_trace g0 trace /\
  is_unpartitioned g0 /\
  forall n, ~ step_at trace n lbl_enter_partition.

Lemma partition_state : forall g,
  is_unpartitioned g ->
  is_partitioned (make_partitioned g).
Proof.
  intros g unp_H.
  unfold is_unpartitioned,is_partitioned in unp_H.
  unfold is_partitioned, make_partitioned, flip_partition_flag.
  simpl. assumption.
Qed.

(** [is_partitioned] as a proposition. *)
Lemma is_partitionedP : forall g : GState,
  reflect
    (g.(network_partition) = true)
    (is_partitioned g).
Admitted.

Lemma partition_free_step : forall g0 g1,
  is_unpartitioned g0 -> GTransition g0 g1 ->
  ~ related_by lbl_enter_partition g0 g1 ->
  is_unpartitioned g1.
Proof.
intros g0 g1 g0unp_H g0g1step_H notpstep_H.
unfold related_by in notpstep_H. intuition.
unfold make_partitioned in H0. unfold flip_partition_flag in H0. simpl in * |- *.
(* almost all cases are straightforward *)
destruct g0g1step_H ; auto.
(* except recover_from_partitioned, which is handled separately *)
  unfold is_unpartitioned in g0unp_H. rewrite H in g0unp_H. auto.
Qed.

Lemma partition_free_prefix : forall g0 n trace,
  n > 0 ->
  partition_free g0 trace ->
  partition_free g0 (take n trace).
Proof.
Admitted.

Lemma partition_free_suffix : forall g0 n trace,
  n < size trace ->
  partition_free g0 trace ->
  partition_free g0 (drop n trace).
Proof.
Admitted.

(* Whether the effect of a message is recored in the user state *)
Definition message_recorded ustate msg : Prop :=
match msg_type msg, msg_ev msg with
| Block, val b =>
  let: r := msg_round msg in
  b \in ustate.(blocks) r
| Proposal, val v =>
  let: uid := msg_sender msg in
  let: r := msg_round msg in
  let: p := msg_period msg in
  exists c, (uid, c, v, true) \in ustate.(proposals) (r, p)
| Reproposal, repr_val v uid' p' =>
  let: uid := msg_sender msg in
  let: r := msg_round msg in
  let: p := msg_period msg in
  exists c, (uid, c, v, false) \in ustate.(proposals) (r, p)
| Softvote, val v =>
  let: uid := msg_sender msg in
  let: r := msg_round msg in
  let: p := msg_period msg in
  (uid, v) \in ustate.(softvotes) (r, p)
| Certvote, val v =>
  let: uid := msg_sender msg in
  let: r := msg_round msg in
  let: p := msg_period msg in
  (uid, v) \in ustate.(certvotes) (r, p)
| Nextvote_Open, step_val s =>
  let: uid := msg_sender msg in
  let: r := msg_round msg in
  let: p := msg_period msg in
  uid \in ustate.(nextvotes_open) (r, p, s)
| Nextvote_Val, next_val v s =>
  let: uid := msg_sender msg in
  let: r := msg_round msg in
  let: p := msg_period msg in
  (uid, v) \in ustate.(nextvotes_val) (r, p, s)
| _, _ => True
end.

(** The effect of the message is recorded in the state of the target user on or
before the message's deadline. *)
Definition msg_timely_delivered msg deadline gstate target : Prop :=
  Rle gstate.(now) deadline /\
  exists ustate, gstate.(users).[? target] = Some ustate /\
  message_recorded ustate msg.

(** If a message is sent along a partition-free trace, and the trace is long enough,
   then the message is received by all honest users in a timely fashion. *)
(* Note: this probably needs revision *)
Lemma sent_msg_timely_received : forall sender msg g0 g1 trace,
  let deadline := msg_deadline msg g0.(now) in
    user_sent sender msg g0 g1 ->
    path gtransition g0 (g1 :: trace) ->
    partition_free g0 (g1 :: trace) ->
    Rle deadline (last g0 (g1 :: trace)).(now) ->
    exists ix g, ohead (drop ix (g1 :: trace)) = Some g
      /\ (forall target, target \in honest_users g.(users) ->
            msg_timely_delivered msg deadline g target).
Proof.
Admitted.

(** If the block proposer of period [r,1] is honest, then a certificate for round [r]
is produced at period [r,1]. *)
(* Need the assumption of no partition?? *)
Lemma prop_a : forall g0 g1 trace uid r v b,
  path gtransition g0 (g1 :: trace) ->
  partition_free g0 (g0 :: g1 :: trace) ->
  leader_in_path_at 0 (g0 :: g1 :: trace) uid r 1 v b ->
  user_honest_at 0 (g0 :: g1 :: trace) uid ->
  certified_in_period trace r 1 v.
Proof.
intros g0 g1 trace sender r v b tr_H pfree_tr_H leader_H honest_H.
destruct leader_H as [proposer_H crommitte_H].
destruct proposer_H as [poleader_H [vb_H proposed_H]].
destruct proposed_H as [g' prop_sent_H].
destruct prop_sent_H as [g'' [prop_step_H prop_sent_H]]. destruct prop_step_H. subst.
  (* Need to identify: - the step and state at which the message is received
                      - the user who is receiving the message *)
destruct prop_sent_H as [propsent_H | repropsent_H].
  destruct propsent_H as [propsent_H blocksent_H].
  pose proof (@sent_msg_timely_received sender (mkMsg Proposal (val v) r 1 sender) g' g'' trace). simpl in * |- *.
Admitted.

(** If some period [r,p] for [p >= 2] is reached with unique starting value bot and the
leader is honest, then the leader’s proposal is certified. *)
(* TODO: all users need starting value bot or just leader? *)
Lemma prop_c : forall ix path uid r p v b,
  p >= 2 ->
  all (fun u => user_stv_val_at ix path u p None) (domf (users_at ix path)) ->
  leader_in_path_at ix path uid r 1 v b ->
  user_honest_at ix path uid ->
  certified_in_period path r p v.
Proof.
Admitted.

(** Softvote quorum of all honest users implies certvote quorum. *)
Lemma honest_softvote_quorum_implies_certvote : forall (softvote_quorum : {fset UserId}) ix path r p v,
  (forall voter : UserId, voter \in softvote_quorum ->
                                    voter \in domf (honest_users (users_at ix path))) ->
  softvote_quorum `<=` committee r p 3 ->
  tau_c <= #|softvote_quorum| ->
  (forall voter : UserId, voter \in softvote_quorum
                                    -> softvoted_in_path_at ix path voter r p v) ->
  (forall voter : UserId, voter \in softvote_quorum
                                    -> certvoted_in_path path voter r p v).
Proof.
Abort.

(** Honest user softvotes starting value. *)
Lemma stv_not_bot_softvote : forall ix path r p v uid,
  uid \in domf (honest_users (users_at ix path)) ->
  user_stv_val_at ix path uid p (Some v) ->
  softvoted_in_path_at ix path uid r p v.
Proof.
Abort.

(** If some period [r,p] with [p >= 2] is reached, and all honest users have starting
value [H(B)], then a certificate for [H(B)] that period is produced by the honest users. *)
(* TODO: need to say quorum for certificate is only *honest* users? *)
Lemma prop_e : forall ix path r p v b,
  p >= 2 ->
  all (fun u => user_stv_val_at ix path u p (Some v))
      (domf (honest_users (users_at ix path))) ->
  valid_block_and_hash b v ->
  certified_in_period path r p v.
Proof.
  intros.
  exists (domf (honest_users (users_at ix path))).
  (* quorum subset of committee at step 3 *)
  assert (domf (honest_users (users_at ix path)) `<=` committee r p 3) by admit.
  (* at least t_H honest users *)
  assert (tau_c <= #|domf (honest_users (users_at ix path))|) by admit.
  repeat split; try assumption.
Admitted.

(** If any honest user is in period [r,p] with starting value bottom, then within
time [(2*lambda+Lambda)], every honest user in period [r,p] will either certify a
value (i.e., will get a certificate) or move to the next period. *)
Lemma prop_f : forall r p g0 g1 g2 path_seq uid,
    path gtransition g0 path_seq ->
    g2 = last g0 path_seq ->
    g1 = last g0 (drop 1 path_seq) ->
    user_honest uid g1 ->
    user_stv_val uid g1 p None ->
    (exists v, certvoted_in_path path_seq uid r p v \/
      period_advance_at 1 path_seq uid r p g1 g2).
Proof.
Admitted.


(*
From Coq Require Import Strings.String.
From Coq Require Import Strings.Ascii.
From Coq Require Import Lists.List. Import ListNotations.

*)
From Coq Require Import Strings.String.

Inductive SP : Type :=
  | ALL
  | NONE.

Inductive ASP : Type :=
  | CPY
  | SIG
  | HSH
  | ASPC (ASP_ID : nat) (Arg : string).

Inductive T : Type :=
  | ASPT (a : ASP)
  | AT (Pl : nat) (t : T)
  | LN (t1 t2 : T)
  | BRS (s1 s2 : SP) (t1 t2 : T)
  | BRP (s1 s2 : SP) (t1 t2 : T).

Delimit Scope string_scope with string.
Local Open Scope string_scope.

Check ASPT (CPY).
Check AT (123) (AT 45 (ASPT CPY)).
Check BRP ALL ALL (ASPT CPY) (ASPT HSH).
Check AT 2 (AT 3 (BRS NONE ALL (ASPT (ASPC 11 bank)) (ASPT SIG))).
Check AT 1 (AT 2 (BRS NONE ALL (ASPT HSH) (LN (ASPT SIG) (AT 3 (ASPT CPY))))).


From BF Require Import Base Byte RelVM VM Token.

Inductive ast : Type :=
  | ARight (a : ast)
  | ALeft (a : ast)
  | AInc (a : ast)
  | ADec (a : ast)
  | AOutput (a : ast)
  | AInput (a : ast)
  | ALoop (body : ast) (a : ast)
  | AEnd.

Inductive execute : ast -> vm -> vm -> Prop :=
  | E_ARight a v v'' :
      execute a (VM.shift_right v) v'' ->
      execute (ARight a) v v''
  | E_ALeft a v v' v'' :
      VM.shift_left v = Some v' ->
      execute a v' v'' ->
      execute (ALeft a) v v''
  | E_AInc a v v'' :
      execute a (VM.add_cell #01 v) v'' ->
      execute (AInc a) v v''
  | E_ADec a v v'' :
      execute a (VM.add_cell #ff v) v'' ->
      execute (ADec a) (v) v''
  | E_AOutput a v v'' :
      execute a (VM.output v) v'' ->
      execute (AOutput a) v v''
  | E_AInput a v v' v'' :
      VM.input v = Some v' ->
      execute a v' v'' ->
      execute (AInput a) v v''
  | E_ALoop body a v v' v'' :
      v.(cell) =? #00 = false ->
      execute body v v' ->
      execute (ALoop body a) v' v'' ->
      execute (ALoop body a) v v''
  | E_ALoop_0 body a v v' :
      v.(cell) =? #00 = true ->
      execute a v v' ->
      execute (ALoop body a) v v'
  | E_AEnd v v' :
      VM.eq v v' = true ->
      execute AEnd v v'.

Inductive execute_rel : ast -> RelVM.vm -> RelVM.vm -> Prop :=
  | ER_ARight a v v' v'' :
      RelVM.move 1 v = Some v' ->
      execute_rel a v' v'' ->
      execute_rel (ARight a) v v''
  | ER_ALeft a v v' v'' :
      RelVM.move (-1) v = Some v' ->
      execute_rel a v' v'' ->
      execute_rel (ALeft a) v v''
  | ER_AInc a v v' v'' :
      RelVM.add_cell #01 0 v = Some v' ->
      execute_rel a v' v'' ->
      execute_rel (AInc a) v v''
  | ER_ADec a v v' v'' :
      RelVM.add_cell #ff 0 v = Some v' ->
      execute_rel a v' v'' ->
      execute_rel (ADec a) (v) v''
  | ER_AOutput a v v' v'' :
      RelVM.output 0 v = Some v' ->
      execute_rel a v' v'' ->
      execute_rel (AOutput a) v v''
  | ER_AInput a v v' v'' :
      RelVM.input 0 v = Some v' ->
      execute_rel a v' v'' ->
      execute_rel (AInput a) v v''
  | ER_ALoop body a v v' v'' :
      RelVM.cell v =? #00 = false ->
      execute_rel body v v' ->
      execute_rel (ALoop body a) v' v'' ->
      execute_rel (ALoop body a) v v''
  | ER_ALoop_0 body a v v' :
      RelVM.cell v =? #00 = true ->
      execute_rel a v v' ->
      execute_rel (ALoop body a) v v'
  | ER_AEnd v v' :
      RelVM.eq v v' = true ->
      execute_rel AEnd v v'.

Definition equiv (a1 a2 : ast) : Prop := forall v v',
  execute a1 v v' <-> execute a2 v v'.

Definition transform_sound (trans : ast -> ast) : Prop := forall a,
  equiv a (trans a).

Fixpoint parse' (ts : list token) : ast * list ast :=
  match ts with
  | t :: ts' =>
      let (body, next) := parse' ts' in
      match t with
      | TRight => (ARight body, next)
      | TLeft => (ALeft body, next)
      | TInc => (AInc body, next)
      | TDec => (ADec body, next)
      | TOutput => (AOutput body, next)
      | TInput => (AInput body, next)
      | THead => match next with
                 | next :: next' => (ALoop body next, next')
                 | [] => (AEnd, [AEnd]) (* unclosed loop *)
                 end
      | TTail => (AEnd, body :: next)
      end
  | [] => (AEnd, [])
  end.

Definition parse (ts : list token) : option ast :=
  match parse' ts with
  | (prog, []) => Some prog
  | _ => None
  end.

Fixpoint flatten (a : ast) : list token :=
  match a with
  | ARight a' => TRight :: flatten a'
  | ALeft a' => TLeft :: flatten a'
  | AInc a' => TInc :: flatten a'
  | ADec a' => TDec :: flatten a'
  | AOutput a' => TOutput :: flatten a'
  | AInput a' => TInput :: flatten a'
  | ALoop body a' => THead :: flatten body ++ TTail :: flatten a'
  | AEnd => []
  end.

Theorem flatten_parse : forall ts a,
  parse ts = Some a ->
  flatten a = ts.
Proof. Admitted.

Theorem parse_flatten : forall a,
  parse (flatten a) = Some a.
Proof. Admitted.

Definition cons_right (n : positive) (a : ast) : ast :=
  repeat_apply ARight (Pos.to_nat n) a.

Definition cons_left (n : positive) (a : ast) : ast :=
  repeat_apply ALeft (Pos.to_nat n) a.

Definition cons_add (n : byte) (a : ast) : ast :=
  match Integers.Byte.signed n with
  | Z0 => a
  | Zpos p => repeat_apply AInc (Pos.to_nat p) a
  | Zneg p => repeat_apply ADec (Pos.to_nat p) a
  end.

Example test_execute : forall a,
  parse (lex ",>+++[-<++>]<-.") = Some a ->
  execute a (VM.make [#02]) (VM [] #07 [] [#07] [] VM.norm_nil).
Proof.
  intros. inversion H; subst; clear H.
  repeat (apply E_ARight
       || (eapply E_ALeft; [reflexivity |])
       || apply E_AInc
       || apply E_ADec
       || apply E_AOutput
       || (eapply E_AInput; [reflexivity |])
       || (eapply E_ALoop; [reflexivity | |])
       || (eapply E_ALoop_0; [reflexivity |])
       || (apply E_AEnd; apply VM.eq_refl)).
  apply E_AEnd. reflexivity.
Qed.


Require Export SystemFR.ErasedArrow.
Require Export SystemFR.ErasedSingleton.
Require Export SystemFR.ReducibilitySubtype.

Opaque reducible_values.

Inductive widen: tree -> tree -> Prop :=
| WidenSingleton:
    forall ty1 ty2 f,
      is_erased_term f ->
      is_erased_type ty2 ->
      wf f 0 ->
      widen
        (T_singleton (T_arrow ty1 ty2) f)
        (T_arrow ty1 (T_singleton ty2 (app f (lvar 0 term_var))))
| WidenSingleton2:
    forall ty f ty',
      widen ty ty' ->
      widen (T_singleton ty f) ty'
| WidenRefl:
    forall ty, widen ty ty
.

Lemma reducible_equiv:
  forall ρ t1 t2,
    [ t1 ≡ t2 ] ->
    [ ρ ⊨ uu : T_equiv t1 t2 ].
Proof.
  intros; unfold reduces_to; repeat step || exists uu || simp_red; t_closer.
Qed.

Lemma widen_singleton_arrow:
  forall Θ Γ ty1 ty2 f,
    is_erased_term f ->
    is_erased_type ty2 ->
    wf f 0 ->
    [Θ; Γ ⊨ T_singleton (T_arrow ty1 ty2) f <:
            T_arrow ty1 (T_singleton ty2 (app f (lvar 0 term_var))) ].
Proof.
  unfold open_subtype;
    repeat step || simp_red || open_none || apply reducible_type_refine with uu ||
           (rewrite shift_nothing2 in * by eauto with wf) || list_utils ||
           apply reducible_equiv || t_instantiate_reducible ||
           apply equivalent_app ||
           rewrite reducibility_rewrite in *;
    eauto with wf fv erased;
    eauto using reducible_values_closed;
    try solve [ apply equivalent_refl; eauto with wf fv erased ].
Qed.

Lemma singleton_subtype:
  forall Θ Γ ty f,
    [ Θ; Γ ⊨ T_singleton ty f <: ty ].
Proof.
  unfold open_subtype; repeat step || simp_red.
Qed.

Lemma widen_singleton:
  forall Θ Γ ty ty' f,
    [Θ; Γ ⊨ ty <: ty'] ->
    [Θ; Γ ⊨ T_singleton ty f <: ty'].
Proof.
  eauto using open_subtype_trans, singleton_subtype.
Qed.

Lemma widen_open_subtype:
  forall Θ Γ ty1 ty2,
    widen ty1 ty2 ->
    [ Θ; Γ ⊨ ty1 <: ty2 ].
Proof.
  induction 1; repeat step;
    eauto using widen_singleton_arrow;
    eauto using widen_singleton.
Qed.

Lemma open_tapp_helper:
  forall Θ Γ t1 t2 S T U,
    is_erased_type T ->
    wf T 1 ->
    subset (fv T) (support Γ) ->
    [ Θ; Γ ⊨ t1 : U ] ->
    widen U (T_arrow S T) ->
    [ Θ; Γ ⊨ t2 : S ] ->
    [ Θ; Γ ⊨ app t1 t2 : open 0 T t2 ].
Proof.
  intros; eapply open_reducible_app; eauto.
  eauto using widen_open_subtype, open_subtype_reducible.
Qed.

Lemma open_tapp:
  forall Γ t1 t2 S T U,
    is_erased_type T ->
    wf T 1 ->
    subset (fv T) (support Γ) ->
    [ Γ ⊫ t1 : U ] ->
    widen U (T_arrow S T) ->
    [ Γ ⊫ t2 : S ] ->
    [ Γ ⊫ app t1 t2 : open 0 T t2 ].
Proof.
  eauto using open_tapp_helper.
Qed.

Lemma open_tlet_helper:
  forall Θ Γ t1 t2 T1 T2 x,
    is_erased_type T2 ->
    is_erased_term t2 ->
    wf T1 0 ->
    wf T2 1 ->
    wf t2 1 ->
    subset (fv T1) (support Γ) ->
    subset (fv T2) (support Γ) ->
    subset (fv t2) (support Γ) ->
    subset (pfv_context Γ term_var) (support Γ) ->
    ~ x ∈ support Γ ->
    [ Θ; Γ ⊨ t1 : T1 ] ->
    [ Θ; (x, T1) :: Γ ⊨ open 0 t2 (fvar x term_var) : open 0 T2 (fvar x term_var) ] ->
    [ Θ; Γ ⊨ let' t1 t2 : open 0 T2 t1 ].
Proof.
  unfold let'; intros.
  apply open_tapp_helper with T1 (T_arrow T1 T2); steps.
  apply open_reducible_lambda with x; steps; eauto with wf erased fv.
Qed.

Lemma open_tlet:
  forall Γ t1 t2 T1 T2 x,
    is_erased_type T2 ->
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf T1 0 ->
    wf T2 1 ->
    wf t1 0 ->
    wf t2 1 ->
    subset (fv T1) (support Γ) ->
    subset (fv T2) (support Γ) ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    subset (pfv_context Γ term_var) (support Γ) ->
    ~ x ∈ support Γ ->
    [ Γ ⊫ t1 : T1 ] ->
    [ (x, T1) :: Γ ⊫ open 0 t2 (fvar x term_var) : open 0 T2 (fvar x term_var) ] ->
    [ Γ ⊫ let' t1 t2 : T_singleton (open 0 T2 t1) (let' t1 t2) ].
Proof.
  intros.
  apply open_reducible_singleton; repeat step || sets || simp_red;
    eauto using open_tlet_helper.
Qed.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <aciclo@gmail.com>                                        *)
(*                                        Computer Science Department, USTC   *)
(*                                                                            *)
(*           Hui Zhang <sa512073@mail.ustc.edu.cn>                            *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Export bnat.
Require Import LibEx.
Require Import ListEx.
Require Import Monad.
Require Import Data.
Require Import Params.

(* NAND hardware interface *)

(* Definition oob := list int. *)

Definition page_off := nat.

Definition block_no := nat.

Definition page_off_of_nat (n: nat) : page_off := n.

(* Definition page_no := prod block_no page_off. *)

Definition page_no := nat.

Definition page_oob_nat := option (prod nat nat).

Inductive page_status : Set :=
  | ps_free
  | ps_programmed.

Inductive block_status : Set :=
  | bs_free
  | bs_programmed.

Record page : Set :=
  mkpage {
      page_data : data;
      page_oob :  page_oob_nat;
      page_state : page_status
      (* data_size: length (page_data) = PAGE_DATA_SIZE; *)
      (* oob_size: length (page_data) = PAGE_SPAREAREA_SIZE *)
    }.

Record block : Set :=
  mkblock {
      block_pages : list page;
      next_page : page_off;
      block_erase_count: nat;
      block_state : block_status
      (* pages_size: length block_pages = PAGES_PER_BLOCK *)
    }.

Record chip : Set :=
  mkchip {
      chip_blocks: list block
      (* blocks_size : length chip_blocks = BLOCKS *)
    }.

(********* Initialization of the Nand Chip ****************)

(*Just init single page's content,including the page content and oob*)
Definition init_page_data : data :=
  metabyte (list_repeat_list PAGE_DATA_SIZE c_ff).

(* Definition init_page_oob : data := *)
(*   metabyte (list_repeat_list PAGE_SPARE_AREA_SIZE c_ff). *)

(*The Initialization oob is 0 *)
Definition init_page : page :=
  mkpage init_page_data None  ps_free.

Definition init_block : block :=
  mkblock (list_repeat_list PAGES_PER_BLOCK init_page) 0 0 bs_free.

Definition erased_block (ec: nat): block :=
  mkblock (list_repeat_list PAGES_PER_BLOCK init_page) 0 (S ec) bs_free.

Definition bvalid_block_no (pbn: block_no) : bool :=
  (blt_nat pbn BLOCKS).

Definition bvalid_page_no (ppn:page_no) : bool :=
  (blt_nat ppn (BLOCKS * PAGES_PER_BLOCK)).

Definition bvalid_page_off (off: page_off) : bool :=
  (blt_nat off PAGES_PER_BLOCK).

(********* Nand chip Operations ***************)
Definition nand_init : chip :=
  mkchip (list_repeat_list BLOCKS init_block).

(* written by zhanghui, generate the content of 'oob' according to the
data stored in this page. *)
(* TEMP: now just return a list of null *)
(* Definition make_oob (d : data) : data := *)
(*   list_repeat_list PAGE_SPARE_AREA_SIZE c_null. *)

Definition page_set__oob (p:page)(oob:page_oob_nat) :=
  ret (mkpage (page_data p) oob (page_state p) ).

Definition page_get_oob (p:page) :page_oob_nat :=
  page_oob p.

Definition chip_get_block (c: chip) (pbn: block_no): option block :=
  list_get (chip_blocks c) pbn.

Definition chip_set_block (c: chip) (pbn: block_no) (b: block) : option chip :=
  test bvalid_block_no pbn;
  do nbl <-- list_set (chip_blocks c) pbn b;
  ret (mkchip nbl).

Definition block_get_page (b: block) (off: page_off) : option page :=
  test (bvalid_page_off off);
  do p <-- (list_get (block_pages b) off);
  ret p.

Definition block_set_page (b: block) (off: page_off) (p: page) : option block :=
  test bvalid_page_off off;
  do npl <-- list_set (block_pages b) off p;
  ret (mkblock npl (next_page b) (block_erase_count b) bs_programmed).

Definition block_set_next_page (b: block) (off: page_off) : option block :=
  ret (mkblock (block_pages b) (off) (block_erase_count b) (block_state b)).

Definition chip_get_page (c: chip) (bln: block_no) (poff: page_off) : option page :=
  match chip_get_block c bln with
    | None => None
    | Some b =>
      block_get_page b poff
  end.

Definition page_get_data (p: page) : option data :=
  match page_state p with
    | ps_free => None (* This is an empty page, no data. *)
    | ps_programmed => Some (page_data p)
  end.

Definition check_page_state_is_free (ps : page_status) : bool :=
  match ps with
    | ps_free => true
    | _ => false
  end.

(*It donesn't need a state,if it is invaild,it will be set to trans_empty.*)
Definition data_get_record_list(pagedata:data)(lpn:page_no) : option meta_trans_record_list :=
  match pagedata with
      | metabyte _  => None
      | metarecord l => Some l
  end.

Fixpoint recordlist_get_record(l:meta_trans_record_list)(lpn:page_no) :option trans_record :=
  match l with
      | nil => None
      | cons a l' =>match a with
                        | trans_empty => recordlist_get_record l' lpn
                        | trans_data lpn' ppn' offset => if beq_nat lpn lpn' then Some a else recordlist_get_record l' lpn
                    end
end.

(*It's can't exist,because the page must write in once*)

(* Fixpoint recordlist_set_record(l:meta_trans_record_list)(lpn:page_no) :option meta_trans_record_list := *)
(*   match l with *)
(*       | nil => None *)
(*       | cons a l' =>match a with  *)
(*                         | trans_empty => recordlist_get_record l' lpn *)
(*                         | trans_data lpn' ppn'=> if beq_nat lpn lpn' then Some a else recordlist_get_record l' lpn  *)
(*                     end *)
(* end. *)

(********* Nand chip Operations ***************)
Definition nand_read_page (c: chip) (pbn: block_no) (poff: page_off) : option (prod data page_oob_nat) :=
  test (bvalid_block_no pbn);
  do b <-- chip_get_block c pbn;
  test (bvalid_page_off poff);
  do p <-- block_get_page b poff;
  ret (page_data p, page_oob p).

Definition nand_write_page (c: chip) (pbn: block_no) (off: page_off) (d: data) (oob: page_oob_nat): option chip :=
  test (bvalid_block_no pbn);
  do b <-- chip_get_block c pbn;
  test (bvalid_page_off off);
  test (ble_nat (next_page b) off);
  do p <-- block_get_page b off;
  test (check_page_state_is_free (page_state p));
  do b' <-- block_set_page b off (mkpage d oob ps_programmed);
  do b'' <-- block_set_next_page b' (S off);
  do c' <-- chip_set_block c pbn b'';
  ret c'.

Definition nand_erase_block (c: chip) (pbn: block_no) : option chip :=
  test (bvalid_block_no pbn);
  do b <-- chip_get_block c pbn;
  let b' := erased_block (block_erase_count b) in
  do c' <-- chip_set_block c pbn b';
  ret c'.