Require Import RelationClasses.

Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import Loc.
Require Import DenseOrder.
Require Import Language.

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

Require Import Cover.
Require Import MemorySplit.
Require Import MemoryMerge.
Require Import FulfillStep.

Set Implicit Arguments.

Inductive sim_message: forall (msg_src msg_tgt: Message.t), Prop :=
| sim_message_concrete
    val released_src released_tgt
    (RELEASED: View.opt_le released_src released_tgt):
    sim_message (Message.concrete val released_src) (Message.concrete val released_tgt)
| sim_message_reserve:
    sim_message Message.reserve Message.reserve
.
Hint Constructors sim_message.

Program Instance sim_message_PreOrder: PreOrder sim_message.
Next Obligation.
  ii. destruct x; econs; refl.
Qed.
Next Obligation.
  ii. inv H; inv H0; econs. etrans; eauto.
Qed.

Inductive message_same_kind: forall (msg_src msg_tgt: Message.t), Prop :=
| message_same_kind_concrete
    val_src val_tgt released_src released_tgt:
    message_same_kind (Message.concrete val_src released_src) (Message.concrete val_tgt released_tgt)
| same_message_kine_reserve:
    message_same_kind Message.reserve Message.reserve
.
Hint Constructors sim_message.

Program Instance message_same_kind_Equivalence: Equivalence message_same_kind.
Next Obligation.
  ii. destruct x; econs.
Qed.
Next Obligation.
  ii. inv H; econs.
Qed.
Next Obligation.
  ii. inv H; inv H0; econs.
Qed.

Lemma sim_message_message_same_kind
      msg_src msg_tgt
      (SIM: sim_message msg_src msg_tgt):
  message_same_kind msg_src msg_tgt.
Proof.
  inv SIM; econs.
Qed.

Inductive sim_memory (mem_src mem_tgt:Memory.t): Prop :=
| sim_memory_intro
    (COVER: forall loc ts, covered loc ts mem_src <-> covered loc ts mem_tgt)
    (MSG: forall loc from_tgt to msg_tgt
            (GET: Memory.get loc to mem_tgt = Some (from_tgt, msg_tgt)),
        exists from_src msg_src,
          <<GET: Memory.get loc to mem_src = Some (from_src, msg_src)>> /\
          <<MSG: sim_message msg_src msg_tgt>>)
    (RESERVE: forall loc from to,
        Memory.get loc to mem_src = Some (from, Message.reserve) <->
        Memory.get loc to mem_tgt = Some (from, Message.reserve))
.

Program Instance sim_memory_PreOrder: PreOrder sim_memory.
Next Obligation.
  econs; try refl. i. esplits; eauto. refl.
Qed.
Next Obligation.
  ii. inv H. inv H0. econs; try etrans; eauto. i.
  exploit MSG0; eauto. i. des.
  exploit MSG; eauto. i. des.
  esplits; eauto. etrans; eauto.
Qed.

Lemma sim_memory_get
      loc from_tgt to msg_tgt mem_src mem_tgt
      (SIM: sim_memory mem_src mem_tgt)
      (GET: Memory.get loc to mem_tgt = Some (from_tgt, msg_tgt)):
  exists from_src msg_src,
    <<GET: Memory.get loc to mem_src = Some (from_src, msg_src)>> /\
    <<MSG: sim_message msg_src msg_tgt>>.
Proof.
  eapply SIM. eauto.
Qed.

Lemma sim_memory_get_message_same_kind
      loc
      from_src to_src msg_src mem_src
      from_tgt to_tgt msg_tgt mem_tgt
      ts
      (SIM: sim_memory mem_src mem_tgt)
      (GET_SRC: Memory.get loc to_src mem_src = Some (from_src, msg_src))
      (GET_TGT: Memory.get loc to_tgt mem_tgt = Some (from_tgt, msg_tgt))
      (ITV_SRC: Interval.mem (from_src, to_src) ts)
      (ITV_TGT: Interval.mem (from_tgt, to_tgt) ts):
  message_same_kind msg_src msg_tgt.
Proof.
  destruct msg_src, msg_tgt; try by econs.
  - inv SIM. rewrite <- RESERVE in GET_TGT.
    exploit Memory.get_disjoint; [exact GET_SRC|exact GET_TGT|..]. i. des; try congr.
    exfalso. apply (x0 ts); auto.
  - inv SIM. rewrite RESERVE in GET_SRC.
    exploit Memory.get_disjoint; [exact GET_SRC|exact GET_TGT|..]. i. des; try congr.
    exfalso. apply (x0 ts); auto.
Qed.

Lemma sim_memory_get_inv
      loc from_src to_src msg_src mem_src
      mem_tgt
      (INHABITED_SRC: Memory.inhabited mem_src)
      (INHABITED_TGT: Memory.inhabited mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (GET_SRC: Memory.get loc to_src mem_src = Some (from_src, msg_src)):
  exists from_tgt to_tgt msg_tgt,
    <<FROM: Time.le from_tgt from_src>> /\
    <<TO: Time.le to_src to_tgt>> /\
    <<GET_TGT: Memory.get loc to_tgt mem_tgt = Some (from_tgt, msg_tgt)>> /\
    <<MSG: message_same_kind msg_src msg_tgt>>.
Proof.
  destruct (Time.eq_dec to_src Time.bot).
  { subst. rewrite INHABITED_SRC in GET_SRC. inv GET_SRC.
    esplits; try refl. apply INHABITED_TGT. }
  dup SIM. inv SIM0. dup COVER. specialize (COVER0 loc to_src). des.
  exploit COVER0.
  { econs; eauto. econs; try refl.
    exploit Memory.get_ts; eauto. i. des; subst; timetac. }
  i. dup x. inv x0. esplits; eauto.
  - destruct (Time.le_lt_dec from from_src); ss.
    dup COVER. specialize (COVER2 loc from). des. exploit COVER2.
    { econs; eauto.
      exploit Memory.get_ts; try exact GET_SRC. i. des; ss.
      inv ITV. econs; eauto. econs. ss. }
    i. inv x0.
    destruct (Time.eq_dec to0 from).
    + subst. exploit MSG; try exact GET0. i. des.
      exploit Memory.get_disjoint; [exact GET_SRC|exact GET1|..]. i. des.
      * subst. inv ITV. timetac.
      * exfalso. apply (x1 from).
        { inv ITV. econs; eauto. s. econs; eauto. }
        { econs; try refl. s.
          exploit Memory.get_ts; try exact GET1. i. des; ss.
          subst. inv ITV0. inv FROM. }
    + exploit Memory.get_disjoint; [exact GET|exact GET0|..]. i. des.
      * subst. inv ITV0. timetac.
      * exfalso. destruct (Time.le_lt_dec to to0).
        { apply (x1 to).
          - econs; try refl.
            exploit Memory.get_ts; try exact GET. i. des; ss.
            subst. inv ITV0. inv FROM.
          - econs; eauto. inv ITV0. ss.
            exploit Memory.get_ts; try exact GET. i. des; ss.
            + subst. inv l.
            + eapply TimeFacts.lt_le_lt; eauto. econs; eauto. }
        { apply (x1 to0).
          - inv ITV0. econs; ss.
            + inv TO; ss. inv H. congr.
            + econs. ss.
          - econs; try refl.
            exploit Memory.get_ts; try exact GET0. i. des; ss.
            subst. inv ITV0. ss. inv TO; inv H. inv FROM. }
  - inv ITV. ss.
  - eapply sim_memory_get_message_same_kind; eauto.
    exploit Memory.get_ts; try exact GET_SRC. i. des; try congr.
    econs; eauto. refl.
Qed.

Lemma sim_memory_max_ts
      mem_src mem_tgt loc
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt):
  Memory.max_ts loc mem_src = Memory.max_ts loc mem_tgt.
Proof.
  inv SIM. inv CLOSED_SRC. inv CLOSED_TGT.
  clear MSG RESERVE CLOSED CLOSED0.
  apply TimeFacts.antisym.
  - specialize (COVER loc (Memory.max_ts loc mem_src)). des.
    exploit Memory.max_ts_spec; try eapply (INHABITED loc). i. des.
    exploit Memory.get_ts; eauto. i. des.
    { rewrite x1. apply Time.bot_spec. }
    exploit COVER; i.
    { econs; eauto. econs; eauto. refl. }
    inv x. exploit Memory.max_ts_spec; try exact GET0. i. des.
    inv ITV. ss. etrans; eauto.
  - specialize (COVER loc (Memory.max_ts loc mem_tgt)). des.
    exploit Memory.max_ts_spec; try eapply (INHABITED0 loc). i. des.
    exploit Memory.get_ts; eauto. i. des.
    { rewrite x1. apply Time.bot_spec. }
    exploit COVER0; i.
    { econs; eauto. econs; eauto. refl. }
    inv x. exploit Memory.max_ts_spec; try exact GET0. i. des.
    inv ITV. ss. etrans; eauto.
Qed.

Lemma sim_memory_max_concrete_ts
      mem_src mem_tgt
      loc mts_src mts_tgt
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (MAX_SRC: Memory.max_concrete_ts mem_src loc mts_src)
      (MAX_TGT: Memory.max_concrete_ts mem_tgt loc mts_tgt):
  mts_src = mts_tgt.
Proof.
  apply TimeFacts.antisym.
  - inv MAX_SRC. des.
    exploit sim_memory_get_inv; eauto.
    { apply CLOSED_SRC. }
    { apply CLOSED_TGT. }
    i. des. inv MSG.
    exploit Memory.max_concrete_ts_spec; eauto. i. des.
    etrans; eauto.
  - inv MAX_TGT. des.
    inv SIM. exploit MSG; eauto. i. des. inv MSG0.
    exploit Memory.max_concrete_ts_spec; eauto. i. des. ss.
Qed.

Lemma sim_memory_max_concrete_timemap
      mem_src mem_tgt mtm_src mtm_tgt
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (MAX_SRC: Memory.max_concrete_timemap mem_src mtm_src)
      (MAX_TGT: Memory.max_concrete_timemap mem_tgt mtm_tgt):
  mtm_src = mtm_tgt.
Proof.
  extensionality loc.
  specialize (MAX_SRC loc).
  specialize (MAX_TGT loc).
  eapply sim_memory_max_concrete_ts; eauto.
Qed.

Lemma sim_memory_max_concrete_view
      mem_src mem_tgt mview_src mview_tgt
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (SIM: sim_memory mem_src mem_tgt)
      (MAX_SRC: Memory.max_concrete_view mem_src mview_src)
      (MAX_TGT: Memory.max_concrete_view mem_tgt mview_tgt):
  mview_src = mview_tgt.
Proof.
  inv MAX_SRC. inv MAX_TGT.
  exploit sim_memory_max_concrete_timemap; try exact SIM; eauto. i.
  subst. ss.
Qed.

Lemma split_sim_memory
      mem0 loc ts1 ts2 ts3 val2 released2 val3 released3 mem1
      (SPLIT: Memory.split mem0 loc ts1 ts2 ts3 (Message.concrete val2 released2) (Message.concrete val3 released3) mem1):
  sim_memory mem1 mem0.
Proof.
  econs; i.
  - eapply split_covered. eauto.
  - exploit Memory.split_get0; eauto. i. des.
    erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. congr.
    + guardH o. des. subst. rewrite GET1 in GET. inv GET.
      esplits; eauto. refl.
    + esplits; eauto. refl.
  - exploit Memory.split_get0; eauto. i. des.
    erewrite Memory.split_o; eauto.
    repeat condtac; ss; split; i; try congr.
    + des. subst. rewrite GET in H. inv H.
    + guardH o. des. subst. rewrite GET0 in H. inv H.
Qed.

Lemma lower_sim_memory
      mem1 loc from to msg1 msg2 mem2
      (LOWER: Memory.lower mem1 loc from to msg1 msg2 mem2)
      (MSG: message_same_kind msg1 msg2):
  sim_memory mem2 mem1.
Proof.
  econs; i.
  - eapply lower_covered. eauto.
  - i. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst.
      exploit Memory.lower_get0; eauto. i. des.
      rewrite GET0 in GET. inv GET.
      inv MSG_LE; inv MSG; esplits; eauto.
    + esplits; eauto. refl.
  - split; i.
    + revert H. erewrite Memory.lower_o; eauto. condtac; ss.
      i. des. subst. inv H. inv LOWER. inv LOWER0. inv MSG.
      unfold Memory.get, Cell.get. rewrite GET2. ss.
    + erewrite Memory.lower_o; eauto. condtac; ss.
      des. subst. inv LOWER. inv LOWER0.
      unfold Memory.get, Cell.get in H. rewrite H in GET2. inv GET2.
      inv MSG. ss.
Qed.

Lemma promise_lower_sim_memory
      promises1 mem1 loc from to msg1 msg2 promises2 mem2
      (PROMISE: Memory.promise promises1 mem1 loc from to msg2 promises2 mem2 (Memory.op_kind_lower msg1))
      (MSG: message_same_kind msg1 msg2):
  sim_memory mem2 mem1.
Proof.
  inv PROMISE. eapply lower_sim_memory; eauto.
Qed.

Lemma sim_memory_add
      mem1_src mem1_tgt msg_src
      mem2_src mem2_tgt msg_tgt
      loc from to
      (SIM_MSG: sim_message msg_src msg_tgt)
      (SRC: Memory.add mem1_src loc from to msg_src mem2_src)
      (TGT: Memory.add mem1_tgt loc from to msg_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs; i.
  - rewrite add_covered; [|eauto]. rewrite (@add_covered mem2_tgt); [|eauto].
    econs; i; des; (try by right).
    + left. eapply COVER. eauto.
    + left. eapply COVER. eauto.
  - revert GET. erewrite Memory.add_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.add_o; eauto. condtac; ss.
    + erewrite (@Memory.add_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.add_o in H; try exact SRC.
      erewrite Memory.add_o; try exact TGT. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.add_o in H; try exact TGT.
      erewrite Memory.add_o; try exact SRC. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_split
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc ts1 ts2 ts3 msg2_src msg3_src msg2_tgt msg3_tgt
      (SIM_MSG: sim_message msg2_src msg2_tgt)
      (SRC: Memory.split mem1_src loc ts1 ts2 ts3 msg2_src msg3_src mem2_src)
      (TGT: Memory.split mem1_tgt loc ts1 ts2 ts3 msg2_tgt msg3_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  inv SIM. econs; i.
  - rewrite split_covered; [|eauto]. rewrite (@split_covered mem2_tgt); [|eauto].
    apply COVER.
  - revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.split_o; eauto. condtac; ss.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss.
      i. inv GET. guardH o. guardH o0. des. subst.
      exploit Memory.split_get0; try exact SRC; eauto. i. des.
      exploit Memory.split_get0; try exact TGT; eauto. i. des.
      exploit MSG; eauto. i. des. rewrite GET0 in GET7. inv GET7.
      esplits; eauto.
    + erewrite (@Memory.split_o mem2_src); eauto. repeat condtac; ss. eauto.
  - split; i.
    + erewrite Memory.split_o in H; try exact SRC.
      erewrite Memory.split_o; try exact TGT. repeat condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * guardH o. des. subst. inv H.
        exploit Memory.split_get0; try exact SRC. i. des.
        exploit Memory.split_get0; try exact TGT. i. des.
        rewrite RESERVE in GET0. rewrite GET0 in GET4. inv GET4. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.split_o in H; try exact TGT.
      erewrite Memory.split_o; try exact SRC. repeat condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * guardH o. des. subst. inv H.
        exploit Memory.split_get0; try exact SRC. i. des.
        exploit Memory.split_get0; try exact TGT. i. des.
        rewrite <- RESERVE in GET4. rewrite GET0 in GET4. inv GET4. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_lower
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc from to msg1_src msg2_src msg1_tgt msg2_tgt
      (SIM_MSG: sim_message msg2_src msg2_tgt)
      (SRC: Memory.lower mem1_src loc from to msg1_src msg2_src mem2_src)
      (TGT: Memory.lower mem1_tgt loc from to msg1_tgt msg2_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  dup SIM. inv SIM0. econs; i.
  - rewrite lower_covered; [|eauto]. rewrite (@lower_covered mem2_tgt); [|eauto].
    apply COVER.
  - revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
    + des. subst. i. inv GET. esplits; eauto.
      erewrite Memory.lower_o; eauto. condtac; ss.
    + erewrite (@Memory.lower_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.lower_o in H; try exact SRC.
      erewrite Memory.lower_o; try exact TGT. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite <- RESERVE. ss.
    + erewrite Memory.lower_o in H; try exact TGT.
      erewrite Memory.lower_o; try exact SRC. condtac; ss.
      * des. subst. inv H. inv SIM_MSG. ss.
      * rewrite RESERVE. ss.
Qed.

Lemma sim_memory_remove
      mem1_src mem1_tgt
      mem2_src mem2_tgt
      loc from to msg_src msg_tgt
      (SRC: Memory.remove mem1_src loc from to msg_src mem2_src)
      (TGT: Memory.remove mem1_tgt loc from to msg_tgt mem2_tgt)
      (SIM: sim_memory mem1_src mem1_tgt):
  sim_memory mem2_src mem2_tgt.
Proof.
  dup SIM. inv SIM0. econs; i.
  - rewrite remove_covered; [|eauto]. rewrite (@remove_covered mem2_tgt); [|eauto].
    rewrite COVER. refl.
  - revert GET. erewrite Memory.remove_o; eauto. condtac; ss.
    erewrite (@Memory.remove_o mem2_src); eauto. condtac; ss. eauto.
  - split; i.
    + erewrite Memory.remove_o in H; try exact SRC.
      erewrite Memory.remove_o; try exact TGT. condtac; ss.
      rewrite <- RESERVE. ss.
    + erewrite Memory.remove_o in H; try exact TGT.
      erewrite Memory.remove_o; try exact SRC. condtac; ss.
      rewrite RESERVE. ss.
Qed.

Lemma sim_memory_closed_timemap
      mem_src mem_tgt
      tm
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_timemap tm mem_tgt):
  Memory.closed_timemap tm mem_src.
Proof.
  ii. exploit TGT; eauto. i. des.
  exploit sim_memory_get; eauto. i. des.
  inv MSG. eauto.
Qed.

Lemma sim_memory_closed_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_view view mem_tgt):
  Memory.closed_view view mem_src.
Proof.
  econs.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
  - eapply sim_memory_closed_timemap; eauto. apply TGT.
Qed.

Lemma sim_memory_closed_opt_view
      mem_src mem_tgt
      view
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_opt_view view mem_tgt):
  Memory.closed_opt_view view mem_src.
Proof.
  inv TGT; econs. eapply sim_memory_closed_view; eauto.
Qed.

Lemma sim_memory_closed_message
      mem_src mem_tgt
      msg
      (SIM: sim_memory mem_src mem_tgt)
      (TGT: Memory.closed_message msg mem_tgt):
  Memory.closed_message msg mem_src.
Proof.
  inv TGT; ss. econs. eapply sim_memory_closed_opt_view; eauto.
Qed.

(* cap *)

Lemma sim_memory_adjacent_src
      mem_src mem_tgt
      loc from1 to1 from2 to2
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (ADJ: Memory.adjacent loc from1 to1 from2 to2 mem_src)
      (TS: Time.lt to1 from2):
  exists from1' to2',
    Memory.adjacent loc from1' to1 from2 to2' mem_tgt.
Proof.
Admitted.
  (* dup SIM. inv SIM0. inv ADJ. clear RESERVE TS0.
  assert (GET1_TGT: exists from1' m1', Memory.get loc to1 mem_tgt = Some (from1', m1')).
  { exploit Memory.get_ts; try exact GET1. i. des.
    { subst. esplits. eapply CLOSED_TGT. }
    destruct (COVER loc to1). exploit H; i.
    { econs; try exact GET1. econs; eauto. refl. }
    inv x. inv ITV. ss. inv TO; cycle 1.
    { inv H1. esplits; eauto. }
    exfalso.
    destruct (Time.le_lt_dec to from2).
    { exploit MSG; eauto. i. des.
      exploit (EMPTY to); eauto. i. congr. }
    destruct (COVER loc from2). exploit H3; i.
    { econs; eauto. econs; eauto. econs. ss. }
    inv x. inv ITV. ss. inv TO.
    - exploit Memory.get_ts; try exact GET2. i. des.
      { subst. inv FROM0. }
      exploit Memory.get_ts; try exact GET0. i. des.
      { subst. inv H4. }
      exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
      { timetac. }
      destruct (Time.le_lt_dec to2 to0).
      + apply (x3 to2); econs; ss; try refl.
        etrans; try exact FROM0. ss.
      + apply (x3 to0); econs; ss; try refl.
        econs. ss.
    - inv H4. exploit (EMPTY to0); eauto; try refl. i. congr.
  }
  assert (GET2_TGT: exists to2' m2', Memory.get loc to2' mem_tgt = Some (from2, m2')).
  { exploit Memory.get_ts; try exact GET2. i. des.
    { subst. inv TS. }
    exploit Memory.max_ts_spec; try exact GET2. i. des.
    clear from msg GET.
    erewrite sim_memory_max_ts in MAX; eauto.
    exploit TimeFacts.lt_le_lt; try exact x0; try exact MAX. i.
    exploit Memory.next_exists; try exact x1; try eapply CLOSED_TGT. i. des.
    destruct (TimeFacts.le_lt_dec from from2).
    - inv l; cycle 1.
      { inv H. esplits; eauto. }
      destruct (COVER loc from2). exploit H1; i.
      { econs; try exact x2. econs; ss. econs; ss. }
      inv x. inv ITV. ss. inv TO; cycle 1.
      { inv H2. exploit (EMPTY to0); eauto; try refl. i. congr. }
      exploit Memory.get_disjoint; [exact GET2|exact GET|..]. i. des.
      { subst. timetac. }
      exfalso.
      destruct (TimeFacts.le_lt_dec to2 to0).
      + apply (x5 to2); econs; ss; try refl.
        etrans; try exact FROM. ss.
      + apply (x5 to0); econs; ss; try refl.
        * econs. ss.
        * etrans; eauto.
    - destruct (TimeFacts.le_lt_dec to2 from).
      + destruct (COVER loc to2). exploit H; i.
        { econs; eauto. econs; ss. refl. }
        inv x. inv ITV. ss.
        exploit (x4 to0); eauto; try congr.
        { eapply TimeFacts.lt_le_lt; try exact TO; ss. }
        destruct (Time.le_lt_dec to to0); ss.
        exploit Memory.get_ts; try exact x2. i. des.
        { subst. inv x3. }
        exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
        { subst. timetac. }
        exfalso.
        apply (x6 to); econs; ss; try refl.
        etrans; try exact FROM.
        eapply TimeFacts.le_lt_lt; try exact x5. ss.
      + destruct (COVER loc from). exploit H; i.
        { econs; try exact GET2. econs; ss. econs. ss. }
        inv x. inv ITV. ss.
        destruct (TimeFacts.le_lt_dec to to0).
        * exploit Memory.get_ts; try exact x2. i. des.
          { subst. inv x3. }
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. timetac. }
          exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
          { subst. timetac. }
          exfalso.
          apply (x7 to); econs; ss; try refl.
          eapply TimeFacts.lt_le_lt; try exact FROM. econs. ss.
        * exploit (x4 to0); ss; try congr.
          eapply TimeFacts.lt_le_lt; try exact TO; ss.
  }
  des. esplits. econs; eauto; i.
  { exploit Memory.get_ts; try exact GET2_TGT. i. des.
    - subst. inv TS.
    - etrans; eauto. }
  destruct (Memory.get loc ts mem_tgt) as [[]|] eqn:GET; ss.
  exfalso.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv TS1. }
  destruct (COVER loc ts). exploit H0; i.
  { econs; eauto. econs; ss. refl. }
  inv x. inv ITV. ss.
  destruct (TimeFacts.le_lt_dec to from2).
  { exploit (EMPTY to); try congr.
    eapply TimeFacts.lt_le_lt; try exact TS1. ss. }
  exploit Memory.get_ts; try exact GET2. i. des.
  { subst. inv TS. }
  exploit Memory.get_ts; try exact GET0. i. des.
  { subst. inv l. }
  exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
  { subst. timetac. }
  destruct (TimeFacts.le_lt_dec to2 to).
  - apply (x3 to2); econs; ss; try refl.
    etrans; try exact x1.
    eapply TimeFacts.lt_le_lt; try exact TS2. ss.
  - apply (x3 to); econs; ss; try refl. econs. ss.
Qed. *)

Lemma sim_memory_adjacent_tgt
      mem_src mem_tgt
      loc from1 to1 from2 to2
      (SIM: sim_memory mem_src mem_tgt)
      (CLOSED_SRC: Memory.closed mem_src)
      (CLOSED_TGT: Memory.closed mem_tgt)
      (ADJ: Memory.adjacent loc from1 to1 from2 to2 mem_tgt)
      (TS: Time.lt to1 from2):
  exists from1' to2',
    Memory.adjacent loc from1' to1 from2 to2' mem_src.
Proof.
  dup SIM. inv SIM0. inv ADJ. clear RESERVE TS0.
  assert (GET1_SRC: exists from1' m1', Memory.get loc to1 mem_src = Some (from1', m1')).
  { exploit MSG; try exact GET1. i. des. eauto. }
  assert (GET2_SRC: exists to2' m2', Memory.get loc to2' mem_src = Some (from2, m2')).
  { exploit Memory.get_ts; try exact GET2. i. des.
    { subst. inv TS. }
    exploit Memory.max_ts_spec; try exact GET2. i. des.
    clear from msg GET.
    erewrite <- sim_memory_max_ts in MAX; eauto.
    exploit TimeFacts.lt_le_lt; try exact x0; try exact MAX. i.
    exploit Memory.next_exists; try exact x1; try eapply CLOSED_SRC. i. des.
    destruct (TimeFacts.le_lt_dec from from2).
    - inv l; cycle 1.
      { inv H. esplits; eauto. }
      destruct (COVER loc from2). exploit H0; i.
      { econs; try exact x2. econs; ss. econs; ss. }
      inv x. inv ITV. ss. inv TO; cycle 1.
      { inv H2. exploit (EMPTY to0); eauto; try refl. i. congr. }
      exploit Memory.get_disjoint; [exact GET2|exact GET|..]. i. des.
      { subst. timetac. }
      exfalso.
      destruct (TimeFacts.le_lt_dec to2 to0).
      + apply (x5 to2); econs; ss; try refl.
        etrans; try exact FROM. ss.
      + apply (x5 to0); econs; ss; try refl.
        * econs. ss.
        * etrans; eauto.
    - destruct (TimeFacts.le_lt_dec to2 from).
      + destruct (COVER loc to2). exploit H0; i.
        { econs; eauto. econs; ss. refl. }
        inv x. inv ITV. ss.
        exploit (x4 to0); eauto; try congr.
        { eapply TimeFacts.lt_le_lt; try exact TO; ss. }
        destruct (Time.le_lt_dec to to0); ss.
        exploit Memory.get_ts; try exact x2. i. des.
        { subst. inv x3. }
        exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
        { subst. timetac. }
        exfalso.
        apply (x6 to); econs; ss; try refl.
        etrans; try exact FROM.
        eapply TimeFacts.le_lt_lt; try exact x5. ss.
      + destruct (COVER loc from). exploit H0; i.
        { econs; try exact GET2. econs; ss. econs. ss. }
        inv x. inv ITV. ss.
        destruct (TimeFacts.le_lt_dec to to0).
        * exploit Memory.get_ts; try exact x2. i. des.
          { subst. inv x3. }
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. timetac. }
          exploit Memory.get_disjoint; [exact x2|exact GET|..]. i. des.
          { subst. timetac. }
          exfalso.
          apply (x7 to); econs; ss; try refl.
          eapply TimeFacts.lt_le_lt; try exact FROM. econs. ss.
        * exploit (x4 to0); ss; try congr.
          eapply TimeFacts.lt_le_lt; try exact TO; ss.
  }
  des. esplits. econs; eauto; i.
  { exploit Memory.get_ts; try exact GET2_SRC. i. des.
    - subst. inv TS.
    - etrans; eauto. }
  destruct (Memory.get loc ts mem_src) as [[]|] eqn:GET; ss.
  exfalso.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv TS1. }
  destruct (COVER loc ts). exploit H; i.
  { econs; eauto. econs; ss. refl. }
  inv x. inv ITV. ss.
  destruct (TimeFacts.le_lt_dec to from2).
  { exploit (EMPTY to); try congr.
    eapply TimeFacts.lt_le_lt; try exact TS1. ss. }
  exploit Memory.get_ts; try exact GET2. i. des.
  { subst. inv TS. }
  exploit Memory.get_ts; try exact GET0. i. des.
  { subst. inv l. }
  exploit Memory.get_disjoint; [exact GET2|exact GET0|..]. i. des.
  { subst. timetac. }
  destruct (TimeFacts.le_lt_dec to2 to).
  - apply (x3 to2); econs; ss; try refl.
    etrans; try exact x1.
    eapply TimeFacts.lt_le_lt; try exact TS2. ss.
  - apply (x3 to); econs; ss; try refl. econs. ss.
Qed.

Lemma sim_memory_cap_get_src
      mem1_src mem2_src
      mem1_tgt mem2_tgt
      loc from to msg
      (MEM1: sim_memory mem1_src mem1_tgt)
      (CAP_SRC: Memory.cap mem1_src mem2_src)
      (CAP_TGT: Memory.cap mem1_tgt mem2_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (GET1_SRC: Memory.get loc to mem1_src = None)
      (GET2_SRC: Memory.get loc to mem2_src = Some (from, msg)):
  <<MSG: msg = Message.reserve>> /\
  <<GET1_TGT: Memory.get loc to mem1_tgt = None>> /\
  <<GET2_TGT: Memory.get loc to mem2_tgt = Some (from, msg)>>.
Proof.
  exploit Memory.cap_inv; try exact CAP_SRC; eauto. i. des; try congr.
  - subst.
    exploit sim_memory_adjacent_src; try exact x1; eauto. i. des.
    inv CAP_TGT. exploit MIDDLE; eauto. i. splits; auto.
    inv x3. apply EMPTY; eauto. refl.
  - subst.
    erewrite sim_memory_max_ts; eauto.
    inv CAP_TGT. splits; auto.
    destruct (Memory.get loc (Time.incr (Memory.max_ts loc mem1_tgt)) mem1_tgt) as [[]|] eqn:MAX; ss.
    exploit Memory.max_ts_spec; eauto. i. des.
    specialize (Time.incr_spec (Memory.max_ts loc mem1_tgt)). i. timetac.
Qed.

Lemma sim_memory_cap_get_tgt
      mem1_src mem2_src
      mem1_tgt mem2_tgt
      loc from to msg
      (MEM1: sim_memory mem1_src mem1_tgt)
      (CAP_SRC: Memory.cap mem1_src mem2_src)
      (CAP_TGT: Memory.cap mem1_tgt mem2_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt)
      (GET1_TGT: Memory.get loc to mem1_tgt = None)
      (GET2_TGT: Memory.get loc to mem2_tgt = Some (from, msg)):
  <<MSG: msg = Message.reserve>> /\
  <<GET1_SRC: Memory.get loc to mem1_src = None>> /\
  <<GET2_SRC: Memory.get loc to mem2_src = Some (from, msg)>>.
Proof.
  exploit Memory.cap_inv; try exact CAP_TGT; eauto. i. des; try congr.
  - subst.
    exploit sim_memory_adjacent_tgt; try exact x1; eauto. i. des.
    inv CAP_SRC. exploit MIDDLE; eauto. i. splits; auto.
    inv x3. apply EMPTY; eauto. refl.
  - subst.
    erewrite <- sim_memory_max_ts; eauto.
    inv CAP_SRC. splits; auto.
    destruct (Memory.get loc (Time.incr (Memory.max_ts loc mem1_src)) mem1_src) as [[]|] eqn:MAX; ss.
    exploit Memory.max_ts_spec; eauto. i. des.
    specialize (Time.incr_spec (Memory.max_ts loc mem1_src)). i. timetac.
Qed.

Lemma sim_memory_cap
      mem1_src mem2_src
      mem1_tgt mem2_tgt
      (MEM1: sim_memory mem1_src mem1_tgt)
      (CAP_SRC: Memory.cap mem1_src mem2_src)
      (CAP_TGT: Memory.cap mem1_tgt mem2_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  econs; i; try split; i.
  - inv H.
    destruct (Memory.get loc to mem1_src) as [[]|] eqn:GET1.
    + inv CAP_SRC. exploit SOUND; eauto. i.
      rewrite x in GET. inv GET.
      eapply cap_covered; eauto.
      inv MEM1. rewrite <- COVER.
      econs; eauto.
    + exploit sim_memory_cap_get_src; eauto. i. des.
      econs; eauto.
  - inv H.
    destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
    + inv CAP_TGT. exploit SOUND; eauto. i.
      rewrite x in GET. inv GET.
      eapply cap_covered; eauto.
      inv MEM1. rewrite COVER.
      econs; eauto.
    + exploit sim_memory_cap_get_tgt; eauto. i. des.
      econs; eauto.
  - destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
    + inv CAP_TGT. exploit SOUND; eauto. i.
      rewrite x in GET. inv GET.
      inv MEM1. exploit MSG; eauto. i. des.
      inv CAP_SRC. exploit SOUND; eauto. i.
      esplits; eauto.
    + exploit sim_memory_cap_get_tgt; eauto. i. des.
      esplits; eauto. refl.
  - destruct (Memory.get loc to mem1_src) as [[]|] eqn:GET1.
    + inv CAP_SRC. exploit SOUND; eauto. i.
      rewrite x in H. inv H.
      inv MEM1. rewrite RESERVE in GET1.
      inv CAP_TGT. exploit SOUND0; eauto.
    + exploit sim_memory_cap_get_src; eauto. i. des. auto.
  - destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
    + inv CAP_TGT. exploit SOUND; eauto. i.
      rewrite x in H. inv H.
      inv MEM1. rewrite <- RESERVE in GET1.
      inv CAP_SRC. exploit SOUND0; eauto.
    + exploit sim_memory_cap_get_tgt; eauto. i. des. auto.
Qed.

(* fulfill_step *)

Lemma fulfill_write_sim_memory
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2
      (FULFILL: fulfill_step lc1 sc1 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem1)
      (ORD: Ordering.le ord Ordering.relaxed)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1):
  exists released' mem2',
    <<STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released' ord lc2 sc2 mem2' (Memory.op_kind_lower (Message.concrete val released))>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem1>>.
Proof.
  inv FULFILL.
  exploit TViewFacts.write_future_fulfill;
    try exact REL_CLOSED; try exact SC1; eauto; try by apply WF1.
  { apply WF1. eapply Memory.remove_get0. eauto. }
  i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF1; try by econs; eauto.
  { econs. inv REL_LE; try apply Time.bot_spec.
    cut (Time.le (View.rlx (View.unwrap (Some lhs)) loc)
                 (View.rlx (View.unwrap (Some rhs)) loc)).
    { i. etrans; eauto.
      cut (Memory.message_to (Message.concrete val (Some rhs)) loc to).
      { i. inv H1. auto. }
      eapply MEM1. apply WF1. eapply Memory.remove_get0. eauto. }
    destruct lhs; destruct rhs; inv LE; ss. }
  i. des.
  esplits; eauto.
  - econs; eauto.
    i. destruct ord; inv ORD; inv H.
  - eapply promise_lower_sim_memory; eauto. econs.
Qed.

Lemma promise_fulfill_write_sim_memory
      lc0 sc0 mem0 loc from to val releasedm released ord lc1 lc2 sc2 mem2 kind
      (PROMISE: Local.promise_step lc0 mem0 loc from to (Message.concrete val released) lc1 mem2 kind)
      (FULFILL: fulfill_step lc1 sc0 loc from to val releasedm released ord lc2 sc2)
      (REL_WF: View.opt_wf releasedm)
      (REL_CLOSED: Memory.closed_opt_view releasedm mem0)
      (ORD: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc0))
      (WF0: Local.wf lc0 mem0)
      (SC0: Memory.closed_timemap sc0 mem0)
      (MEM0: Memory.closed mem0):
  exists released' mem2',
    <<STEP: Local.write_step lc0 sc0 mem0 loc from to val releasedm released' ord lc2 sc2 mem2' kind>> /\
    <<REL_LE: View.opt_le released' released>> /\
    <<MEM: sim_memory mem2' mem2>> /\
    <<REL: released' = TView.write_released (Local.tview lc0) sc0 loc to releasedm ord>>.
Proof.
  exploit Local.promise_step_future; eauto. i. des.
  inv PROMISE. inv FULFILL. ss.
  exploit TViewFacts.write_future_fulfill; try exact REL_WF; eauto; try by apply WF2.
  { eapply Memory.future_closed_opt_view; eauto. }
  { eapply Memory.promise_get2; eauto. inv PROMISE0; ss. }
  s. i. des.
  exploit MemorySplit.remove_promise_remove;
    try exact REMOVE; eauto; try apply WF2; try by econs; eauto.
  { econs. inv REL_LE; try apply Time.bot_spec.
    cut (Time.le (View.rlx (View.unwrap (Some lhs)) loc)
                 (View.rlx (View.unwrap (Some rhs)) loc)).
    { i. etrans; eauto.
      cut (Memory.message_to (Message.concrete val (Some rhs)) loc to).
      { i. inv H1. auto. }
      eapply CLOSED2. apply WF2. eapply Memory.remove_get0. eauto. }
    destruct lhs; destruct rhs; inv LE; ss. }
  i. des.
  esplits; eauto.
  - econs; eauto. econs; eauto.
    eapply MemoryMerge.promise_promise_promise; eauto.
  - eapply promise_lower_sim_memory; eauto. econs.
Qed.


(** Static Intra-method control flow step. We also implement an iterator on it *)
(* Hendra : - Modified to suit DEX program.
            - DEX has different instructions list from JVM.
            - Also trim the system to contain only Arithmetic
            - Only retain the for_all_steps lemma *)
Require Export Annotated.
Import DEX_BigStep.DEX_Dom DEX_Prog.

  Section DEX_S_section.   (** step relation **)
    Variable m : DEX_Method.

    Inductive DEX_step : DEX_PC -> DEX_Instruction -> option DEX_PC -> Prop :=
    | DEX_nop : forall i j,

      next m i = Some j ->
      DEX_step i DEX_Nop (Some j)

    | DEX_move : forall i j (k:DEX_ValKind) (rt:DEX_Reg) (rs:DEX_Reg),

      next m i = Some j ->
      DEX_step i (DEX_Move k rt rs) (Some j)

    | DEX_return_s : forall i,
      DEX_step i DEX_Return None

    | DEX_vReturn : forall i (k:DEX_ValKind) (rt:DEX_Reg),
      DEX_step i (DEX_VReturn k rt) None

    | DEX_const : forall i j (k:DEX_ValKind) (rt:DEX_Reg) (v:Z),

      next m i = Some j ->
      DEX_step i (DEX_Const k rt v) (Some j)

    | DEX_goto : forall i (o:DEX_OFFSET.t),
      DEX_step i (DEX_Goto o) (Some (DEX_OFFSET.jump i o))

    | DEX_ifcmp : forall i j (cmp:DEX_CompInt) (ra:DEX_Reg) (rb:DEX_Reg) (o:DEX_OFFSET.t),
      next m i = Some j \/ j = DEX_OFFSET.jump i o ->
      DEX_step i (DEX_Ifcmp cmp ra rb o) (Some j)

    | DEX_ifz : forall i j (cmp:DEX_CompInt) (r:DEX_Reg) (o:DEX_OFFSET.t),
      next m i = Some j \/ j = DEX_OFFSET.jump i o ->
      DEX_step i (DEX_Ifz cmp r o) (Some j)

    | DEX_ineg : forall i j (rt:DEX_Reg) (rs:DEX_Reg),
      next m i = Some j ->
      DEX_step i (DEX_Ineg rt rs) (Some j)

    | DEX_inot : forall i j (rt:DEX_Reg) (rs:DEX_Reg),
      next m i = Some j ->
      DEX_step i (DEX_Inot rt rs) (Some j)

    | DEX_i2b : forall i j (rt:DEX_Reg) (rs:DEX_Reg),
      next m i = Some j ->
      DEX_step i (DEX_I2b rt rs) (Some j)

    | DEX_i2s : forall i j (rt:DEX_Reg) (rs:DEX_Reg),
       next m i = Some j ->
      DEX_step i (DEX_I2s rt rs) (Some j)
    | DEX_ibinop : forall i j (op:DEX_BinopInt) (rt:DEX_Reg) (ra:DEX_Reg) (rb:DEX_Reg),
       next m i = Some j ->
      DEX_step i (DEX_Ibinop op rt ra rb) (Some j)

    | DEX_ibinopConst : forall i j (op:DEX_BinopInt) (rt:DEX_Reg) (r:DEX_Reg) (v:Z),
       next m i = Some j ->
      DEX_step i (DEX_IbinopConst op rt r v) (Some j)

    | DEX_packedSwitch : forall i j (reg:DEX_Reg) (firstKey:Z) (size:nat) (l:list DEX_OFFSET.t),
      next m i = Some j ->
      DEX_step i (DEX_PackedSwitch reg firstKey size l) (Some j)

    | DEX_packedSwitch_jump : forall i j (reg:DEX_Reg) (firstKey:Z) (size:nat) (l:list DEX_OFFSET.t),
      In j l ->
      DEX_step i (DEX_PackedSwitch reg firstKey size l) (Some (DEX_OFFSET.jump i j))

    | DEX_sparseSwitch_default : forall i j (reg:DEX_Reg) (size:nat) (l:list (Z * DEX_OFFSET.t)),
      next m i = Some j ->
      DEX_step i (DEX_SparseSwitch reg size l) (Some j)

    | DEX_sparseSwitch_jump : forall i (j:DEX_OFFSET.t) (reg:DEX_Reg) (size:nat) (l:list (Z * DEX_OFFSET.t)),
      In j (@map _ _ (@snd _ _) l) ->
      DEX_step i (DEX_SparseSwitch reg size l) (Some (DEX_OFFSET.jump i j))

    | DEX_iput : forall i j k rs ro f,
      next m i = Some j ->
      DEX_step i (DEX_Iput k rs ro f) (Some j)

    | DEX_iget : forall i j k r ro f,
      next m i = Some j ->
      DEX_step i (DEX_Iget k r ro f) (Some j)

    | DEX_new : forall i j r c,
      next m i = Some j ->
      DEX_step i (DEX_New r c) (Some j)
.

    Definition get_steps (i:DEX_PC) (ins:DEX_Instruction) (next:option DEX_PC): list (option DEX_PC) :=
      match ins with
        | DEX_SparseSwitch r size l =>
            next :: map (fun o => (Some (DEX_OFFSET.jump i o))) (@map _ _ (@snd _ _) l)
        | DEX_PackedSwitch r firstKey size l =>
            next :: map (fun o => (Some (DEX_OFFSET.jump i o))) (l)
        | DEX_Return => None::nil
        | DEX_VReturn k rt => None::nil
        | DEX_Goto o => (Some (DEX_OFFSET.jump i o))::nil
        | DEX_Ifcmp cmp ra rb o => next::(Some (DEX_OFFSET.jump i o))::nil
        | DEX_Ifz cmp r o => next::(Some (DEX_OFFSET.jump i o))::nil
        | _ => next::nil
      end.

    Lemma all_step_in_get_steps : forall i ins oj,
        DEX_step i ins oj ->
        In oj (get_steps i ins (next m i)).
    Proof.
      intros.
      inversion_clear H;
      simpl get_steps; try rewrite H0;
      auto with datatypes;
      (* ifcmp and ifz cases *)
        try (destruct H0 as [H0|H0]; rewrite <- H0; auto with datatypes;
        right; subst; left; reflexivity).
      (* PackedSwitch case *)
      right; apply in_map with (f:=(fun o : DEX_OFFSET.t => Some (DEX_OFFSET.jump i o))); auto.
      (* SparseSwitch case *)
      right; apply in_map with (f:=(fun o : DEX_OFFSET.t => Some (DEX_OFFSET.jump i o))); auto.
    Qed.

  Section for_all_steps.
    Variable test : DEX_PC -> DEX_Instruction -> option DEX_PC -> bool.

    Definition for_all_steps_bm (bm:DEX_BytecodeMethod) : bool :=
      MapN.for_all _
      (fun i (ins_next:DEX_Instruction*(option DEX_PC *list DEX_ClassName )) =>
        let (ins,next) := ins_next in
          for_all _
          (fun (oj:option DEX_PC) => test i ins oj)
          (get_steps i ins ( fst  next)))
      bm.(DEX_BYTECODEMETHOD.instr).

    Lemma for_all_steps_bm_true : forall bm,
      DEX_METHOD.body m = Some bm ->
      for_all_steps_bm bm = true ->
      forall i ins oj,
        instructionAt m i = Some ins ->
        DEX_step i ins oj -> test i ins oj = true.
    Proof.
      intros.
      assert (T1:=MapN.for_all_true _ _ _ H0).
      assert (T2:=all_step_in_get_steps _ _ _ H2).
      unfold instructionAt, DEX_BYTECODEMETHOD.instructionAt in H1.
      rewrite H in H1.
      caseeq (MapN.get (DEX_Instruction * (option DEX_PC*list DEX_ClassName)) (DEX_BYTECODEMETHOD.instr bm) i).
      intros (ins0,next0) T3.
      rewrite T3 in H1.
      generalize (T1 _ _ T3); clear T1; intros T1.
      apply for_all_true with
        (test:=(fun oj : option DEX_PC => test i ins oj))
        (2:=T2).
      unfold next, DEX_BYTECODEMETHOD.nextAddress.
      rewrite H; rewrite T3; simpl.
      inversion_mine H1; auto.
      intros T3; rewrite T3 in H1; discriminate.
    Qed.

  Definition for_all_steps_m : bool :=
    match DEX_METHOD.body m with
      | None => false
      | Some bm => for_all_steps_bm bm
    end.

  Definition test_all_steps_m : list (DEX_PC*bool) :=
    match DEX_METHOD.body m with
      | None => nil
      | Some bm =>
      List.map
      (fun (ins_next:DEX_PC*(DEX_Instruction*(option DEX_PC*list DEX_ClassName))) =>
        let (i,ins_next) := ins_next in
        let (ins,next) := ins_next in
          (i,for_all _
            (fun (oj:option DEX_PC) => test i ins oj)
            (get_steps i ins (fst next))))
      (MapN.elements _ bm.(DEX_BYTECODEMETHOD.instr))
    end.

  Lemma for_all_steps_m_true : for_all_steps_m = true ->
      forall i ins oj,
        instructionAt m i = Some ins ->
        DEX_step i ins oj -> test i ins oj = true.
  Proof.
    unfold for_all_steps_m.
    generalize for_all_steps_bm_true.
    destruct (DEX_METHOD.body m) as [bm|]; intro.
    apply H; auto.
    intros; discriminate.
  Qed.
  End for_all_steps.

  Section for_all_succs.
    Variable pc:DEX_PC.
    Variable test : option DEX_PC -> bool.

    Definition for_all_succs_bm (bm:DEX_BytecodeMethod) : bool :=
      match MapN.get _ bm.(DEX_BYTECODEMETHOD.instr) pc with
        | None => true
        | Some (ins,(op,l)) =>
          for_all _
          (fun (oj:option DEX_PC) => test oj)
          (get_steps pc ins op)
      end.

    Lemma for_all_succs_bm_true : forall bm,
      DEX_METHOD.body m = Some bm ->
      for_all_succs_bm bm = true ->
      forall ins oj,
        instructionAt m pc = Some ins ->
        DEX_step pc ins oj -> test oj = true.
    Proof.
      unfold for_all_succs_bm; intros.
      assert (T2:=all_step_in_get_steps _ _ _ H2).
      unfold instructionAt, DEX_BYTECODEMETHOD.instructionAt in H1.
      rewrite H in H1.
      caseeq (MapN.get (DEX_Instruction * (option DEX_PC*list DEX_ClassName)) (DEX_BYTECODEMETHOD.instr bm) pc).
      intros (ins0,next0) T3.
      rewrite T3 in H1; rewrite T3 in H0.
      destruct next0.
      apply for_all_true with
        (test:=(fun oj : option DEX_PC => test oj))
        (2:=T2).
      unfold next, DEX_BYTECODEMETHOD.nextAddress.
      inversion_mine H1.
      rewrite H; rewrite T3; simpl; auto.
      intros.
      rewrite H3 in H1; discriminate.
    Qed.

  Definition for_all_succs_m : bool :=
    match DEX_METHOD.body m with
      | None => false
      | Some bm => for_all_succs_bm bm
    end.

  Lemma for_all_succs_m_true : for_all_succs_m = true ->
      forall ins oj,
        instructionAt m pc = Some ins ->
        DEX_step pc ins oj -> test oj = true.
  Proof.
    unfold for_all_succs_m.
    generalize for_all_succs_bm_true.
    destruct (DEX_METHOD.body m) as [bm|]; intro.
    apply H; auto.
    intros; discriminate.
  Qed.

 End for_all_succs.

  Section for_all_instrs.
    Variable test : DEX_PC -> DEX_Instruction -> bool.

    Definition for_all_instrs_bm (bm:DEX_BytecodeMethod) : bool :=
      MapN.for_all _
      (fun i (ins_next:DEX_Instruction*(option DEX_PC*list DEX_ClassName)) =>
        let (ins,next) := ins_next in test i ins)
      bm.(DEX_BYTECODEMETHOD.instr).

    Lemma for_all_instrs_bm_true : forall bm,
      DEX_METHOD.body m = Some bm ->
      for_all_instrs_bm bm = true ->
      forall i ins,
        instructionAt m i = Some ins -> test i ins = true.
    Proof.
      intros.
      assert (T1:=MapN.for_all_true _ _ _ H0).
      unfold instructionAt, DEX_BYTECODEMETHOD.instructionAt in H1.
      rewrite H in H1.
      caseeq (MapN.get (DEX_Instruction * (option DEX_PC*list DEX_ClassName)) (DEX_BYTECODEMETHOD.instr bm) i).
      intros (ins0,next0) T3.
      rewrite T3 in H1.
      generalize (T1 _ _ T3); clear T1; intros T1.
      inversion_mine H1; auto.
      intros T3; rewrite T3 in H1; discriminate.
    Qed.

    Definition for_all_instrs_m : bool :=
      match DEX_METHOD.body m with
        | None => false
        | Some bm => for_all_instrs_bm bm
      end.

    Lemma for_all_instrs_m_true : for_all_instrs_m = true ->
      forall i ins,
        instructionAt m i = Some ins -> test i ins = true.
    Proof.
      unfold for_all_instrs_m.
      generalize for_all_instrs_bm_true.
      destruct (DEX_METHOD.body m) as [bm|]; intro.
      apply H; auto.
      intros; discriminate.
    Qed.

  End for_all_instrs.

End DEX_S_section.

Module DEX_MapClassTools := MapProjTools DEX_PROG.DEX_MapClass.

Section p.
  Variable p : DEX_Program.

  Definition ValidMethod (m:DEX_Method) : Prop :=
    exists c, DEX_PROG.defined_Class p c /\ DEX_CLASS.defined_Method c m.

  Variable test : DEX_Method -> bool.

  Definition for_all_methods : bool :=
    DEX_MapClassTools.for_all
    (fun cl =>  DEX_MapShortMethSign.for_all _ (fun _ => test) cl.(DEX_CLASS.methods))
    p.(DEX_PROG.classes_map).

  Lemma for_all_methods_true : for_all_methods = true ->
    forall m, ValidMethod m -> test m = true.
  Proof.
    intros.
    destruct H0 as [c [H0 H1]].
    generalize (DEX_MapClassTools.for_all_true _ _ H _ H0); intros.
    unfold DEX_CLASS.defined_Method, DEX_CLASS.method in H1.
    caseeq (DEX_MapShortMethSign.get DEX_Method (DEX_CLASS.methods c) (DEX_METHOD.signature m)); intros.
    rewrite H3 in H1.
    destruct (DEX_METHODSIGNATURE.eq_t (DEX_METHOD.signature m) (DEX_METHOD.signature d)); inversion_mine H1.
    apply (DEX_MapShortMethSign.for_all_true _ _ _ H2 _ _ H3).
    rewrite H3 in H1; discriminate.
  Qed.

End p.


(** A definition of concurrent programming with a callbacks style. *)

Module Effect.
  Record t := New {
    command : Type;
    answer : command -> Type }.
End Effect.

Module C.
  Inductive t (E : Effect.t) : Type :=
  | Ret : t E
  | Call : forall (c : Effect.command E), (Effect.answer E c -> t E) -> t E
  | Fork : t E -> t E -> t E.
  Arguments Ret {E}.
  Arguments Call {E} _ _.
  Arguments Fork {E} _ _.
End C.

Module DPN.
  Record t (State Action : Type) := New {
    seq_step : State -> Action -> State -> Prop;
    par_step : State -> Action -> State -> State -> Prop }.

  Definition empty {State Action : Type} : t State Action := {|
    seq_step := fun _ _ _ => False;
    par_step := fun _ _ _ _ => False |}.

  Module Action.
    Inductive t (E : Effect.t) :=
    | Call : forall (c : Effect.command E), Effect.answer E c -> t E
    | Fork : t E.
    Arguments Call {E} _ _.
    Arguments Fork {E}.
  End Action.

  Definition call {E : Effect.t} (c : Effect.command E)
    (callback : Effect.answer E c -> C.t E) : t (C.t E) (Action.t E) := {|
    seq_step := fun x action y =>
      exists a : Effect.answer E c,
        x = C.Call c callback /\
        action = Action.Call c a /\
        y = callback a;
    par_step := fun _ _ _ _ => False |}.
End DPN.


Extraction Language Haskell.

Require Import NArith.
Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Bag.
Require Import Dict.
Require Import Misc.
Require Import SpaceSearch.CpdtTactics.
Require Import JamesTactics.
Require Import KonneTactics.
Require Import Coq.Program.Basics.
Require Import SpaceSearch.EqDec.
Require Import Enumerable.
Require Import BGPSpec.
Require Import Equality.
Require Import SymbolicExecution.
Require Import Graph.
Import ListNotations.
Import EqNotations.

Section Simulation.

Definition decide P := {P} + {~P}.

Parameter CIDR : Type.
Parameter eqDecideCIDR : forall (c c':CIDR), decide (c = c').
Parameter IP : Type.
Parameter eqDecideIP : forall (i i':IP), decide (i = i').
Parameter ASN : Type.
Parameter eqDecideASN : forall (a a':ASN), decide (a = a').

Instance eqDecCIDR : eqDec CIDR.
  constructor.
  exact eqDecideCIDR.
Defined.

Instance eqDecIP : eqDec IP.
  constructor.
  exact eqDecideIP.
Defined.

Instance eqDecASN : eqDec ASN.
  constructor.
  exact eqDecideASN.
Defined.

Existing Instance eqDecProd.
Existing Instance eqDecMode.
Existing Instance eqDecUpdateMessage.

Instance natPrefix : PrefixClass := {| Prefix := CIDR |}.

(* see main bgp spec and https://tools.ietf.org/html/rfc1997 *)
Inductive BGPPathAttributes := {
  LOCAL_PREF : nat;
  COMMUNITIES : list nat;
  AS_PATH : list ASN
}.

Inductive Match :=
| RAny : Match
| RCommunityIs : nat -> Match
| RNot : Match -> Match
| RAnd : Match -> Match -> Match
| ROr : Match -> Match -> Match.

Inductive Modify :=
| MAddCommunity : nat -> Modify
| MStripCommunities : Modify.

Inductive Action :=
| AModify : Modify -> Action
| AAccept : Action
| AReject : Action.

Definition Rule := (Match * Action)%type.

Instance eqDecBGPPathAttributes : eqDec BGPPathAttributes.
  constructor.
  decide equality; apply eqDecide.
Defined.

Instance bgpPathAttributes : PathAttributesClass := {|
  PathAttributes := BGPPathAttributes;
  leDecPathAttributes a a' := Nat.leb (LOCAL_PREF a) (LOCAL_PREF a')
|}.
Proof.
  intros.
  apply leb_correct.
  Require Import Omega.
  omega.
Defined.

Record Setup := {
  ases : list (ASN * list IP);
  links : list ((ASN * IP * list Rule * list Rule) * (ASN * IP * list Rule * list Rule));
  injections : list ((ASN * IP) * CIDR)
}.

Inductive PolicyResult := replaced | filtered.

Fixpoint zipIn {A} `{eqDec A} l : list {a:A | In a l}.
  refine (match l with
  | [] => []
  | a::l' => exist _ a _ :: (fun s => exist _ (proj1_sig s) _) <$> (zipIn _ _ l')
  end).
  - cbn.
    left.
    reflexivity.
  - destruct s as [a'].
    cbn.
    destruct (a =? a'); intuition.
Defined.

Lemma zipInOk {A} `{eqDec A} {l} : forall a : {a : A | In a l}, In a (zipIn l).
  intros.
  revert a.
  induction l.
  - cbn.
    intros [].
    trivial.
  - intros [a' ?].
    cbn.
    destruct (a =? a').
    + left.
      subst_max.
      generalize_proofs.
      reflexivity.
    + right.
      destruct i; [congruence|].
      specialize (IHl (exist _ a' i)).
      Arguments exist [_ _] _ _.
      idtac.
      Arguments exist [_] _ _ _.
      admit.
Admitted.

Instance enumerableSigIn {A} `{eqDec A} {l} : enumerable {a:A | In a l}.
  refine {| enumerate := zipIn l |}.
Proof.
  apply zipInOk.
Defined.

Typeclasses Transparent const.

Instance eqDecProp {P:Prop} : eqDec P.
  constructor.
  intros.
  proof_irrelevance.
  left.
  reflexivity.
Defined.

Instance eqDecEmptySet : eqDec Empty_set.
  constructor.
  intros [].
Defined.

Definition routers (setup:Setup) : list (ASN * IP) :=
  bindList (ases setup) (fun asips => map (fun ip => (fst asips, ip)) (snd asips)).

Definition linkWithoutRules (l : ((ASN * IP * list Rule * list Rule) * (ASN * IP * list Rule * list Rule))) : ((ASN * IP) * (ASN * IP)) :=
  ((fst (fst (fst (fst l)))), (snd (fst (fst (fst l)))), (fst (fst (snd l)))).

Definition linksWithoutRules (s : Setup) : list ((ASN * IP) * (ASN * IP)).
  destruct s.
  exact (map linkWithoutRules links0).
Defined.

Variable setup:Setup.

Definition inDec {A} `{eqDec A} (a:A) l : decide (In a l).
  refine (in_dec _ a l).
Proof.
  intros a' a''.
  destruct (a' =? a'').
  - left. trivial.
  - right. trivial.
Defined.

Definition hasConnection (r r':ASN*IP) : bool :=
  (((fst r) =? (fst r')) && negb ((snd r) =? (snd r'))) ||
  inDec (r , r') (linksWithoutRules setup) ||
  inDec (r', r ) (linksWithoutRules setup).

Instance bgpTopology : TopologyClass. refine {|
  Router := {r:ASN * IP | In r (routers setup)};
  connections := fun r r' => if hasConnection (proj1_sig r) (proj1_sig r') then unit else Empty_set;
  mode := fun r r' _ => if (fst (proj1_sig r)) =? (fst (proj1_sig r'))
                        then ibgp else ebgp
|}.
Proof.
  - intros.
    unfold edge.
    break_match.
    + exact eqDecUnit.
    + exact eqDecEmptySet.
  - intros.
    unfold edge.
    break_match.
    + exact enumerableUnit.
    + exact enumerableEmptySet.
Defined.

Definition extendPath (asn:ASN) (a:PathAttributes) : PathAttributes :=
  {| LOCAL_PREF := LOCAL_PREF a; COMMUNITIES := COMMUNITIES a; AS_PATH := asn :: AS_PATH a |}.

Definition setPref (pref : nat) (a : PathAttributes) : PathAttributes :=
  {| LOCAL_PREF := pref; COMMUNITIES := COMMUNITIES a; AS_PATH := AS_PATH a |}.

Fixpoint indexOf' {A} `{eqDec A} (l : list A) a (n : nat) : option nat :=
  match l with
    | a' :: l' =>
      if eqDecide a a' then
        Some n
      else
        indexOf' l' a (S n)
    | [] => None
  end.

Definition indexOf {A} `{eqDec A} (l : list A) a := indexOf' l a 0.

Definition pref {r} (i : incoming r) : option nat.
refine (match i with
          | injected => None
          | received r' => _
       end).
destruct r'. destruct x. destruct r.
destruct (indexOf (linksWithoutRules setup) ( x0, x )).
- exact (Some (100 + (2 * n))).
- destruct (indexOf (linksWithoutRules setup) ( x, x0 )).
  + exact (Some (S (100 + (2 * n)))).
  + exact None.
Defined.

Definition adjustPref {r}  (i : incoming r) a :=
  match pref i with
    | Some n => setPref n a
    | _ => a
  end.

Definition sameRouter {r} (i : incoming r) (o : outgoing r) : bool.
  destruct i.
  - exact false.
  - destruct s, o.
    destruct (eqDecide x x0).
    + exact true.
    + exact false.
Defined.

Definition inASPath {r} (o : outgoing r) (a : PathAttributes) : bool.
  destruct a. destruct o. destruct x.
  destruct (inDec (fst x) AS_PATH0).
  - exact true.
  - exact false.
Defined.

Fixpoint lookupRules (r r' : (ASN * IP)) (l : list ((ASN * IP * list Rule * list Rule) *
                                                   (ASN * IP * list Rule * list Rule))) :
  option ( list Rule * list Rule ).
refine (match l with
          | [] => None
          | c :: l' => _
        end).
destruct (eqDecide (r, r') (linkWithoutRules c)).
  - exact (Some (snd (fst (fst c)), (snd (fst c)))).
  - destruct (eqDecide (r', r) (linkWithoutRules c)).
    + exact (Some (snd (fst (snd c)), (snd (snd c)))).
    + exact (lookupRules r r' l').
Defined.

Definition importRules {r} (i : incoming r) : list Rule.
  destruct r. destruct i.
  - exact [].
  - destruct s. destruct x0.
    exact (match (lookupRules x x0 (links setup)) with
             | None => []
             | Some (i, e) => i
           end).
Defined.

Definition exportRules {r} (o : outgoing r) : list Rule.
  destruct r. destruct o. destruct x0.
  exact (match (lookupRules x x0 (links setup)) with
           | None => []
           | Some (i, e) => e
         end).
Defined.

Fixpoint matches (m : Match) (a : PathAttributes) :=
  match m with
    | RAny => true
    | RCommunityIs c => if inDec c (COMMUNITIES a) then true else false
    | RNot m' => negb (matches m' a)
    | RAnd m1 m2 => andb (matches m1 a) (matches m2 a)
    | ROr m1 m2 => orb (matches m1 a) (matches m2 a)
  end.

Definition modify (m : Modify) (a : PathAttributes) :=
  match m with
    | MAddCommunity c =>
      {| LOCAL_PREF := LOCAL_PREF a; COMMUNITIES := c :: COMMUNITIES a; AS_PATH := AS_PATH a |}
    | MStripCommunities =>
      {| LOCAL_PREF := LOCAL_PREF a; COMMUNITIES := []; AS_PATH := AS_PATH a |}
  end.

Fixpoint executeRules (rules : list Rule) (a : PathAttributes) : RoutingInformation :=
  match rules with
    | [] => available a
    | (m, ac) :: rules' =>
      if (matches m a) then
        match ac with
          | AAccept => available a
          | AReject => notAvailable
          | AModify mo => executeRules rules' (modify mo a)
        end
      else
        executeRules rules' a
  end.

Existing Instance enumerableIncoming.

Lemma cbgb_best_best:
  forall (r : Router) (f : incoming r -> RoutingInformation) (i : incoming r),
    leDecRoutingInformation (f i)
                            (f
                               (argMax'
                                  (compose
                                     (fun a : RoutingInformation =>
                                        match a with
                                        | available a0 => S (LOCAL_PREF a0)
                                        | notAvailable => 0
                                        end) f) injected)) = true.
Proof.
  intros.
  unfold leDecRoutingInformation.
  branch; [|congruence].
  branch.
  - cbn.
    apply leb_correct.
    unfold compose in *.
Admitted.

Instance cbgpConfiguration r : ConfigurationClass r.
  refine {|
    import i p a := executeRules (importRules i) (adjustPref i a);
    export i o p a := if ((sameRouter i o) : bool) then notAvailable else
                        if (inASPath o a) then notAvailable else _;
    originate p a := true;
    bestIncoming f := argMax' (compose (fun a => match a with
                                                 | notAvailable => 0
                                                 | available a => S (LOCAL_PREF a)
                                                 end) f) injected
  |}. {
    destruct (executeRules (exportRules o) a) as [a'|].
    + destruct o as [d c].
      exact (available (if mode c =? ebgp then extendPath (fst (proj1_sig r)) a' else a')).
    + exact notAvailable.
  }
  Proof.
  apply cbgb_best_best.
Defined.

Definition TraceExists := NetworkState.

Definition BGPRouter : Type := ASN * IP.
Definition BGPAttributes : Type := option BGPPathAttributes.
Definition BGPMessage : Type := CIDR * BGPAttributes.

Typeclasses Transparent BGPRouter.
Typeclasses Transparent BGPAttributes.
Typeclasses Transparent BGPMessage.

Definition bgpAttributes (a:RoutingInformation) : BGPAttributes :=
  match a with available a => Some a | notAvailable => None end.

Definition bgpMessage (m:UpdateMessage) : BGPMessage :=
  (nlri m, bgpAttributes (attributes m)).

Record Event := {
  number : nat;
  srcRouter : BGPRouter;
  handlingRouter : BGPRouter;
  incomingNlri : option CIDR;
  incomingAnnouncement : BGPAttributes
                           (*
  eligibleAnnouncements : list BGPAttributes;
  oldBestAnnouncement : BGPAttributes;
  newBestAnnouncement : BGPAttributes;
  disseminates : list (BGPRouter * PolicyResult) *)
}.

Inductive TraceError :=
  handlerNotARouter (r:BGPRouter)
| sourceNotARouter (r:BGPRouter)
| sourceAndHandlerNotConnected (s d:BGPRouter)
| originationNotAllowed (a:BGPMessage)
| messageNotOnLink (sender : IP) (receiver : IP)  (e_num : nat) (m m':BGPMessage) (ms:list BGPMessage)
| linkEmpty (m : option BGPMessage) (e_num : nat)
| incorrectWithdraw
.

Fixpoint applyInjection (i : BGPRouter * CIDR) (ns:TraceExists) : TraceError + TraceExists.
  destruct i as [r p].
  refine (if inDec r (routers setup) then _ else inl (handlerNotARouter r)).
  refine (let a := available {| LOCAL_PREF := 0; COMMUNITIES := []; AS_PATH := [] |} in _).
  refine (let m := {| nlri := p; attributes := a |} in _).
  refine (if originate' (exist _ r _) p a then _ else inl (originationNotAllowed (bgpMessage m))); [trivial|].
  refine (let ls := linkState ns in _).
  refine (let rs := routerState ns in _).
  simple refine (let Ers' := generateHandler (exist _ r _) m rs in _); [trivial|].
  refine (let E := fst Ers' in _).
  refine (let rs' := snd Ers' in _).
  refine (inr {| routerState := rs'; linkState := build (fun c => lookup ls c ++ lookup E c) |}).
Defined.

Instance eqDecOption {A} `{eqDec A} : eqDec (option A).
  constructor.
  decide equality.
  apply eqDecide.
Defined.

Definition messageWithoutCommunities (m : UpdateMessage) : UpdateMessage.
  destruct m. destruct attributes.
  - exact (updateMessage nlri (available (modify MStripCommunities p))).
  - exact (updateMessage nlri notAvailable).
Defined.

Definition applyEvent (e:Event) (ns:TraceExists) : TraceError + TraceExists.
  refine (let s := srcRouter e in _).
  refine (let r := handlingRouter e in _).
  refine (if inDec s (routers setup) then _ else inl (sourceNotARouter s)).
  refine (if inDec r (routers setup) then _ else inl (handlerNotARouter r)).
  destruct (hasConnection s r) eqn:?; [|exact (inl (sourceAndHandlerNotConnected s r))].
  refine (let ls0 := linkState ns in _).
  refine (let rs := routerState ns in _).
  refine (let ai := match incomingAnnouncement e with None => notAvailable | Some a => available a end in _).
  simple refine (let c : Connection := _ in _). {
    simple refine [ (exist _ s _, exist _ r _) & _].
    - trivial.
    - trivial.
    - cbn.
      break_match; [|congruence].
      exact tt.
  }
  destruct (incomingNlri e).
  - refine (let m := {| nlri := c0; attributes := ai |} in _).
    refine (match ls0 c with
              | [] => inl (linkEmpty (Some (bgpMessage m)) (number e))
              | m'::ms => if m =? (messageWithoutCommunities m') then _
                         else inl (messageNotOnLink (snd s) (snd r) (number e) (bgpMessage m) (bgpMessage m') (bgpMessage <$> ms))
            end).
    refine (let ls := overwrite ls0 c ms in _).
    refine (let Ers' := forwardHandler c m' rs in _).
    refine (let E := fst Ers' in _).
    refine (let rs' := snd Ers' in _).
    refine (inr {| routerState := rs'; linkState := build (fun c => lookup ls c ++ lookup E c) |}).
  - refine (match ls0 c with
              | [] => inl (linkEmpty None (number e))
              | m' :: ms => _
            end).
    destruct m'. destruct attributes.
    + exact (inl incorrectWithdraw).
    + remember ({| nlri := nlri; attributes := notAvailable |}) as m'.
      refine (let ls := overwrite ls0 c ms in _).
      refine (let Ers' := forwardHandler c m' rs in _).
      refine (let E := fst Ers' in _).
      refine (let rs' := snd Ers' in _).
      refine (inr {| routerState := rs'; linkState := build (fun c => lookup ls c ++ lookup E c) |}).
Defined.

(*
TODO: Check that the following matc
Record Event := {
  eligibleAnnouncements : list (option BGPPathAttributes);
  oldBestAnnouncement : option BGPPathAttributes;
  newBestAnnouncement : option BGPPathAttributes;
  disseminates : list ((ASN * IP) * PolicyResult)
}.
*)

Definition emptyNetwork : TraceExists := emptyNetworkState.

Definition debugTraceExists (ns:TraceExists) :
    list (BGPRouter * BGPRouter * list (BGPMessage)).
  refine (bindList (routers setup) (fun s  => _)).
  refine (bindList (routers setup) (fun r => _)).
  refine (if inDec s (routers setup) then _ else []).
  refine (if inDec r (routers setup) then _ else []).
  destruct (hasConnection s r) eqn:?; [|exact []].
  simple refine (let c : Connection := _ in _). {
    simple refine [ (exist _ s _, exist _ r _) & _].
    - trivial.
    - trivial.
    - cbn.
      break_match; [|congruence].
      exact tt.
  }
  refine (let ms := bgpMessage <$> linkState ns c in _).
  refine [(s, r, ms)].
Defined.

End Simulation.

(* TODO move connection into Prop *)

Require Import ExtractPrelude.

Extract Inlined Constant map => "Prelude.map".
Extract Inlined Constant concat => "List.concat".
Extract Inlined Constant bindList => "(Prelude.>>=)".

Extract Inductive nat => "Prelude.Int" [ "0" "Prelude.succ" ]
                                    "(\fO fS n -> if n==0 then fO () else fS (n-1))".

Extract Inlined Constant plus => "(Prelude.+)".
Extract Inlined Constant mult => "(Prelude.*)".

Extract Inlined Constant Nat.leb => "(Prelude.<=)".

Extract Inlined Constant False_rect => "Prelude.undefined".

Extract Inlined Constant sumBoolAnd => "(Prelude.&&)".

Extract Inductive sigT => "(,)" [ "(,)" ].
Extract Inlined Constant projT1 => "Prelude.fst".
Extract Inlined Constant projT2 => "Prelude.snd".

Extraction Inline sumbool_rec.
Extraction Inline sumbool_rect.

Extraction Inline eq_rect.
Extraction Inline eq_rect_r.
Extraction Inline eq_rec_r.
Extraction Inline eq_rec.

Extraction Inline unit_rec.
Extraction Inline unit_rect.

Extraction Inline nat_rec.
Extraction Inline nat_rect.

Extraction Inline list_rec.
Extraction Inline list_rect.

Extract Inlined Constant eqDecNat => "(Prelude.==)".

Extraction Inline Mode_rect.
Extraction Inline Mode_rec.
Extraction Inline incoming_rect.
Extraction Inline incoming_rec.
Extraction Inline RoutingInformation_rect.
Extraction Inline RoutingInformation_rec.
Extraction Inline BGPPathAttributes_rect.
Extraction Inline BGPPathAttributes_rec.

Extract Inlined Constant CIDR => "Prelude.String".
Extract Inlined Constant eqDecideCIDR => "(Prelude.==)".
Extract Inlined Constant IP => "Prelude.String".
Extract Inlined Constant eqDecideIP => "(Prelude.==)".
Extract Inlined Constant ASN => "Prelude.Int".
Extract Inlined Constant eqDecideASN => "(Prelude.==)".

Extraction "MessageHandling.hs" Setup links emptyNetwork applyEvent applyInjection injections emptyNetwork debugTraceExists PolicyResult.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University

  This file is part of Velisarios.

  Velisarios is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export generic_tactics.
Require Export list_util1.

Require Export Eqdep_dec.

Require Export Node.

Section Quorum.

  Context { pn  : @Node }.

  Definition nat_n (n : nat) : Set := {m : nat | m <? n = true}.

  Record bijective {A B} (f : A -> B) :=
    {
      bij_inv : B -> A;
      bij_id1 : forall x : A, bij_inv (f x) = x;
      bij_id2 : forall y : B, f (bij_inv y) = y;
    }.
  Arguments bij_inv [A] [B] [f] _ _.

  Lemma nat_n_deq: forall n, Deq (nat_n n).
  Proof.
    introv; introv.
    destruct x as [n1 p1], y as [n2 p2].
    destruct (deq_nat n1 n2);[left|right].

    - subst.
      f_equal.
      apply UIP_dec.
      apply bool_dec.

    - introv xx; inversion xx; tcsp.
  Defined.

  Definition injective {A B} (F : A -> B) :=
    forall n m, F n = F m -> n = m.

  Class Quorum_context :=
    MkQuorumContext
      {
        node_type      : Set;
        num_nodes      : nat;
        node_deq       : Deq node_type;
        node2nat       : node_type -> nat_n num_nodes;
        node_bij       : bijective node2nat;
        node2name      : node_type -> name;
        name2node      : name -> option node_type;
        node2name_cond : forall n, name2node (node2name n) = Some n;
        name2node_cond : forall n m, name2node m = Some n -> node2name n = m;
        node2name_inj  : injective node2name;
      }.

  Context { quorum_context : Quorum_context }.

  Definition mk_nat_n {x n : nat} (p : x < n) : nat_n n :=
    exist _ x (leb_correct _ _ p).

  Definition nodes : list node_type :=
    mapin
      (seq 0 num_nodes)
      (fun n i => bij_inv node_bij (mk_nat_n (seq_0_lt i))).

  Lemma nodes_no_repeats : no_repeats nodes.
  Proof.
    apply no_repeats_mapin; eauto 3 with list.
    introv d.
    assert (node2nat (bij_inv node_bij (mk_nat_n (seq_0_lt i)))
            = node2nat (bij_inv node_bij (mk_nat_n (seq_0_lt j))))
      as h by (allrw; auto).
    repeat rewrite (bij_id2 _ node_bij) in h.
    clear d.
    unfold mk_nat_n in h.
    inversion h; auto.
  Qed.

  Lemma length_nodes : length nodes = num_nodes.
  Proof.
    introv; unfold nodes; autorewrite with list; auto.
  Qed.

  Lemma nodes_prop : forall (x : node_type), In x nodes.
  Proof.
    introv.
    unfold nodes.
    apply in_mapin.

    remember (node2nat x) as nx.
    destruct nx as [nx condnx].

    pose proof (leb_complete _ _ condnx) as c.

    assert (In nx (seq O num_nodes)) as i.
    { apply in_seq; omega. }

    exists nx i; simpl.

    unfold mk_nat_n.
    unfold bij_inv.
    destruct node_bij.
    pose proof (bij_id3 x) as h.
    rewrite <- Heqnx in h; subst; simpl.

    f_equal; f_equal.
    apply UIP_dec; apply bool_dec.
  Qed.

  Lemma num_nodes_list_le :
    forall (l : NRlist node_type), length l <= num_nodes.
  Proof.
    introv.
    apply (le_trans _ (length nodes));[|rewrite length_nodes;auto].

    assert (subset l nodes) as ss.
    { introv j; apply nodes_prop. }

    pose proof (no_repeats_implies_remove_repeats_eq node_deq l (nrl_no_repeats _ l)) as e.

    apply (subset_implies_eq_length_remove_repeats node_deq) in ss.
    rewrite e in ss.
    eapply le_trans;[exact ss|].
    eauto with list.
  Qed.

  Lemma overlapping_quorums :
    forall (l1 l2 : NRlist node_type) n m,
      n <= length l1
      -> m <= length l2
      -> exists good,
          (n + m) - num_nodes <= length good
          /\ no_repeats good
          /\ subset good l1
          /\ subset good l2.
  Proof.
    introv len1 len2.

    exists (keep node_deq l1 l2).
    dands; eauto 3 with list;[].

    destruct (le_lt_dec ((n + m) - num_nodes) (length (keep node_deq l1 l2))) as [d|d]; auto.
    assert False; tcsp.

    assert (no_repeats (remove_repeats node_deq (l1 ++ l2))) as nr by eauto 3 with list.

    pose proof (num_nodes_list_le (MkNRlist _ (remove_repeats node_deq (l1 ++ l2)) nr)) as q.
    simpl in *.
    rewrite remove_repeats_app in q.
    rewrite app_length in q.
    rewrite (no_repeats_implies_remove_repeats_eq _ l2) in q; auto; eauto 3 with list.
    rewrite (no_repeats_implies_remove_repeats_eq _ l1) in q; auto; eauto 3 with list.

    pose proof (split_length_as_keep_remove_list node_deq l1 l2) as w; try omega.
  Qed.

  Lemma overlapping_quorums_same_size :
    forall (l1 l2 : NRlist node_type) n,
      n <= length l1
      -> n <= length l2
      -> exists l,
          (2 * n) - num_nodes <= length l
          /\ no_repeats l
          /\ subset l l1
          /\ subset l l2.
  Proof.
    introv len1 len2.

    assert (n + n = 2 * n) as eqn by omega.

    pose proof (overlapping_quorums l1 l2 n n) as q.
    rewrite eqn in q.
    repeat (autodimp q hyp); try omega.
  Qed.

  Lemma overlapping_quorums_different_sizes :
    forall (l1 l2 : NRlist node_type) n m,
      num_nodes - n < m
      -> n <= length l1
      -> m <= length l2
      -> exists good,
          1 <= length good
          /\ no_repeats good
          /\ subset good l1
          /\ subset good l2.
  Proof.
    introv cond len1 len2.
    pose proof (overlapping_quorums l1 l2 n m) as q.
    repeat (autodimp q hyp).
    exrepnd.
    exists good; dands; auto; try omega.
  Qed.

End Quorum.

Arguments bij_inv [A] [B] [f] _ _.


Set Warnings "-notation-overridden".

Require Import LinearScan.Lib.
Require Import LinearScan.UsePos.
Require Import String.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Section Blocks.

Variable maxReg : nat.          (* max number of registers *)
Definition PhysReg := 'I_maxReg.

Definition VarId := nat.

(* [VarInfo] abstracts information about the caller's notion of variables
   associated with an operation. *)
Record VarInfo := {
  varId       : PhysReg + VarId;   (* from 0 to highest var index *)
  varKind     : VarKind;
  regRequired : bool
}.

Definition nat_of_varId v := match varId v with
  | inl n => nat_of_ord n
  | inr v => v + maxReg
  end.

Inductive OpKind : Set := IsNormal | IsCall | IsBranch.

Definition OpId := nat.

(* The [OpInfo] structure is a collection of functions that allow us to
   determine information about each operation coming from the caller's
   side. *)
Record OpInfo `{Monad m} (opType1 opType2 : Set) := {
  opKind      : opType1 -> OpKind;
  opRefs      : opType1 -> seq VarInfo;
  moveOp      : PhysReg -> VarId -> PhysReg -> m (seq opType2);
  saveOp      : PhysReg -> VarId -> m (seq opType2);
  restoreOp   : VarId   -> PhysReg -> m (seq opType2);
  applyAllocs : opType1 -> seq (VarId * VarKind * PhysReg) -> m (seq opType2);
  showOp      : opType1 -> string
}.

Definition BlockId := nat.

Record BlockInfo `{Monad m} (blockType1 blockType2 opType1 opType2 : Set) := {
  blockId         : blockType1 -> BlockId;
  blockSuccessors : blockType1 -> seq BlockId;

  splitCriticalEdge : blockType1 -> blockType1
                        -> m (blockType1 * blockType1)%type;

  blockOps    : blockType1 -> (seq opType1 * seq opType1 * seq opType1);
  setBlockOps : blockType1 -> seq opType2 -> seq opType2 -> seq opType2
                  -> blockType2
}.

Close Scope string_scope.

Variables blockType1 blockType2 opType1 opType2 : Set.
Variables mType : Type -> Type.
Context `{mDict : Monad mType}.

Variable binfo : BlockInfo blockType1 blockType2 opType1 opType2.
Variable oinfo : OpInfo opType1 opType2.

Definition allBlockOps (block : blockType1) : seq opType1 :=
  let: (a, b, c) := blockOps binfo block in a ++ b ++ c.

Definition blockSize (block : blockType1) := size (allBlockOps block).

Definition foldOps {a} (f : a -> opType1 -> a) (z : a) : seq blockType1 -> a :=
  foldl (fun bacc blk => foldl f bacc (allBlockOps blk)) z.

Definition countOps : seq blockType1 -> nat :=
  foldOps (fun acc _ => acc.+1) 0.

End Blocks.