(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Export tactics smallstep executable.

Section soundness.
Context `{EnvSpec K}.

Lemma assign_exec_correct Γ m a v ass va' v' :
  assign_exec Γ m a v ass = Some (va',v') ↔ assign_sem Γ m a v ass va' v'.
Proof.
  split; [|by destruct 1; simplify_option_eq].
  intros. destruct ass; simplify_option_eq; econstructor; eauto.
Qed.
Lemma ctx_lookup_correct (k : ctx K) i : ctx_lookup i k = locals k !! i.
Proof.
  revert i.
  induction k as [|[]]; intros [|x]; f_equal'; rewrite ?list_lookup_fmap; auto.
Qed.
Lemma ehexec_sound Γ k m1 m2 e1 e2 :
  (e2,m2) ∈ ehexec Γ k e1 m1 → Γ\ locals k ⊢ₕ e1, m1 ⇒ e2, m2.
Proof.
  intros. destruct e1;
    repeat match goal with
    | H : assign_exec _ _ _ _ _ = Some _ |- _ =>
      apply assign_exec_correct in H
    | _ => progress decompose_elem_of
    | H : ctx_lookup _ _ = _ |- _ => rewrite ctx_lookup_correct in H
    | _ => progress simplify_equality'
    | _ => case_match
    end; do_ehstep.
Qed.
Lemma ehexec_weak_complete Γ k e1 m1 e2 m2 :
  ehexec Γ k e1 m1 ≡ ∅ →
  ¬Γ\ locals k ⊢ₕ e1, m1 ⇒ e2, m2.
Proof.
  destruct 2;
    repeat match goal with
    | H : assign_sem _ _ _ _ _ _ _ |- _ =>
      apply assign_exec_correct in H
    | H : is_Some _ |- _ => destruct H as [??]
    | _ => progress decompose_empty
    | H : locals _ !! _ = Some _ |- _ => rewrite <-ctx_lookup_correct in H
    | H : option_to_set ?o ≫= _ ≡ _, Ho : ?o = Some _ |- _ =>
       rewrite Ho in H; csimpl in H; rewrite set_bind_singleton in H
    | _ => progress simplify_option_eq
    | _ => case_match
    | H : mguard (_) (_) ≡ ∅ |- _ => apply guard_empty in H
    | H : _ ∨ _ |- _ => destruct H
    end; eauto.
Qed.
Lemma ehstep_dec Γ ρ e1 m1 :
  (∃ e2 m2, Γ\ ρ ⊢ₕ e1, m1 ⇒ e2, m2) ∨ ∀ e2 m2, ¬Γ\ ρ ⊢ₕ e1, m1 ⇒ e2, m2.
Proof.
  set (k:=(λ oτ, CLocal (oτ.1) (oτ.2)) <$> ρ).
  replace ρ with (locals k) by (induction ρ as [|[]]; f_equal'; auto).
  destruct (set_choose_or_empty (ehexec Γ k e1 m1)) as [[[e2 m2]?]|];
    eauto using ehexec_sound, ehexec_weak_complete.
Qed.
Lemma cexec_sound Γ δ S1 S2 : Γ\ δ ⊢ₛ S1 ⇒ₑ S2 → Γ\ δ ⊢ₛ S1 ⇒ S2.
Proof.
  intros. assert (
    ∀ (k : ctx K) e m,
      ehexec Γ k e m ≡ ∅ →
      maybe_ECall_redex e = None →
      is_redex e →
      ¬Γ\ locals k ⊢ₕ safe e, m
  ).
  { intros k e m He. rewrite eq_None_not_Some.
    intros Hmaybe Hred Hsafe; apply Hmaybe; destruct Hsafe.
    * eexists; apply maybe_ECall_redex_Some; eauto.
    * edestruct ehexec_weak_complete; eauto. }
  destruct S1;
    repeat match goal with
    | H : _ ∈ ehexec _ _ _ _ |- _ => apply ehexec_sound in H
    | H : _ ∈ expr_redexes _ |- _ =>
      apply expr_redexes_correct in H; destruct H
    | H : maybe VBase ?vb = _ |- _ => is_var vb; destruct vb
    | H : maybe_ECall_redex _ = Some _ |- _ =>
      apply maybe_ECall_redex_Some in H; destruct H
    | _ => progress decompose_elem_of
    | _ => case_decide
    | _ => case_match
    | _ => progress simplify_equality'
    | H : maybe2 _ ?e = Some _ |- _ => is_var e; destruct e
    end; do_cstep.
Qed.
Lemma cexecs_sound Γ δ S1 S2 : Γ\ δ ⊢ₛ S1 ⇒ₑ* S2 → Γ\ δ ⊢ₛ S1 ⇒* S2.
Proof. induction 1; econstructor; eauto using cexec_sound. Qed.
Lemma cexec_ex_loop Γ δ S :
  ex_loop (λ S1 S2, Γ\ δ ⊢ₛ S1 ⇒ₑ S2) S → ex_loop (cstep Γ δ) S.
Proof.
  revert S; cofix COH; intros S; destruct 1 as [S1 S2 p].
  econstructor; eauto using cexec_sound.
Qed.
End soundness.


Require Import RelationClasses.
Require Import List.

Require Import sflib.
From Paco Require Import paco.

Require Import Basic.
Require Import Axioms.
Require Import Loc.
Require Import LibTactics.
Require Import Integers.
Require Import Language.
Require Import ZArith.
Require Import Maps.
Require Import FSets.
Require Import FSetInterface.
Require Import Lattice.
Require Import Event.
Require Import Syntax.
Require Import Semantics.

Require Import Kildall.
Require Import LiveAnalysis.
Require Import CorrectOpt.
Require Import DCE.

Require Import Language.
Require Import Time.
Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import MsgMapping.
Require Import DelaySet.
Require Import LocalSim.

(** * Invariant in dead code elimination  *)
Definition I_dce (lo: Ordering.LocOrdMap) (inj: Mapping) (S: Rss) :=
  match S with
  | Build_Rss sc_tgt mem_tgt sc_src mem_src =>
    (* injection timemaps for SC fence *)
    (<<INJ_SC: TMapInj inj sc_tgt sc_src>> /\
    (* memory injection *)
    <<INJ_MEM: MsgInj inj mem_tgt mem_src>> /\
    (* timestamps reservation *)
    <<TS_RSV: forall loc val from' to' R' to,
        Memory.get loc to' mem_src = Some (from', Message.concrete val R') ->
        inj loc to = Some to' ->
        Time.lt Time.bot to ->
        lo loc = Ordering.nonatomic ->
        exists to_r, Time.lt to_r from' /\
                (forall ts, Interval.mem (to_r, from') ts -> ~Cover.covered loc ts mem_src)>> /\
    (* no atomic location has no reservation *)
    <<NO_RSVs: forall loc to from,
            Memory.get loc to mem_src = Some (from, Message.reserve) -> lo loc = Ordering.atomic>> /\
    (* identity atomic *)
    <<ID_ATOMIC: forall loc to to', lo loc = Ordering.atomic -> inj loc to = Some to' -> to = to'>> /\
    (* closed src memory *)
    <<CLOSED_SRC_MEM: Memory.closed mem_src>>
    )
  end.

(** * Match state *)
(* timestamp match *)
Definition TM (inj: Mapping) (loc: Loc.t) (tm_tgt: TimeMap.t)
           (tm_src: TimeMap.t) (mem_src: Memory.t) :=
  (forall to to', inj loc to = Some to' -> Time.lt (tm_tgt loc) to -> Time.lt (tm_src loc) to') /\
  (exists to', inj loc (tm_tgt loc) = Some to' /\ Time.le to' (tm_src loc) /\
          (forall ts, Interval.mem (to', tm_src loc) ts -> concrete_covered loc ts mem_src)).

(* view match *)
Inductive InvView_dce: Mapping -> Ordering.LocOrdMap -> TView.t -> TView.t -> Memory.t -> Prop :=
| InvView_dce_intro
    inj lo tview_tgt tview_src mem_src
    (* For current view *)
    (ATM_LOC_CUR_PLN:
       forall loc, lo loc = Ordering.atomic ->
              inj loc ((View.pln (TView.cur tview_tgt)) loc) = Some ((View.pln (TView.cur tview_src)) loc))
    (ATM_LOC_CUR_RLX:
       forall loc, lo loc = Ordering.atomic ->
              inj loc ((View.rlx (TView.cur tview_tgt)) loc) = Some ((View.rlx (TView.cur tview_src)) loc))
    (NA_LOC_CUR_RLX:
       forall loc, lo loc = Ordering.nonatomic ->
              TM inj loc (View.rlx (TView.cur tview_tgt)) (View.rlx (TView.cur tview_src)) mem_src)
    (* For acquire view *)
    (ATM_LOC_ACQ_PLN:
       forall loc, lo loc = Ordering.atomic ->
              inj loc ((View.pln (TView.acq tview_tgt)) loc) = Some ((View.pln (TView.acq tview_src)) loc))
    (ATM_LOC_ACQ_RLX:
       forall loc, lo loc = Ordering.atomic ->
              inj loc ((View.rlx (TView.acq tview_tgt)) loc) = Some ((View.rlx (TView.acq tview_src)) loc))
    (NA_LOC_CUR_RLX:
       forall loc, lo loc = Ordering.nonatomic ->
              TM inj loc (View.rlx (TView.acq tview_tgt)) (View.rlx (TView.acq tview_src)) mem_src)
    (* For release view *)
    (ATM_LOC_REL:
       forall loc, lo loc = Ordering.atomic ->
              ViewInj inj ((TView.rel tview_tgt) loc) ((TView.rel tview_src) loc)):
    InvView_dce inj lo tview_tgt tview_src mem_src.

Definition cur_acq (lo: Ordering.LocOrdMap) (inj: Mapping)
           (cur_tgt acq_tgt: View.t) (cur_src acq_src: View.t) :=
  forall loc
    (NA_LOC: lo loc = Ordering.nonatomic),
    <<LT: Time.lt ((View.rlx cur_tgt) loc) ((View.rlx acq_tgt) loc) /\
          inj loc ((View.rlx acq_tgt) loc) = Some ((View.rlx acq_src) loc)>> \/
    <<EQ: ((View.rlx cur_tgt) loc) = ((View.rlx acq_tgt) loc) /\
          ((View.rlx cur_src) loc) = ((View.rlx acq_src) loc)>>.

Definition cur_acq_pln (lo: Ordering.LocOrdMap) (inj: Mapping)
           (cur_tgt acq_tgt: View.t) (cur_src acq_src: View.t) :=
  forall loc
    (NA_LOC: lo loc = Ordering.nonatomic),
    <<LT: Time.lt ((View.rlx cur_tgt) loc) ((View.pln acq_tgt) loc) /\
          inj loc ((View.pln acq_tgt) loc) = Some ((View.pln acq_src) loc)>> \/
    <<EQ: Time.le ((View.pln acq_tgt) loc) ((View.rlx cur_tgt) loc) /\
          Time.le ((View.pln acq_src) loc) ((View.rlx cur_src) loc)>>.

(* semantics for abstract interpretation *)
Definition sem_live_reg (R_tgt R_src: RegFile.t) (nr: nreg): Prop :=
  forall r, NREG.get r nr = true -> RegFun.find r R_tgt = RegFun.find r R_src.

Definition sem_live_loc (inj: Mapping) (tview_tgt tview_src: TView.t) (nm: nmem): Prop :=
  forall loc, negb (is_dead_loc loc nm) ->
         (
           (inj loc ((View.pln (TView.cur tview_tgt)) loc) = Some ((View.pln (TView.cur tview_src)) loc)) /\
           (inj loc ((View.pln (TView.acq tview_tgt)) loc) = Some ((View.pln (TView.acq tview_src)) loc)) /\
           (inj loc ((View.rlx (TView.cur tview_tgt)) loc) = Some ((View.rlx (TView.cur tview_src)) loc)) /\
           (inj loc ((View.rlx (TView.acq tview_tgt)) loc) = Some ((View.rlx (TView.acq tview_src)) loc))
         ).

Definition ai_interp (inj: Mapping)
           (R_tgt: RegFile.t) (tview_tgt: TView.t)
           (R_src: RegFile.t) (tview_src: TView.t)
           (ai: LvDS.L.t): Prop :=
  match ai with
  | (nr, nm) => sem_live_reg R_tgt R_src nr /\ sem_live_loc inj tview_tgt tview_src nm
  end.

(* promise relation *)
Definition promises_relation (inj: Mapping) (lo: Ordering.LocOrdMap) (prm_tgt prm_src: Memory.t) :=
  @rel_promises nat inj dset_init prm_tgt prm_src /\
  (forall loc from to,
      lo loc = Ordering.atomic ->
      (Memory.get loc to prm_tgt = Some (from, Message.reserve) <->
       Memory.get loc to prm_src = Some (from, Message.reserve))).

(* match state for current stack frame *)
Inductive match_state_cur_stkframe:
  Mapping -> Ordering.LocOrdMap ->
  (RegFile.t * BBlock.t * CodeHeap * TView.t) ->
  (RegFile.t * BBlock.t * CodeHeap * TView.t) -> Prop :=
| match_state_cur_stkframe_intro
    inj lo R_tgt BB_tgt C_tgt tview_tgt R_src BB_src C_src tview_src
    afunc ai_tail ai ai_pblk fid
    (* function analysis *)
    (FUNC_ANALYSIS: LvDS.analyze_func_backward (C_src, fid) succ transf_blk = Some afunc)
    (* transformation code heap *)
    (FUNC_TRANS: transform_cdhp C_src afunc = C_tgt)
    (* analysis for the current source block *)
    (AI_FOR_CBLK: transf_blk ai_tail BB_src = LvDS.AI.Cons ai ai_pblk)
    (* current source and target blocks transformation *)
    (TRANS_PBLK: transform_blk' ai_pblk BB_src = BB_tgt)
    (* current ai interpretation *)
    (AI_INTERP: ai_interp inj R_tgt tview_tgt R_src tview_src ai)
    (* link *)
    (LINK: forall s BB_src',
        In s (succ BB_src) -> C_src ! s = Some BB_src' ->
        LvDS.L.ge ai_tail (LvDS.AI.getFirst (transf_blk (LvDS.AI.getLast (afunc !! s)) BB_src'))):
    match_state_cur_stkframe inj lo
                             (R_tgt, BB_tgt, C_tgt, tview_tgt)
                             (R_src, BB_src, C_src, tview_src).

(* match state for stack frames *)
Inductive match_state_stkframes:
  Ordering.LocOrdMap ->
  Continuation.t -> Continuation.t -> Prop :=
| match_state_stkframes_done
    lo:
    match_state_stkframes lo Continuation.done Continuation.done
| match_state_stkframes_cont
    lo
    R_tgt BB_tgt C_tgt cont_tgt
    R_src BB_src C_src cont_src
    (CUR_MATCH:
       forall tview_tgt tview_src inj',
         sem_live_loc inj' tview_tgt tview_src (NMem LocSet.empty) ->
         match_state_cur_stkframe inj' lo
                                  (R_tgt, BB_tgt, C_tgt, tview_tgt)
                                  (R_src, BB_src, C_src, tview_src)
    )
    (CONT_MATCH: match_state_stkframes lo cont_tgt cont_src):
    match_state_stkframes lo
                          (Continuation.stack R_tgt BB_tgt C_tgt cont_tgt)
                          (Continuation.stack R_src BB_src C_src cont_src).

Lemma match_state_call_stack
      inj lo fid ai_tail ai_pblk nr afunc
      R_tgt BB_tgt C_tgt tview_tgt
      R_src BB_src C_src tview_src
      (FUNC_ANALYSIS: LvDS.analyze_func_backward (C_src, fid) succ transf_blk = Some afunc)
      (FUNC_TRANS: transform_cdhp C_src afunc = C_tgt)
      (AI_FOR_CBLK: transf_blk ai_tail BB_src = LvDS.AI.Cons (nr, NMem LocSet.empty) ai_pblk)
      (TRANS_PBLK: transform_blk' ai_pblk BB_src = BB_tgt)
      (LV_REG: sem_live_reg R_tgt R_src nr)
      (LV_LOC: sem_live_loc inj tview_tgt tview_src (NMem LocSet.empty))
      (LINK: forall s BB_src',
          In s (succ BB_src) -> C_src ! s = Some BB_src' ->
          LvDS.L.ge ai_tail (LvDS.AI.getFirst (transf_blk (LvDS.AI.getLast (afunc !! s)) BB_src'))):
  match_state_cur_stkframe inj lo
                           (R_tgt, BB_tgt, C_tgt, tview_tgt)
                           (R_src, BB_src, C_src, tview_src).
Proof.
  econs; eauto.
  unfold ai_interp.
  split; eauto.
Qed.

(* match state for the thread-local state *)
Inductive match_state_tlocal:
  Mapping -> Ordering.LocOrdMap ->
  (State.t * TView.t * Memory.t) -> (State.t * TView.t * Memory.t) -> Prop :=
| match_state_tlocal_intro
    inj lo
    R_tgt BB_tgt C_tgt cont_tgt Prog_tgt tview_tgt prm_tgt
    R_src BB_src C_src cont_src Prog_src tview_src prm_src
    (PROG_TRANS: transform_prog Prog_src = Some Prog_tgt)
    (CUR_STK_FRAME: match_state_cur_stkframe inj lo
                                             (R_tgt, BB_tgt, C_tgt, tview_tgt)
                                             (R_src, BB_src, C_src, tview_src))
    (STK_FRAMES: match_state_stkframes lo cont_tgt cont_src):
    match_state_tlocal inj lo
                       (State.mk R_tgt BB_tgt C_tgt cont_tgt Prog_tgt, tview_tgt, prm_tgt)
                       (State.mk R_src BB_src C_src cont_src Prog_src, tview_src, prm_src).

(* match state for thread state *)
Inductive match_state_dce:
  Mapping -> Ordering.LocOrdMap -> bool ->
  Thread.t rtl_lang -> Thread.t rtl_lang -> Prop :=
| match_state_dce_intro
    inj inj' lo b
    state_tgt tview_tgt prm_tgt sc_tgt mem_tgt
    state_src tview_src prm_src sc_src mem_src
    (INV: I_dce lo inj' (Build_Rss sc_tgt mem_tgt sc_src mem_src))
    (ATOM_MEM_EQ: Mem_at_eq lo mem_tgt mem_src)
    (MATCH_THRD_LOCAL:
       match_state_tlocal inj' lo (state_tgt, tview_tgt, prm_tgt) (state_src, tview_src, prm_src))
    (VIEW_MATCH: InvView_dce inj' lo tview_tgt tview_src mem_src)
    (CUR_ACQ: cur_acq lo inj' (TView.cur tview_tgt) (TView.acq tview_tgt)
                      (TView.cur tview_src) (TView.acq tview_src))
    (CUR_ACQ_PLN: cur_acq_pln lo inj' (TView.cur tview_tgt) (TView.acq tview_tgt)
                              (TView.cur tview_src) (TView.acq tview_src))
    (* promise injection *)
    (PROM_INJ: promises_relation inj lo prm_tgt prm_src)
    (ATM_BIT: (b = false /\ (forall loc t t', inj loc t = Some t' -> inj' loc t = Some t')) \/
              (b = true /\ inj = inj'))
    (* wf local, closed sc, closed memory *)
    (LOCAL_WF_TGT: Local.wf (Local.mk tview_tgt prm_tgt) mem_tgt)
    (CLOSED_SC_TGT: Memory.closed_timemap sc_tgt mem_tgt)
    (MEM_CLOSED_TGT: Memory.closed mem_tgt)
    (LOCAL_WF_SRC: Local.wf (Local.mk tview_src prm_src) mem_src)
    (CLOSED_SC_SRC: Memory.closed_timemap sc_src mem_src):
    (*(MEM_CLOSED_SRC: Memory.closed mem_src):*)
  match_state_dce inj lo b
                  (Thread.mk rtl_lang state_tgt (Local.mk tview_tgt prm_tgt) sc_tgt mem_tgt)
                  (Thread.mk rtl_lang state_src (Local.mk tview_src prm_src) sc_src mem_src).

Lemma promise_consistent_prsv
      inj lo
      tview_tgt prm_tgt tview_src prm_src mem_src
      (VIEW_MATCH: InvView_dce inj lo tview_tgt tview_src mem_src)
      (PROM_REL: promises_relation inj lo prm_tgt prm_src)
      (PROM_CONS: Local.promise_consistent (Local.mk tview_tgt prm_tgt))
      (MON_INJ: monotonic_inj inj):
  Local.promise_consistent (Local.mk tview_src prm_src).
Proof.
  unfold Local.promise_consistent in *; ii; ss.
  unfold promises_relation in PROM_REL. des. clear PROM_REL0.
  inv PROM_REL.
  exploit COMPLETE; eauto. ii; des.
  rewrite dset_gempty in x0. ss.
  exploit PROM_CONS; eauto. ii.
  clear - VIEW_MATCH x x0 x1 MON_INJ.
  inv VIEW_MATCH.
  destruct (lo loc) eqn:Heqe.
  exploit ATM_LOC_CUR_RLX; eauto.
  exploit NA_LOC_CUR_RLX; eauto.
  introv TM_H. inv TM_H; ss. eauto.
Qed.


Require Import Setoid PArith.
From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising2 Require Import TView View Time Event Cell Thread Memory Configuration Local.

From imm Require Import Events.
From imm Require Import Execution.
From imm Require Import Execution_eco.
From imm Require Import imm_s_hb.
From imm Require Import imm_s.
From imm Require Import imm_bob imm_s_ppo.
From imm Require Import CombRelations.
From imm Require Import CombRelationsMore.
From imm Require Import AuxDef.

From imm Require Import TraversalConfig.
From imm Require Import ViewRelHelpers.
Require Import SimulationRel.
Require Import SimState.
Require Import MemoryAux.
Require Import MaxValue.
Require Import ViewRel.
Require Import Event_imm_promise.
Require Import ExtTraversalConfig.
Require Import ExtTraversal.
Require Import ExtTraversalProperties.
Require Import FtoCoherent.
Require Import SimulationRelProperties.
Require Import IntervalHelper.
Require Import ExistsIssueInterval.

Set Implicit Arguments.

Section IssueStepHelper.

Variable G : execution.
Variable WF : Wf G.
Variable sc : relation actid.

Notation "'acts'" := G.(acts).
Notation "'co'" := G.(co).
Notation "'sw'" := G.(sw).
Notation "'hb'" := G.(hb).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'rfi'" := G.(rfi).
Notation "'rfe'" := G.(rfe).
Notation "'rmw'" := G.(rmw).
Notation "'lab'" := G.(lab).
Notation "'msg_rel'" := (msg_rel G sc).
Notation "'urr'" := (urr G sc).
Notation "'release'" := G.(release).

Notation "'E'" := G.(acts_set).
Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1).
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'W_'" := (fun l => W ∩₁ Loc_ l).
(* Notation "'RW'" := (fun x => R x \/ W x). *)
Notation "'FR'" := (fun x => F x \/ R x).
Notation "'FW'" := (fun x => F x \/ W x).

Notation "'W_ex'" := (W_ex G).
Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (is_rlx lab).
Notation "'Rel'" := (is_rel lab).
Notation "'Acq'" := (is_acq lab).
Notation "'Acqrel'" := (is_acqrel lab).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Variable IMMCON : imm_consistent G sc.

Variable T : trav_config.
Variable S : actid -> Prop.
Variable ETCCOH : etc_coherent G sc (mkETC T S).

Variable RELCOV : W ∩₁ Rel ∩₁ issued T ⊆₁ covered T.

Variable f_to f_from : actid -> Time.t.
Variable FCOH : f_to_coherent G S f_to f_from.

Variable PC : Configuration.t.
Hypothesis THREAD : forall e (ACT : E e) (NINIT : ~ is_init e),
    exists langst, IdentMap.find (tid e) PC.(Configuration.threads) = Some langst.

Variable smode : sim_mode.
Hypothesis SC_REQ :
  smode = sim_normal ->
  forall (l : Loc.t),
    max_value f_to (S_tm G l (covered T)) (LocFun.find l PC.(Configuration.sc)).

Variable thread : thread_id.
Variable local : Local.t.
Hypothesis SIM_PROM     : sim_prom     G sc T   f_to f_from thread local.(Local.promises).
Hypothesis SIM_RES_PROM : sim_res_prom G    T S f_to f_from thread local.(Local.promises).

Hypothesis CLOSED_SC : Memory.closed_timemap PC.(Configuration.sc) PC.(Configuration.memory).

Hypothesis PROM_DISJOINT :
  forall thread' langst' local'
         (TNEQ : thread <> thread')
         (TID' : IdentMap.find thread' PC.(Configuration.threads) =
                 Some (langst', local')),
  forall loc to,
    Memory.get loc to local .(Local.promises) = None \/
    Memory.get loc to local'.(Local.promises) = None.

Hypothesis PROM_IN_MEM :
  forall thread' langst local
         (TID : IdentMap.find thread' PC.(Configuration.threads) =
                Some (langst, local)),
    Memory.le local.(Local.promises) PC.(Configuration.memory).

Hypothesis INHAB      : Memory.inhabited (Configuration.memory PC).
Hypothesis CLOSED_MEM : Memory.closed (Configuration.memory PC).
Hypothesis PLN_RLX_EQ : pln_rlx_eq local.(Local.tview).
Hypothesis MEM_CLOSE : memory_close local.(Local.tview) PC.(Configuration.memory).

Hypothesis RESERVED_TIME:
  reserved_time G T S f_to f_from smode PC.(Configuration.memory).

Hypothesis SIM_RES_MEM :
  sim_res_mem G T S f_to f_from thread local (Configuration.memory PC).

Hypothesis SIM_MEM : sim_mem G sc T f_to f_from thread local PC.(Configuration.memory).
Hypothesis SIM_TVIEW : sim_tview G sc (covered T) f_to local.(Local.tview) thread.

Lemma issue_step_helper_no_next w valw locw ordw langst
      (TID : IdentMap.find (tid w) PC.(Configuration.threads) = Some (langst, local))
      (NWEX : ~ W_ex w)
      (NISSB : ~ issued T w)
      (ISSUABLE : issuable G sc T w)
      (NONEXT : dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) ⊆₁ ∅)
      (LOC : loc lab w = Some locw)
      (VAL : val lab w = Some valw)
      (ORD : mod lab w = ordw)
      (WTID : thread = tid w) :
  let promises := local.(Local.promises) in
  let memory   := PC.(Configuration.memory) in
  let sc_view  := PC.(Configuration.sc) in
  let covered' := if Rel w then covered T ∪₁ eq w else covered T in
  let T'       := mkTC covered' (issued T ∪₁ eq w) in
  let S'       := S ∪₁ eq w ∪₁ dom_sb_S_rfrmw G (mkETC T S) rfi (eq w) in
  exists p_rel,
    rfrmw_prev_rel G sc T f_to f_from PC.(Configuration.memory) w locw p_rel /\
    (⟪ FOR_ISSUE :
         exists f_to' f_from',
           let rel'' :=
               if is_rel lab w
               then (TView.cur (Local.tview local))
               else (TView.rel (Local.tview local) locw)
           in
           let rel' := (View.join (View.join rel'' p_rel.(View.unwrap))
                                  (View.singleton_ur locw (f_to' w))) in
           ⟪ RELWFEQ : View.pln rel' = View.rlx rel' ⟫ /\
           ⟪ REL_VIEW_LT : Time.lt (View.rlx rel'' locw) (f_to' w) ⟫ /\
           ⟪ REL_VIEW_LE : Time.le (View.rlx rel'  locw) (f_to' w) ⟫ /\

           ⟪ REQ_TO : forall e (SE : S e) (NEQ : e <> w), f_to' e = f_to e ⟫ /\
           ⟪ REQ_FROM : forall e (SE : S e) (NEQ : e <> w), f_from' e = f_from e ⟫ /\
           ⟪ ISSEQ_TO   : forall e (ISS: issued T e), f_to' e = f_to e ⟫ /\
           ⟪ ISSEQ_FROM : forall e (ISS: issued T e), f_from' e = f_from e ⟫ /\
           ⟪ FTOWNBOT : f_to' w <> Time.bot ⟫ /\

           exists promises_add memory',
             ⟪ PADD :
                 Memory.add local.(Local.promises) locw (f_from' w) (f_to' w)
                            (Message.full valw (Some rel')) promises_add ⟫ /\
             ⟪ MADD :
                 Memory.add memory locw (f_from' w) (f_to' w)
                            (Message.full valw (Some rel')) memory' ⟫ /\

             ⟪ INHAB : Memory.inhabited memory' ⟫ /\
             ⟪ RELMCLOS : Memory.closed_timemap (View.rlx rel') memory' ⟫ /\
             ⟪ RELVCLOS : Memory.closed_view rel' memory' ⟫ /\

             ⟪ FCOH : f_to_coherent G S' f_to' f_from' ⟫ /\

             ⟪ HELPER :
                 sim_mem_helper
                   G sc f_to' w (f_from' w) valw
                   (View.join (View.join (if is_rel lab w
                                          then (TView.cur (Local.tview local))
                                          else (TView.rel (Local.tview local) locw))
                                         p_rel.(View.unwrap))
                              (View.singleton_ur locw (f_to' w))) ⟫ /\

             ⟪ RESERVED_TIME :
                 reserved_time G T' S' f_to' f_from' smode memory' ⟫ /\

             ⟪ MEM_PROMISE :
                 Memory.promise (Local.promises local) memory locw (f_from' w) (f_to' w)
                                (Message.full valw (Some rel'))
                                promises_add memory' Memory.op_kind_add ⟫ /\

             exists promises',
               ⟪ PEQ :
                   if Rel w
                   then Memory.remove promises_add locw (f_from' w) (f_to' w)
                                      (Message.full valw (Some rel')) promises'
                   else promises' = promises_add ⟫ /\

               ⟪ NEW_PROM_IN_MEM : Memory.le promises' memory' ⟫ /\

               let tview' := if is_rel lab w
                             then TView.write_tview
                                    (Local.tview local) sc_view locw
                                    (f_to' w) (Event_imm_promise.wmod ordw)
                             else (Local.tview local) in
               let local' := Local.mk tview' promises' in
               let threads' :=
                   IdentMap.add (tid w)
                                (langst, local')
                                (Configuration.threads PC) in

               ⟪ THREAD : forall e (ACT : E e) (NINIT : ~ is_init e),
                   exists langst, IdentMap.find (tid e) threads' = Some langst ⟫ /\

               ⟪ SC_REQ : smode = sim_normal ->
                          forall (l : Loc.t),
                            max_value
                              f_to' (S_tm G l covered') (LocFun.find l sc_view) ⟫ /\
               ⟪ CLOSED_SC : Memory.closed_timemap sc_view memory' ⟫ /\

               ⟪ PROM_IN_MEM :
                   forall thread' langst local
                          (TID : IdentMap.find thread' threads' = Some (langst, local)),
                     Memory.le (Local.promises local) memory' ⟫ /\

               ⟪ SIM_PROM     : sim_prom G sc T' f_to' f_from' (tid w) promises'  ⟫ /\
               ⟪ SIM_RES_PROM : sim_res_prom G T' S' f_to' f_from' (tid w) promises'  ⟫ /\

               ⟪ PROM_DISJOINT :
                   forall thread' langst' local'
                          (TNEQ : tid w <> thread')
                          (TID' : IdentMap.find thread' threads' =
                                  Some (langst', local')),
                   forall loc to,
                     Memory.get loc to promises' = None \/
                     Memory.get loc to (Local.promises local') = None ⟫ /\

               ⟪ SIM_MEM     : sim_mem G sc T' f_to' f_from' (tid w) local' memory' ⟫ /\
               ⟪ SIM_RES_MEM : sim_res_mem G T' S' f_to' f_from' (tid w) local' memory' ⟫ /\
               ⟪ NOWLOC : Rel w -> Memory.nonsynch_loc locw (Local.promises local') ⟫
     ⟫ \/
     ⟪ FOR_SPLIT :
         ⟪ SMODE : smode = sim_certification ⟫ /\
         exists ws wsv wsrel f_to' f_from',
           let rel'' :=
               if is_rel lab w
               then (TView.cur (Local.tview local))
               else (TView.rel (Local.tview local) locw)
           in
           let rel' := (View.join (View.join rel'' p_rel.(View.unwrap))
                                  (View.singleton_ur locw (f_to' w))) in
           let wsmsg := Message.full wsv wsrel in
           ⟪ NREL    : ~ Rel w ⟫ /\
           ⟪ EWS     : E ws ⟫ /\
           ⟪ WSS     : S ws ⟫ /\
           ⟪ WSISS  : issued T ws ⟫ /\
           ⟪ NWEXWS : ~ W_ex ws ⟫ /\
           ⟪ WSNCOV  : ~ covered T ws ⟫ /\
           ⟪ WSNINIT : ~ is_init ws ⟫ /\
           ⟪ WSTID   : tid ws = tid w ⟫ /\
           ⟪ WSVAL   : val lab ws = Some wsv ⟫ /\
           ⟪ WSSMSG : sim_msg G sc f_to ws (View.unwrap wsrel) ⟫ /\

           ⟪ SBWW : sb w ws ⟫ /\
           ⟪ SAME_LOC : Loc_ locw ws ⟫ /\
           ⟪ COWW : co w ws ⟫ /\

           ⟪ FEQ1 : f_to' w = f_from' ws ⟫ /\
           ⟪ FEQ2 : f_from' w = f_from ws ⟫ /\

           ⟪ WSPROM : Memory.get locw (f_to ws) (Local.promises local) =
                      Some (f_from ws, wsmsg)⟫ /\
           ⟪ WSMEM : Memory.get locw (f_to ws) memory =
                     Some (f_from ws, wsmsg)⟫ /\

           ⟪ RELWFEQ : View.pln rel' = View.rlx rel' ⟫ /\
           ⟪ REL_VIEW_LT : Time.lt (View.rlx rel'' locw) (f_to' w) ⟫ /\
           ⟪ REL_VIEW_LE : Time.le (View.rlx rel'  locw) (f_to' w) ⟫ /\
           ⟪ FCOH : f_to_coherent G S' f_to' f_from' ⟫ /\

           ⟪ REQ_TO : forall e (SE : S e) (NEQ : e <> w), f_to' e = f_to e ⟫ /\
           ⟪ ISSEQ_TO   : forall e (ISS: issued T e), f_to' e = f_to e ⟫ /\
           ⟪ FTOWNBOT : f_to' w <> Time.bot ⟫ /\

           exists promises_add memory',
             ⟪ PADD :
                 Memory.split (Local.promises local)
                              locw (f_from' w) (f_to' w) (f_to' ws)
                              (Message.full valw (Some rel'))
                              wsmsg
                              promises_add ⟫ /\
             ⟪ MADD :
                 Memory.split memory locw (f_from' w) (f_to' w) (f_to' ws)
                              (Message.full valw (Some rel'))
                              wsmsg
                              memory' ⟫ /\

             ⟪ INHAB : Memory.inhabited memory' ⟫ /\
             ⟪ RELMCLOS : Memory.closed_timemap (View.rlx rel') memory' ⟫ /\
             ⟪ RELVCLOS : Memory.closed_view rel' memory' ⟫ /\

             ⟪ HELPER :
                 sim_mem_helper
                   G sc f_to' w (f_from' w) valw
                   (View.join (View.join (if is_rel lab w
                                          then (TView.cur (Local.tview local))
                                          else (TView.rel (Local.tview local) locw))
                                         p_rel.(View.unwrap))
                              (View.singleton_ur locw (f_to' w))) ⟫ /\

             ⟪ RESERVED_TIME :
                 reserved_time G T' S' f_to' f_from' smode memory' ⟫ /\

             exists promises',
               ⟪ PEQ :
                   if Rel w
                   then Memory.remove promises_add locw (f_from' w) (f_to' w)
                                      (Message.full valw (Some rel')) promises'
                   else promises' = promises_add ⟫ /\

               ⟪ NEW_PROM_IN_MEM : Memory.le promises' memory' ⟫ /\

               let tview' := if is_rel lab w
                             then TView.write_tview
                                    (Local.tview local) sc_view locw
                                    (f_to' w) (Event_imm_promise.wmod ordw)
                             else (Local.tview local) in
               let local' := Local.mk tview' promises' in
               let threads' :=
                   IdentMap.add (tid w)
                                (langst, local')
                                (Configuration.threads PC) in

               ⟪ THREAD : forall e (ACT : E e) (NINIT : ~ is_init e),
                   exists langst, IdentMap.find (tid e) threads' = Some langst ⟫ /\

               ⟪ SC_REQ : smode = sim_normal ->
                          forall (l : Loc.t),
                            max_value
                              f_to' (S_tm G l covered') (LocFun.find l sc_view) ⟫ /\
               ⟪ CLOSED_SC : Memory.closed_timemap sc_view memory' ⟫ /\

               ⟪ MEM_PROMISE :
                   ~ Rel w ->
                   Memory.promise (Local.promises local) memory locw (f_from' w) (f_to' w)
                                  (Message.full valw (Some rel'))
                                  promises' memory'
                                  (Memory.op_kind_split (f_to' ws) wsmsg) ⟫ /\

               ⟪ PROM_IN_MEM :
                   forall thread' langst local
                          (TID : IdentMap.find thread' threads' = Some (langst, local)),
                     Memory.le (Local.promises local) memory' ⟫ /\

               ⟪ SIM_PROM     : sim_prom G sc T' f_to' f_from' (tid w) promises'  ⟫ /\
               ⟪ SIM_RES_PROM : sim_res_prom G T' S' f_to' f_from' (tid w) promises'  ⟫ /\

               ⟪ PROM_DISJOINT :
                   forall thread' langst' local'
                          (TNEQ : tid w <> thread')
                          (TID' : IdentMap.find thread' threads' =
                                  Some (langst', local')),
                   forall loc to,
                     Memory.get loc to promises' = None \/
                     Memory.get loc to (Local.promises local') = None ⟫ /\

               ⟪ SIM_MEM     : sim_mem G sc T' f_to' f_from' (tid w) local' memory' ⟫ /\
               ⟪ SIM_RES_MEM : sim_res_mem G T' S' f_to' f_from' (tid w) local' memory' ⟫ /\
               ⟪ NOWLOC : Rel w -> Memory.nonsynch_loc locw (Local.promises local') ⟫ ⟫).
Proof using All.
  assert (tc_coherent G sc T) as TCCOH by apply ETCCOH.
  assert (complete G) as COMPL by apply IMMCON.
  assert (sc_per_loc G) as SPL by (apply coherence_sc_per_loc; apply IMMCON).

  assert (NSW : ~ S w).
  { intros HH. apply NWEX. apply ETCCOH. by split. }

  assert (S ⊆₁ E ∩₁ W) as SEW.
  { apply set_subset_inter_r. split; [by apply ETCCOH|].
    apply (reservedW WF ETCCOH). }
  assert (E w /\ W w) as [EW WW] by (by apply ISSUABLE).
  assert (~ covered T w) as NCOVB.
  { intros AA. apply NISSB. eapply w_covered_issued; eauto. by split. }
  assert (~ is_init w) as WNINIT.
  { intros HH. apply NCOVB. eapply init_covered; eauto. by split. }

  subst.
  edestruct exists_time_interval_for_issue_no_next as [p_rel [PREL [SEW' [HH|HH]]]]; eauto.
  2: { red in HH. desc. exists p_rel. splits; eauto.
       right. splits; eauto.
       set (wsmsg := Message.full wsv wsrel).
       exists ws, wsv, wsrel. exists f_to', f_from'.
       splits; eauto.
       exists promises', memory'. splits; eauto.

       assert (ws <> w) as WSNEQ by (by intros HH; subst).
       assert (sim_msg G sc f_to' ws (View.unwrap wsrel)) as WSMSG'.
       { eapply sim_msg_f_issued; eauto. }

       set (rel'' :=
              if is_rel lab w
              then (TView.cur (Local.tview local))
              else (TView.rel (Local.tview local) locw)).
       set (rel' := (View.join (View.join rel'' p_rel.(View.unwrap))
                               (View.singleton_ur locw (f_to' w)))).

       assert (exists promises'',
                  ⟪ PEQ :
                      if Rel w
                      then Memory.remove promises' locw (f_from' w) (f_to' w)
                                         (Message.full valw (Some rel')) promises''
                      else promises'' = promises' ⟫).
       { destruct (is_rel lab w) eqn:REL; eauto.
         edestruct Memory.remove_exists as [promises''].
         2: { exists promises''. eauto. }
         erewrite Memory.split_o; eauto. rewrite loc_ts_eq_dec_eq; auto. }
       desc.
       exists promises''. simpls.

       assert (Memory.le promises' memory') as PP.
       { eapply memory_le_split2; eauto. }

       assert (forall tmap (MCLOS : Memory.closed_timemap tmap PC.(Configuration.memory)),
                  Memory.closed_timemap tmap memory') as MADDCLOS.
       { ins. eapply Memory.split_closed_timemap; eauto. }

       assert (Memory.le promises'' promises') as LEPADD.
       { destruct (Rel w) eqn:RELB; subst; [|reflexivity].
         eapply memory_remove_le; eauto. }

       assert (Memory.le promises'' memory') as NEW_PROM_IN_MEM.
       { etransitivity; eauto. }

       assert (forall l to from msg
                      (NEQ  : l <> locw \/ to <> f_to' w)
                      (NEQ' : l <> locw \/ to <> f_to' ws),
                  Memory.get l to memory' = Some (from, msg) <->
                  Memory.get l to PC.(Configuration.memory) = Some (from, msg))
         as NOTNEWM.
       { ins. erewrite Memory.split_o; eauto. rewrite !loc_ts_eq_dec_neq; auto. }

       assert (forall l to from msg
                      (NEQ  : l <> locw \/ to <> f_to' w)
                      (NEQ' : l <> locw \/ to <> f_to' ws),
                  Memory.get l to promises' = Some (from, msg) <->
                  Memory.get l to local.(Local.promises) = Some (from, msg))
         as NOTNEWA.
       { ins. erewrite Memory.split_o; eauto. rewrite !loc_ts_eq_dec_neq; auto. }

       assert (forall l to from msg
                      (NEQ  : l <> locw \/ to <> f_to' w)
                      (NEQ' : l <> locw \/ to <> f_to' ws),
                  Memory.get l to promises'' = Some (from, msg) <->
                  Memory.get l to local.(Local.promises) = Some (from, msg))
         as NOTNEWP.
       { ins. arewrite (promises'' = promises') by desf. by apply NOTNEWA. }

       assert (~ Rel w ->
               Memory.get locw (f_to' w) promises'' =
               Some (f_from' w, Message.full valw (Some rel')))
         as INP''.
       { ins. destruct (Rel w); subst; [by desf|].
         erewrite Memory.split_o; eauto. by rewrite loc_ts_eq_dec_eq. }

       assert (f_to' ws <> f_to' w) as WWSFTONEQ.
       { intros HH. eapply f_to_eq in HH; eauto.
         { red. by rewrite LOC. }
         all: basic_solver. }

       assert (Memory.get locw (f_to' ws) promises' =
               Some (f_from' ws, Message.full wsv wsrel)) as WSMSGGET'.
       { erewrite Memory.split_o; eauto. rewrite loc_ts_eq_dec_neq; eauto.
         rewrite loc_ts_eq_dec_eq. by rewrite FEQ1. }

       assert (Memory.get locw (f_to' ws) promises'' =
               Some (f_from' ws, Message.full wsv wsrel)) as WSMSGGET'' by desf.

       splits; eauto.
       { ins.
         destruct (Ident.eq_dec (tid e) (tid w)) as [EQ|NEQ].
         { rewrite EQ. rewrite IdentMap.gss.
           eexists. eauto. }
         rewrite IdentMap.gso; auto. }
       { intros QQ l.
         assert (max_value f_to' (S_tm G l (covered T)) (LocFun.find l (Configuration.sc PC))) as BB.
         { eapply sc_view_f_issued; eauto. }
         destruct (Rel w); auto.
         eapply max_value_same_set.
         { apply BB. }
         eapply s_tm_n_f_steps.
         { apply TCCOH. }
         { clear. basic_solver. }
         intros a [HB|HB] HH AA.
         { eauto. }
         subst. clear -WW AA. type_solver. }
       { intros HH. arewrite (promises'' = promises') by desf. }
       { ins.
         destruct (Ident.eq_dec thread' (tid w)) as [EQ|NEQ].
         { subst. rewrite IdentMap.gss in TID0.
           inv TID0; simpls; clear TID0. }
         red; ins; rewrite IdentMap.gso in TID0; auto.
         erewrite Memory.split_o; eauto.
         destruct (loc_ts_eq_dec (loc, to) (locw, f_to' w)) as [[A B]|LL].
         { simpls; rewrite A in *; rewrite B in *; subst.
           exfalso. erewrite NINTER in LHS; eauto. inv LHS. }
         rewrite (loc_ts_eq_dec_neq LL).
         set (AA:=LHS).
         eapply PROM_IN_MEM in AA; eauto.
         destruct (loc_ts_eq_dec (loc, to) (locw, f_to' ws)) as [[A B]|LL'].
         2: by rewrite (loc_ts_eq_dec_neq LL').
         simpls; subst.
         rewrite (loc_ts_eq_dec_eq locw (f_to' ws)).
         rewrite REQ_TO in LHS; auto.
         rewrite REQ_TO in AA; auto.
         rewrite WSMEM in AA. inv AA.
         exfalso.
         edestruct PROM_DISJOINT with (local':=local0) as [BB|BB]; eauto.
         2: { rewrite BB in LHS. inv LHS. }
         rewrite WSPROM in BB. inv BB. }
       { simpls. red. ins.
         destruct (loc_ts_eq_dec (l, to) (locw, f_to' w)) as [[A' B']|LL].
         { simpls; rewrite A' in *; rewrite B' in *.
           destruct (Rel w) eqn:RELB; subst.
           { erewrite Memory.remove_o in PROM; eauto.
             rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in PROM. inv PROM. }
           erewrite Memory.split_o in PROM; eauto.
           rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in PROM.
           inv PROM. exists w. splits; eauto. by right. }
         simpls.
         assert (PROM' :
                   Memory.get l to promises' = Some (from, Message.full v rel)).
         { destruct (Rel w) eqn:RELB; subst; auto. }
         erewrite Memory.split_o in PROM'; eauto.
         rewrite (loc_ts_eq_dec_neq LL) in PROM'.
         destruct (loc_ts_eq_dec (l, to) (locw, f_to' ws)) as [[A' B']|LL'].
         { simpls; rewrite A' in *; rewrite B' in *.
           rewrite (loc_ts_eq_dec_eq locw (f_to' ws)) in PROM'.
           inv PROM'. exists ws. splits; eauto.
           { basic_solver. }
           { intros HH. desf. }
           red. splits; eauto.
           left. eapply f_to_co_mon; eauto.
           all: basic_solver. }
         simpls. rewrite (loc_ts_eq_dec_neq LL') in PROM'.
         edestruct SIM_PROM as [b H]; eauto; desc.
         exists b; splits; auto.
         { by left. }
         { assert (W b) as WB by (eapply issuedW; eauto).
           destruct (Rel w) eqn:RELB; auto. }
         { rewrite ISSEQ_FROM; auto. intros HH. subst.
           assert (Some l = Some locw) as BB.
           { rewrite <- LOC0. by rewrite <- SAME_LOC. }
           inv BB. destruct LL' as [|LL']; [done|].
           rewrite ISSEQ_TO in LL'; auto. }
         { by rewrite ISSEQ_TO. }
         eapply sim_mem_helper_f_issued with (f_to:=f_to); eauto. }
       { simpls. red. ins.
         destruct (loc_ts_eq_dec (l, to) (locw, f_to' w)) as [[A' B']|LL].
         { simpls; rewrite A' in *; rewrite B' in *.
           destruct (Rel w) eqn:RELB; subst.
           { erewrite Memory.remove_o in RES; eauto.
             rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in RES. inv RES. }
           erewrite Memory.split_o in RES; eauto.
           rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in RES. inv RES. }
         simpls.
         assert (PROM' :
                   Memory.get l to promises' = Some (from, Message.reserve)).
         { destruct (Rel w) eqn:RELB; subst; auto. }
         erewrite Memory.split_o in PROM'; eauto.
         rewrite (loc_ts_eq_dec_neq LL) in PROM'.
         destruct (loc_ts_eq_dec (l, to) (locw, f_to' ws)) as [[A' B']|LL'].
         { simpls; rewrite A' in *; rewrite B' in *.
           rewrite (loc_ts_eq_dec_eq locw (f_to' ws)) in PROM'.
           inv PROM'. }
         simpls. rewrite (loc_ts_eq_dec_neq LL') in PROM'.
         edestruct SIM_RES_PROM as [b H]; eauto; desc.
         exists b. splits; auto.
         { generalize RES0. clear. basic_solver. }
         { intros [A|A]; desf. }
         { rewrite REQ_FROM; auto. intros HH; subst.
           assert (Some l = Some locw) as BB.
           { rewrite <- LOC0. by rewrite <- SAME_LOC. }
           inv BB. }
         rewrite REQ_TO; auto. by intros HH; subst. }
       { ins.
         rewrite IdentMap.gso in TID'; auto.
         destruct (loc_ts_eq_dec (loc, to) (locw, (f_to' w))) as [EQ|NEQ]; simpls.
         { desc. subst. right.
           destruct (Memory.get locw (f_to' w) (Local.promises local')) eqn: HH; auto.
           exfalso.
           erewrite NINTER in HH; eauto. inv HH. }
         edestruct (PROM_DISJOINT TNEQ TID') as [HH|HH]; eauto.
         left.
         enough (Memory.get loc to promises' = None).
         { destruct (Rel w) eqn:RELB; subst; auto.
           erewrite Memory.remove_o; eauto. by rewrite (loc_ts_eq_dec_neq NEQ). }
         erewrite Memory.split_o; eauto.
         rewrite (loc_ts_eq_dec_neq NEQ).
         destruct (loc_ts_eq_dec (loc, to) (locw, (f_to' ws))) as [[A' B']|NEQ'].
         2: by rewrite (loc_ts_eq_dec_neq NEQ').
         simpls; rewrite A' in *; rewrite B' in *.
         exfalso. rewrite REQ_TO in HH; auto.
         rewrite HH in WSPROM. inv WSPROM. }
       { red. ins.
         destruct ISSB as [ISSB|]; subst.
         { edestruct SIM_MEM as [rel_opt HH]; eauto. simpls. desc.
           exists rel_opt. unnw.
           destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' w))) as [EQ|NEQ]; simpls; desc; subst.
           { exfalso.
             assert (b = w); [|by desf].
             eapply f_to_eq; try apply FCOH0; eauto.
             { red. by rewrite LOC. }
             { do 2 left. by apply ETCCOH.(etc_I_in_S). }
             clear. basic_solver. }
           destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' ws))) as [EQ|NEQ']; simpls; desc; subst.
           { assert (b = ws); subst.
             { eapply f_to_eq; try apply FCOH0; eauto.
               { red. by rewrite SAME_LOC. }
               { do 2 left. by apply ETCCOH.(etc_I_in_S). }
               basic_solver. }
             rewrite INMEM in WSMEM. inv WSMEM.
             splits; eauto.
             { red. splits; eauto. left. apply FCOH0; auto.
               basic_solver. }
             ins. destruct HH1 as [HH1 HH2]; auto.
             split; auto.
             desc. exists p_rel0. split.
             { rewrite ISSEQ_TO with (e:=ws); auto. desf. }
             destruct HH0 as [AA|]; desc; [left; split; auto|right].
             { intros HH. apply NWEXWS. red. generalize HH. clear. basic_solver. }
             exfalso. apply NWEXWS. red. generalize H2. clear. basic_solver. }

           assert (b <> ws) as NWSNEQ.
           { intros SUBST; subst.
             destruct NEQ' as [AA|]; eauto. rewrite LOC0 in SAME_LOC. inv SAME_LOC. }
           erewrite Memory.split_o with (mem2:=memory'); eauto.
           rewrite !loc_ts_eq_dec_neq; auto.
           splits; eauto.
           { rewrite ISSEQ_TO; auto. rewrite ISSEQ_FROM; auto. }
           { rewrite ISSEQ_FROM; auto. eapply sim_mem_helper_f_issued; eauto. }
           intros AA BB.
           assert (~ covered T b) as NCOVBB.
           { intros HH. apply BB. generalize HH. clear. basic_solver. }
           specialize (HH1 AA NCOVBB).
           desc. splits; auto.
           { apply NOTNEWP; auto.
             rewrite ISSEQ_TO; auto. rewrite ISSEQ_FROM; auto. }
           eexists. splits; eauto.
           2: { destruct HH2 as [[CC DD]|CC]; [left|right].
                { split; eauto. intros [y HH]. destruct_seq_l HH as OO.
                  destruct OO as [OO|]; subst.
                  { apply CC. exists y. apply seq_eqv_l. by split. }
                  apply NISSB. eapply rfrmw_I_in_I; eauto. exists b.
                  apply seqA. apply seq_eqv_r. by split. }
                desc. exists p. splits; auto.
                { by left. }
                assert (loc lab p = Some l) as PLOC.
                { rewrite <- LOC0. by apply wf_rfrmwl. }
                eexists. splits; eauto.
                assert (l <> locw \/ f_to' p <> f_to' w) as NEQ''.
                { destruct (classic (l = locw)); subst; [right|left]; auto.
                  intros HH. eapply f_to_eq in HH; eauto; subst; auto.
                  { red. by rewrite PLOC. }
                  { do 2 left. by apply ETCCOH.(etc_I_in_S). }
                  clear. basic_solver. }
                destruct (classic (p = ws)) as [|NEQPWS]; subst.
                2: { apply NOTNEWM; auto.
                     2: by rewrite ISSEQ_TO; auto; rewrite ISSEQ_FROM.
                     destruct (classic (l = locw)) as [|LNEQ]; subst; auto.
                     right. intros HH. eapply f_to_eq in HH; eauto.
                     { red. by rewrite PLOC. }
                     all: by do 2 left; apply ETCCOH.(etc_I_in_S). }
                rewrite PLOC in SAME_LOC. inv SAME_LOC.
                erewrite Memory.split_o; eauto.
                rewrite loc_ts_eq_dec_neq; auto.
                rewrite loc_ts_eq_dec_eq; auto. by rewrite FEQ1. }
           destruct (Rel w) eqn:RELW; eauto.
           { by desf. }
             by rewrite ISSEQ_TO. }

         assert (Some l = Some locw) as QQ.
         { by rewrite <- LOC0. }
         inv QQ.
         eexists. splits; eauto.
         intros _ NT.
         destruct (Rel b); desf.
         splits.
         { erewrite Memory.split_o; eauto. rewrite loc_ts_eq_dec_eq; eauto. }
         exists p_rel. splits; eauto. left.
         cdes PREL. destruct PREL1; desc.
         2: { exfalso. apply NWEX. red. generalize INRMW. clear. basic_solver. }
         split; auto.
         intros [a HH].
         apply seq_eqv_l in HH. destruct HH as [[HH|] RFRMW]; subst; eauto.
         { apply NINRMW. generalize HH RFRMW. clear. basic_solver 10. }
         eapply wf_rfrmw_irr; eauto. }
       { red. ins.
         assert (b <> w /\ ~ issued T b) as [BNEQ NISSBB].
         { generalize NISSB0. clear. basic_solver. }
         assert (b <> ws) as BNEQ'.
         { intros HH; subst. eauto. }
         destruct RESB as [[SB|]|HH]; subst.
         3: { exfalso. eapply NONEXT; eauto. }
         2: by desf.
         unnw.
         erewrite Memory.split_o with (mem2:=memory'); eauto.
         destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' w))) as [PEQ'|PNEQ];
           simpls; desc; subst.
         { exfalso. apply BNEQ.
           eapply f_to_eq with (f_to:=f_to'); eauto. red.
           { by rewrite LOC. }
           { by do 2 left. }
           clear. basic_solver. }
         rewrite (loc_ts_eq_dec_neq PNEQ).
         destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' ws))) as [PEQ''|PNEQ'];
           simpls; desc; subst.
         { exfalso. apply BNEQ'.
           eapply f_to_eq with (f_to:=f_to'); eauto. red.
           { by rewrite LOC0. }
           all: by do 2 left. }
         rewrite (loc_ts_eq_dec_neq PNEQ').
         edestruct SIM_RES_MEM with (b:=b); eauto; unnw.
         rewrite REQ_TO; auto. rewrite REQ_FROM; auto.
         splits; ins.
         apply NOTNEWP; auto.
         all: rewrite <- REQ_TO; auto. }
       intros WREL. exfalso. desf. }
  red in HH. desc. exists p_rel. splits; eauto.
  left. exists f_to', f_from'. splits; eauto.
  exists promises', memory'. splits; eauto.

  set (rel'' :=
        if is_rel lab w
        then (TView.cur (Local.tview local))
        else (TView.rel (Local.tview local) locw)).
  set (rel' := (View.join (View.join rel'' p_rel.(View.unwrap))
                          (View.singleton_ur locw (f_to' w)))).

  assert (exists promises'',
             ⟪ PEQ :
                 if Rel w
                 then Memory.remove promises' locw (f_from' w) (f_to' w)
                                    (Message.full valw (Some rel')) promises''
                 else promises'' = promises' ⟫).
  { destruct (is_rel lab w) eqn:REL; eauto.
    edestruct Memory.remove_exists as [promises''].
    2: { exists promises''. eauto. }
    erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_eq; auto. }
  desc.
  exists promises''. simpls.

  assert (Memory.le promises' memory') as PP.
  { eapply memory_le_add2; eauto. }

  assert (forall thread' langst' local' (TNEQ : tid w <> thread')
                 (TID' : IdentMap.find thread' (Configuration.threads PC) =
                         Some (langst', local')),
             Memory.get locw (f_to' w) (Local.promises local') = None) as NINTER.
  (* TODO: Move to IssueInterval.v? *)
  { ins.
    destruct (Memory.get locw (f_to' w) (Local.promises local')) eqn:HH; auto.
    exfalso. destruct p as [from].
    eapply PROM_IN_MEM in HH; eauto.
    set (AA := HH). apply Memory.get_ts in AA.
    destruct AA as [|AA]; desc; eauto.
    apply DISJOINT in HH.
    apply HH with (x:=f_to' w); constructor; simpls; try reflexivity.
    apply FCOH0; auto. clear. basic_solver. }

  assert (forall tmap (MCLOS : Memory.closed_timemap tmap PC.(Configuration.memory)),
             Memory.closed_timemap tmap memory') as MADDCLOS.
  { ins. eapply Memory.add_closed_timemap; eauto. }

  assert (Memory.le promises'' promises') as LEPADD.
  { destruct (Rel w) eqn:RELB; subst; [|reflexivity].
    eapply memory_remove_le; eauto. }

  assert (Memory.le promises'' memory') as NEW_PROM_IN_MEM.
  { etransitivity; eauto. }

  (* assert (forall l to from msg  *)
  (*                (NEQ : l <> locw \/ to <> f_to w), *)
  (*            Memory.get l to promises_cancel = Some (from, msg) <-> *)
  (*            Memory.get l to local.(Local.promises) = Some (from, msg)) *)
  (*   as NOTNEWC. *)
  (* { ins. erewrite Memory.remove_o; eauto. *)
  (*   rewrite loc_ts_eq_dec_neq; auto. } *)

  assert (forall l to from msg
                 (NEQ : l <> locw \/ to <> f_to' w),
             Memory.get l to memory' = Some (from, msg) <->
             Memory.get l to PC.(Configuration.memory) = Some (from, msg))
    as NOTNEWM.
  { ins. erewrite Memory.add_o; eauto.
    rewrite loc_ts_eq_dec_neq; auto. }

  assert (forall l to from msg
                 (NEQ : l <> locw \/ to <> f_to' w),
             Memory.get l to promises' = Some (from, msg) <->
             Memory.get l to local.(Local.promises) = Some (from, msg))
    as NOTNEWA.
  { ins. erewrite Memory.add_o; eauto.
    rewrite loc_ts_eq_dec_neq; auto. }

  assert (forall l to from msg
                 (NEQ : l <> locw \/ to <> f_to' w),
             Memory.get l to promises'' = Some (from, msg) <->
             Memory.get l to local.(Local.promises) = Some (from, msg))
    as NOTNEWP.
  { ins. destruct (Rel w); subst; auto.
    erewrite Memory.remove_o; eauto. rewrite loc_ts_eq_dec_neq; auto. }

  assert (~ Rel w ->
          Memory.get locw (f_to' w) promises'' =
          Some (f_from' w, Message.full valw (Some rel')))
    as INP''.
  { ins. destruct (Rel w); subst; [by desf|].
    erewrite Memory.add_o; eauto. by rewrite loc_ts_eq_dec_eq. }

  splits; eauto.
  { ins.
    destruct (Ident.eq_dec (tid e) (tid w)) as [EQ|NEQ].
    { rewrite EQ. rewrite IdentMap.gss.
      eexists. eauto. }
    rewrite IdentMap.gso; auto. }
  { intros QQ l.
    assert (max_value f_to' (S_tm G l (covered T)) (LocFun.find l (Configuration.sc PC))) as BB.
    { eapply sc_view_f_issued; eauto. }
    destruct (Rel w); auto.
    eapply max_value_same_set.
    { apply BB. }
    eapply s_tm_n_f_steps.
    { apply TCCOH. }
    { clear. basic_solver. }
    intros a [HB|HB] HH AA.
    { eauto. }
    subst. clear -WW AA. type_solver. }
  { ins.
    destruct (Ident.eq_dec thread' (tid w)) as [EQ|NEQ].
    { subst. rewrite IdentMap.gss in TID0.
      inv TID0; simpls; clear TID0. }
    red; ins; rewrite IdentMap.gso in TID0; auto.
    erewrite Memory.add_o; eauto.
    destruct (loc_ts_eq_dec (loc, to) (locw, f_to' w)) as [[A B]|LL].
    { simpls; rewrite A in *; rewrite B in *; subst.
      exfalso. erewrite NINTER in LHS; eauto. inv LHS. }
    rewrite (loc_ts_eq_dec_neq LL).
    eapply PROM_IN_MEM in LHS; eauto. }
  { simpls. red. ins.
    destruct (loc_ts_eq_dec (l, to) (locw, f_to' w)) as [[A' B']|LL].
    { simpls; rewrite A' in *; rewrite B' in *.
      destruct (Rel w) eqn:RELB; subst.
      { erewrite Memory.remove_o in PROM; eauto.
        rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in PROM. inv PROM. }
      erewrite Memory.add_o in PROM; eauto.
      rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in PROM.
      inv PROM. exists w. splits; eauto. by right. }
    eapply NOTNEWP in PROM; eauto.
    edestruct SIM_PROM as [b H]; eauto; desc.
    exists b; splits; auto.
    { by left. }
    { assert (W b) as WB by (eapply issuedW; eauto).
      destruct (Rel w) eqn:RELB; auto.
      intros [HH|HH]; desf. }
    { by rewrite ISSEQ_FROM. }
    { by rewrite ISSEQ_TO. }
    eapply sim_mem_helper_f_issued with (f_to:=f_to); eauto. }
  { simpls. red. ins.
    destruct (loc_ts_eq_dec (l, to) (locw, f_to' w)) as [[A' B']|LL].
    { simpls; rewrite A' in *; rewrite B' in *.
      destruct (Rel w) eqn:RELB; subst.
      { erewrite Memory.remove_o in RES; eauto.
        rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in RES. inv RES. }
      erewrite Memory.add_o in RES; eauto.
      rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in RES. inv RES. }
    apply NOTNEWP in RES; auto.
    edestruct SIM_RES_PROM as [b H]; eauto; desc.
    exists b. splits; auto.
    { generalize RES0. basic_solver. }
    { intros [A|A]; desf. }
    { rewrite REQ_FROM; auto. by intros HH; subst. }
      rewrite REQ_TO; auto. by intros HH; subst. }
  { ins.
    rewrite IdentMap.gso in TID'; auto.
    destruct (loc_ts_eq_dec (loc, to) (locw, (f_to' w))) as [EQ|NEQ]; simpls.
    { desc. subst. right.
      destruct (Memory.get locw (f_to' w) (Local.promises local')) eqn: HH; auto.
      exfalso.
      erewrite NINTER in HH; eauto. inv HH. }
    edestruct (PROM_DISJOINT TNEQ TID') as [HH|HH]; eauto.
    left.
    destruct (Memory.get loc to promises'') eqn:BB; auto.
    destruct p. eapply NOTNEWP in BB; eauto. desf. }
  { red. ins.
    destruct ISSB as [ISSB|]; subst.
    { edestruct SIM_MEM as [rel_opt HH]; eauto. simpls. desc.
      exists rel_opt. unnw.
      destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' w))) as [EQ|NEQ]; simpls; desc; subst.
      { exfalso.
        assert (b = w); [|by desf].
        eapply f_to_eq; try apply FCOH0; eauto.
        { red. by rewrite LOC. }
        { do 2 left. by apply ETCCOH.(etc_I_in_S). }
        clear. basic_solver. }
      erewrite Memory.add_o with (mem2:=memory'); eauto.
      rewrite !loc_ts_eq_dec_neq; auto.
      splits; eauto.
      { rewrite ISSEQ_TO; auto. rewrite ISSEQ_FROM; auto. }
      { rewrite ISSEQ_FROM; auto. eapply sim_mem_helper_f_issued; eauto. }
      intros AA BB.
      assert (~ covered T b) as NCOVBB.
      { intros HH. apply BB. generalize HH. clear. basic_solver. }
      specialize (HH1 AA NCOVBB).
      desc. splits; auto.
      { apply NOTNEWP; auto.
        rewrite ISSEQ_TO; auto. rewrite ISSEQ_FROM; auto. }
      eexists. splits; eauto.
      2: { destruct HH2 as [[CC DD]|CC]; [left|right].
           { split; eauto. intros [y HH]. destruct_seq_l HH as OO.
             destruct OO as [OO|]; subst.
             { apply CC. exists y. apply seq_eqv_l. by split. }
             apply NISSB. eapply rfrmw_I_in_I; eauto. exists b.
             apply seqA. apply seq_eqv_r. by split. }
           desc. exists p. splits; auto.
           { by left. }
           eexists. splits; eauto.
           rewrite ISSEQ_TO; auto. rewrite ISSEQ_FROM; auto.
           apply NOTNEWM; auto.
           destruct (classic (l = locw)) as [|LNEQ]; subst; auto.
           right. intros HH.
           rewrite <- ISSEQ_TO in HH; auto.
           eapply f_to_eq in HH; eauto; subst; auto.
           { red. rewrite LOC. rewrite <- LOC0. by apply WF.(wf_rfrmwl). }
           { do 2 left. by apply ETCCOH.(etc_I_in_S). }
           clear. basic_solver. }
      destruct (Rel w) eqn:RELW; auto.
      2: by rewrite ISSEQ_TO.
      assert (wmod (mod lab w) = Ordering.acqrel) as MM.
      { clear -RELW. mode_solver. }
      rewrite MM.
      unfold TView.rel, TView.write_tview.
      arewrite (Ordering.le Ordering.acqrel Ordering.acqrel = true) by reflexivity.
      destruct (classic (l = locw)) as [|LNEQ]; subst.
      2: { unfold LocFun.add. rewrite Loc.eq_dec_neq; auto. by rewrite ISSEQ_TO. }
      exfalso.
      assert (E b) as EB by (eapply issuedE; eauto).
      assert (W b) as WB by (eapply issuedW; eauto).
      assert ((⦗E⦘ ⨾ same_tid ⨾ ⦗E⦘) w b) as ST.
      { apply seq_eqv_lr. by splits. }
      apply tid_sb in ST. destruct ST as [[[|ST]|ST]|[AI BI]]; subst; auto.
      2: { apply NCOVBB. apply ISSUABLE. exists w. apply seq_eqv_r. split; auto.
           apply sb_to_w_rel_in_fwbob. apply seq_eqv_r. split; auto. by split. }
      assert (issuable G sc T b) as IB by (eapply issued_in_issuable; eauto).
      apply NCOVB. apply IB. exists b. apply seq_eqv_r. split; auto.
      apply sb_from_w_rel_in_fwbob; auto. apply seq_eqv_lr. splits; auto.
      all: split; auto. red. by rewrite LOC. }
    assert (Some l = Some locw) as QQ.
    { by rewrite <- LOC0. }
    inv QQ.
    eexists. splits; eauto.
    { erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_eq; eauto. }
    { apply HELPER. }
    { apply RELWFEQ. }
    { apply RELMCLOS. }
    intros _ NT.
    destruct (Rel b); desf.
    { exfalso. apply NT. by right. }
    splits.
    { erewrite Memory.add_o; eauto. rewrite loc_ts_eq_dec_eq; eauto. }
    exists p_rel. splits; eauto. left.
    cdes PREL. destruct PREL1; desc.
    2: { exfalso. apply NWEX. red. generalize INRMW. clear. basic_solver. }
    split; auto.
    intros [a HH].
    apply seq_eqv_l in HH. destruct HH as [[HH|] RFRMW]; subst; eauto.
    { apply NINRMW. generalize HH RFRMW. clear. basic_solver 10. }
    eapply wf_rfrmw_irr; eauto. }
  { red. ins.
    assert (b <> w /\ ~ issued T b) as [BNEQ NISSBB].
    { generalize NISSB0. clear. basic_solver. }
    destruct RESB as [[SB|]|HH]; subst.
    3: { exfalso. eapply NONEXT; eauto. }
    2: by desf.
    unnw.
    erewrite Memory.add_o with (mem2:=memory'); eauto.
    destruct (loc_ts_eq_dec (l, f_to' b) (locw, (f_to' w))) as [PEQ'|PNEQ];
      simpls; desc; subst.
    { exfalso. apply BNEQ.
      eapply f_to_eq with (f_to:=f_to'); eauto. red.
      { by rewrite LOC. }
      { by do 2 left. }
      clear. basic_solver. }
    edestruct SIM_RES_MEM with (b:=b); eauto; unnw.
    rewrite !(loc_ts_eq_dec_neq PNEQ); auto.
    rewrite REQ_TO; auto. rewrite REQ_FROM; auto.
    splits; ins.
    apply NOTNEWP; auto. rewrite <- REQ_TO; auto. }
  intros WREL. red. ins. destruct msg; auto.
  rewrite WREL in PEQ.
  exfalso.
  erewrite Memory.remove_o in GET; eauto.
  destruct (loc_ts_eq_dec (locw, t) (locw, f_to' w)) as [AA|NEQ]; simpls.
  { desc; subst. rewrite (loc_ts_eq_dec_eq locw (f_to' w)) in GET.
    inv GET. }
  rewrite (loc_ts_eq_dec_neq NEQ) in GET.
  erewrite Memory.add_o in GET; eauto.
  rewrite (loc_ts_eq_dec_neq NEQ) in GET.
  eapply SIM_PROM in GET. desc; subst.
  assert (E b) as EB.
  { eapply issuedE; eauto. }
  assert (W b) as WB.
  { eapply issuedW; eauto. }
  assert ((⦗E⦘ ⨾ same_tid ⨾ ⦗E⦘) b w) as HH.
  { apply seq_eqv_lr. splits; auto. }
  apply tid_sb in HH. destruct HH as [[[HH|HH]|HH]|[AA BB]]; subst; auto.
  2: { apply NCOVB. eapply dom_W_Rel_sb_loc_I_in_C; eauto.
       exists b. apply seq_eqv_l. split; [by split|].
       apply seqA.
       do 2 (apply seq_eqv_r; split; auto).
       split; auto. red. rewrite LOC. auto. }
  apply NCOV. apply ISSUABLE. exists w. apply seq_eqv_r. split; auto.
  apply sb_to_w_rel_in_fwbob. apply seq_eqv_r.
  do 2 (split; auto).
Qed.

End IssueStepHelper.


(** * Implementation of Section 4.4 *)
Require Import RL.Utilities.Rpos.
Require Import RL.Utilities.riesz_logic_List_more.
Require Import RL.hmr.term.
Require Import RL.hmr.hseq.
Require Import RL.hmr.hmr.
Require Import RL.hmr.semantic.
Require Import RL.hmr.interpretation.
Require Import RL.hmr.tech_lemmas.
Require Import RL.hmr.lambda_prop_tools.
Require Import RL.hmr.soundness.
Require Import RL.hmr.tactics.

Require Import Lra.
Require Import Lia.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Local Open Scope R_scope.

(** ** First formulation : A = B implies |- 1.A,1.-B and |- 1.B, 1.-A are derivable *)
(** Proof of Lemma 4.20 *)
Lemma completeness_1 : forall A B r, A === B -> HMR_M_can (((r, -S B) :: (r, A) :: nil) :: nil)
with completeness_2 : forall A B r, A === B -> HMR_M_can (((r, -S A) :: (r, B) :: nil) :: nil).
Proof with try assumption; try reflexivity.
  - intros A B r Heq; destruct Heq.
    + change ((r, -S t) :: (r, t) :: nil) with ((vec (r :: nil) (-S t)) ++ (vec (r :: nil) t) ++ nil).
      apply hmrr_ID_gen...
      apply hmrr_INIT.
    + apply hmrr_can with t2 (r :: nil) (r :: nil)...
      apply hmrr_ex_seq with (((r, -S t2) :: (r, t1) :: nil) ++ ((r, -S t3) :: (r, t2) :: nil)); [ Permutation_Type_solve | ].
      apply hmrr_M; try reflexivity; [ apply (completeness_1 _ _ _ Heq1) | apply (completeness_1 _ _ _ Heq2)].
    + revert r; induction c; (try rename r into r0); intros r.
      * apply completeness_1.
        apply Heq.
      * eapply hmrr_ex_seq ; [ apply Permutation_Type_swap | ].
        apply completeness_2.
        simpl; rewrite minus_minus; apply Heq.
      * simpl; change ((r, -S t) :: (r, t) :: nil) with ((vec (r :: nil) (-S t)) ++ (vec (r :: nil) t) ++ nil).
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * simpl.
        change ((r, MRS_covar v) :: (r, MRS_var v) :: nil) with ((vec (r :: nil) (MRS_covar v)) ++ (vec (r :: nil) (MRS_var v)) ++ nil).
        apply hmrr_ID...
        apply hmrr_INIT.
      * simpl.
        apply hmrr_ex_seq with ((vec (r :: nil) (MRS_covar v)) ++ (vec (r :: nil) (MRS_var v)) ++ nil) ; [Permutation_Type_solve | ].
        apply hmrr_ID...
        apply hmrr_INIT.
      * simpl.
        change ((r, MRS_zero) :: (r, MRS_zero) :: nil) with ((vec (r:: r:: nil) MRS_zero) ++ nil).
        apply hmrr_Z.
        apply hmrr_INIT.
      * unfold evalContext; fold evalContext.
        unfold MRS_minus; fold MRS_minus.
        apply hmrr_ex_seq with ((vec (r :: nil) (evalContext c1 t1 /\S evalContext c2 t1)) ++ (vec (r :: nil) (-S evalContext c1 t2 \/S -S evalContext c2 t2)) ++ nil) ; [ Permutation_Type_solve | ].
        apply hmrr_min.
        -- apply hmrr_ex_seq with  ((vec (r :: nil) (-S evalContext c1 t2 \/S -S evalContext c2 t2)) ++ (vec (r :: nil) (evalContext c1 t1)) ++ nil); [ Permutation_Type_solve | ].
           apply hmrr_max.
           apply hmrr_W.
           apply IHc1.
        -- apply hmrr_ex_seq with  ((vec (r :: nil) (-S evalContext c1 t2 \/S -S evalContext c2 t2)) ++ (vec (r :: nil) (evalContext c2 t1)) ++ nil); [ Permutation_Type_solve | ].
           apply hmrr_max.
           eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ].
           apply hmrr_W.
           eapply hmrr_ex_seq ; [ | apply IHc2].
           Permutation_Type_solve.
      * unfold evalContext; fold evalContext.
        unfold MRS_minus; fold MRS_minus.
        change ((r, -S evalContext c1 t2 /\S -S evalContext c2 t2)
                  :: (r, evalContext c1 t1 \/S evalContext c2 t1) :: nil) with
            ((vec (r ::nil) (-S evalContext c1 t2 /\S -S evalContext c2 t2)) ++ (vec (r ::nil) (evalContext c1 t1 \/S evalContext c2 t1)) ++ nil).
        apply hmrr_min.
        -- apply hmrr_ex_seq with  ((vec (r :: nil) (evalContext c1 t1 \/S evalContext c2 t1)) ++ (vec (r :: nil) (-S evalContext c1 t2)) ++ nil); [ Permutation_Type_solve | ].
           apply hmrr_max.
           apply hmrr_W.
           eapply hmrr_ex_seq ; [ | apply IHc1].
           Permutation_Type_solve.
        -- apply hmrr_ex_seq with  ((vec (r :: nil) (evalContext c1 t1 \/S evalContext c2 t1)) ++ (vec (r :: nil) (-S evalContext c2 t2)) ++ nil); [ Permutation_Type_solve | ].
           apply hmrr_max.
           eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ].
           apply hmrr_W.
           eapply hmrr_ex_seq ; [ | apply IHc2].
           Permutation_Type_solve.
      * unfold evalContext; fold evalContext; unfold MRS_minus; fold MRS_minus.
        change ((r, (-S evalContext c1 t2) -S (evalContext c2 t2))
                  :: (r, evalContext c1 t1 +S evalContext c2 t1) :: nil)
          with ((vec (r :: nil) ((-S evalContext c1 t2) -S (evalContext c2 t2))) ++ (vec (r :: nil) (evalContext c1 t1 +S evalContext c2 t1)) ++ nil).
        apply hmrr_plus.
        apply hmrr_ex_seq with (vec (r :: nil) (evalContext c1 t1 +S evalContext c2 t1) ++
                               vec (r :: nil) (-S evalContext c1 t2) ++
                               vec (r :: nil) (-S evalContext c2 t2) ++ nil) ; [ Permutation_Type_solve | ].
        apply hmrr_plus.
        apply hmrr_ex_seq with (((r, -S evalContext c1 t2) :: (r, evalContext c1 t1) :: nil) ++ ((r, -S evalContext c2 t2) :: (r, evalContext c2 t1) :: nil)) ; [ Permutation_Type_solve | ].
        apply hmrr_M; try reflexivity; [ apply IHc1 | apply IHc2].
      * unfold evalContext; fold evalContext; unfold MRS_minus; fold MRS_minus.
        change ((r, r0 *S (-S evalContext c t2)) :: (r, r0 *S evalContext c t1) :: nil) with ((vec (r :: nil) (r0 *S (-S evalContext c t2))) ++ (vec (r :: nil) (r0 *S evalContext c t1)) ++ nil).
        apply hmrr_mul.
        apply hmrr_ex_seq with (vec (r :: nil) (r0 *S evalContext c t1) ++ vec (mul_vec r0 (r :: nil)) (-S evalContext c t2) ++  nil) ; [ Permutation_Type_solve | ].
        apply hmrr_mul.
        simpl.
        eapply hmrr_ex_seq; [ | apply IHc].
        Permutation_Type_solve.
      * simpl.
        change ((r, MRS_coone) :: (r, MRS_one) :: nil) with (vec (r :: nil) MRS_coone ++ vec (r :: nil) MRS_one ++ nil).
        apply hmrr_one; [ | apply hmrr_INIT].
        simpl; nra.
      * eapply hmrr_ex_seq;  [ apply Permutation_Type_swap | ].
        simpl.
        change ((r, MRS_coone) :: (r, MRS_one) :: nil) with (vec (r :: nil) MRS_coone ++ vec (r :: nil) MRS_one ++ nil).
        apply hmrr_one; [ | apply hmrr_INIT].
        simpl; nra.
      * simpl in *.
        change ((r, <S> (-S evalContext c t2)) :: (r, <S> evalContext c t1) :: nil) with (seq_diamond ((r , (-S evalContext c t2)) :: (r , evalContext c t1) :: nil)).
        apply hmrr_diamond_no_one.
        apply IHc.
    + apply (completeness_2 _ _ _ Heq).
    + replace (((r, -S subs t2 n t) :: (r, subs t1 n t) :: nil) :: nil) with (subs_hseq (((r, -S t2) :: (r, t1) :: nil) :: nil) n t) by now rewrite <-eq_subs_minus.
      apply subs_proof.
      apply completeness_1; apply Heq.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can. do_HMR_logical.
      apply hmrr_ex_seq with ((vec (r :: nil) (-S t1)) ++ (vec (r :: nil) (t1)) ++ (vec (r :: nil) (-S t2)) ++ (vec (r :: nil) (t2)) ++ (vec (r :: nil) (-S t3)) ++ (vec (r :: nil) (t3)) ++ nil); [ Permutation_Type_solve | ].
      do 3 (apply hmrr_ID_gen; try reflexivity).
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ex_seq with ((vec (r :: nil) (-S t1)) ++ (vec (r :: nil) (t1)) ++ (vec (r :: nil) (-S t2)) ++ (vec (r :: nil) (t2)) ++ nil); [ Permutation_Type_solve | ].
      do 2 (apply hmrr_ID_gen; try reflexivity).
      apply hmrr_INIT.
    + unfold HMR_M_can; do_HMR_logical.
      pattern t at 1; rewrite <- minus_minus.
      apply hmrr_ID_gen...
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      pattern t at 1; rewrite <-(minus_minus t).
      rewrite<- ? app_assoc; apply hmrr_ID_gen...
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      unfold mul_vec.
      apply hmrr_ex_seq with ((vec ((time_pos (minus_pos Hlt) r) ::(time_pos b r) :: nil) (-S t)) ++ (vec ((time_pos a r) :: nil) t) ++ nil); [ Permutation_Type_solve | ].
      apply hmrr_ID_gen ; [ | apply hmrr_INIT ].
      simpl; destruct a; destruct b; destruct r; unfold minus_pos.
      simpl; nra.
    + pattern t at 2; rewrite <- minus_minus.
      apply hmrr_ex_seq with ((vec (r :: nil) (One *S (-S (-S t)))) ++ (vec (r :: nil) (-S t)) ++ nil); [ Permutation_Type_solve | ].
      apply hmrr_mul.
      apply hmrr_ID_gen; [ destruct r; simpl; nra | apply hmrr_INIT].
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      pattern t at 1; rewrite <- minus_minus.
      apply hmrr_ID_gen ; [ | apply hmrr_INIT].
      destruct r; destruct x; destruct y; simpl.
      nra.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ex_seq with ((vec (mul_vec x (r :: nil)) (-S t1)) ++ (vec (mul_vec x (r :: nil)) ( t1)) ++ (vec (mul_vec x (r :: nil)) (-S t2))++ (vec (mul_vec x (r :: nil)) (t2)) ++ nil) ; [ Permutation_Type_solve | ].
      do 2 (apply hmrr_ID_gen; try reflexivity).
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      unfold mul_vec.
      apply hmrr_ex_seq with ((vec ((time_pos x r) :: (time_pos y r) :: nil) (-S t)) ++ (vec (time_pos (plus_pos x y) r :: nil) t) ++ nil) ; [ Permutation_Type_solve | ].
      apply hmrr_ID_gen; [ | apply hmrr_INIT].
      destruct r; destruct x; destruct y; unfold plus_pos; simpl; nra.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ID_gen ; [ | apply hmrr_INIT].
      simpl; nra.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_W; apply hmrr_W.
        pattern t1 at 1; rewrite <- (minus_minus).
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W; eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        pattern t2 at 1; rewrite <- (minus_minus).
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | apply hmrr_W ; eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | apply hmrr_W]].
        pattern t3 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        pattern t2 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W.
        pattern t1 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_W.
        pattern t1 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W.
        pattern t1 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_W; eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ]; apply hmrr_W; eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W; apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * pattern t1 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W.
        pattern t1 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_W.
        rewrite <- app_assoc.
        apply hmrr_ID_gen...
        pattern t3 at 1; rewrite<- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        rewrite <-app_assoc; apply hmrr_ID_gen...
        pattern t3 at 1; rewrite<- minus_minus; apply hmrr_ID_gen...
        apply hmrr_INIT.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        rewrite <-app_assoc; apply hmrr_ID_gen...
        pattern t3 at 1; rewrite<- minus_minus; apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_INIT.
      * simpl.
        eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ].
        apply hmrr_W.
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      change (vec (r :: nil) (<S> (-S t1)) ++ vec (r :: nil) (<S> (-S t2)) ++ vec (r :: nil) (<S> (t1 +S t2)) ++ nil)
        with
          (seq_diamond (vec (r :: nil) (-S t1) ++ vec (r :: nil) (-S t2) ++ vec (r :: nil) (t1 +S t2) ++ nil)).
      apply hmrr_diamond_no_one.
      do_HMR_logical.
      apply hmrr_ex_seq with (vec (r :: nil) (-S t2) ++ vec (r :: nil) t2 ++ vec (r :: nil) (-S t1) ++ vec (r :: nil) t1 ++ nil); [ Permutation_Type_solve | ].
      apply hmrr_ID_gen; try reflexivity.
      apply hmrr_ID_gen; try reflexivity.
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      change (vec (mul_vec r0 (r :: nil)) (<S> (-S t)) ++ vec (r :: nil) (<S> (r0 *S t)) ++ nil)
        with
          (seq_diamond (vec (mul_vec r0 (r :: nil)) (-S t) ++ vec (r :: nil) (r0 *S t) ++ nil)).
      apply hmrr_diamond_no_one.
      do_HMR_logical.
      pattern t at 1.
      rewrite <- minus_minus.
      apply hmrr_ID_gen; try reflexivity.
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * change (<S> MRS_one) with (-S (<S> MRS_coone)).
        apply hmrr_ID_gen; try reflexivity.
        apply hmrr_INIT.
      * rewrite app_nil_r.
        change (vec (r :: nil) MRS_one ++ vec (r :: nil) (<S> MRS_coone))
          with
            (vec nil MRS_coone ++ vec (r :: nil) MRS_one ++ seq_diamond (vec (r :: nil) (MRS_coone))).
        apply hmrr_diamond.
        { destruct r as [r Hr]; simpl; apply R_blt_lt in Hr; nra. }
        change MRS_one with (-S MRS_coone).
        rewrite app_nil_l; rewrite <- (app_nil_r (vec (r :: nil) MRS_coone)).
        apply hmrr_ID_gen; try reflexivity.
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical ; try apply hmrr_INIT.
      change (vec (r :: nil) (<S> pos t) ++ nil) with (seq_diamond (vec (r :: nil) (pos t) ++ nil)).
      apply hmrr_diamond_no_one.
      do_HMR_logical; simpl.
      eapply hmrr_ex_hseq;  [ apply Permutation_Type_swap | ].
      apply hmrr_W.
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical ; try apply hmrr_INIT.
      change (vec (r :: nil) MRS_one ++ nil)
        with (vec nil MRS_coone ++ vec (r :: nil) MRS_one ++ nil).
      apply hmrr_one; try apply hmrr_INIT.
      destruct r as [r Hr]; simpl.
      apply R_blt_lt in Hr; nra.
  - intros A B r Heq; destruct Heq.
    + unfold HMR_M_can; HMR_to_vec.
      apply hmrr_ID_gen...
      apply hmrr_INIT.
    + apply hmrr_can with t2 (r :: nil) (r :: nil)...
      apply hmrr_ex_seq with (((r, -S t1) :: (r, t2) :: nil) ++ ((r, -S t2) :: (r, t3) :: nil)); [ Permutation_Type_solve | ].
      apply hmrr_M; try reflexivity; [ apply (completeness_2 _ _ _ Heq1) | apply (completeness_2 _ _ _ Heq2)].
    + revert r;induction c; try (rename r into r0); intros r.
      * apply completeness_2.
        apply Heq.
      * eapply hmrr_ex_seq ; [ apply Permutation_Type_swap | ].
        apply completeness_1.
        simpl; rewrite minus_minus; apply Heq.
      * unfold HMR_M_can; simpl; HMR_to_vec.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * simpl; unfold HMR_M_can; HMR_to_vec.
        apply hmrr_ID...
        apply hmrr_INIT.
      * simpl.
        apply hmrr_ex_seq with ((vec (r :: nil) (MRS_covar v)) ++ (vec (r :: nil) (MRS_var v)) ++ nil) ; [Permutation_Type_solve | ].
        apply hmrr_ID...
        apply hmrr_INIT.
      * simpl.
        unfold HMR_M_can; do_HMR_logical.
        apply hmrr_INIT.
      * unfold evalContext; fold evalContext.
        unfold MRS_minus; fold MRS_minus.
        unfold HMR_M_can; do_HMR_logical.
        -- apply hmrr_W.
           apply IHc1.
        -- eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ]; apply hmrr_W; apply IHc2.
      * unfold evalContext; fold evalContext.
        unfold MRS_minus; fold MRS_minus.
        unfold HMR_M_can; do_HMR_logical.
        -- apply hmrr_W.
           simpl; eapply hmrr_ex_seq ; [ apply Permutation_Type_swap | ].
           apply IHc1.
        -- eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ]; apply hmrr_W.
           eapply hmrr_ex_seq ; [ apply Permutation_Type_swap | ].
           apply IHc2.
      * simpl. unfold HMR_M_can; do_HMR_logical.
        apply hmrr_ex_seq with (((r, -S evalContext c1 t1) :: (r, evalContext c1 t2) :: nil) ++ ((r, -S evalContext c2 t1) :: (r, evalContext c2 t2) :: nil)) ; [ Permutation_Type_solve | ].
        apply hmrr_M; try reflexivity; [apply IHc1 | apply IHc2].
      * simpl; unfold HMR_M_can; do_HMR_logical.
        apply IHc.
      * simpl.
        change ((r, MRS_coone) :: (r, MRS_one) :: nil) with (vec (r :: nil) MRS_coone ++ vec (r :: nil) MRS_one ++ nil).
        apply hmrr_one; [ | apply hmrr_INIT].
        simpl; nra.
      * eapply hmrr_ex_seq;  [ apply Permutation_Type_swap | ].
        simpl.
        change ((r, MRS_coone) :: (r, MRS_one) :: nil) with (vec (r :: nil) MRS_coone ++ vec (r :: nil) MRS_one ++ nil).
        apply hmrr_one; [ | apply hmrr_INIT].
        simpl; nra.
      * simpl in *.
        change ((r, <S> (-S evalContext c t1)) :: (r, <S> evalContext c t2) :: nil) with (seq_diamond ((r , (-S evalContext c t1)) :: (r , evalContext c t2) :: nil)).
        apply hmrr_diamond_no_one.
        apply IHc.
    + apply (completeness_1 _ _ _ Heq).
    + replace (((r, -S subs t1 n t) :: (r, subs t2 n t) :: nil) :: nil) with (subs_hseq (((r, -S t1) :: (r, t2) :: nil) :: nil) n t) by now rewrite <-eq_subs_minus.
      apply subs_proof.
      apply completeness_2; apply Heq.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ex_seq with ((vec (r :: nil) (-S t1)) ++ (vec (r :: nil) (t1)) ++ (vec (r :: nil) (-S t2)) ++ (vec (r :: nil) (t2)) ++ (vec (r :: nil) (-S t3)) ++ (vec (r :: nil) (t3)) ++ nil); [ Permutation_Type_solve | ].
      do 3 (apply hmrr_ID_gen; try reflexivity).
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ex_seq with ((vec (r :: nil) (-S t1)) ++ (vec (r :: nil) (t1)) ++ (vec (r :: nil) (-S t2)) ++ (vec (r :: nil) (t2)) ++ nil); [ Permutation_Type_solve | ].
      do 2 (apply hmrr_ID_gen; try reflexivity).
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ID_gen...
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      rewrite minus_minus.
      rewrite<- ? app_assoc; apply hmrr_ID_gen...
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      unfold mul_vec.
      rewrite minus_minus.
      apply hmrr_ex_seq with ((vec (time_pos a r :: nil) (-S t)) ++ (vec (time_pos (minus_pos Hlt) r :: time_pos b r :: nil) t) ++ nil); [ Permutation_Type_solve | ].
      apply hmrr_ID_gen ; [ | apply hmrr_INIT ].
      destruct r; destruct a; destruct b; unfold minus_pos.
      simpl; nra.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ID_gen; [ | apply hmrr_INIT].
      destruct r; simpl; nra.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ID_gen ; [ | apply hmrr_INIT].
      destruct r; destruct x; destruct y; simpl.
      nra.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ex_seq with ((vec (mul_vec x (r :: nil)) (-S t1)) ++ (vec (mul_vec x (r :: nil)) ( t1)) ++ (vec (mul_vec x (r :: nil)) (-S t2))++ (vec (mul_vec x (r :: nil)) (t2)) ++ nil) ; [ Permutation_Type_solve | ].
      do 2 (apply hmrr_ID_gen; try reflexivity).
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      unfold mul_vec.
      apply hmrr_ex_seq with ((vec (time_pos (plus_pos x y) r :: nil) (-S t)) ++ (vec (time_pos x r :: time_pos y r :: nil) t) ++ nil) ; [ Permutation_Type_solve | ].
      apply hmrr_ID_gen; [ | apply hmrr_INIT].
      destruct r; destruct x; destruct y; unfold plus_pos; simpl; nra.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ID_gen ; [ | apply hmrr_INIT].
      simpl; nra.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_W; eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        pattern t1 at 1; rewrite <- (minus_minus).
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | apply hmrr_W ; eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | apply hmrr_W]].
        pattern t2 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W; apply hmrr_W.
        pattern t3 at 1; rewrite <- (minus_minus).
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        pattern t1 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W.
        pattern t2 at 1; rewrite <- minus_minus.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_W; apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W; eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ]; apply hmrr_W; eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W.
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      * apply hmrr_W; apply hmrr_W.
        apply hmrr_ex_seq with ((vec (r :: nil) (-S t1)) ++ (vec (r :: nil) t1) ++ (vec (r :: nil) (-S t3)) ++ (vec (r :: nil) t3) ++ nil); [ Permutation_Type_solve | ].
        apply hmrr_ID_gen...
        apply hmrr_ID_gen...
        apply hmrr_INIT.
      * apply hmrr_W.
        eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ]; apply hmrr_W.
        apply hmrr_ex_seq with ((vec (r :: nil) (-S t2)) ++ (vec (r :: nil) t2) ++ (vec (r :: nil) (-S t3)) ++ (vec (r :: nil) t3) ++ nil); [ Permutation_Type_solve | ].
        apply hmrr_ID_gen...
        apply hmrr_ID_gen...
        apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      simpl.
      eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ].
      apply hmrr_W.
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ex_seq with (seq_diamond (vec (r :: nil) ((-S t1) -S t2) ++ vec (r :: nil) t1 ++ vec (r :: nil) t2 ++ nil)) ; [ Permutation_Type_solve | ].
      apply hmrr_diamond_no_one.
      apply hmrr_plus.
      apply hmrr_ex_seq with (vec (r :: nil) (-S t2) ++ vec (r :: nil) t2 ++ vec (r :: nil) (-S t1) ++ vec (r :: nil) t1 ++ nil) ; [ Permutation_Type_solve | ].
      apply hmrr_ID_gen; try reflexivity.
      apply hmrr_ID_gen; try reflexivity.
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_ex_seq with (seq_diamond (vec (r :: nil) (r0 *S (-S t)) ++ vec (mul_vec r0 (r :: nil)) t ++ nil)); [Permutation_Type_solve | ].
      apply hmrr_diamond_no_one; apply hmrr_mul.
      apply hmrr_ID_gen; try reflexivity.
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      apply hmrr_W.
      change (vec (r :: nil) (<S> MRS_coone) ++ vec (r :: nil) (<S> MRS_one) ++ nil)
        with (seq_diamond (vec (r :: nil) MRS_coone ++ vec (r :: nil) MRS_one ++ nil)).
      apply hmrr_diamond_no_one.
      apply hmrr_one; simpl; try nra.
      apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      simpl.
      eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ].
      apply hmrr_W; apply hmrr_INIT.
    + unfold MRS_minus; fold MRS_minus.
      unfold HMR_M_can; do_HMR_logical.
      simpl.
      eapply hmrr_ex_hseq; [ apply Permutation_Type_swap | ].
      apply hmrr_W.
      apply hmrr_INIT.
Qed.

(** ** Second formulation *)
(** We use the can rule and the M rule to go from a proof |- 1.G to a proof of G *)
Lemma HMR_sem_seq P : forall G T D,
    HMR P (((One, sem_seq T) :: D) :: G) ->
    HMR (hmr_frag_add_CAN (hmr_frag_add_M P)) ((T ++ D) :: G).
Proof.
  intros G T; revert P G; induction T; intros P G D pi.
  - simpl in *.
    apply hmrr_Z_can_inv with (One :: nil).
    apply HMR_le_frag with P; [ | apply pi].
    apply add_M_le_frag.
  - destruct a as (a , A).
    simpl in *.
    apply hmrr_ex_seq with (T ++ (a , A) :: D); [ Permutation_Type_solve | ].
    apply (IHT (hmr_frag_add_CAN (hmr_frag_add_M (hmr_frag_add_CAN (hmr_frag_add_M P))))).
    replace a with (time_pos a One) by (destruct a; unfold One; apply Rpos_eq; simpl; nra).
    apply hmrr_ex_seq with ((vec (mul_vec a (One :: nil)) A) ++ (vec (One :: nil) (sem_seq T)) ++ D) ; [ Permutation_Type_solve | ].
    apply hmrr_mul_can_inv.
    apply hmrr_plus_can_inv.
    apply pi.
Qed.

Lemma HMR_sem_hseq P : forall G H,
    H <> nil ->
    HMR P (((One, sem_hseq H) :: nil) :: G) ->
    HMR (hmr_frag_add_CAN (hmr_frag_add_M P)) (H ++ G).
Proof with try assumption; try reflexivity.
  intros G H Hnnil; revert P G.
  induction H; [ now auto | ].
  rename a into T.
  intros P G pi.
  destruct H as [ | T2 H ].
  - simpl in *.
    replace T with (T ++ nil) by now rewrite app_nil_r.
    apply HMR_sem_seq...
  - unfold sem_hseq in pi; fold (sem_hseq (T2 :: H)) in pi.
    change ((One, sem_seq T \/S sem_hseq (T2 :: H)) :: nil) with ((vec (One :: nil) (sem_seq T \/S sem_hseq (T2 :: H))) ++ nil) in pi.
    apply hmrr_max_can_inv in pi.
    apply hmrr_ex_hseq with ((T2 :: H) ++ (T :: G)); [ Permutation_Type_solve | ].
    apply HMR_le_frag with (hmr_frag_add_CAN (hmr_frag_add_M (hmr_frag_add_CAN (hmr_frag_add_M (hmr_frag_add_CAN (hmr_frag_add_M P)))))).
    { destruct P; repeat split; Bool.destr_bool. }
    refine (IHlist _ (hmr_frag_add_CAN (hmr_frag_add_M (hmr_frag_add_CAN (hmr_frag_add_M P)))) (T :: G) _) ; [ now auto | ].
    apply hmrr_ex_hseq with (T :: ((One , sem_hseq (T2 :: H)) :: nil) :: G) ; [ Permutation_Type_solve | ].
    replace T with (T ++ nil) by now rewrite app_nil_r.
    apply HMR_sem_seq.
    eapply hmrr_ex_hseq ; [ apply Permutation_Type_swap | ].
    apply pi.
Qed.

(** Proof of the completeness of the system of HMR - hmr_complete return a T free proof of G *)
Lemma hmr_complete : forall G,
    G <> nil ->
    MRS_zero <== sem_hseq G ->
    HMR_M_can G.
Proof with try assumption.
  intros G Hnnil Hleq.
  assert (pi := completeness_1 _ _ One Hleq).
  replace G with (G ++ nil) by now rewrite app_nil_r.
  apply (@HMR_sem_hseq hmr_frag_M_can)...
  change ((One , sem_hseq G) :: nil) with ((vec (One :: nil) (sem_hseq G)) ++ nil).
  apply (@hmrr_min_can_inv_r hmr_frag_M_can) with MRS_zero.
  apply (@hmrr_Z_can_inv hmr_frag_M_can) with (One :: nil)...
Qed.


Require Import Relations.
Require Import EqNat.
Require Import ZArith.
Require Import List.
Require Import Utils.
Require Import Instr.
Require Import Concrete ConcreteMachine.

Set Implicit Arguments.
Local Open Scope Z_scope.

(** The concrete machine is deterministic. *)

Section Determinism.

Lemma cache_hit_read_determ: forall c rl1 rpcl1 rl2 rpcl2,
  cache_hit_read c rl1 rpcl1 ->
  cache_hit_read c rl2 rpcl2 ->
  rl1 = rl2 /\ rpcl1 = rpcl2.
Proof.
  intros. inv H. inv TAG_Res. inv TAG_ResPC.
  inv H0. inv TAG_Res. inv TAG_ResPC.
  allinv'. allinv'. intuition.
Qed.

Lemma cmach_determ:
  forall s e s' e' s'',
    cstep s e s' ->
    cstep s e' s'' ->
    s' = s'' /\ e = e'.
Proof.
  induction 1; intros;
  match goal with
      | [HH: cstep _ _ _ |- _ ] => inv HH; try congruence; auto
  end;
  try (match goal with
    | [H1 : cache_hit_read ?c ?rl _,
       H2 : cache_hit_read ?c ?rl0 _ |- _ ] =>
  (exploit (@cache_hit_read_determ c rl); eauto; intros [Heq Heq'])
  end);
  (allinv'; split ; try reflexivity).

  - (* Store user *)
    allinv'. split ; reflexivity.

  - (* Call user *)
    subst.
    exploit app_same_length_eq; eauto. intro Heq ; inv Heq.
    exploit app_same_length_eq_rest ; eauto. intro Heq ; inv Heq.
    split; reflexivity.

  - (* Call kernel *)
    subst.
    exploit app_same_length_eq; eauto. intro Heq ; inv Heq.
    exploit app_same_length_eq_rest ; eauto. intro Heq ; inv Heq.
    split ; reflexivity.

  - (* Ret Ret user *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto.  move_to_top POP0.
    exploit @c_pop_to_return_spec2; eauto. intros.
    inv H. inv H0.

    exploit @c_pop_to_return_spec3; eauto. clear POP.
    exploit @c_pop_to_return_spec3; eauto.
    intros.  inv H.
    split ; reflexivity.

  - (* Ret user *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto.  move_to_top POP0.
    exploit @c_pop_to_return_spec2; eauto. intros.
    inv H. inv H0. congruence.

  - (* Ret kernel / user - sym *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto.  move_to_top POP0.
    exploit @c_pop_to_return_spec2; eauto. intros.
    inv H. inv H0. congruence.

  - (* Ret kernel *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto.  move_to_top POP0.
    exploit @c_pop_to_return_spec2; eauto. intros.
    inv H. inv H0.
    split ; reflexivity.

  - (* Ret Ret *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto.  move_to_top H12.
    exploit @c_pop_to_return_spec2; eauto. intros.
    inv H1. inv H2.

    exploit @c_pop_to_return_spec3; eauto. clear H0.
    exploit @c_pop_to_return_spec3; eauto.
    intros.  inv H1.
    split ; reflexivity.

  - (* VRet user *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto. intros. move_to_top POP0.
    exploit @c_pop_to_return_spec2; eauto. intros.

    exploit @c_pop_to_return_spec3; eauto. intros.
    generalize POP0 ; clear POP0 ; intros POP0.
    exploit @c_pop_to_return_spec3; eauto. intros.
    inv H1.  inv H. inv H0.
    split ; reflexivity.

  - (* Ret kernel / user *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto.  move_to_top POP0.
    exploit @c_pop_to_return_spec2; eauto. intros.
    inv H. inv H0.
    congruence.

  - (* Ret kernel / user - sym *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto.  move_to_top POP0.
    exploit @c_pop_to_return_spec2; eauto. intros.
    inv H. inv H0.
    congruence.

  - (* VRet priv *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto.  move_to_top POP0.
    exploit @c_pop_to_return_spec2; eauto. intros.
    inv H. inv H0.

    exploit @c_pop_to_return_spec3; eauto.

  - (* VRet true *)
    exploit @c_pop_to_return_spec; eauto.
    intros [dstk [stk [a [b [p [Hs Hdstk]]]]]]. inv Hs.

    exploit @c_pop_to_return_spec2; eauto. intros. move_to_top H14.
    exploit @c_pop_to_return_spec2; eauto. intros.
    inv H1. inv H2.

    exploit @c_pop_to_return_spec3; eauto. clear H0.
    exploit @c_pop_to_return_spec3; eauto. intros.
    inv H1.
    split ; reflexivity.
Qed.

End Determinism.