Require Import RelationClasses.
Require Import Coq.Logic.PropExtensionality.

From sflib Require Import sflib.
From Paco Require Import paco.

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

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

Require Import Cover.
Require Import PFConsistent.
Require Import Certify.

Set Implicit Arguments.

Definition map_t: Type := Loc.t -> Time.t -> Time.t -> Prop.

Section Mapping.
  Variable f: map_t.

  Definition map_inhabited: Prop :=
    forall loc, f loc Time.bot Time.bot.

  Definition map_finite: Prop :=
    forall loc,
    exists dom,
    forall ts fts (MAP: f loc ts fts),
      List.In ts dom.

  Definition map_eq: Prop :=
    forall loc x y fx fy
      (EQ: x = y)
      (MAP1: f loc x fx)
      (MAP2: f loc y fy),
      fx = fy.

  Definition map_eq_inv: Prop :=
    forall loc x y fx fy
      (EQ: fx = fy)
      (MAP1: f loc x fx)
      (MAP2: f loc y fy),
      x = y.

  Definition map_lt: Prop :=
    forall loc x y fx fy
      (LT: Time.lt x y)
      (MAP1: f loc x fx)
      (MAP2: f loc y fy),
      Time.lt fx fy.

  Definition map_lt_inv: Prop :=
    forall loc x y fx fy
      (LT: Time.lt fx fy)
      (MAP1: f loc x fx)
      (MAP2: f loc y fy),
      Time.lt x y.

  Lemma map_le
        loc x y fx fy
        (MAP_EQ: map_eq)
        (MAP_LT: map_lt)
        (LE: Time.le x y)
        (MAP1: f loc x fx)
        (MAP2: f loc y fy):
    Time.le fx fy.
  Proof.
    inv LE.
    - left. eauto.
    - right. eapply MAP_EQ; eauto.
  Qed.

  Lemma map_le_inv
        loc x y fx fy
        (MAP_EQ_INV: map_eq_inv)
        (MAP_LT_INV: map_lt_inv)
        (LE: Time.le fx fy)
        (MAP1: f loc x fx)
        (MAP2: f loc y fy):
    Time.le x y.
  Proof.
    inv LE.
    - left. eauto.
    - right. eapply MAP_EQ_INV; eauto.
  Qed.

  Variant map_wf: Prop :=
    | map_wf_intro
        (MAP_INHABITED: map_inhabited)
        (MAP_FINITE: map_finite)
        (MAP_EQ: map_eq)
        (MAP_EQ_INV: map_eq_inv)
        (MAP_LT: map_lt)
        (MAP_LT_INV: map_lt_inv)
  .

  Lemma map_min_exists
        loc P
        (FINITE: map_finite):
    (<<NONE: forall ts fts (MAP: f loc ts fts), ~ P ts>>) \/
    exists ts_min fts_min,
      (<<MAP: f loc ts_min fts_min>>) /\
      (<<SAT: P ts_min>>) /\
      (<<MIN: forall ts' fts'
                     (MAP: f loc ts' fts')
                     (SAT: P ts'),
          Time.le ts_min ts'>>).
  Proof.
    specialize (FINITE loc). des.
    specialize (Cell.min_exists_aux
                  (fun ts => P ts /\ exists fts, f loc ts fts) dom).
    i. des.
    - left. ii. eapply NONE; eauto.
    - right. esplits; eauto.
  Qed.

  Lemma map_fmin_exists
        loc P
        (FINITE: map_finite)
        (MAP_EQ: map_eq)
        (MAP_LT: map_lt):
    (<<NONE: forall ts fts (MAP: f loc ts fts), ~ P fts>>) \/
    exists ts_min fts_min,
      (<<MAP: f loc ts_min fts_min>>) /\
      (<<SAT: P fts_min>>) /\
      (<<MIN: forall ts' fts'
                     (MAP: f loc ts' fts')
                     (SAT: P fts'),
          Time.le fts_min fts'>>).
  Proof.
    specialize (FINITE loc). des.
    specialize (Cell.min_exists_aux
                  (fun ts => exists fts, f loc ts fts /\ P fts) dom).
    i. des.
    - left. ii. eapply NONE; eauto.
    - right. esplits; eauto. i.
      exploit FINITE; eauto. i.
      exploit MIN; eauto. i.
      eapply map_le; eauto.
  Qed.

  Lemma map_max_exists
        loc P
        (FINITE: map_finite):
    (<<NONE: forall ts fts (MAP: f loc ts fts), ~ P ts>>) \/
    exists ts_max fts_max,
      (<<MAP: f loc ts_max fts_max>>) /\
      (<<SAT: P ts_max>>) /\
      (<<MAX: forall ts' fts'
                     (MAP: f loc ts' fts')
                     (SAT: P ts'),
          Time.le ts' ts_max>>).
  Proof.
    specialize (FINITE loc). des.
    specialize (Cell.max_exists_aux
                  (fun ts => P ts /\ exists fts, f loc ts fts) dom).
    i. des.
    - left. ii. eapply NONE; eauto.
    - right. esplits; eauto.
  Qed.

  Lemma map_fmax_exists
        loc P
        (FINITE: map_finite)
        (MAP_EQ: map_eq)
        (MAP_LT: map_lt):
    (<<NONE: forall ts fts (MAP: f loc ts fts), ~ P fts>>) \/
    exists ts_max fts_max,
      (<<MAP: f loc ts_max fts_max>>) /\
      (<<SAT: P fts_max>>) /\
      (<<MAX: forall ts' fts'
                     (MAP: f loc ts' fts')
                     (SAT: P fts'),
          Time.le fts' fts_max>>).
  Proof.
    specialize (FINITE loc). des.
    specialize (Cell.max_exists_aux
                  (fun ts => exists fts, f loc ts fts /\ P fts) dom).
    i. des.
    - left. ii. eapply NONE; eauto.
    - right. esplits; eauto. i.
      exploit FINITE; eauto. i.
      exploit MAX; eauto. i.
      eapply map_le; eauto.
  Qed.

  Definition timemap_map (tm ftm: TimeMap.t): Prop :=
    forall loc, f loc (tm loc) (ftm loc).

  Variant view_map (view fview: View.t): Prop :=
    | view_map_intro
        (RLX: timemap_map view.(View.rlx) (fview.(View.rlx)))
        (PLN: timemap_map view.(View.pln) (fview.(View.pln)))
  .

  Variant opt_view_map: forall (view fview: option View.t), Prop :=
    | opt_view_map_None:
      opt_view_map None None
    | opt_view_map_Some
        view fview
        (VIEW: view_map view fview):
      opt_view_map (Some view) (Some fview)
  .

  Variant tview_map (tview ftview: TView.t): Prop :=
    | tview_map_intro
        (REL: forall loc, view_map (TView.rel tview loc) (TView.rel ftview loc))
        (CUR: view_map (TView.cur tview) (TView.cur ftview))
        (ACQ: view_map (TView.acq tview) (TView.acq ftview))
  .

  Variant message_map: forall (msg fmsg: Message.t), Prop :=
    | message_map_message
        val view fview na
        (RELEASED: opt_view_map view fview):
      message_map (Message.message val view na) (Message.message val fview na)
    | message_map_reserve:
      message_map Message.reserve Message.reserve
  .

  Variant memory_map (rsv: Memory.t) (mem fmem: Memory.t): Prop :=
    | memory_map_intro
        (SOUND: forall loc from to msg
                       (GET: Memory.get loc to mem = Some (from, msg)),
            (<<RESERVE: msg = Message.reserve>>) \/
            exists ffrom fto fmsg,
              (<<FGET: Memory.get loc fto fmem = Some (ffrom, fmsg)>>) /\
              (<<FROM: f loc from ffrom>>) /\
              (<<TO: f loc to fto>>) /\
              (<<MSG: message_map msg fmsg>>))
        (COMPLETE: forall loc ffrom fto fmsg
                          (FGET: Memory.get loc fto fmem = Some (ffrom, fmsg)),
            exists ffrom' fto' from to,
              (<<FFROM: Time.le ffrom' ffrom>>) /\
              (<<FTO: Time.le fto fto'>>) /\
              (<<FROM: f loc from ffrom'>>) /\
              (<<TO: f loc to fto'>>) /\
              (<<COVERED: forall ts (ITV: Interval.mem (from, to) ts), covered loc ts mem>>) /\
              (<<RESERVED: forall f t m
                             (GET: Memory.get loc t rsv = Some (f, m)),
                  Interval.disjoint (f, t) (from, to)>>))
  .

  Variant local_map (lc flc: Local.t): Prop :=
    | local_map_intro
        (TVIEW: tview_map (Local.tview lc) (Local.tview flc))
  .

  Variant global_map (rsv: Memory.t) (gl fgl: Global.t): Prop :=
    | global_map_intro
        (MEMORY: memory_map rsv (Global.memory gl) (Global.memory fgl))
  .

  Definition promises_map (lc: Local.t) (gl: Global.t) (flc: Local.t) (fgl: Global.t): Prop :=
    BoolMap.minus (Global.promises gl) (Local.promises lc) =
    BoolMap.minus (Global.promises fgl) (Local.promises flc)
  .

  Variant event_map: forall (e fe: ThreadEvent.t), Prop :=
    | event_map_promise
        loc:
      event_map (ThreadEvent.promise loc) (ThreadEvent.promise loc)
    | event_map_reserve
        loc from to ffrom fto
        (FROM: f loc from ffrom)
        (TO: f loc to fto):
      event_map (ThreadEvent.reserve loc from to) (ThreadEvent.reserve loc ffrom fto)
    | event_map_cancel
        loc from to ffrom fto
        (FROM: f loc from ffrom)
        (TO: f loc to fto):
      event_map (ThreadEvent.cancel loc from to) (ThreadEvent.cancel loc ffrom fto)
    | event_map_silent:
      event_map ThreadEvent.silent ThreadEvent.silent
    | event_map_read
        loc ts fts val released freleased ord
        (TS: f loc ts fts)
        (RELEASED: opt_view_map released freleased):
      event_map (ThreadEvent.read loc ts val released ord)
                (ThreadEvent.read loc fts val freleased ord)
    | event_map_write
        loc from ffrom to fto val released freleased ord
        (FROM: f loc from ffrom)
        (TO: f loc to fto)
        (RELEASED: opt_view_map released freleased):
      event_map (ThreadEvent.write loc from to val released ord)
                (ThreadEvent.write loc ffrom fto val freleased ord)
    | event_map_update
        loc tsr ftsr tsw ftsw valr valw releasedr freleasedr releasedw freleasedw ordr ordw
        (TSR: f loc tsr ftsr)
        (TSW: f loc tsw ftsw)
        (RELEASEDR: opt_view_map releasedr freleasedr)
        (RELEASEDW: opt_view_map releasedw freleasedw):
      event_map (ThreadEvent.update loc tsr tsw valr valw releasedr releasedw ordr ordw)
                (ThreadEvent.update loc ftsr ftsw valr valw freleasedr freleasedw ordr ordw)
    | event_map_fence
        ordr ordw:
      event_map (ThreadEvent.fence ordr ordw) (ThreadEvent.fence ordr ordw)
    | event_map_syscall
        e:
      event_map (ThreadEvent.syscall e) (ThreadEvent.syscall e)
    | event_map_failure:
      event_map ThreadEvent.failure ThreadEvent.failure
    | event_map_racy_read
        loc to fto val ord
        (TO: option_rel (f loc) to fto):
      event_map (ThreadEvent.racy_read loc to val ord)
                (ThreadEvent.racy_read loc fto val ord)
    | event_map_racy_write
        loc to fto val ord
        (TO: option_rel (f loc) to fto):
      event_map (ThreadEvent.racy_write loc to val ord)
                (ThreadEvent.racy_write loc fto val ord)
    | event_map_racy_update
        loc to fto valr valw ordr ordw
        (TO: option_rel (f loc) to fto):
      event_map (ThreadEvent.racy_update loc to valr valw ordr ordw)
                (ThreadEvent.racy_update loc fto valr valw ordr ordw)
  .
End Mapping.

Lemma bot_timemap_map
      f
      (MAP_WF: map_wf f):
  timemap_map f TimeMap.bot TimeMap.bot.
Proof.
  ii. apply MAP_WF.
Qed.

Lemma bot_view_map
      f
      (MAP_WF: map_wf f):
  view_map f View.bot View.bot.
Proof.
  econs; eauto using bot_timemap_map.
Qed.

Lemma unwrap_map
      f v fv
      (MAP_WF: map_wf f)
      (VIEW: opt_view_map f v fv):
  view_map f (View.unwrap v) (View.unwrap fv).
Proof.
  inv VIEW; ss.
  apply bot_view_map; auto.
Qed.

Lemma time_join_map
      f loc t1 t2 ft1 ft2
      (MAP_WF: map_wf f)
      (TIME1: f loc t1 ft1)
      (TIME2: f loc t2 ft2):
  f loc (Time.join t1 t2) (Time.join ft1 ft2).
Proof.
  unfold Time.join. repeat condtac; ss.
  - exploit map_le; eauto; try apply MAP_WF. i. timetac.
  - exploit map_le_inv; eauto; try apply MAP_WF. i. timetac.
Qed.

Lemma timemap_join_map
      f tm1 tm2 ftm1 ftm2
      (MAP_WF: map_wf f)
      (TIMEMAP1: timemap_map f tm1 ftm1)
      (TIMEMAP2: timemap_map f tm2 ftm2):
  timemap_map f (TimeMap.join tm1 tm2) (TimeMap.join ftm1 ftm2).
Proof.
  ii. unfold TimeMap.join.
  eapply time_join_map; eauto.
Qed.

Lemma view_join_map
      f view1 view2 fview1 fview2
      (MAP_WF: map_wf f)
      (VIEW1: view_map f view1 fview1)
      (VIEW2: view_map f view2 fview2):
  view_map f (View.join view1 view2) (View.join fview1 fview2).
Proof.
  inv VIEW1. inv VIEW2.
  econs; ss; eauto using timemap_join_map.
Qed.

Lemma singleton_ur_map
      f loc to fto
      (MAP_WF: map_wf f)
      (MAP: f loc to fto):
  view_map f (View.singleton_ur loc to) (View.singleton_ur loc fto).
Proof.
  unfold View.singleton_ur, TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
  econs; ss; ii; condtac; subst; ss; try apply MAP_WF.
Qed.

Lemma singleton_rw_map
      f loc to fto
      (MAP_WF: map_wf f)
      (MAP: f loc to fto):
  view_map f (View.singleton_rw loc to) (View.singleton_rw loc fto).
Proof.
  unfold View.singleton_rw, TimeMap.singleton, LocFun.add, LocFun.find, LocFun.init.
  econs; ss; ii; try condtac; subst; ss; try apply MAP_WF.
Qed.

Lemma singleton_ur_if_map
      f c loc to fto
      (MAP_WF: map_wf f)
      (MAP: f loc to fto):
  view_map f (View.singleton_ur_if c loc to) (View.singleton_ur_if c loc fto).
Proof.
  unfold View.singleton_ur_if.
  condtac; auto using singleton_ur_map, singleton_rw_map.
Qed.

Definition map_add (loc: Loc.t) (ts fts: Time.t) (f: map_t): map_t :=
  fun loc' ts' fts' =>
    (loc' = loc /\ ts' = ts /\ fts' = fts) \/ f loc' ts' fts'.
#[local] Hint Unfold map_add: core.

Lemma map_add_ident
      (f: map_t) loc ts fts
      (MAP: f loc ts fts):
  map_add loc ts fts f = f.
Proof.
  extensionality loc'.
  extensionality ts'.
  extensionality fts'.
  apply propositional_extensionality.
  unfold map_add. split; auto.
  i. des; subst; ss.
Qed.

Lemma map_add_incr loc ts fts f:
  f <3= map_add loc ts fts f.
Proof.
  unfold map_add. auto.
Qed.

Lemma map_add_inhabited
      f loc ts fts
      (MAP_INHABITED: map_inhabited f):
  map_inhabited (map_add loc ts fts f).
Proof.
  ii. auto.
Qed.

Lemma map_add_finite
      f loc ts fts
      (MAP_FINITE: map_finite f):
  map_finite (map_add loc ts fts f).
Proof.
  ii. specialize (MAP_FINITE loc0). des.
  exists (ts :: dom). i. inv MAP.
  - des. subst. left. ss.
  - right. eauto.
Qed.

Lemma map_add_eq
      f loc ts fts
      (MAP_EQ: map_eq f)
      (ADD_EX: forall fts' (MAP: f loc ts fts'), fts' = fts):
  map_eq (map_add loc ts fts f).
Proof.
  unfold map_add. ii. des; subst; ss.
  - exploit ADD_EX; eauto.
  - exploit ADD_EX; eauto.
  - exploit MAP_EQ; eauto.
Qed.

Lemma map_add_eq_inv
      f loc ts fts
      (MAP_EQ_INV: map_eq_inv f)
      (ADD_EX: forall ts' (MAP: f loc ts' fts), ts' = ts):
  map_eq_inv (map_add loc ts fts f).
Proof.
  unfold map_add. ii. des; subst; ss.
  - exploit ADD_EX; eauto.
  - exploit ADD_EX; eauto.
  - exploit MAP_EQ_INV; eauto.
Qed.

Lemma map_add_lt
      f loc ts fts
      (MAP_LT: map_lt f)
      (ADD_EX: forall ts' fts' (MAP: f loc ts' fts'),
          Time.lt ts' ts /\ Time.lt fts' fts \/
            ts' = ts /\ fts' = fts \/
            Time.lt ts ts' /\ Time.lt fts fts'):
  map_lt (map_add loc ts fts f).
Proof.
  unfold map_add. ii. des; subst; eauto; timetac.
  - exploit ADD_EX; try exact MAP1. i. des; timetac.
  - exploit ADD_EX; try exact MAP2. i. des; timetac.
Qed.

Lemma map_add_lt_inv
      f loc ts fts
      (MAP_LT_INV: map_lt_inv f)
      (ADD_EX: forall ts' fts' (MAP: f loc ts' fts'),
          Time.lt ts' ts /\ Time.lt fts' fts \/
            ts' = ts /\ fts' = fts \/
            Time.lt ts ts' /\ Time.lt fts fts'):
  map_lt_inv (map_add loc ts fts f).
Proof.
  unfold map_add. ii. des; subst; eauto; timetac.
  - exploit ADD_EX; try exact MAP1. i. des; timetac.
  - exploit ADD_EX; try exact MAP2. i. des; timetac.
Qed.

Lemma timemap_map_incr
      f1 f2
      (INCR: f1 <3= f2):
  timemap_map f1 <2= timemap_map f2.
Proof.
  ii. auto.
Qed.

Lemma view_map_incr
      f1 f2
      (INCR: f1 <3= f2):
  view_map f1 <2= view_map f2.
Proof.
  i. inv PR. econs; eauto using timemap_map_incr.
Qed.

Lemma opt_view_map_incr
      f1 f2
      (INCR: f1 <3= f2):
  opt_view_map f1 <2= opt_view_map f2.
Proof.
  i. inv PR; econs.
  eauto using view_map_incr.
Qed.

Lemma message_map_incr
      f1 f2
      (INCR: f1 <3= f2):
  message_map f1 <2= message_map f2.
Proof.
  i. inv PR; econs.
  eauto using opt_view_map_incr.
Qed.

Lemma tview_map_incr
      f1 f2
      (INCR: f1 <3= f2):
  tview_map f1 <2= tview_map f2.
Proof.
  i. inv PR. econs; eauto using view_map_incr.
Qed.

Lemma event_map_incr
      f1 f2
      (INCR: f1 <3= f2):
  event_map f1 <2= event_map f2.
Proof.
  i. inv PR.
  - econs 1.
  - econs 2; eauto.
  - econs 3; eauto.
  - econs 4.
  - econs 5; eauto using opt_view_map_incr.
  - econs 6; eauto using opt_view_map_incr.
  - econs 7; eauto using opt_view_map_incr.
  - econs 8.
  - econs 9.
  - econs 10.
  - econs 11. destruct to, fto; ss. auto.
  - econs 12. destruct to, fto; ss. auto.
  - econs 13. destruct to, fto; ss. auto.
Qed.

Lemma memory_map_get
      f rsv mem fmem
      loc from to msg
      (MAP: memory_map f rsv mem fmem)
      (GET: Memory.get loc to mem = Some (from, msg))
      (RESERVE: msg <> Message.reserve):
  exists ffrom fto fmsg,
    (<<FGET: Memory.get loc fto fmem = Some (ffrom, fmsg)>>) /\
    (<<FROM: f loc from ffrom>>) /\
    (<<TO: f loc to fto>>) /\
    (<<MSG: message_map f msg fmsg>>).
Proof.
  destruct MAP.
  exploit SOUND; eauto. i. des; try congr.
  esplits; eauto.
Qed.

Lemma memory_map_closed_timemap
      f rsv mem fmem
      tm ftm
      (WF: map_wf f)
      (MEMORY: memory_map f rsv mem fmem)
      (TIMEMAP: timemap_map f tm ftm)
      (CLOSED: Memory.closed_timemap tm mem):
  Memory.closed_timemap ftm fmem.
Proof.
  ii. specialize (CLOSED loc). des.
  exploit memory_map_get; eauto; ss. i. des. inv MSG.
  specialize (TIMEMAP loc).
  inv WF. exploit MAP_EQ; [|exact TIMEMAP|exact TO|]; ss. i. subst.
  esplits; eauto.
Qed.

Lemma lt_get_from
      mem loc
      from1 to1 msg1
      from2 to2 msg2
      (LT: Time.lt to1 to2)
      (GET1: Memory.get loc to1 mem = Some (from1, msg1))
      (GET2: Memory.get loc to2 mem = Some (from2, msg2)):
  Time.le to1 from2.
Proof.
  exploit Memory.get_ts; try exact GET1. i. des.
  { subst. timetac. }
  exploit Memory.get_disjoint; [exact GET1|exact GET2|]. i. des.
  { subst. timetac. }
  destruct (TimeFacts.le_lt_dec to1 from2); ss. exfalso.
  apply (x1 to1); econs; ss; try refl. econs. ss.
Qed.

Lemma add_cases
      mem1 loc from to msg mem2
      (INHABITED: Memory.inhabited mem1)
      (ADD: Memory.add mem1 loc from to msg mem2):
  exists pfrom pto pmsg,
    (<<PGET: Memory.get loc pto mem1 = Some (pfrom, pmsg)>>) /\
    (<<PREV: Time.le pto from>>) /\
    (<<PREV_TS: Time.le pfrom pto>>) /\
    (<<PEMPTY: Memory.empty mem1 loc pto to>>) /\
    __guard__ (
        (exists nfrom nto nmsg,
            (<<NGET: Memory.get loc nto mem1 = Some (nfrom, nmsg)>>) /\
            (<<NEXT: Time.le to nfrom>>) /\
            (<<NEXT_TS: Time.lt nfrom nto>>) /\
            (<<NEMPTY: Memory.empty mem1 loc to nto>>)) \/
        (<<LATEST: forall ts (LT: Time.lt to ts), Memory.get loc ts mem1 = None>>)).
Proof.
  exploit Memory.add_ts; eauto. i.
  hexploit Memory.add_inhabited; eauto. i. des.
  exploit Memory.add_get0; eauto. i. des.
  exploit (@Memory.prev_exists to mem2 loc); try apply H.
  { eapply TimeFacts.le_lt_lt; eauto. apply Time.bot_spec. }
  i. des.
  revert x1. erewrite Memory.add_o; eauto. condtac; ss.
  { des. subst. timetac. }
  clear o COND. i.
  esplits; try eapply x1; eauto.
  { exploit Memory.add_get1; try exact x1; eauto. i.
    eapply lt_get_from; eauto.
  }
  { exploit Memory.get_ts; try exact x1. i. des; timetac. }
  { ii. exploit x3; eauto.
    erewrite Memory.add_o; eauto. condtac; ss.
  }
  destruct (TimeFacts.le_lt_dec (Memory.max_ts loc mem1) to).
  { right. i.
    destruct (Memory.get loc ts mem1) as [[]|] eqn:GET'; ss.
    exploit Memory.max_ts_spec; try exact GET'. i. des.
    rewrite l in MAX. timetac.
  }
  { left.
    exploit Memory.next_exists; try exact l; eauto. i. des.
    exploit Memory.get_ts; try exact x4. i. des; timetac.
    esplits; eauto.
    exploit Memory.add_get1; try exact x4; eauto. i.
    eapply lt_get_from; eauto.
  }
Qed.

Lemma map_ts_add_exists
      f1 loc ts
      (WF1: map_wf f1):
  exists fts f2,
    (<<F2: f2 = map_add loc ts fts f1>>) /\
    (<<WF2: map_wf f2>>).
Proof.
  inv WF1.
  exploit (@map_max_exists
             f1 loc (fun ts' => Time.le ts' ts)); eauto. i. des.
  { exfalso. eapply NONE; try apply MAP_INHABITED. apply Time.bot_spec. }
  inv SAT; cycle 1.
  { inv H. exists fts_max. esplits; try refl.
    rewrite map_add_ident; ss.
  }
  exploit (@map_min_exists
             f1 loc (fun ts' => Time.lt ts ts')); eauto. i. des.
  { exists (Time.incr fts_max). esplits; try refl.
    econs.
    - apply map_add_inhabited. ss.
    - apply map_add_finite. ss.
    - apply map_add_eq; ss. i.
      exploit MAX; try exact MAP0; try refl. i.
      exfalso. timetac.
    - apply map_add_eq_inv; ss. i.
      exploit MAP_LT_INV; [|exact MAP|exact MAP0|]; try apply Time.incr_spec. i.
      hexploit NONE; try exact MAP0. i.
      exploit MAX; try exact MAP0.
      { destruct (TimeFacts.le_lt_dec ts' ts); ss. }
      i. exfalso. timetac.
    - apply map_add_lt; ss. i.
      hexploit NONE; try exact MAP0. i.
      exploit MAX; try exact MAP0.
      { destruct (TimeFacts.le_lt_dec ts' ts); ss. }
      i. left. split.
      + ett; eauto.
      + ett; try apply Time.incr_spec.
        eapply map_le; eauto.
    - apply map_add_lt_inv; ss. i.
      hexploit NONE; try exact MAP0. i.
      exploit MAX; try exact MAP0.
      { destruct (TimeFacts.le_lt_dec ts' ts); ss. }
      i. left. split.
      + ett; eauto.
      + ett; try apply Time.incr_spec.
        eapply map_le; eauto.
  }
  exploit MAP_LT; [|exact MAP|exact MAP0|].
  { etrans; eauto. }
  i. exploit Time.middle_spec; try exact x0. i. des.
  exists (Time.middle fts_max fts_min). esplits; try refl.
  econs.
  - apply map_add_inhabited. ss.
  - apply map_add_finite. ss.
  - apply map_add_eq; ss. i.
    exploit MAX; try exact MAP1; try refl. i.
    exfalso. timetac.
  - apply map_add_eq_inv; ss. i.
    exploit MAP_LT_INV; try exact x1; try eassumption. i.
    exploit MAP_LT_INV; try exact x2; try eassumption. i.
    destruct (TimeFacts.le_lt_dec ts' ts).
    + exploit MAX; try exact MAP1; ss. i. exfalso. timetac.
    + exploit MIN; try exact MAP1; ss. i. exfalso. timetac.
  - apply map_add_lt; ss. i.
    destruct (TimeFacts.le_lt_dec ts' ts).
    + exploit MAX; try exact MAP1; ss. i.
      exploit map_le; try exact x3; try eassumption. i.
      left. split; ett; eauto.
    + exploit MIN; try exact MAP1; ss. i.
      exploit map_le; try exact x3; try eassumption. i.
      right. right. split; tet; eauto. refl.
  - apply map_add_lt_inv; ss. i.
    destruct (TimeFacts.le_lt_dec ts' ts).
    + exploit MAX; try exact MAP1; ss. i.
      exploit map_le; try exact x3; try eassumption. i.
      left. split; ett; eauto.
    + exploit MIN; try exact MAP1; ss. i.
      exploit map_le; try exact x3; try eassumption. i.
      right. right. split; tet; eauto. refl.
Qed.

Lemma memory_map_add
      f1 rsv mem1 fmem1
      loc from to msg mem2
      (WF1: map_wf f1)
      (MAP1: memory_map f1 rsv mem1 fmem1)
      (LE: Memory.le rsv mem1)
      (INHABITED1: Memory.inhabited mem1)
      (ADD: Memory.add mem1 loc from to msg mem2):
  exists ffrom fto f2,
    (<<F2: f2 = map_add loc from ffrom (map_add loc to fto f1)>>) /\
    (<<WF2: map_wf f2>>) /\
    forall fmsg
      (FMSG_WF: Message.wf fmsg)
      (MSG_MAP: message_map f2 msg fmsg),
    exists fmem2,
      (<<FADD: Memory.add fmem1 loc ffrom fto fmsg fmem2>>) /\
      (<<MAP2: memory_map f2 rsv mem2 fmem2>>).
Proof.
  inv WF1. inv MAP1.
  exploit Memory.add_ts; eauto. intro TS.
  exploit (@map_ts_add_exists f1 loc to); ss. i. des.
  exploit (@map_ts_add_exists f2 loc from); ss. i. des.
  subst. clear WF2.
  rename fts into fto, fts0 into ffrom, WF0 into WF2.
  esplits; try exact WF2; eauto. i.

  destruct WF2.
  exploit MAP_LT0; try exact TS; [left|right|]; eauto. intro FTS.
  exploit (@Memory.add_exists fmem1 loc); try exact FTS; try exact FMSG_WF.
  { ii. inv LHS. inv RHS. ss.
    clear fmsg FMSG_WF MSG_MAP.
    exploit COMPLETE; try exact GET2. i. des.
    cut (exists ts, Interval.mem (from, to) ts /\ Interval.mem (from0, to0) ts).
    { i. des. exploit COVERED; eauto. i. inv x1.
      exploit Memory.add_get1; try exact GET; eauto. i.
      exploit Memory.add_get0; eauto. i. des.
      exploit Memory.get_disjoint; [exact x1|exact GET1|]. i.
      des; subst; eauto. congr.
    }
    exploit TimeFacts.lt_le_lt; try exact FROM; try exact TO0. i.
    exploit TimeFacts.lt_le_lt; try exact x1; try exact FTO. i.
    exploit TimeFacts.lt_le_lt; try exact FROM0; try exact TO. i.
    exploit TimeFacts.le_lt_lt; try exact x3; try exact FFROM. i.
    exploit MAP_LT_INV0; try exact x2; eauto. i.
    exploit MAP_LT_INV0; try exact x4; try right; eauto. i.
    exploit TimeFacts.le_lt_lt; try exact FFROM; try exact FROM0. i.
    exploit TimeFacts.lt_le_lt; try exact x7; try exact TO0. i.
    exploit TimeFacts.lt_le_lt; try exact x8; try exact FTO. i.
    exploit MAP_LT_INV0; try exact x9; eauto. i.
    destruct (TimeFacts.le_lt_dec to to0).
    - exists to. split; econs; ss; try refl.
    - exists to0. split; econs; ss; try refl. timetac.
  }
  i. des. rename x0 into FADD.

  esplits; try exact FADD.
  econs; i.
  { revert GET. erewrite Memory.add_o; eauto.
    condtac; ss; i.
    - des. inv GET. right.
      exploit Memory.add_get0; try exact FADD. i. des.
      esplits; try exact GET0; eauto 6.
    - guardH o.
      exploit SOUND; eauto. i. des; eauto.
      exploit Memory.add_get1; try exact FGET; eauto. i.
      right. esplits; eauto.
      do 2 (eapply message_map_incr; try eapply map_add_incr). ss.
  }
  { revert FGET. erewrite Memory.add_o; eauto.
    condtac; ss; i.
    - des. symmetry in FGET. inv FGET.
      exploit Memory.add_get0; try exact ADD. i. des.
      esplits; try exact GET0; try refl.
      + left. eauto.
      + right. eauto.
      + i. econs; eauto.
      + ii. exploit LE; eauto. i.
        exploit Memory.add_get1; try exact x1; eauto. i.
        exploit Memory.get_disjoint; [exact GET0|exact x2|]. i.
        des; eauto. subst. congr.
    - guardH o.
      exploit COMPLETE; eauto. i. des.
      exploit Memory.add_get1; try exact GET; eauto. i.
      esplits; try exact x0; eauto. i.
      erewrite add_covered; try exact ADD. auto.
  }
Qed.

Lemma memory_map_reserve
      f1 rsv1 mem1 fmem1
      loc from to rsv2 mem2
      (MAP1: memory_map f1 rsv1 mem1 fmem1)
      (RESERVE: Memory.reserve rsv1 mem1 loc from to rsv2 mem2):
  (<<MAP2: memory_map f1 rsv2 mem2 fmem1>>).
Proof.
  inv MAP1. inv RESERVE. econs; i.
  - revert GET. erewrite Memory.add_o; eauto.
    condtac; ss; eauto. i. des. inv GET. auto.
  - exploit COMPLETE; eauto. i. des.
    esplits; eauto.
    + i. erewrite add_covered; try exact MEM. auto.
    + i. revert GET. erewrite Memory.add_o; eauto.
      condtac; ss; eauto. i. des. inv GET.
      ii. exploit COVERED; eauto. i. inv x1.
      exploit Memory.add_get1; try exact GET; eauto. i.
      exploit Memory.add_get0; try exact MEM. i. des.
      exploit Memory.get_disjoint; [exact x1|exact GET1|]. i.
      des; eauto. subst. congr.
Qed.

Lemma memory_map_cancel
      f1 rsv1 mem1 fmem1
      loc from to rsv2 mem2
      (WF1: map_wf f1)
      (MAP1: memory_map f1 rsv1 mem1 fmem1)
      (LE: Memory.le rsv1 mem1)
      (INHABITED1: Memory.inhabited mem1)
      (CANCEL: Memory.cancel rsv1 mem1 loc from to rsv2 mem2):
  (<<MAP2: memory_map f1 rsv2 mem2 fmem1>>).
Proof.
  inv WF1. inv MAP1. inv CANCEL. econs; i.
  - revert GET. erewrite Memory.remove_o; eauto.
    condtac; ss; eauto.
  - exploit COMPLETE; eauto. i. des.
    esplits; eauto.
    + i. exploit COVERED; eauto. i.
      erewrite remove_covered; try exact MEM. split; ss.
      destruct (Loc.eq_dec loc0 loc); auto. subst. right.
      exploit Memory.remove_get0; try exact MEM. i. des.
      ii. inv x0.
      exploit Memory.get_disjoint; [exact GET|exact GET1|]. i.
      des; eauto. subst.
      exploit Memory.remove_get0; try exact RSV. i. des.
      exploit RESERVED; eauto.
    + i. revert GET. erewrite Memory.remove_o; eauto.
      condtac; ss; eauto.
Qed.

Lemma map_readable
      f tview ftview
      loc to fto ord
      (MAP_WF: map_wf f)
      (TVIEW: tview_map f tview ftview)
      (TO: f loc to fto)
      (READABLE: TView.readable (TView.cur tview) loc to ord):
  TView.readable (TView.cur ftview) loc fto ord.
Proof.
  inv READABLE. econs.
  - eapply map_le; try exact PLN; try apply MAP_WF; eauto. apply TVIEW.
  - i. eapply map_le; try eapply RLX; try apply MAP_WF; eauto. apply TVIEW.
Qed.

Lemma read_tview_map
      f tview ftview
      loc to fto released freleased ord
      (MAP_WF: map_wf f)
      (TVIEW: tview_map f tview ftview)
      (TO: f loc to fto)
      (RELEASED: opt_view_map f released freleased):
  tview_map f
            (TView.read_tview tview loc to released ord)
            (TView.read_tview ftview loc fto freleased ord).
Proof.
  unfold TView.read_tview.
  econs; s; (try condtac); (repeat apply view_join_map); ss;
    try apply TVIEW; try apply bot_view_map; ss;
    try apply unwrap_map; ss;
    eauto using singleton_rw_map, singleton_ur_map, singleton_ur_if_map.
Qed.

Lemma map_read_step
      rsv
      f1 lc1 gl1 flc1 fgl1
      loc to val released ord lc2
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (STEP: Local.read_step lc1 gl1 loc to val released ord lc2):
  exists fto freleased flc2,
    (<<FSTEP: Local.read_step flc1 fgl1 loc fto val freleased ord flc2>>) /\
    (<<TO_MAP: f1 loc to fto>>) /\
    (<<RELEASED_MAP: opt_view_map f1 released freleased>>) /\
    (<<LC_MAP2: local_map f1 lc2 flc2>>).
Proof.
  inv STEP. exploit memory_map_get; try apply GL_MAP1; eauto; ss. i. des. inv MSG.
  esplits; eauto.
  - econs; eauto.
    eapply map_readable; try apply LC_MAP1; eauto.
  - econs; s; try apply LC_MAP1.
    apply read_tview_map; ss. apply LC_MAP1.
Qed.

Lemma map_writable
      f tview ftview
      loc to fto ord
      (MAP_WF: map_wf f)
      (TVIEW: tview_map f tview ftview)
      (TO: f loc to fto)
      (WRITABLE: TView.writable (TView.cur tview) loc to ord):
  TView.writable (TView.cur ftview) loc fto ord.
Proof.
  inv MAP_WF. inv WRITABLE. econs.
  eapply MAP_LT; try exact TS; eauto. apply TVIEW.
Qed.

Lemma write_tview_map
      f tview ftview
      loc to fto ord
      (MAP_WF: map_wf f)
      (TVIEW: tview_map f tview ftview)
      (TO: f loc to fto):
  tview_map f (TView.write_tview tview loc to ord) (TView.write_tview ftview loc fto ord).
Proof.
  econs; s; i.
  - unfold LocFun.add.
    repeat condtac; try apply TVIEW.
    + apply view_join_map; ss; try apply TVIEW.
      apply singleton_ur_map; ss.
    + apply view_join_map; ss; try apply TVIEW.
      apply singleton_ur_map; ss.
  - apply view_join_map; ss; try apply TVIEW.
    apply singleton_ur_map; ss.
  - apply view_join_map; ss; try apply TVIEW.
    apply singleton_ur_map; ss.
Qed.

Lemma write_released_map
      f tview ftview
      loc to fto releasedm freleasedm ord
      (MAP_WF: map_wf f)
      (TVIEW: tview_map f tview ftview)
      (TO: f loc to fto)
      (RELEASEDM: opt_view_map f releasedm freleasedm):
  opt_view_map f
               (TView.write_released tview loc to releasedm ord)
               (TView.write_released ftview loc fto freleasedm ord).
Proof.
  unfold TView.write_released. condtac; econs.
  apply view_join_map; ss.
  - apply unwrap_map; ss.
  - unfold LocFun.add. condtac; ss.
    condtac; apply view_join_map; ss;
      try apply TVIEW; apply singleton_ur_map; ss.
Qed.

Lemma map_write_step
      f1 lc1 gl1 flc1 fgl1
      loc from to val releasedm released ord lc2 gl2
      freleasedm
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 (Local.reserves lc1) gl1 fgl1)
      (LC_WF1: Local.wf lc1 gl1)
      (GL_WF1: Global.wf gl1)
      (FLC_WF1: Local.wf flc1 fgl1)
      (RELEASEDM_MAP: opt_view_map f1 releasedm freleasedm)
      (FRELEASEDM: View.opt_wf freleasedm)
      (STEP: Local.write_step lc1 gl1 loc from to val releasedm released ord lc2 gl2):
  exists f2 ffrom fto freleased flc2 fgl2,
    (<<FSTEP: Local.write_step flc1 fgl1 loc ffrom fto val freleasedm freleased ord flc2 fgl2>>) /\
    (<<F2: f2 = map_add loc from ffrom (map_add loc to fto f1)>>) /\
    (<<MAP_WF2: map_wf f2>>) /\
    (<<FROM_MAP: f2 loc from ffrom>>) /\
    (<<TO_MAP: f2 loc to fto>>) /\
    (<<RELEASED_MAP: opt_view_map f2 released freleased>>) /\
    (<<LC_MAP2: local_map f2 lc2 flc2>>) /\
    (<<GL_MAP2: global_map f2 (Local.reserves lc2) gl2 fgl2>>).
Proof.
  destruct lc1 as [tview1 prm1 rsv1].
  destruct flc1 as [ftview1 fprm1 frsv1].
  destruct gl1 as [sc1 gprm1 mem1].
  destruct fgl1 as [fsc1 fgprm1 fmem1].
  inv LC_MAP1. inv GL_MAP1. ss.
  inv STEP. ss.
  exploit memory_map_add; try exact MEMORY;
    try apply LC_WF1; try apply GL_WF1; eauto. i. des.
  assert (REL: opt_view_map
                 f2
                 (TView.write_released tview1 loc to releasedm ord)
                 (TView.write_released ftview1 loc fto freleasedm ord)).
  { subst. eapply write_released_map; ss.
    - eapply tview_map_incr; try exact TVIEW.
      i. repeat apply map_add_incr. ss.
    - auto 6.
    - eapply opt_view_map_incr; try exact RELEASEDM_MAP.
      i. repeat apply map_add_incr. ss.
  }
  exploit x0; [|econs; eauto|].
  { econs. eapply TViewFacts.write_future0; ss. apply FLC_WF1. }
  i. des. clear x0. subst.
  esplits; eauto 6.
  - econs; try exact FADD; eauto; s.
    eapply map_writable; try exact WRITABLE; try exact WF2; auto 6.
    eapply tview_map_incr; try exact TVIEW.
    i. repeat apply map_add_incr. ss.
  - econs; ss.
    apply write_tview_map; ss; auto 6.
    eapply tview_map_incr; try apply TVIEW.
    i. repeat apply map_add_incr. ss.
  - econs; ss.
Qed.

Lemma write_fence_tview_map
      f tview ftview sc fsc ord
      (MAP_WF: map_wf f)
      (TVIEW: tview_map f tview ftview)
      (ORD: Ordering.le ord Ordering.acqrel):
  tview_map f (TView.write_fence_tview tview sc ord) (TView.write_fence_tview ftview fsc ord).
Proof.
  econs; ss; i; repeat condtac;
    try apply view_join_map; ss; try apply TVIEW;
    try apply bot_view_map; ss;
    destruct ord; ss.
Qed.

Lemma read_fence_tview_map
      f tview ftview ord
      (MAP_WF: map_wf f)
      (TVIEW: tview_map f tview ftview):
  tview_map f (TView.read_fence_tview tview ord) (TView.read_fence_tview ftview ord).
Proof.
  econs; ss; i; repeat condtac;
    try apply view_join_map; ss; try apply TVIEW;
    try apply bot_view_map; ss.
Qed.

Lemma map_fence_step
      rsv
      f1 lc1 gl1 flc1 fgl1
      ordr ordw lc2 gl2
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (ORD: Ordering.le ordw Ordering.acqrel)
      (STEP: Local.fence_step lc1 gl1 ordr ordw lc2 gl2):
  exists flc2 fgl2,
    (<<FSTEP: Local.fence_step flc1 fgl1 ordr ordw flc2 fgl2>>) /\
    (<<LC_MAP2: local_map f1 lc2 flc2>>) /\
    (<<GL_MAP2: global_map f1 rsv gl2 fgl2>>).
Proof.
  inv STEP.
  esplits.
  - econs; eauto. destruct ordw; ss.
  - econs; try apply LC_MAP1. s.
    apply write_fence_tview_map; ss; try apply GL_MAP1.
    apply read_fence_tview_map; ss. apply LC_MAP1.
  - econs; try apply GL_MAP1.
Qed.

Lemma map_racy_view
      f view fview loc ts fts
      (MAP_WF: map_wf f)
      (VIEW: view_map f view fview)
      (TS: f loc ts fts)
      (RACY: TView.racy_view view loc ts):
  TView.racy_view fview loc fts.
Proof.
  inv MAP_WF. unfold TView.racy_view in *.
  eapply MAP_LT; try exact RACY; eauto.
  apply VIEW.
Qed.

Lemma map_is_racy
      rsv
      f1 lc1 gl1 flc1 fgl1
      loc to ord
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (STEP: Local.is_racy lc1 gl1 loc (Some to) ord):
  exists fto,
    (<<FSTEP: Local.is_racy flc1 fgl1 loc (Some fto) ord>>) /\
    (<<TO: f1 loc to fto>>).
Proof.
  inv LC_MAP1. inv GL_MAP1.
  inv STEP.
  exploit memory_map_get; eauto; ss. i. des. inv MSG0.
  esplits; [econs 2|]; eauto.
  eapply map_racy_view; try apply TVIEW; eauto.
Qed.

Lemma map_racy_read_step
      rsv
      f1 lc1 gl1 flc1 fgl1
      loc to val ord
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (STEP: Local.racy_read_step lc1 gl1 loc (Some to) val ord):
  exists fto,
    (<<FSTEP: Local.racy_read_step flc1 fgl1 loc (Some fto) val ord>>) /\
    (<<TO: f1 loc to fto>>).
Proof.
  inv STEP.
  exploit map_is_racy; eauto. i. des.
  esplits; eauto.
Qed.

Lemma map_racy_write_step
      rsv
      f1 lc1 gl1 flc1 fgl1
      loc to ord
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (STEP: Local.racy_write_step lc1 gl1 loc (Some to) ord):
  exists fto,
    (<<FSTEP: Local.racy_write_step flc1 fgl1 loc (Some fto) ord>>) /\
    (<<TO: f1 loc to fto>>).
Proof.
  inv STEP.
  exploit map_is_racy; eauto. i. des.
  esplits; eauto.
Qed.

Lemma map_racy_update_step
      rsv
      f1 lc1 gl1 flc1 fgl1
      loc to ordr ordw
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (RACE: to = None -> Ordering.le ordr Ordering.na \/ Ordering.le ordw Ordering.na)
      (STEP: Local.racy_update_step lc1 gl1 loc to ordr ordw):
  exists fto,
    (<<FSTEP: Local.racy_update_step flc1 fgl1 loc fto ordr ordw>>) /\
    (<<TO: option_rel (f1 loc) to fto>>).
Proof.
  inv STEP.
  - esplits; eauto. ss.
  - esplits; eauto. ss.
  - destruct to.
    + exploit map_is_racy; eauto. i. des. eauto.
    + exploit RACE; eauto.
      i. des; esplits; eauto; ss.
Qed.

Lemma map_is_racy_promise
      rsv
      f1 lc1 gl1 flc1 fgl1
      loc to ord
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (PRM_MAP1: promises_map lc1 gl1 flc1 fgl1)
      (STEP: Local.is_racy lc1 gl1 loc to ord):
  exists fto,
    (<<FSTEP: Local.is_racy flc1 fgl1 loc fto ord>>) /\
    (<<TO: option_rel (f1 loc) to fto>>).
Proof.
  destruct to.
  { exploit map_is_racy; eauto. i. des. eauto. }
  inv STEP. r in PRM_MAP1.
  eapply equal_f in PRM_MAP1.
  unfold BoolMap.minus in PRM_MAP1.
  rewrite GET, GETP in *. ss.
  destruct (fgl1.(Global.promises) loc) eqn:FGET;
    destruct (flc1.(Local.promises) loc) eqn:FGETP; ss.
  esplits; [econs 1|]; ss.
Qed.

Lemma map_racy_read_step_racy_promise
      rsv
      f1 lc1 gl1 flc1 fgl1
      loc to val ord
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (PRM_MAP1: promises_map lc1 gl1 flc1 fgl1)
      (STEP: Local.racy_read_step lc1 gl1 loc to val ord):
  exists fto,
    (<<FSTEP: Local.racy_read_step flc1 fgl1 loc fto val ord>>) /\
    (<<TO: option_rel (f1 loc) to fto>>).
Proof.
  inv STEP.
  exploit map_is_racy_promise; eauto. i. des.
  esplits; eauto.
Qed.

Lemma map_racy_write_step_racy_promise
      rsv
      f1 lc1 gl1 flc1 fgl1
      loc to ord
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (PRM_MAP1: promises_map lc1 gl1 flc1 fgl1)
      (STEP: Local.racy_write_step lc1 gl1 loc to ord):
  exists fto,
    (<<FSTEP: Local.racy_write_step flc1 fgl1 loc fto ord>>) /\
    (<<TO: option_rel (f1 loc) to fto>>).
Proof.
  inv STEP.
  exploit map_is_racy_promise; eauto. i. des.
  esplits; eauto.
Qed.

Lemma map_racy_update_step_racy_promise
      rsv
      f1 lc1 gl1 flc1 fgl1
      loc to ordr ordw
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 rsv gl1 fgl1)
      (PRM_MAP1: promises_map lc1 gl1 flc1 fgl1)
      (STEP: Local.racy_update_step lc1 gl1 loc to ordr ordw):
  exists fto,
    (<<FSTEP: Local.racy_update_step flc1 fgl1 loc fto ordr ordw>>) /\
    (<<TO: option_rel (f1 loc) to fto>>).
Proof.
  inv STEP.
  - esplits; eauto. ss.
  - esplits; eauto. ss.
  - exploit map_is_racy_promise; eauto. i. des. eauto.
Qed.

Lemma map_internal_step
      f1 lc1 gl1 flc1 fgl1
      e lc2 gl2
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 (Local.reserves lc1) gl1 fgl1)
      (LC_WF1: Local.wf lc1 gl1)
      (GL_WF1: Global.wf gl1)
      (STEP: Local.internal_step e lc1 gl1 lc2 gl2):
  (<<LC_MAP2: local_map f1 lc2 flc1>>) /\
  (<<GL_MAP2: global_map f1 (Local.reserves lc2) gl2 fgl1>>).
Proof.
  inv LC_MAP1. inv GL_MAP1. inv STEP.
  - inv LOCAL. ss.
  - inv LOCAL. ss.
    exploit memory_map_reserve; eauto. i. des.
    esplits; ss.
  - inv LOCAL. ss.
    exploit memory_map_cancel; eauto; try apply LC_WF1; try apply GL_WF1. i. des.
    esplits; ss.
Qed.

Lemma map_program_step
      f1 lc1 gl1 flc1 fgl1
      e lc2 gl2
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 (Local.reserves lc1) gl1 fgl1)
      (LC_WF1: Local.wf lc1 gl1)
      (GL_WF1: Global.wf gl1)
      (FLC_WF1: Local.wf flc1 fgl1)
      (FGL_WF1: Global.wf fgl1)
      (STEP: Local.program_step e lc1 gl1 lc2 gl2)
      (EVENT1: ~ ThreadEvent.is_racy_promise e)
      (EVENT2: ~ ThreadEvent.is_sc e):
  exists f2 fe flc2 fgl2,
    (<<FSTEP: Local.program_step fe flc1 fgl1 flc2 fgl2>>) /\
    (<<EVENT: event_map f2 e fe>>) /\
    (<<MAP_INCR: f1 <3= f2>>) /\
    (<<MAP_WF2: map_wf f2>>) /\
    (<<LC_MAP2: local_map f2 lc2 flc2>>) /\
    (<<GL_MAP2: global_map f2 (Local.reserves lc2) gl2 fgl2>>).
Proof.
  inv STEP.
  - esplits; [econs 1|..]; eauto. econs.
  - exploit map_read_step; eauto. i. des.
    esplits; [econs 2|..]; eauto.
    + econs; ss.
    + inv LOCAL. ss.
  - exploit map_write_step; eauto; try by econs. i. des.
    esplits; [econs 3|..]; try exact MAP_WF2; eauto.
    + econs; ss.
    + i. subst. repeat apply map_add_incr; ss.
  - exploit map_read_step; eauto. i. des.
    exploit Local.read_step_future; try exact LOCAL1; eauto. i. des.
    exploit Local.read_step_future; try exact FSTEP; eauto. i. des.
    exploit map_write_step; try exact LOCAL2; eauto.
    { inv LOCAL1. ss. }
    i. des.
    replace fto with ffrom in *; cycle 1.
    { inv MAP_WF2. eapply MAP_EQ; [refl|exact FROM_MAP|..]. auto. }
    esplits; [econs 4|..]; try exact MAP_WF2; eauto.
    + econs; ss.
      eapply opt_view_map_incr; try exact RELEASED_MAP.
      i. subst. repeat apply map_add_incr; ss.
    + i. subst. repeat apply map_add_incr; ss.
  - exploit map_fence_step; eauto.
    { destruct ordw; ss. }
    i. des.
    esplits; [econs 5|..]; eauto.
    + econs; ss.
    + inv LOCAL. ss.
  - exploit map_fence_step; eauto; ss.
  - esplits; [econs 7|..]; eauto. econs.
  - destruct to; ss.
    exploit map_racy_read_step; eauto. i. des.
    esplits; [econs 8|..]; eauto. econs; ss.
  - destruct to; ss.
    exploit map_racy_write_step; eauto. i. des.
    esplits; [econs 9|..]; eauto. econs; ss.
  - exploit map_racy_update_step; eauto.
    { i. subst. ss.
      apply not_and_or in EVENT1. des.
      - left. destruct ordr; ss.
      - right. destruct ordw; ss.
    }
    i. des.
    esplits; [econs 10|..]; eauto. econs; ss.
Qed.

Lemma map_program_step_racy_promise
      f1 lc1 gl1 flc1 fgl1
      e lc2 gl2
      (MAP_WF1: map_wf f1)
      (LC_MAP1: local_map f1 lc1 flc1)
      (GL_MAP1: global_map f1 (Local.reserves lc1) gl1 fgl1)
      (PRM_MAP1: promises_map lc1 gl1 flc1 fgl1)
      (LC_WF1: Local.wf lc1 gl1)
      (GL_WF1: Global.wf gl1)
      (FLC_WF1: Local.wf flc1 fgl1)
      (FGL_WF1: Global.wf fgl1)
      (STEP: Local.program_step e lc1 gl1 lc2 gl2)
      (EVENT: ~ ThreadEvent.is_sc e):
  exists f2 fe flc2 fgl2,
    (<<FSTEP: Local.program_step fe flc1 fgl1 flc2 fgl2>>) /\
    (<<EVENT: event_map f2 e fe>>) /\
    (<<MAP_INCR: f1 <3= f2>>) /\
    (<<MAP_WF2: map_wf f2>>) /\
    (<<LC_MAP2: local_map f2 lc2 flc2>>) /\
    (<<GL_MAP2: global_map f2 (Local.reserves lc2) gl2 fgl2>>).
Proof.
  destruct (classic (ThreadEvent.is_racy_promise e));
    eauto using map_program_step.
  inv STEP; ss.
  - exploit map_racy_read_step_racy_promise; eauto. i. des.
    esplits; [econs 8|..]; eauto. econs; ss.
  - exploit map_racy_write_step_racy_promise; eauto. i. des.
    esplits; [econs 9|..]; eauto. econs; ss.
  - exploit map_racy_update_step_racy_promise; eauto. i. des.
    esplits; [econs 10|..]; eauto. econs; ss.
Qed.

Lemma event_map_program_event
  f e fe
  (MAP: event_map f e fe):
  ThreadEvent.get_program_event e = ThreadEvent.get_program_event fe.
Proof.
  inv MAP; ss.
Qed.

Lemma event_map_machine_event
  f e fe
  (MAP: event_map f e fe):
  ThreadEvent.get_machine_event e = ThreadEvent.get_machine_event fe.
Proof.
  inv MAP; ss.
Qed.

Lemma event_map_is_program
  f e fe
  (MAP: event_map f e fe):
  ThreadEvent.is_program e <-> ThreadEvent.is_program fe.
Proof.
  inv MAP; ss.
Qed.

Lemma event_map_is_racy_promise
  f e fe
  (MAP: event_map f e fe):
  ThreadEvent.is_racy_promise e <-> ThreadEvent.is_racy_promise fe.
Proof.
  inv MAP; ss; destruct to, fto; ss.
Qed.

Lemma event_map_strict_pf
  f e fe
  (MAP: event_map f e fe):
  strict_pf e <-> strict_pf fe.
Proof.
  inv MAP; ss; destruct to, fto; ss.
Qed.

Lemma event_map_non_sc
  f e fe
  (MAP: event_map f e fe):
  non_sc e <-> non_sc fe.
Proof.
  inv MAP; ss.
Qed.

Lemma event_map_is_writing
      f e fe
      loc from to val released ord
      (MAP: event_map f e fe)
      (WRITING: ThreadEvent.is_writing e = Some (loc, from, to, val, released, ord)):
  exists ffrom fto freleased,
    (<<FWRITING: ThreadEvent.is_writing fe = Some (loc, ffrom, fto, val, freleased, ord)>>) /\
    (<<FROM: f loc from ffrom>>) /\
    (<<TO: f loc to fto>>) /\
    (<<RELEASED: opt_view_map f released freleased>>).
Proof.
  inv MAP; ss; inv WRITING; esplits; eauto.
Qed.

Lemma closed_timemap_map
      (f: map_t) mem tm
      (MAP: forall loc from to val released na
                   (GET: Memory.get loc to mem = Some (from, Message.message val released na)),
          f loc to to)
      (CLOSED: Memory.closed_timemap tm mem):
  timemap_map f tm tm.
Proof.
  ii. specialize (CLOSED loc). des. eauto.
Qed.

Lemma closed_view_map
      (f: map_t) mem view
      (MAP: forall loc from to val released na
                   (GET: Memory.get loc to mem = Some (from, Message.message val released na)),
          f loc to to)
      (CLOSED: Memory.closed_view view mem):
  view_map f view view.
Proof.
  inv CLOSED.
  econs; eauto using closed_timemap_map.
Qed.

Lemma closed_opt_view_map
      (f: map_t) mem view
      (MAP: forall loc from to val released na
                   (GET: Memory.get loc to mem = Some (from, Message.message val released na)),
          f loc to to)
      (CLOSED: Memory.closed_opt_view view mem):
  opt_view_map f view view.
Proof.
  inv CLOSED; econs.
  eauto using closed_view_map.
Qed.

Lemma closed_message_map
      (f: map_t) mem msg
      (MAP: forall loc from to val released na
                   (GET: Memory.get loc to mem = Some (from, Message.message val released na)),
          f loc to to)
      (CLOSED: Memory.closed_message msg mem):
  message_map f msg msg.
Proof.
  inv CLOSED; econs.
  eauto using closed_opt_view_map.
Qed.

Lemma closed_tview_map
      (f: map_t) mem tview
      (MAP: forall loc from to val released na
                   (GET: Memory.get loc to mem = Some (from, Message.message val released na)),
          f loc to to)
      (CLOSED: TView.closed tview mem):
  tview_map f tview tview.
Proof.
  inv CLOSED.
  econs; eauto using closed_view_map.
Qed.

Section ThreadMap.
  Variable lang: language.

  Variant thread_map (f: map_t) (th fth: Thread.t lang): Prop :=
    | thread_map_intro
        (STATE: Thread.state th = Thread.state fth)
        (LOCAL: local_map f (Thread.local th) (Thread.local fth))
        (GLOBAL: global_map f (Local.reserves (Thread.local th))
                            (Thread.global th) (Thread.global fth))
  .

  Lemma map_step
        f1 th1 fth1
        e th2
        (MAP_WF1: map_wf f1)
        (MAP1: thread_map f1 th1 fth1)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1))
        (FLC_WF1: Local.wf (Thread.local fth1) (Thread.global fth1))
        (FGL_WF1: Global.wf (Thread.global fth1))
        (STEP: Thread.step e th1 th2)
        (EVENT1: ~ ThreadEvent.is_racy_promise e)
        (EVENT2: ~ ThreadEvent.is_sc e):
    exists f2 fe fth2,
      (<<FSTEP: Thread.opt_step fe fth1 fth2>>) /\
      (<<EVENT: __guard__ (ThreadEvent.is_internal e /\ fe = ThreadEvent.silent \/
                           ThreadEvent.is_program e /\ event_map f2 e fe)>>) /\
      (<<MAP_INCR: f1 <3= f2>>) /\
      (<<MAP_WF2: map_wf f2>>) /\
      (<<MAP2: thread_map f2 th2 fth2>>).
  Proof.
    destruct th1, fth1. inv MAP1. ss. subst.
    inv STEP.
    - exploit map_internal_step; try exact LOCAL; try exact GLOBAL; eauto. i. des.
      esplits; eauto.
      + left. split; ss. inv LOCAL0; ss.
      + ss.
    - exploit map_program_step; try exact LOCAL; try exact GLOBAL; eauto. i. des.
      esplits.
      + econs 2. econs 2; [|eauto].
        erewrite <- event_map_program_event; eauto.
      + right. split; eauto. inv LOCAL0; ss.
      + ss.
      + ss.
      + econs; ss.
  Qed.

  Lemma map_rtc_step
        f1 th1 fth1
        th2
        (MAP_WF1: map_wf f1)
        (MAP1: thread_map f1 th1 fth1)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1))
        (FLC_WF1: Local.wf (Thread.local fth1) (Thread.global fth1))
        (FGL_WF1: Global.wf (Thread.global fth1))
        (STEPS: rtc (pstep (@Thread.step _) (strict_pf /1\ non_sc)) th1 th2):
    exists f2 fth2,
      (<<FSTEPS: rtc (pstep (@Thread.step _) (fully_pf /1\ non_sc)) fth1 fth2>>) /\
      (<<MAP_INCR: f1 <3= f2>>) /\
      (<<MAP_WF2: map_wf f2>>) /\
      (<<MAP2: thread_map f2 th2 fth2>>).
  Proof.
    revert f1 fth1 MAP_WF1 MAP1 FLC_WF1 FGL_WF1.
    induction STEPS; i.
    { esplits; eauto. }
    inv H. des.
    exploit map_step; eauto; try apply EVENT; try apply EVENT0. i. des.
    exploit Thread.step_future; try exact STEP; eauto. i. des.
    exploit Thread.opt_step_future; try exact FSTEP; eauto. i. des.
    exploit IHSTEPS; eauto. i. des.
    esplits; try exact MAP0; eauto.
    inv FSTEP; eauto.
    econs 2; try exact FSTEPS. econs; eauto.
    inv EVENT1; des.
    - subst. repeat (split; ss).
    - split.
      + split.
        * erewrite <- event_map_is_program; eauto.
        * erewrite <- event_map_is_racy_promise; eauto. apply EVENT.
      + erewrite <- event_map_non_sc; eauto.
  Qed.

  Lemma map_certify
        f th fth loc
        (MAP_WF: map_wf f)
        (MAP: thread_map f th fth)
        (LC_WF: Local.wf (Thread.local th) (Thread.global th))
        (GL_WF: Global.wf (Thread.global th))
        (FLC_WF: Local.wf (Thread.local fth) (Thread.global fth))
        (FGL_WF: Global.wf (Thread.global fth))
        (CERTIFY: certify loc th):
    pf_certify loc fth.
  Proof.
    inv CERTIFY.
    { exploit map_rtc_step; try exact STEPS; eauto. i. des.
      exploit Thread.rtc_all_step_future; try eapply rtc_implies; try exact STEPS; eauto.
      { i. inv H. econs. eauto. }
      i. des.
      exploit Thread.rtc_all_step_future; try eapply rtc_implies; try exact FSTEPS; eauto.
      { i. inv H. econs. eauto. }
      i. des.
      exploit map_step; try exact STEP_FAILURE; try exact MAP2; eauto.
      { apply EVENT_PF. }
      { destruct e; ss. }
      i. des.
      unguardH EVENT. des.
      { subst. destruct e; ss. }
      inv FSTEP; try by (inv EVENT0; ss).
      econs 1; try exact STEP; eauto.
      - erewrite <- event_map_machine_event; eauto.
      - erewrite <- event_map_is_racy_promise; eauto. apply EVENT_PF.
    }
    { exploit map_rtc_step; try exact STEPS; eauto. i. des.
      destruct th1, fth2. inv MAP2. ss. subst.
      inv STEP_FULFILL; try by (inv LOCAL0; ss).
      exploit Thread.rtc_all_step_future; try eapply rtc_implies; try exact FSTEPS; eauto.
      { i. inv H. econs. eauto. }
      s. i. des.
      exploit Local.write_max_exists; try exact LC_WF2; try by econs 2. s. i. des.
      econs 2; try exact FSTEPS.
      - econs 2; [|econs 3; eauto]. eauto.
      - ss.
      - inv WRITE. ss.
        exploit Memory.add_ts; try exact WRITE0. i.
        etrans; eauto.
      - ss.
    }
  Qed.

  (* race with promises *)

  Variant thread_map_racy_promise (f: map_t) (th fth: Thread.t lang): Prop :=
    | thread_map_racy_promise_intro
        (STATE: Thread.state th = Thread.state fth)
        (LOCAL: local_map f (Thread.local th) (Thread.local fth))
        (GLOBAL: global_map f (Local.reserves (Thread.local th))
                            (Thread.global th) (Thread.global fth))
        (PROMISES: promises_map (Thread.local th) (Thread.global th)
                                (Thread.local fth) (Thread.global fth))
  .

  Lemma map_step_racy_promise
        f1 th1 fth1
        e th2
        (MAP_WF1: map_wf f1)
        (MAP1: thread_map_racy_promise f1 th1 fth1)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1))
        (FLC_WF1: Local.wf (Thread.local fth1) (Thread.global fth1))
        (FGL_WF1: Global.wf (Thread.global fth1))
        (STEP: Thread.step e th1 th2)
        (EVENT: ~ ThreadEvent.is_sc e):
    exists f2 fe fth2,
      (<<FSTEP: Thread.opt_step fe fth1 fth2>>) /\
      (<<EVENT: __guard__ (ThreadEvent.is_internal e /\ fe = ThreadEvent.silent \/
                           ThreadEvent.is_program e /\ event_map f2 e fe)>>) /\
      (<<MAP_INCR: f1 <3= f2>>) /\
      (<<MAP_WF2: map_wf f2>>) /\
      (<<MAP2: thread_map_racy_promise f2 th2 fth2>>).
  Proof.
    destruct th1, fth1. inv MAP1. ss. subst.
    inv STEP.
    - exploit map_internal_step; try exact LOCAL; try exact GLOBAL; eauto. i. des.
      esplits; eauto.
      + left. split; ss. inv LOCAL0; ss.
      + econs; ss. unfold promises_map in *.
        exploit Local.internal_step_promises_minus; eauto. i. congr.
    - exploit map_program_step_racy_promise; try exact LOCAL; try exact GLOBAL; eauto. i. des.
      esplits.
      + econs 2. econs 2; [|eauto].
        erewrite <- event_map_program_event; eauto.
      + right. split; eauto. inv LOCAL0; ss.
      + ss.
      + ss.
      + econs; ss. unfold promises_map in *.
        exploit Local.program_step_promises_minus; try exact LOCAL0. i.
        exploit Local.program_step_promises_minus; try exact FSTEP. i.
        congr.
  Qed.

  Lemma map_rtc_step_racy_promise
        f1 th1 fth1
        th2
        (MAP_WF1: map_wf f1)
        (MAP1: thread_map_racy_promise f1 th1 fth1)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1))
        (FLC_WF1: Local.wf (Thread.local fth1) (Thread.global fth1))
        (FGL_WF1: Global.wf (Thread.global fth1))
        (STEPS: rtc (pstep (@Thread.step _) (ThreadEvent.is_pf /1\ non_sc)) th1 th2):
    exists f2 fth2,
      (<<FSTEPS: rtc (pstep (@Thread.step _) (ThreadEvent.is_program /1\ non_sc)) fth1 fth2>>) /\
      (<<MAP_INCR: f1 <3= f2>>) /\
      (<<MAP_WF2: map_wf f2>>) /\
      (<<MAP2: thread_map_racy_promise f2 th2 fth2>>).
  Proof.
    revert f1 fth1 MAP_WF1 MAP1 FLC_WF1 FGL_WF1.
    induction STEPS; i.
    { esplits; eauto. }
    inv H. des.
    exploit map_step_racy_promise; eauto; try apply EVENT; try apply EVENT0. i. des.
    exploit Thread.step_future; try exact STEP; eauto. i. des.
    exploit Thread.opt_step_future; try exact FSTEP; eauto. i. des.
    exploit IHSTEPS; eauto. i. des.
    esplits; try exact MAP0; eauto.
    inv FSTEP; eauto.
    econs 2; try exact FSTEPS. econs; eauto.
    inv EVENT1; des.
    - subst. repeat (split; ss).
    - split.
      + erewrite <- event_map_is_program; eauto.
      + erewrite <- event_map_non_sc; eauto.
  Qed.

  Lemma map_certify_racy_promise
        f th fth loc
        (MAP_WF: map_wf f)
        (MAP: thread_map_racy_promise f th fth)
        (LC_WF: Local.wf (Thread.local th) (Thread.global th))
        (GL_WF: Global.wf (Thread.global th))
        (FLC_WF: Local.wf (Thread.local fth) (Thread.global fth))
        (FGL_WF: Global.wf (Thread.global fth))
        (CERTIFY: certify_racy_promise loc th):
    pf_certify_racy_promise loc fth.
  Proof.
    inv CERTIFY.
    { exploit map_rtc_step_racy_promise; try exact STEPS; eauto. i. des.
      exploit Thread.rtc_all_step_future; try eapply rtc_implies; try exact STEPS; eauto.
      { i. inv H. econs. eauto. }
      i. des.
      exploit Thread.rtc_all_step_future; try eapply rtc_implies; try exact FSTEPS; eauto.
      { i. inv H. econs. eauto. }
      i. des.
      exploit map_step_racy_promise; try exact STEP_FAILURE; try exact MAP2; eauto.
      { destruct e; ss. }
      i. des.
      unguardH EVENT. des.
      { subst. destruct e; ss. }
      inv FSTEP; try by (inv EVENT0; ss).
      econs 1; try exact STEP; eauto.
      erewrite <- event_map_machine_event; eauto.
    }
    { exploit map_rtc_step_racy_promise; try exact STEPS; eauto. i. des.
      destruct th1, fth2. inv MAP2. ss. subst.
      inv STEP_FULFILL; try by (inv LOCAL0; ss).
      exploit Thread.rtc_all_step_future; try eapply rtc_implies; try exact FSTEPS; eauto.
      { i. inv H. econs. eauto. }
      s. i. des.
      exploit Local.write_max_exists; try exact LC_WF2; try by econs 2. s. i. des.
      econs 2; try exact FSTEPS.
      - econs 2; [|econs 3; eauto]. eauto.
      - ss.
      - inv WRITE. ss.
        exploit Memory.add_ts; try exact WRITE0. i.
        etrans; eauto.
      - ss.
    }
  Qed.
End ThreadMap.


Require Import Relations.
Require Import List.
Require Import Utils.
Require Import Semantics.
Require TINI.

(** Generic notion of refinement between two semantics *)

Set Implicit Arguments.
Hint Constructors TINI.exec : core.

(** * Definition of refinement *)
Section Refinement.

Variable S1 : semantics.
Let trace1 := list (event S1).

Variable S2 : semantics.
Let trace2 := list (event S2).

Inductive match_traces (match_events : event S1 -> event S2 -> Prop)
  : trace1 -> trace2 -> Prop :=
| mt_nil : match_traces match_events nil nil
| mt_cons : forall e1 t1 e2 t2,
              match_events e1 e2 ->
              match_traces match_events t1 t2 ->
              match_traces match_events (e1 :: t1) (e2 :: t2).
Hint Constructors match_traces : core.

Lemma match_traces_no_filter:
  forall (match_events: event S1 -> event S2 -> Prop) tr1 tr2,
    match_traces match_events tr1 tr2 ->
      length tr1 = length tr2.
Proof.
  intros hme tr1 tr2 hmt.
  induction hmt; auto. simpl. rewrite IHhmt. auto.
Qed.

Definition refinement_statement match_init_data
                                match_events :=
  forall i1 i2 t2 s2,
    match_init_data i1 i2 ->
    @TINI.exec S2 (init_state S2 i2) t2 s2 ->
    exists t1 s1,
      @TINI.exec S1 (init_state S1 i1) t1 s1 /\
      match_traces match_events t1 t2.

Record refinement := {
  ref_match_init_data : init_data S1 -> init_data S2 -> Prop;
  ref_match_events : event S1 -> event S2 -> Prop;
  ref_prop : refinement_statement ref_match_init_data
                                  ref_match_events
}.

Definition state_refinement_statement match_states
                                      match_events :=
  forall s1 s2 t2 s2',
    match_states s1 s2 ->
    @TINI.exec S2 s2 t2 s2' ->
    exists t1 s1',
      @TINI.exec S1 s1 t1 s1' /\
      match_traces match_events t1 t2.

Record state_refinement := {
  sref_match_states : state S1 -> state S2 -> Prop;
  sref_match_events : event S1 -> event S2 -> Prop;
  sref_prop : state_refinement_statement sref_match_states
                                         sref_match_events
}.

(** * Refinement from state *)
Section RefinementFromStateRefinement.

Variable SR : state_refinement.

Variable match_init_data : init_data S1 -> init_data S2 -> Prop.

Hypothesis match_init_data_match_states :
  forall i1 i2,
    match_init_data i1 i2 ->
    sref_match_states SR (init_state _ i1) (init_state _ i2).

Lemma refinement_from_state_refinement_prop :
  refinement_statement match_init_data
                       (sref_match_events SR).
Proof.
  unfold refinement_statement. eauto using (sref_prop SR).
Qed.

Definition refinement_from_state_refinement : refinement :=
  {| ref_match_init_data := match_init_data
   ; ref_match_events := sref_match_events SR
   ; ref_prop := refinement_from_state_refinement_prop |}.

End RefinementFromStateRefinement.

(** * Refinement preserves [tini] *)

Section NI.

Context {O1 : TINI.Observation S1}
        {O2 : TINI.Observation S2}.

Variable R : refinement.

Hypothesis noninterference1 : TINI.tini O1.

Let low_compatible o1 o2 :=
  forall e1 e2,
    ref_match_events R e1 e2 ->
    (TINI.e_low o1 e1 <-> TINI.e_low o2 e2).

Let i_equiv1_i_equiv2 o1 o2 :=
  forall i21 i22,
    TINI.i_equiv o2 i21 i22 ->
    exists i11 i12,
      TINI.i_equiv o1 i11 i12 /\
      ref_match_init_data R i11 i21 /\
      ref_match_init_data R i12 i22.

Let a_equiv1_a_equiv2 o1 o2 :=
  forall e11 e12 e21 e22,
    TINI.a_equiv _ o1 (E e11) (E e12) ->
    ref_match_events R e11 e21 ->
    ref_match_events R e12 e22 ->
    TINI.a_equiv _ o2 (E e21) (E e22).

Lemma match_traces_match_observations :
  forall o1 o2 t1 t2
         (COMP : low_compatible o1 o2)
         (TRACES : match_traces (ref_match_events R) t1 t2),
    match_traces (ref_match_events R)
                 (TINI.observe O1 o1 t1) (TINI.observe O2 o2 t2).
Proof.
  intros.
  induction TRACES; simpl; auto.
  exploit COMP; eauto. intros [COMP1 COMP2].
  destruct (TINI.e_low_dec o1 e1) as [E1 | E1];
  destruct (TINI.e_low_dec o2 e2) as [E2 | E2];
  intuition.
Qed.

Definition tini_preservation_hypothesis :=
  forall o2, exists o1,
    low_compatible o1 o2 /\
    i_equiv1_i_equiv2 o1 o2 /\
    a_equiv1_a_equiv2 o1 o2.

Hypothesis compatibility : tini_preservation_hypothesis.

Theorem refinement_preserves_noninterference : TINI.tini O2.
Proof.
  intros o2 i21 t21 s21' i22 t22 s22' Heq2 Hexec21 Hexec22.
  destruct (compatibility o2) as [o1 [H1 [H2 H3]]].
  assert (H := H2 _ _ Heq2).
  destruct H as [i11 [i12 [Heq1 [Hm1 Hm2]]]].
  assert (H := ref_prop R _ _ Hm1 Hexec21).
  destruct H as [t11 [s11' [Hexec11 Hmt1]]].
  assert (H := ref_prop R _ _ Hm2 Hexec22).
  destruct H as [t12 [s12' [Hexec12 Hmt2]]].
  assert (Hindist := noninterference1 _ _ _ Heq1 Hexec11 Hexec12).
  generalize (match_traces_match_observations H1 Hmt1). clear Hmt1. intros Hmt1.
  generalize (match_traces_match_observations H1 Hmt2). clear Hmt2. intros Hmt2.
  generalize (TINI.observe_forall _ o2 t22). intros.
  generalize (TINI.observe_forall _ o2 t21). intros.
  gdep (TINI.observe O2 o2 t22). gdep (TINI.observe O2 o2 t21).
  gdep (TINI.observe O1 o1 t12). gdep (TINI.observe O1 o1 t11).
  clear - H3.

  intros t11 t12 Hindist.
  induction Hindist as [| |e1 t11' t12'];
  intros t21 Hmt1 Ht21 t22 Hmt2 Ht22;
  inv Hmt1; inv Hmt2; try constructor; eauto.
  match goal with
    | |- TINI.ti_trace_indist (?E1 :: _) (?E2 :: _) =>
      assert (Heq : TINI.a_equiv _ o2 (E E1) (E E2))
        by (eapply H3; eauto; try reflexivity)
  end.
  inv Ht21. inv Ht22. inv Heq; intuition.
  constructor. auto.
Qed.

End NI.

(** A proof technique for proving refinement : lockstep simulation *)
Section Strong.

Variable match_events : event S1 -> event S2 -> Prop.
Variable match_states : state S1 -> state S2 -> Prop.

Inductive match_actions : (event S1)+τ -> (event S2)+τ -> Prop :=
| match_actions_silent : match_actions Silent Silent
| match_actions_event : forall e1 e2,
  match_events e1 e2 -> match_actions (E e1) (E e2).

(* To be used in the abstract <-> quasi-abtract layer *)
Hypothesis lockstep : forall s11 s21 a2 s22,
                        match_states s11 s21 ->
                        step S2 s21 a2 s22 ->
                        exists a1 s12,
                          step S1 s11 a1 s12 /\ match_actions a1 a2 /\ match_states s12 s22.

Theorem strong_refinement_prop :
  state_refinement_statement match_states
                             match_events.
Proof.
  intros s11 s21 t2 s22 Hmt Hexec2.
  gdep s11.
  induction Hexec2; intros s11 Hmt.
  - repeat eexists; eauto.
  - match goal with
      | H1 : match_states _ _,
        H2 : step _ _ _ _ |- _ =>
        exploit lockstep; eauto;
        intros Hlock;
        destruct Hlock as [? [? [? [? ?]]]]
    end.
    match goal with
      | H : match_states _ _ |- _ =>
        apply IHHexec2 in H;
        destruct H as [? [? [? ?]]]
    end.
    inv H1.
    match goal with
      | H1 : step S1 _ (E ?e1) _,
        H2 : @TINI.exec S1 _ ?t1 ?s12 |- _ =>
        exists (e1 :: t1)
    end.
    eauto.
  -  exploit lockstep; eauto.
     intros (a1 & s12 & T1 & T2 & T3).
     apply IHHexec2 in T3.
     destruct T3 as (t1 & s1' & V1 & V2).
     inv T2; eauto.
Qed.

Definition strong_refinement : state_refinement :=
  {| sref_prop := strong_refinement_prop |}.

End Strong.

End Refinement.

(** * Composition of refinements *)
Section Composition.

Variable S1 : semantics.
Variable S2 : semantics.
Variable S3 : semantics.

Variable R12 : refinement S1 S2.
Variable R23 : refinement S2 S3.

Variable match_init_data : init_data S1 -> init_data S3 -> Prop.
Variable match_events : event S1 -> event S3 -> Prop.

Hypothesis mid13 : forall s1 s3,
                     match_init_data s1 s3 ->
                     exists s2,
                       ref_match_init_data R12 s1 s2 /\
                       ref_match_init_data R23 s2 s3.
Hypothesis me13 : forall e1 e2 e3,
                    ref_match_events R12 e1 e2 ->
                    ref_match_events R23 e2 e3 ->
                    match_events e1 e3.

Lemma match_events_composition : forall t1 t2 t3,
                                   match_traces S1 S2
                                                (ref_match_events R12) t1 t2 ->
                                   match_traces S2 S3
                                                (ref_match_events R23) t2 t3 ->
                                   match_traces S1 S3 match_events t1 t3.
Proof.
  intros t1 t2 t3 H12.
  gdep t3.
  induction H12; intros t3 H23; inv H23; econstructor; eauto.
Qed.

Lemma ref_composition_prop : refinement_statement S1 S3 match_init_data match_events.
Proof.
  intros s11 s31 t3 s32 H13 Hexec3.
  exploit mid13; eauto.
  intros [s2 [H12 H23]].
  exploit (ref_prop R23); eauto.
  intros [? [? [? ?]]].
  exploit (ref_prop R12); eauto.
  intros H'.
  destruct H' as [? [? [? ?]]].
  eauto using match_events_composition.
Qed.

Definition ref_composition :=
  {| ref_prop := ref_composition_prop |}.

End Composition.


(******************************************************************************)
(** * Definition of execution graph events *)
(******************************************************************************)
Require Import Lia.
Require Import FinFun.
Require Import List.
From hahn Require Import Hahn.
Require Import AuxRel.
Require Import basic.Labels.

Set Implicit Arguments.

Definition Tid := nat.

Section Events.

(******************************************************************************)
(** ** Execution graph events  *)
(******************************************************************************)

Inductive Event :=
  | InitEvent (x : Labels.Loc)
  | ThreadEvent (thread : Tid) (index : nat) (l : Lab).

Definition is_init a :=
  match a with
    | InitEvent _ => True
    | _ => False
  end.

Definition tid a :=
  match a with
    | InitEvent _ => 0
    | ThreadEvent i _ _ => i
  end.

Definition index a :=
  match a with
    | InitEvent _ => 0
    | ThreadEvent _ n _ => n
  end.

Definition lab a :=
  match a with
    | InitEvent x => (Astore x 0)
    | ThreadEvent _ _ l => l
  end.

Definition loc a := loc_l (lab a).
Definition valr a := valr_l (lab a).
Definition valw a := valw_l (lab a).
Definition is_r a := is_r_l (lab a).
Definition is_w a := is_w_l (lab a).
Definition is_rmw a := is_rmw_l (lab a).

Lemma r_or_w a : is_r a \/ is_w a.
Proof using.
  unfold is_r, is_w. destruct (lab a); ins; auto.
Qed.

(******************************************************************************)
(** ** is_init properties *)
(******************************************************************************)
Lemma is_init_InitEvent x :
  is_init (InitEvent x).
Proof using.
  done.
Qed.

(******************************************************************************)
(** ** Same tid restriction *)
(******************************************************************************)

Definition is_tid i a : Prop := tid a = i.

Definition same_tid := (fun x y => tid x = tid y).

Lemma restr_eq_rel_same_tid r :  restr_eq_rel tid r  ≡ r ∩ same_tid.
Proof using. unfold same_tid; basic_solver. Qed.

Lemma funeq_same_tid (r: relation Event) (H: funeq tid r):
 r ⊆ r ∩ same_tid.
Proof using.
unfold same_tid; basic_solver.
Qed.

Lemma same_tid_funeq (r: relation Event) (H: r ⊆ r ∩ same_tid):
 funeq tid r.
Proof using.
unfold same_tid; unfolder; firstorder.
Qed.

(******************************************************************************)
(** ** Same location restriction *)
(******************************************************************************)

Definition is_loc x a : Prop := loc a = x.

Definition same_loc := (fun x y => loc x = loc y).

Lemma restr_eq_rel_same_loc r :  restr_eq_rel loc r  ≡ r ∩ same_loc.
Proof using. unfold same_loc; basic_solver. Qed.

Lemma funeq_same_loc (r: relation Event) (H: funeq loc r):
 r ⊆ r ∩ same_loc.
Proof using.
unfold same_loc; basic_solver.
Qed.

Lemma same_loc_funeq (r: relation Event) (H: r ⊆ r ∩ same_loc):
 funeq loc r.
Proof using.
unfold same_loc; unfolder; firstorder.
Qed.

Lemma same_loc_trans : transitive same_loc.
Proof using. unfold same_loc; red; ins. by rewrite H. Qed.

Lemma same_loc_sym : symmetric same_loc.
Proof using. unfold same_loc; red; ins. Qed.

(******************************************************************************)
(** ** Values and locations getters  *)
(******************************************************************************)

Lemma exists_valw a : exists vw, valw a = vw.
Proof using. unfold valw; desc; eexists; eauto. Qed.

Lemma exists_valr a : exists vw, valr a = vw.
Proof using. unfold valr; desc; eexists; eauto. Qed.

Lemma exists_loc a : exists x, loc a = x.
Proof using. unfold loc; desc; eexists; eauto. Qed.

(******************************************************************************)
(** ** Sequenced-Before *)
(******************************************************************************)

Definition same_index := (fun x y => index x = index y).

Definition ext_sb a b :=
  match a, b with
    | _, InitEvent _ => False
    | InitEvent _, ThreadEvent _ _ _ => True
    | ThreadEvent t i _, ThreadEvent t' i' _ => t = t' /\ i < i'
   end.

Lemma ext_sb_trans : transitive ext_sb.
Proof using.
unfold ext_sb; red; ins.
destruct x,y,z; ins; desf; splits; eauto.
by rewrite H2.
Qed.

Lemma ext_sb_irr : irreflexive ext_sb.
Proof using.
unfold ext_sb; red; ins.
destruct x; firstorder; lia.
Qed.

Lemma ext_sb_to_non_init : ext_sb ⊆ ext_sb ⨾  ⦗fun x => ~ is_init x⦘.
Proof using.
unfold is_init, ext_sb; basic_solver.
Qed.

Lemma ext_sb_semi_total_l x y z
  (N: ~ is_init x) (NEQ: index y <> index z) (XY: ext_sb x y) (XZ: ext_sb x z):
  ext_sb y z \/ ext_sb z y.
Proof using.
unfold ext_sb in *.
destruct x,y,z; ins; desf.
cut(index1 < index2 \/ index2 < index1).
tauto.
lia.
Qed.

Lemma ext_sb_semi_total_r x y z
  (NEQ: index y <> index z) (XY: ext_sb y x) (XZ: ext_sb z x):
  ext_sb y z \/ ext_sb z y.
Proof using.
unfold ext_sb in *.
destruct x,y,z; ins; desf; eauto.
cut(index1 < index2 \/ index2 < index1).
tauto.
lia.
Qed.

Lemma ext_sb_tid_init x y (SB : ext_sb x y): tid x = tid y \/ is_init x.
Proof using.
unfold ext_sb in *; desf; ins; desf; eauto.
Qed.

Lemma ext_sb_tid_init': ext_sb ⊆ ext_sb ∩ same_tid ∪ ⦗is_init⦘ ⨾ ext_sb.
Proof using.
generalize ext_sb_tid_init; firstorder.
Qed.

Lemma tid_ext_sb: same_tid ⊆ same_tid ∩ same_index ∪ ext_sb ∪ ext_sb⁻¹ ∪ (is_init × is_init).
Proof using.
  unfold ext_sb, same_tid, same_index, tid, is_init, cross_rel; unfolder.
  ins; destruct x, y; desf; eauto.
  cut (index0 < index1 \/ index1 < index0 \/ index0 = index1).
  ins; desf; eauto 10.
  lia.
Qed.

Lemma tid_n_init_ext_sb: same_tid ⨾ ⦗set_compl is_init⦘ ⊆ same_index ∪ ext_sb ∪ ext_sb⁻¹.
Proof using.
  rewrite tid_ext_sb at 1.
  unfold cross_rel.
  basic_solver 12.
Qed.

End Events.

(******************************************************************************)
(** ** Tactics *)
(******************************************************************************)

#[global]
Hint Unfold set_union set_inter is_r is_w is_rmw : type_unfolderDb.
#[global]
Hint Unfold is_r_l is_w_l is_rmw_l : type_unfolderDb.
Tactic Notation "type_unfolder" :=  repeat autounfold with type_unfolderDb in *.

Tactic Notation "type_solver" int_or_var(index) :=
  type_unfolder; basic_solver index.

Tactic Notation "type_solver" :=  type_solver 4.


Set Implicit Arguments.
Require Import VST.msl.Axioms.
Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import sha.general_lemmas.
Require Import sha.ByteBitRelations.
Require Import sha.HMAC_common_defs.
Require Import sha.HMAC_spec_pad.

(*The sha-specific imports*)
Require Import sha.SHA256.
Require Import sha.HMAC_functional_prog.
Require Import sha.HMAC256_functional_prog.
Require Import sha.hmac_common_lemmas.
Require Import sha.sha_padding_lemmas. (*for pad_len_64_nat*)
Require Import sha.ShaInstantiation.

(*Derived lemmas
Lemma front_equiv_SHA256 :
  forall (back : Blist) (BACK : list int) (front : Blist) (FRONT : list int),
    (length front)%nat = 512%nat ->
    (length FRONT)%nat = 16%nat ->
    front ++ back = convert (FRONT ++ BACK) ->
    front = convert FRONT.
Proof. intros. eapply front_equiv; try eassumption. omega. Qed.

Lemma back_equiv_SHA256 :
  forall (back : Blist) (BACK : list int) (front : Blist) (FRONT : list int),
    (length front)%nat = 512%nat ->
    (length FRONT)%nat = 16%nat ->
    front ++ back = convert (FRONT ++ BACK) ->
    back = convert BACK.
Proof. intros. eapply back_equiv; try eassumption. omega. Qed.
*)

(*Lemma fold_equiv_blocks_SHA256 :
  forall (l : Blist) (acc : Blist)
         (L : list int) (ACC : list int),
      InBlocks ShaInstantiation.b l ->
      InBlocks 16 L ->
      l = convert L ->
      acc = convert ACC ->
      hash_blocks_bits _ ShaInstantiation.B sha_h acc l = convert (hash_blocks ACC L).
Proof. intros. eapply fold_equiv_blocks.
  3: apply SHA256.hash_blocks_equation.
  reflexivity. reflexivity. trivial. trivial. trivial. trivial.
Qed.
*)
Lemma splitandpad_equiv : forall (bits : Blist) (bytes : list byte),
                            bytes_bits_lists bits bytes ->
                            bytes_bits_lists
                              (sha_splitandpad bits)
                              (pad bytes).
Proof.
  intros bits bytes inputs_eq.
  unfold concat.
  unfold sha_splitandpad.

  apply bytes_bits_ind_comp in inputs_eq.
  rewrite inputs_eq.
  apply bytes_bits_def_eq.
Qed.

Lemma gap_divide16 bits: NPeano.Nat.divide 16 (length (generate_and_pad' (bitsToBytes bits))).
Proof.
    unfold generate_and_pad'.
    destruct (pad_len_64_nat (bitsToBytes bits)).
     rewrite pure_lemmas.length_bytelist_to_intlist with (n:=(x*16)%nat).
       exists x. trivial.
     rewrite H. unfold WORD. rewrite (mult_comm (Z.to_nat 4)). rewrite mult_comm.
        rewrite <- mult_assoc. reflexivity.
Qed.

Module I256 <: INST.
Definition shah : Blist -> Blist ->  Blist := sha_h.
Definition hashblock : list int -> list int -> list int := SHA256.hash_block.
Definition HHB : shah =
      (fun rgs bl : Blist =>
       intsToBits (hashblock (bitsToInts rgs) (bitsToInts bl))).
  reflexivity. Qed.
Definition hashblocks: list int -> list int -> list int := SHA256.hash_blocks.
Definition d:nat := 16%nat.
Definition HBS_eq : forall r msg : list int,
         hash_blocks r msg =
         match msg with
         | List.nil => r
         | _ :: _ => hash_blocks (hash_block r (firstn d msg)) (skipn d msg)
         end := hash_blocks_equation.
End I256.

Module PAD := HMAC_Pad SHA256 I256.

(* Relates the HMAC padded spec to the HMAC functional program *)
Theorem HMAC_pad_concrete (K : list byte) (M H : list byte) (OP IP : byte)
                          (k m h : Blist) (op ip : Blist):
  ((length K) * 8)%nat = (c + p)%nat ->
  bytes_bits_lists k K ->
  bytes_bits_lists m M ->
  bytes_bits_lists op (HMAC_SHA256.sixtyfour OP) ->
  bytes_bits_lists ip (HMAC_SHA256.sixtyfour IP) ->
  sha.HMAC_spec_pad.HMAC c p B sha_h sha_iv sha_splitandpad op ip k m = h ->
  HMAC_SHA256.HmacCore IP OP M K = H ->
  bytes_bits_lists h H.
Proof. intros.
assert (sha_splitandpad =
        (fun bits : Blist =>
   bytesToBits (intlist_to_bytelist (generate_and_pad (bitsToBytes bits))))).
  clear.
  apply extensionality. intros l. unfold sha_splitandpad.
  f_equal. rewrite <- pad_compose_equal. unfold generate_and_pad'.
  rewrite pure_lemmas.bytelist_to_intlist_to_bytelist. trivial.
  destruct (pad_len_64_nat (bitsToBytes l)). rewrite Zlength_correct, H. exists (Z.of_nat (x*16)). do 2 rewrite Nat2Z.inj_mul. rewrite Z.mul_comm, <- Z.mul_assoc.  reflexivity.
rewrite H7 in H5; clear H7.
eapply PAD.HMAC_pad_concrete with (c:=c)(p:=p)(IP:=IP)(OP:=OP)(B:=B)(ip:=ip)(op:=op)(m:=m)(K:=K)
  (ir:=SHA256.init_registers)(gap:=generate_and_pad); try reflexivity; try eassumption.
- intros. rewrite <- pad_compose_equal. apply gap_divide16.
- intros; unfold SHA256.Hash.
  rewrite functional_prog.SHA_256'_eq; reflexivity.
- unfold SHA256.BlockSize.
  unfold c, p in H0. omega.
Qed.

Theorem HMAC_pad_concrete' (K : list byte) (M : list byte) (OP IP : byte)
                           (k m : Blist) (op ip : Blist):
  ((length K) * 8)%nat = (c + p)%nat ->
  Zlength K = Z.of_nat SHA256.BlockSize ->
  bytes_bits_lists k K ->
  bytes_bits_lists m M ->
  bytes_bits_lists op (HMAC_SHA256.sixtyfour OP) ->
  bytes_bits_lists ip (HMAC_SHA256.sixtyfour IP) ->
  sha.HMAC_spec_pad.HMAC c p B sha_h sha_iv sha_splitandpad op ip k m =
  bytesToBits (HMAC_SHA256.HmacCore IP OP M K).
Proof. intros.
  eapply bits_bytes_ind_comp.
    eapply HMAC_pad_concrete; try reflexivity; trivial.
Qed.

(*earlier /additional proofs
Lemma equiv_pad_SHA256 : forall (bits : Blist) (bytes : list Z),
                    bytes_bits_lists bits bytes ->
                    bytes_bits_lists
                      (sha.HMAC_spec_pad.hash_words_padded c p B sha_h sha_iv sha_splitandpad bits)
                      (HP.SHA256.Hash bytes).
Proof. intros.
Locate equiv_pad.
  eapply sha.HMAC_spec_pad.equiv_pad with (gap:=generate_and_pad').
  reflexivity.
  apply hash_blocks_equation.
  reflexivity.
  reflexivity.
  apply gap_divide16.
  intros. unfold sha_splitandpad. f_equal.
    apply bytes_bits_ind_comp in H.
    { subst bytes. unfold generate_and_pad'.
      rewrite pure_lemmas.Zlist_to_intlist_to_Zlist; trivial.
        destruct (pad_len_64_nat (bitsToBytes bits0)). rewrite H.
          exists ((x*16)%nat). rewrite mult_comm, <- mult_assoc. reflexivity.
        apply pad_isbyteZ. eapply bitsToBytes_isbyteZ. reflexivity. }
    apply (bytesBitsLists_isbyteZ _ _ H).
  intros; unfold HP.SHA256.Hash.
    rewrite -> functional_prog.SHA_256'_eq. unfold SHA256.SHA_256.
    rewrite <- pad_compose_equal; reflexivity.
  assumption.
Qed.

Theorem HMAC_pad_concrete (K : list byte) (M H : list Z) (OP IP : Z)
                          (k m h : Blist) (op ip : Blist) (ipByte: isbyteZ IP) (opByte: isbyteZ OP):
  ((length K) * 8)%nat = (c + p)%nat ->
  bytes_bits_lists k (map Byte.unsigned K) ->
  bytes_bits_lists m M ->
  bytes_bits_lists op (HP.HMAC_SHA256.sixtyfour OP) ->
  bytes_bits_lists ip (HP.HMAC_SHA256.sixtyfour IP) ->
  HMAC_Pad.HMAC c p B sha_h sha_iv sha_splitandpad op ip k m = h ->
  HP.HMAC_SHA256.HmacCore (Byte.repr IP) (Byte.repr OP) M K = H ->
  bytes_bits_lists h H.
Proof.
  intros padded_key_len padded_keys_eq msgs_eq ops_eq ips_eq.
  intros HMAC_abstract HMAC_concrete.

  rewrite <- HMAC_abstract. rewrite <- HMAC_concrete.

  unfold HMAC_Pad.HMAC. unfold HP.HMAC_SHA256.HmacCore. unfold HP.HMAC_SHA256.OUTER. unfold HP.HMAC_SHA256.INNER.
  unfold HP.HMAC_SHA256.outerArg. unfold HP.HMAC_SHA256.innerArg.

  unfold HMAC_Pad.HMAC_2K. unfold HMAC_Pad.GHMAC_2K. rewrite -> split_append_id.

  { apply equiv_pad_SHA256.
    apply bytes_bits_lists_append.
    apply xor_equiv_byte; trivial.

    apply equiv_pad_SHA256.
    apply bytes_bits_lists_append.
    - apply xor_equiv_byte; trivial.
    - assumption. }
  { apply BLxor_length; erewrite bytes_bits_length; try eassumption.
         rewrite map_length, padded_key_len. reflexivity.
         unfold HP.HMAC_SHA256.sixtyfour.
         rewrite -> length_list_repeat. reflexivity. }
  { apply BLxor_length; erewrite bytes_bits_length; try eassumption.
         rewrite map_length, padded_key_len. reflexivity.
         unfold HP.HMAC_SHA256.sixtyfour.
         rewrite -> length_list_repeat. reflexivity. }
Qed.
*)