Require Import RelationClasses.
Require Import Program.

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

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

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
(* Require Import MemoryFacts. *)
Require Import TView.
Require Import BoolMap.
Require Import Promises.
Require Import Local.
Require Import Global.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Require Import Cover.
Require Import MemoryProps.
Require Import LowerMemory.
(* Require Import FulfillStep. *)
(* Require Import ReorderStepPromise. *)
(* Require Import Pred. *)
(* Require Import Trace. *)

Require Import LowerMemory.

Require Import Delayed.
Require Import LowerStep.
Require Import Owned.

Set Implicit Arguments.

Section DStep.
  Variable lang: language.

  (** delayed steps *)

  Variant dstep (e: ThreadEvent.t) (e1 e4: Thread.t lang): Prop :=
  | dstep_intro
      e2 e3
      (PROMISES: rtc (@Thread.internal_step _) e1 e2)
      (LOWERS: rtc (tau lower_step) e2 e3)
      (STEP_RELEASE: Thread.step e e3 e4)
      (EVENT_RELEASE: release_event e)
  .

  Variant dsteps: forall (e: MachineEvent.t) (e1 e2: Thread.t lang), Prop :=
  | dsteps_promises
      e1 e2 e3
      (DSTEPS: rtc (tau dstep) e1 e2)
      (PROMISES: rtc (@Thread.internal_step _) e2 e3):
    dsteps MachineEvent.silent e1 e3
  | dsteps_step
      e te e1 e2 e3
      (DSTEPS: rtc (tau dstep) e1 e2)
      (DSTEP: dstep te e2 e3)
      (EVENT: e = ThreadEvent.get_machine_event te):
    dsteps e e1 e3
  .

  Definition delayed_consistent (e1: Thread.t lang): Prop :=
    exists e e2,
      (<<DSTEPS: dsteps
                   e (Thread.mk _ (Thread.state e1) (Thread.local e1) (Global.cap_of (Thread.global e1))) e2>>) /\
      ((<<FAILURE: e = MachineEvent.failure>>) \/
       (exists e3,
           (<<SILENT: e = MachineEvent.silent>>) /\
           (<<STEPS: rtc (tau lower_step) e2 e3>>) /\
           (<<PROMISES: Local.promises (Thread.local e3) = BoolMap.bot>>))).

  Lemma dstep_future
        e e1 e2
        (STEP: dstep e e1 e2)
        (LC_WF1: Local.wf e1.(Thread.local) e1.(Thread.global))
        (GL_WF1: Global.wf e1.(Thread.global)):
    (<<LC_WF2: Local.wf e2.(Thread.local) e2.(Thread.global)>>) /\
      (<<GL_WF2: Global.wf e2.(Thread.global)>>) /\
      (<<TVIEW_FUTURE: TView.le e1.(Thread.local).(Local.tview) e2.(Thread.local).(Local.tview)>>) /\
      (<<GL_FUTURE: Global.future e1.(Thread.global) e2.(Thread.global)>>).
  Proof.
    inv STEP.
    hexploit Thread.rtc_internal_step_future; eauto. i. des.
    hexploit lower_steps_future; eauto. i. des.
    hexploit Thread.step_future; eauto. i. des. splits; auto.
    { etrans; eauto. etrans; eauto. }
    { etrans; eauto. etrans; eauto. }
  Qed.

  Lemma rtc_dstep_future
        e1 e2
        (STEPS: rtc (tau dstep) e1 e2)
        (LC_WF1: Local.wf e1.(Thread.local) e1.(Thread.global))
        (GL_WF1: Global.wf e1.(Thread.global)):
    (<<LC_WF2: Local.wf e2.(Thread.local) e2.(Thread.global)>>) /\
      (<<GL_WF2: Global.wf e2.(Thread.global)>>) /\
      (<<TVIEW_FUTURE: TView.le e1.(Thread.local).(Local.tview) e2.(Thread.local).(Local.tview)>>) /\
      (<<GL_FUTURE: Global.future e1.(Thread.global) e2.(Thread.global)>>).
  Proof.
    induction STEPS.
    { splits; auto; try by refl. }
    { inv H. hexploit dstep_future; eauto. i. des.
      hexploit IHSTEPS; eauto. i. des. splits; auto; try by (etrans; eauto). }
  Qed.

  Lemma dsteps_future
        e e1 e2
        (STEPS: dsteps e e1 e2)
        (LC_WF1: Local.wf e1.(Thread.local) e1.(Thread.global))
        (GL_WF1: Global.wf e1.(Thread.global)):
    (<<LC_WF2: Local.wf e2.(Thread.local) e2.(Thread.global)>>) /\
      (<<GL_WF2: Global.wf e2.(Thread.global)>>) /\
      (<<TVIEW_FUTURE: TView.le e1.(Thread.local).(Local.tview) e2.(Thread.local).(Local.tview)>>) /\
      (<<GL_FUTURE: Global.future e1.(Thread.global) e2.(Thread.global)>>).
  Proof.
    inv STEPS.
    { hexploit rtc_dstep_future; eauto. i. des.
      hexploit Thread.rtc_internal_step_future; eauto. i. des.
      esplits; eauto; try by (etrans; eauto).
    }
    { hexploit rtc_dstep_future; eauto. i. des.
      hexploit dstep_future; eauto. i. des.
      esplits; eauto; try by (etrans; eauto).
    }
  Qed.

  Lemma dstep_rtc_all_step
        e e1 e2
        (STEP: dstep e e1 e2):
    rtc (@Thread.all_step lang) e1 e2.
  Proof.
    inv STEP.
    etrans.
    { eapply rtc_implies; try eapply PROMISES.
      i. inv H. econs; eauto.
    }
    etrans.
    { instantiate (1:=e3). clear - LOWERS. induction LOWERS; auto.
      transitivity y; auto.
      inv H. eapply lower_step_step; eauto.
    }
    econs 2; eauto. econs; eauto.
  Qed.

  Lemma dstep_rtc_tau_step
        e e1 e2
        (STEP: dstep e e1 e2)
        (SILENT: ThreadEvent.get_machine_event e = MachineEvent.silent):
    rtc (@Thread.tau_step lang) e1 e2.
  Proof.
    inv STEP.
    etrans.
    { eapply rtc_implies; try eapply PROMISES.
      i. inv H. econs; eauto. inv LOCAL; ss.
    }
    etrans.
    { instantiate (1:=e3). clear - LOWERS. induction LOWERS; auto.
      transitivity y; auto.
      eapply tau_lower_step_tau_step; eauto.
    }
    econs 2; eauto. econs; eauto.
  Qed.

  Lemma rtc_dstep_rtc_tau_step
        e1 e2
        (STEP: rtc (tau dstep) e1 e2):
    rtc (@Thread.tau_step lang) e1 e2.
  Proof.
    induction STEP; eauto. inv H.
    exploit dstep_rtc_tau_step; eauto. i.
    etrans; eauto.
  Qed.

  Lemma dsteps_rtc_all_step
        e e1 e2
        (STEP: dsteps e e1 e2):
    rtc (@Thread.all_step lang) e1 e2.
  Proof.
    inv STEP.
    - exploit rtc_dstep_rtc_tau_step; eauto. i.
      etrans.
      + eapply rtc_implies; try eapply x0.
        i. inv H. econs. eauto.
      + eapply rtc_implies; try eapply PROMISES.
        i. inv H. econs; eauto.
    - exploit rtc_dstep_rtc_tau_step; eauto. i.
      exploit dstep_rtc_all_step; eauto. i.
      etrans; [|eauto].
      eapply rtc_implies; try eapply x0.
      i. inv H. econs. eauto.
  Qed.

  Lemma dsteps_rtc_tau_step
        e e1 e2
        (STEP: dsteps e e1 e2)
        (SILENT: e = MachineEvent.silent):
    rtc (@Thread.tau_step lang) e1 e2.
  Proof.
    inv STEP.
    - exploit rtc_dstep_rtc_tau_step; eauto. i.
      etrans; eauto.
      eapply rtc_implies; try eapply PROMISES.
      i. inv H0. econs; eauto. inv LOCAL; ss.
    - exploit rtc_dstep_rtc_tau_step; eauto. i.
      exploit dstep_rtc_tau_step; eauto. i.
      etrans; eauto.
  Qed.

  Lemma dsteps_plus_step
        e e1 e3
        (STEP: dsteps e e1 e3):
    e = MachineEvent.silent /\ e1 = e3 \/
    exists e2 te,
      (<<STEPS: rtc (@Thread.tau_step lang) e1 e2>>) /\
      (<<STEP: Thread.step te e2 e3>>) /\
      (<<EVENT: ThreadEvent.get_machine_event te = e>>).
  Proof.
    inv STEP.
    { exploit rtc_dstep_rtc_tau_step; eauto. i.
      exploit rtc_implies; try eapply PROMISES.
      { i. instantiate (1 := @Thread.tau_step lang).
        inv H. econs; eauto. inv LOCAL; ss.
      }
      i. rewrite x1 in x0. clear e2 DSTEPS PROMISES x1.
      exploit rtc_tail; try exact x0. i. des; eauto.
      right. inv x2. esplits; eauto.
    }
    { exploit rtc_dstep_rtc_tau_step; eauto. i.
      inv DSTEP.
      exploit rtc_implies; try eapply PROMISES; i.
      { i. instantiate (1 := @Thread.tau_step lang).
        inv H. econs; eauto. inv LOCAL; ss.
      }
      exploit rtc_implies; try eapply LOWERS; i.
      { i. instantiate (1 := rtc (@Thread.tau_step lang)).
        eapply tau_lower_step_tau_step; eauto.
      }
      eapply rtc_join in x2.
      rewrite x2 in x1. rewrite x1 in x0.
      clear x1 x2 DSTEPS PROMISES LOWERS.
      right. esplits; eauto.
    }
  Qed.

  Lemma interal_steps_lower_steps_dstep_dstep th0 th1 th2 th3 e
        (INTERNALS: rtc (@Thread.internal_step _) th0 th1)
        (LOWERS: rtc (tau lower_step) th1 th2)
        (STEP: dstep e th2 th3)
        (LOCAL: Local.wf th0.(Thread.local) th0.(Thread.global))
        (GLOBAL: Global.wf th0.(Thread.global))
    :
    dstep e th0 th3.
  Proof.
    hexploit Thread.rtc_internal_step_future; eauto. i. des.
    inv STEP. hexploit reorder_lower_steps_internal_steps; eauto.
    i. des. econs.
    { etrans; eauto. }
    { etrans; eauto. }
    { eauto. }
    { eauto. }
  Qed.

  Lemma interal_steps_lower_steps_dsteps_dsteps th0 th1 th2 th3 e
        (INTERNALS: rtc (@Thread.internal_step _) th0 th1)
        (LOWERS: rtc (tau lower_step) th1 th2)
        (STEP: dsteps e th2 th3)
        (LOCAL: Local.wf th0.(Thread.local) th0.(Thread.global))
        (GLOBAL: Global.wf th0.(Thread.global))
        (EVENT: e <> MachineEvent.silent)
    :
    dsteps e th0 th3.
  Proof.
    inv STEP; ss. inv DSTEPS.
    { econs 2.
      { refl. }
      { eapply interal_steps_lower_steps_dstep_dstep; eauto. }
      { auto. }
    }
    { econs 2.
      { econs 2; [|eauto]. inv H. econs; [|eauto].
        eapply interal_steps_lower_steps_dstep_dstep; eauto.
      }
      { eauto. }
      { auto. }
    }
  Qed.

  Lemma failure_dfailure th0
        (FAILURE: Thread.steps_failure th0)
        (LOCAL: Local.wf th0.(Thread.local) th0.(Thread.global))
        (GLOBAL: Global.wf th0.(Thread.global))
    :
    exists th1, (<<FAILURE: dsteps MachineEvent.failure th0 th1>>).
  Proof.
    inv FAILURE. revert e th3 STEP_FAILURE EVENT_FAILURE LOCAL GLOBAL.
    induction STEPS; i.
    { esplits. econs.
      { refl. }
      { econs.
        { refl. }
        { refl. }
        { eauto. }
        destruct e; ss.
      }
      { auto. }
    }
    inv H. hexploit Thread.step_future; eauto. i. des.
    hexploit IHSTEPS; eauto. i. des.
    destruct (classic (release_event e0)).
    { esplits. inv FAILURE; ss. econs; [|eauto|eauto].
      econs 2; [|eauto]. econs; [|eapply EVENT]. econs.
      { refl. }
      { refl. }
      { eauto. }
      { eauto. }
    }
    hexploit split_step; eauto. i. des.
    { esplits. eapply interal_steps_lower_steps_dsteps_dsteps; eauto. ss. }
    { esplits. econs 2.
      { refl. }
      econs.
      { refl. }
      { refl. }
      { eauto. }
      { destruct e_race; ss. }
      { eauto. }
    }
  Qed.

  Lemma tau_dsteps_dsteps_dsteps th0 th1 th2 e
        (STEP0: dsteps MachineEvent.silent th0 th1)
        (STEP1: dsteps e th1 th2)
    :
    dsteps e th0 th2.
  Proof.
    inv STEP0; inv STEP1.
    { inv DSTEPS0.
      { econs 1; [eauto|]. etrans; eauto. }
      { inv H. inv TSTEP. econs 1; [|eauto].
        etrans; eauto. econs 2; [|eauto].
        econs; [|eauto]. econs.
        { etrans; eauto. }
        { eauto. }
        { eauto. }
        { eauto. }
      }
    }
    { inv DSTEPS0.
      { inv DSTEP. econs 2; [eauto| |eauto].
        econs; [|eauto|eauto|eauto]. etrans; eauto.
      }
      { inv H. inv TSTEP. econs 2; [|eauto|eauto].
        etrans; eauto. econs 2; [|eauto].
        econs; eauto. econs; [|eauto|eauto|eauto]. etrans; eauto.
      }
    }
    { econs 1; [|eapply PROMISES]. etrans; eauto. }
    { econs 2; [|eapply DSTEP0|]; auto. etrans; eauto. }
  Qed.

  Lemma rtc_tau_dstep_dsteps_dsteps th0 th1 th2 e
        (STEP0: rtc (tau dstep) th0 th1)
        (STEP1: dsteps e th1 th2)
    :
    dsteps e th0 th2.
  Proof.
    eapply tau_dsteps_dsteps_dsteps; [|eauto].
    econs 1; eauto.
  Qed.

  (** steps to delayed steps *)

  Variant delayed_thread (th_delayed th: Thread.t lang): Prop :=
  | delayed_thread_intro
      (DELAYED: delayed
                  _
                  (Thread.state th_delayed) (Thread.state th)
                  (Thread.local th_delayed) (Thread.local th)
                  (Thread.global th_delayed) (Thread.global th))
  .

  Lemma internal_step_strong_le
        th1 th2
        (STEP: @Thread.internal_step lang th1 th2)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1)):
    Global.strong_le (Thread.global th1) (Thread.global th2).
  Proof.
    inv STEP. hexploit Local.internal_step_strong_le; eauto.
    i. des. splits; auto.
  Qed.

  Lemma rtc_internal_step_strong_le
        th1 th2
        (STEPS: rtc (@Thread.internal_step lang) th1 th2)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1)):
    Global.strong_le (Thread.global th1) (Thread.global th2).
  Proof.
    revert LC_WF1 GL_WF1. induction STEPS; i.
    { refl. }
    hexploit internal_step_strong_le; eauto. i.
    hexploit Thread.internal_step_future; eauto. i. des.
    etrans; eauto.
  Qed.

  Lemma lower_step_strong_le
        e th1 th2
        (STEP: lower_step e th1 th2)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1)):
    (<<LE: Global.strong_le (Thread.global th1) (Thread.global th2)>>) \/
      exists e_race th2',
        (<<STEP: @Thread.step lang e_race th1 th2'>>) /\
          (<<RELEASE: release_event e_race>>) /\
          (<<EVENT: ThreadEvent.get_program_event e_race = ThreadEvent.get_program_event e>>) /\
          (<<RACE: ThreadEvent.get_machine_event e_race = MachineEvent.failure>>).
  Proof.
    inv STEP. des; subst.
    { inv STEP0. hexploit Local.program_step_strong_le; eauto. i. des; auto.
      right. esplits.
      { econs 2; [|eauto]; eauto. rewrite EVENT. eauto. }
      { destruct e_race; ss. }
      { eauto. }
      { auto. }
    }
    { inv STEP; [|inv LOCAL].
      hexploit Local.internal_step_strong_le; eauto.
      i. des. splits; auto.
      inv STEP0. hexploit Local.program_step_strong_le; eauto. i. des.
      { left. etrans; eauto. }
      right. inv LOCAL. inv LOCAL1. ss. inv CANCEL.
      inv STEP; ss. inv LOCAL. clarify. esplits.
      { econs 2; cycle 1.
        { eapply Local.program_step_racy_write. econs; eauto.
          instantiate (1:=Ordering.na). instantiate (1:=to0). instantiate (1:=loc).
          inv RACE0.
          { econs 1; eauto. }
          { econs 2; eauto. erewrite Memory.remove_o in GET; eauto.
            des_ifs. eauto.
          }
        }
        { eauto. }
      }
      { ss. }
      { eauto. }
      { eauto. }
    }
  Qed.

  Lemma rtc_tau_lower_step_strong_le
        th1 th2
        (STEPS: rtc (tau (@lower_step lang)) th1 th2)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1)):
    (<<LE: Global.strong_le (Thread.global th1) (Thread.global th2)>>) \/
      exists e_race th1' th2',
        (<<STEPS: rtc (tau (@lower_step lang)) th1 th1'>>) /\
          (<<STEP: @Thread.step lang e_race th1' th2'>>) /\
          (<<RELEASE: release_event e_race>>) /\
          (<<RACE: ThreadEvent.get_machine_event e_race = MachineEvent.failure>>).
  Proof.
    revert LC_WF1 GL_WF1. induction STEPS; i.
    { left. r. refl. }
    { inv H. hexploit lower_step_strong_le; eauto. i. des.
      2:{ right. esplits; eauto. }
      hexploit lower_step_future; eauto. i. des.
      hexploit IHSTEPS; eauto. i. des.
      { left. r. etrans; eauto. }
      { right. esplits.
        { econs 2; eauto. }
        { eauto. }
        { eauto. }
        { eauto. }
      }
    }
  Qed.

  Lemma dstep_strong_le
        th1 th2 e
        (STEP: dstep e th1 th2)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1)):
    (<<LE: Global.strong_le (Thread.global th1) (Thread.global th2)>>) \/
      exists e_race th2',
        (<<STEP: dstep e_race th1 th2'>>) /\
          (<<RACE: ThreadEvent.get_machine_event e_race = MachineEvent.failure>>).
  Proof.
    inv STEP.
    hexploit rtc_internal_step_strong_le; eauto. i. des.
    hexploit Thread.rtc_internal_step_future; eauto. i. des.
    hexploit rtc_tau_lower_step_strong_le; eauto. i. des; cycle 1.
    { right. esplits; [..|eauto]. econs; eauto. }
    hexploit lower_steps_future; eauto. i. des.
    hexploit Thread.step_strong_le; eauto. i. des.
    { left. r. etrans; eauto. etrans; eauto. }
    { right. esplits; eauto. econs; eauto. destruct e_race; ss. }
  Qed.

  Lemma rtc_tau_dstep_strong_le
        th1 th2
        (STEPS: rtc (tau dstep) th1 th2)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1)):
    (<<LE: Global.strong_le (Thread.global th1) (Thread.global th2)>>) \/
      exists e_race th1' th2',
        (<<STEPS: rtc (tau dstep) th1 th1'>>) /\
          (<<STEP: dstep e_race th1' th2'>>) /\
          (<<RACE: ThreadEvent.get_machine_event e_race = MachineEvent.failure>>).
  Proof.
    revert LC_WF1 GL_WF1. induction STEPS; i.
    { left. r. refl. }
    inv H. hexploit dstep_strong_le; eauto. i. des; cycle 1.
    { right. esplits; eauto. }
    hexploit dstep_future; eauto. i. des.
    hexploit IHSTEPS; eauto. i. des.
    { left. r. etrans; eauto. }
    { right. esplits; [..|eauto|eauto]. econs 2; eauto. }
  Qed.

  Lemma dsteps_strong_le
        th1 th2 e
        (STEPS: dsteps e th1 th2)
        (LC_WF1: Local.wf (Thread.local th1) (Thread.global th1))
        (GL_WF1: Global.wf (Thread.global th1)):
    (<<LE: Global.strong_le (Thread.global th1) (Thread.global th2)>>) \/
      exists th2',
          (<<STEPS: dsteps MachineEvent.failure th1 th2'>>).
  Proof.
    inv STEPS.
    { hexploit rtc_tau_dstep_strong_le; eauto. i. des.
      { hexploit rtc_dstep_future; eauto. i. des.
        hexploit rtc_internal_step_strong_le; eauto.
        i. left. r. etrans; eauto.
      }
      { right. esplits. eapply rtc_tau_dstep_dsteps_dsteps.
        { eauto. }
        { econs 2; eauto. }
      }
    }
    { hexploit rtc_tau_dstep_strong_le; eauto. i. des.
      { hexploit rtc_dstep_future; eauto. i. des.
        hexploit dstep_strong_le; eauto.
        i. des.
        { left. r. etrans; eauto. }
        { right. esplits. econs 2; eauto. }
      }
      { right. esplits. econs 2; eauto. }
    }
  Qed.

  Lemma dsteps_promises_minus
        e th1 th2
        (STEP: dsteps e th1 th2):
    BoolMap.minus (Global.promises (Thread.global th1)) (Local.promises (Thread.local th1)) =
      BoolMap.minus (Global.promises (Thread.global th2)) (Local.promises (Thread.local th2)).
  Proof.
    eapply Thread.rtc_all_step_promises_minus.
    eapply dsteps_rtc_all_step; eauto.
  Qed.

  Lemma delayed_thread_delayed_global th_src0 th_tgt0
        (DELAYED: delayed_thread th_src0 th_tgt0)
        (LOCALSRC0: Local.wf th_src0.(Thread.local) th_src0.(Thread.global))
        (LOCALTGT0: Local.wf th_tgt0.(Thread.local) th_tgt0.(Thread.global))
        (GLOBALSRC0: Global.wf th_src0.(Thread.global))
        (GLOBALTGT0: Global.wf th_tgt0.(Thread.global))
    :
    delayed_global_private th_src0.(Thread.local) th_tgt0.(Thread.local) th_src0.(Thread.global) th_tgt0.(Thread.global).
  Proof.
    inv DELAYED. hexploit delayed_sync; eauto. i. des.
    eapply lower_steps_delayed_preserve; eauto.
  Qed.

  Lemma delayed_thread_step th_src0 th_tgt0 th_tgt1 e
        (STEP: Thread.step e th_tgt0 th_tgt1)
        (DELAYED: delayed_thread th_src0 th_tgt0)
        (LOCALSRC: Local.wf th_src0.(Thread.local) th_src0.(Thread.global))
        (LOCALTGT: Local.wf th_tgt0.(Thread.local) th_tgt0.(Thread.global))
        (GLOBALSRC: Global.wf th_src0.(Thread.global))
        (GLOBALTGT: Global.wf th_tgt0.(Thread.global))
        (CONSISTENT: ThreadEvent.get_machine_event e <> MachineEvent.failure -> rtc_consistent th_tgt1)
    :
    exists th_src1,
      ((<<STEP: dsteps (ThreadEvent.get_machine_event e) th_src0 th_src1>>) /\
         (<<DELAYED: delayed_thread th_src1 th_tgt1>>) /\
         (<<GLOBAL: delayed_global_public th_src1.(Thread.global) th_tgt1.(Thread.global)>>) /\
         (<<FUTURESRC: owned_future_global_promises
                         (BoolMap.minus th_src0.(Thread.global).(Global.promises) th_src0.(Thread.local).(Local.promises))
                         th_src0.(Thread.global) th_src1.(Thread.global)>>) /\
         (<<FUTURETGT: owned_future_global_promises
                         (BoolMap.minus th_src0.(Thread.global).(Global.promises) th_src0.(Thread.local).(Local.promises))
                         th_tgt0.(Thread.global) th_tgt1.(Thread.global)>>)) \/
        (<<FAILURE: dsteps MachineEvent.failure th_src0 th_src1>>)
  .
  Proof.
    inv DELAYED. destruct th_src0, th_tgt0, th_tgt1; ss.
    destruct (classic (release_event e)).
    { hexploit delayed_step_release; eauto. i. des.
      { esplits. left. esplits.
        { econs 2; [refl|..|].
          { econs; eauto. }
          { auto. }
        }
        { econs; eauto. }
        { eapply delayed_global_private_to_public; eauto. }
        { eauto. }
        { eauto. }
      }
      { hexploit failure_dfailure; eauto. i. des.
        esplits. right. eauto.
      }
    }
    { hexploit delayed_step_non_release; eauto. i. des.
      { esplits. left. esplits.
        { rewrite SILENT. econs 1; [refl|..]. eauto. }
        { econs; eauto. }
        { eapply delayed_global_private_to_public; eauto. }
        { eauto. }
        { eauto. }
      }
      { hexploit failure_dfailure; eauto. i. des.
        esplits. right. eauto.
      }
    }
  Qed.

  Lemma delayed_thread_bot th_src0 th_tgt0
        (DELAYED: delayed_thread th_src0 th_tgt0)
        (LOCALSRC: Local.wf th_src0.(Thread.local) th_src0.(Thread.global))
        (LOCALTGT: Local.wf th_tgt0.(Thread.local) th_tgt0.(Thread.global))
        (GLOBALSRC: Global.wf th_src0.(Thread.global))
        (GLOBALTGT: Global.wf th_tgt0.(Thread.global))
        (TERMINAL: Local.promises th_tgt0.(Thread.local) = BoolMap.bot)
    :
    exists th_src1,
      ((<<STEPS: rtc (tau lower_step) th_src0 th_src1>>) /\
         (<<GLOBAL: delayed_global_public th_src1.(Thread.global) th_tgt0.(Thread.global)>>) /\
         (<<FUTURESRC: owned_future_global_promises
                         (BoolMap.minus th_src0.(Thread.global).(Global.promises) th_src0.(Thread.local).(Local.promises))
                         th_src0.(Thread.global) th_src1.(Thread.global)>>) /\
         (<<STATE: th_src1.(Thread.state) = th_tgt0.(Thread.state)>>) /\
         (<<TERMINAL: Local.promises th_src1.(Thread.local) = BoolMap.bot>>)) \/
        (<<FAILURE: dsteps MachineEvent.failure th_src0 th_src1>>)
  .
  Proof.
    inv DELAYED. destruct th_src0, th_tgt0; ss.
    hexploit delayed_sync; eauto. i. des.
    esplits. left. esplits; eauto.
    { eapply delayed_global_private_to_public; eauto. }
    { eapply SimLocal.sim_local_is_terminal; eauto. }
  Qed.

  Lemma delayed_thread_steps th_src0 th_tgt0 th_tgt1
        (STEPS: rtc (@Thread.tau_step _) th_tgt0 th_tgt1)
        (DELAYED: delayed_thread th_src0 th_tgt0)
        (LOCALSRC: Local.wf th_src0.(Thread.local) th_src0.(Thread.global))
        (LOCALTGT: Local.wf th_tgt0.(Thread.local) th_tgt0.(Thread.global))
        (GLOBALSRC: Global.wf th_src0.(Thread.global))
        (GLOBALTGT: Global.wf th_tgt0.(Thread.global))
        (CONSISTENT: rtc_consistent th_tgt1)
      :
    exists th_src1,
      ((<<STEP: dsteps MachineEvent.silent th_src0 th_src1>>) /\
         (<<DELAYED: delayed_thread th_src1 th_tgt1>>) /\
         (<<GLOBAL: delayed_global_public th_src1.(Thread.global) th_tgt1.(Thread.global)>>) /\
         (<<FUTURESRC: owned_future_global_promises
                         (BoolMap.minus th_src0.(Thread.global).(Global.promises) th_src0.(Thread.local).(Local.promises))
                         th_src0.(Thread.global) th_src1.(Thread.global)>>) /\
         (<<FUTURETGT: owned_future_global_promises
                         (BoolMap.minus th_src0.(Thread.global).(Global.promises) th_src0.(Thread.local).(Local.promises))
                         th_tgt0.(Thread.global) th_tgt1.(Thread.global)>>)) \/
        (<<FAILURE: dsteps MachineEvent.failure th_src0 th_src1>>)
  .
  Proof.
    revert th_src0 DELAYED LOCALSRC LOCALTGT GLOBALSRC GLOBALTGT CONSISTENT.
    induction STEPS; i.
    { esplits. left. esplits; eauto.
      { econs 1; eauto. }
      { eapply delayed_global_private_to_public; eauto.
        eapply delayed_thread_delayed_global; eauto. }
      { refl. }
      { refl. }
    }
    inv H. hexploit Thread.step_future; eauto. i. des.
    hexploit Thread.step_promises_minus; eauto. i.
    hexploit delayed_thread_step; eauto.
    { i. eapply tau_steps_rtc_consistent; eauto. }
    i. des; cycle 1.
    { esplits. right. esplits; eauto. }
    hexploit dsteps_future; eauto. i. des.
    hexploit dsteps_promises_minus; eauto. i.
    rewrite EVENT in *.
    hexploit IHSTEPS; eauto. i. des; cycle 1.
    { esplits. right. eapply tau_dsteps_dsteps_dsteps; eauto. }
    esplits. left. esplits.
    { eapply tau_dsteps_dsteps_dsteps; eauto. }
    { eauto. }
    { eauto. }
    { etrans; eauto. rewrite H0. auto. }
    { etrans; eauto. rewrite H0. auto. }
  Qed.

  Lemma delayed_thread_future th_src0 th_tgt0 gl_src1 gl_tgt1
        (DELAYED: delayed_thread th_src0 th_tgt0)
        (GLOBAL: delayed_global_public gl_src1 gl_tgt1)
        (LOCALSRC0: Local.wf th_src0.(Thread.local) th_src0.(Thread.global))
        (LOCALTGT0: Local.wf th_tgt0.(Thread.local) th_tgt0.(Thread.global))
        (GLOBALSRC0: Global.wf th_src0.(Thread.global))
        (GLOBALTGT0: Global.wf th_tgt0.(Thread.global))
        (LOCALSRC1: Local.wf th_src0.(Thread.local) gl_src1)
        (LOCALTGT1: Local.wf th_tgt0.(Thread.local) gl_tgt1)
        (GLOBALSRC1: Global.wf gl_src1)
        (GLOBALTGT1: Global.wf gl_tgt1)
        (FUTURESRC: Global.strong_le th_src0.(Thread.global) gl_src1)
        (FUTURETGT: Global.le th_tgt0.(Thread.global) gl_tgt1)
        (OWNEDSRC: owned_future_global_promises th_src0.(Thread.local).(Local.promises) th_src0.(Thread.global) gl_src1)
        (OWNEDTGT: owned_future_global_promises th_src0.(Thread.local).(Local.promises) th_tgt0.(Thread.global) gl_tgt1)
    :
    (<<DELAYED: delayed_thread (Thread.mk _ th_src0.(Thread.state) th_src0.(Thread.local) gl_src1) (Thread.mk _ th_tgt0.(Thread.state) th_tgt0.(Thread.local) gl_tgt1)>>) \/
      exists th_src1, (<<FAILURE: dsteps MachineEvent.failure (Thread.mk _ th_src0.(Thread.state) th_src0.(Thread.local) gl_src1) th_src1>>).
  Proof.
    hexploit delayed_thread_delayed_global; eauto. i.
    inv DELAYED. hexploit delayed_future; eauto. i. des; cycle 1.
    { hexploit failure_dfailure; eauto. }
    left. r. econs; eauto.
  Qed.

  Lemma delayed_thread_consistent th_src0 th_tgt0
        (DELAYED: delayed_thread th_src0 th_tgt0)
        (LOCALSRC: Local.wf th_src0.(Thread.local) th_src0.(Thread.global))
        (LOCALTGT: Local.wf th_tgt0.(Thread.local) th_tgt0.(Thread.global))
        (GLOBALSRC: Global.wf th_src0.(Thread.global))
        (GLOBALTGT: Global.wf th_tgt0.(Thread.global))
        (CONSISTENT: Thread.consistent th_tgt0)
    :
    delayed_consistent th_src0.
  Proof.
    hexploit delayed_global_public_cap; eauto.
    { eapply delayed_global_private_to_public.
      eapply delayed_thread_delayed_global; eauto.
    }
    intros CAP.
    pose proof (Local.cap_wf LOCALSRC) as LOCALSRC1.
    pose proof (Local.cap_wf LOCALTGT) as LOCALTGT1.
    pose proof (Global.cap_wf GLOBALSRC) as GLOBALSRC1.
    pose proof (Global.cap_wf GLOBALTGT) as GLOBALTGT1.
    hexploit delayed_thread_future; eauto.
    { eapply Global.cap_strong_le; eauto. }
    { eapply Global.cap_le; eauto. }
    { eapply cap_owned_future_global_promises; eauto. }
    { eapply cap_owned_future_global_promises; eauto. }
    i. des; cycle 1.
    { r. esplits; eauto. }
    inv CONSISTENT.
    { inv FAILURE.
      hexploit Thread.rtc_tau_step_future; eauto. i. des.
      hexploit delayed_thread_steps; eauto.
      { eapply failure_rtc_consistent. econs; eauto. }
      i. des; ss; cycle 1.
      { r. esplits; eauto. }
      hexploit dsteps_future; eauto. i. des; s.
      hexploit delayed_thread_step; eauto.
      { i. ss. }
      i. des.
      { r. esplits.
        { eapply tau_dsteps_dsteps_dsteps; eauto. }
        { eauto. }
      }
      { r. esplits.
        { eapply tau_dsteps_dsteps_dsteps; eauto. }
        { eauto. }
      }
    }
    hexploit Thread.rtc_tau_step_future; eauto. i. des.
    hexploit delayed_thread_steps; eauto.
    { eapply bot_rtc_consistent; eauto. }
    i. des; cycle 1; ss.
    { r. esplits; eauto. }
    hexploit dsteps_future; eauto. i. des; ss.
    hexploit delayed_thread_bot; eauto. i. des.
    { r. esplits.
      { eauto. }
      { right. esplit; eauto. }
    }
    { r. esplits.
      { eapply tau_dsteps_dsteps_dsteps; eauto. }
      { eauto. }
    }
  Qed.

  Lemma delayed_thread_steps_full th_src0 th_tgt0
        gl_src1 gl_tgt1 th_tgt1 th_tgt2 e_tgt
        (DELAYED: delayed_thread th_src0 th_tgt0)
        (STEPS: rtc (@Thread.tau_step _) (Thread.mk _ th_tgt0.(Thread.state) th_tgt0.(Thread.local) gl_tgt1) th_tgt1)
        (STEP1: Thread.step e_tgt th_tgt1 th_tgt2)
        (GLOBAL: delayed_global_public gl_src1 gl_tgt1)
        (LOCALSRC: Local.wf th_src0.(Thread.local) th_src0.(Thread.global))
        (LOCALTGT: Local.wf th_tgt0.(Thread.local) th_tgt0.(Thread.global))
        (GLOBALSRC: Global.wf th_src0.(Thread.global))
        (GLOBALTGT: Global.wf th_tgt0.(Thread.global))
        (LOCALSRC1: Local.wf th_src0.(Thread.local) gl_src1)
        (LOCALTGT1: Local.wf th_tgt0.(Thread.local) gl_tgt1)
        (GLOBALSRC1: Global.wf gl_src1)
        (GLOBALTGT1: Global.wf gl_tgt1)
        (FUTURESRC: Global.strong_le th_src0.(Thread.global) gl_src1)
        (FUTURETGT: Global.le th_tgt0.(Thread.global) gl_tgt1)
        (OWNEDSRC: owned_future_global_promises th_src0.(Thread.local).(Local.promises) th_src0.(Thread.global) gl_src1)
        (OWNEDTGT: owned_future_global_promises th_src0.(Thread.local).(Local.promises) th_tgt0.(Thread.global) gl_tgt1)
        (CONSISTENT: ThreadEvent.get_machine_event e_tgt <> MachineEvent.failure -> Thread.consistent th_tgt2)
      :
    exists th_src1,
      ((<<STEP: dsteps (ThreadEvent.get_machine_event e_tgt) (Thread.mk _ th_src0.(Thread.state) th_src0.(Thread.local) gl_src1) th_src1>>) /\
         (<<DELAYED: delayed_thread th_src1 th_tgt2>>) /\
         (<<GLOBAL: delayed_global_public th_src1.(Thread.global) th_tgt2.(Thread.global)>>) /\
         (<<CONSISTENT: ThreadEvent.get_machine_event e_tgt <> MachineEvent.failure -> delayed_consistent th_src1>>) /\
         (<<FUTURESRC: owned_future_global_promises
                         (BoolMap.minus gl_src1.(Global.promises) th_src0.(Thread.local).(Local.promises))
                         gl_src1 th_src1.(Thread.global)>>) /\
         (<<FUTURETGT: owned_future_global_promises
                         (BoolMap.minus gl_src1.(Global.promises) th_src0.(Thread.local).(Local.promises))
                         gl_tgt1 th_tgt2.(Thread.global)>>)) \/
        (<<FAILURE: dsteps MachineEvent.failure (Thread.mk _ th_src0.(Thread.state) th_src0.(Thread.local) gl_src1) th_src1>>)
  .
  Proof.
    hexploit delayed_thread_future; eauto. i. des; cycle 1.
    { esplits; eauto. }
    hexploit Thread.rtc_tau_step_future; eauto. i. des.
    hexploit Thread.step_future; eauto. i. des.
    hexploit delayed_thread_steps; eauto.
    { eapply tau_steps_rtc_consistent; eauto.
      eapply step_rtc_consistent; eauto.
      i. eapply consistent_rtc_consistent. eapply CONSISTENT.
      rewrite H. ss.
    }
    i. des; eauto. hexploit dsteps_future; eauto. i. des.
    hexploit dsteps_promises_minus; eauto. i. ss.
    hexploit delayed_thread_step; eauto.
    { i. eapply consistent_rtc_consistent. eapply CONSISTENT; auto. }
    i. des; cycle 1.
    { esplits. right. eapply tau_dsteps_dsteps_dsteps; eauto. }
    { hexploit dsteps_future; eauto. i. des.
      esplits. left. esplits.
      { eapply tau_dsteps_dsteps_dsteps; eauto. }
      { eauto. }
      { eauto. }
      { i. eapply delayed_thread_consistent; eauto. }
      { etrans; eauto. rewrite H. auto. }
      { etrans; eauto. rewrite H. auto. }
    }
  Qed.

  Lemma delayed_thread_steps_terminal th_src0 th_tgt0
        gl_src1 gl_tgt1
        (DELAYED: delayed_thread th_src0 th_tgt0)
        (TERMINAL: Local.is_terminal th_tgt0.(Thread.local))
        (LANG: Language.is_terminal _ th_tgt0.(Thread.state))
        (GLOBAL: delayed_global_public gl_src1 gl_tgt1)
        (LOCALSRC: Local.wf th_src0.(Thread.local) th_src0.(Thread.global))
        (LOCALTGT: Local.wf th_tgt0.(Thread.local) th_tgt0.(Thread.global))
        (GLOBALSRC: Global.wf th_src0.(Thread.global))
        (GLOBALTGT: Global.wf th_tgt0.(Thread.global))
        (LOCALSRC1: Local.wf th_src0.(Thread.local) gl_src1)
        (LOCALTGT1: Local.wf th_tgt0.(Thread.local) gl_tgt1)
        (GLOBALSRC1: Global.wf gl_src1)
        (GLOBALTGT1: Global.wf gl_tgt1)
        (FUTURESRC: Global.strong_le th_src0.(Thread.global) gl_src1)
        (FUTURETGT: Global.le th_tgt0.(Thread.global) gl_tgt1)
        (OWNEDSRC: owned_future_global_promises th_src0.(Thread.local).(Local.promises) th_src0.(Thread.global) gl_src1)
        (OWNEDTGT: owned_future_global_promises th_src0.(Thread.local).(Local.promises) th_tgt0.(Thread.global) gl_tgt1)
    :
    exists th_src1,
      ((<<STEPS: rtc (tau lower_step) (Thread.mk _ th_src0.(Thread.state) th_src0.(Thread.local) gl_src1) th_src1>>) /\
         (<<GLOBAL: delayed_global_public th_src1.(Thread.global) gl_tgt1>>) /\
         (<<FUTURESRC: owned_future_global_promises
                         (BoolMap.minus gl_src1.(Global.promises) th_src0.(Thread.local).(Local.promises))
                         gl_src1 th_src1.(Thread.global)>>) /\
        (<<TERMINAL: Local.is_terminal th_src1.(Thread.local)>>) /\
        (<<LANG: Language.is_terminal _ th_src1.(Thread.state)>>)) \/
        (<<FAILURE: dsteps MachineEvent.failure (Thread.mk _ th_src0.(Thread.state) th_src0.(Thread.local) gl_src1) th_src1>>).
  Proof.
    hexploit delayed_thread_future; eauto. i. des; cycle 1.
    { esplits; eauto. }
    hexploit delayed_thread_bot; eauto.
    { eapply TERMINAL. }
    i. des; cycle 1.
    { esplits; eauto. }
    esplits. left. esplits; eauto.
    { rewrite STATE. auto. }
  Qed.

  Lemma delayed_thread_init st:
    delayed_thread (Thread.mk _ st Local.init Global.init) (Thread.mk _ st Local.init Global.init).
  Proof.
    econs; ss. r. esplits.
    { refl. }
    { refl. }
    econs.
    { refl. }
    { refl. }
    { ii. erewrite ! Memory.bot_get.
      destruct (Memory.get loc to Memory.init) as [[]|]; econs. refl.
    }
  Qed.

  Lemma delayed_global_public_init
    :
    delayed_global_public Global.init Global.init.
  Proof.
    econs.
    { refl. }
    { refl. }
    { ii. destruct (Memory.get loc to Memory.init) as [[]|]; econs. refl. }
  Qed.

  Variant past_delayed_thread: Thread.t lang -> Thread.t lang -> Prop :=
  | past_delayed_thread_intro
      st_src lc_src st_tgt lc_tgt gl_src gl_tgt
      gl_src0 gl_tgt0
      (DELAYED:
        delayed_thread (Thread.mk lang st_src lc_src gl_src0)
                       (Thread.mk lang st_tgt lc_tgt gl_tgt0))
      (FUTURESRC: Global.strong_le gl_src0 gl_src)
      (FUTURETGT: Global.le gl_tgt0 gl_tgt)
      (OWNEDSRC: owned_future_global_promises lc_src.(Local.promises) gl_src0 gl_src)
      (OWNEDTGT: owned_future_global_promises lc_src.(Local.promises) gl_tgt0 gl_tgt)
      (LOCALSRC: Local.wf lc_src gl_src0)
      (LOCALTGT: Local.wf lc_tgt gl_tgt0)
      (GLOBALSRC: Global.wf gl_src0)
      (GLOBALTGT: Global.wf gl_tgt0)
    :
    past_delayed_thread (Thread.mk lang st_src lc_src gl_src)
                        (Thread.mk lang st_tgt lc_tgt gl_tgt)
  .

  Lemma delayed_consistent_consistent
        e
        (CONSISTENT: delayed_consistent e):
    (<<CONSISTENT: Thread.consistent e>>).
  Proof.
    rr in CONSISTENT. des.
    { left.
      exploit dsteps_plus_step; eauto. i. des; subst; ss.
      econs; eauto.
    }
    { exploit dsteps_rtc_tau_step; eauto. i.
      esplits; try exact PROMISES. econs 2; [|eauto].
      etrans; eauto. eapply rtc_join.
      eapply rtc_implies; try exact STEPS.
      eapply tau_lower_step_tau_step.
    }
  Qed.

End DStep.

Module DConfiguration.
  Variant step: forall (e: MachineEvent.t) (tid: Ident.t) (c1 c2: Configuration.t), Prop :=
  | step_intro
      e tid c1 lang st1 lc1 st2 lc2 gl2
      (TID: IdentMap.find tid (Configuration.threads c1) = Some (existT _ lang st1, lc1))
      (DSTEPS: dsteps e (Thread.mk _ st1 lc1 (Configuration.global c1))
                      (Thread.mk _ st2 lc2 gl2))
      (CONSISTENT: e <> MachineEvent.failure ->
                   delayed_consistent (Thread.mk _ st2 lc2 gl2)):
      step e tid c1
           (Configuration.mk (IdentMap.add tid (existT _ _ st2, lc2) (Configuration.threads c1)) gl2)
  .

  Variant terminal_step: forall (tid: Ident.t) (c1 c2: Configuration.t), Prop :=
  | terminal_step_intro
      tid c1 lang st1 lc1 st2 lc2 gl2
      (TID: IdentMap.find tid (Configuration.threads c1) = Some (existT _ lang st1, lc1))
      (STEPS: rtc (tau lower_step)
                  (Thread.mk _ st1 lc1 (Configuration.global c1))
                  (Thread.mk _ st2 lc2 gl2))
      (TERMINAL: Language.is_terminal _ st2)
      (PROMISES: Local.is_terminal lc2):
      terminal_step tid c1
                    (Configuration.mk
                       (IdentMap.add tid (existT _ _ st2, lc2) (Configuration.threads c1))
                       gl2)
  .

  Inductive terminal_steps: forall (tids: list Ident.t) (c1 c2: Configuration.t), Prop :=
  | terminal_steps_nil
      c
      (TERMINAL: Configuration.is_terminal c):
      terminal_steps [] c c
  | terminal_steps_failure
      tid c1 c2 tids c3
      (NOTIN: ~ List.In tid tids)
      (STEP: step MachineEvent.failure tid c1 c2):
      terminal_steps (tid :: tids) c1 c3
  | terminal_steps_cons
      tid c1 c2 tids c3
      (NOTIN: ~ List.In tid tids)
      (STEP: terminal_step tid c1 c2)
      (STEPS: terminal_steps tids c2 c3):
      terminal_steps (tid :: tids) c1 c3
  .

  Lemma step_step
        e tid c1 c2
        (STEP: step e tid c1 c2):
    Configuration.opt_step e tid c1 c2.
  Proof.
    inv STEP.
    exploit dsteps_plus_step; eauto. i. des.
    - inv x1. destruct c1 as [threads mem]. ss.
      rewrite IdentMap.gsident; eauto.
    - subst. econs 2. econs; eauto. i.
      hexploit CONSISTENT; eauto. i.
      eapply delayed_consistent_consistent; eauto.
  Qed.

  Lemma terminal_step_step
        tid c1 c2
        (STEP: terminal_step tid c1 c2):
    Configuration.opt_step MachineEvent.silent tid c1 c2.
  Proof.
    inv STEP.
    exploit rtc_tail; eauto. i. des.
    - inv x1. inv TSTEP. destruct a2. ss.
      rewrite <- EVENT. des; clarify.
      { econs 2. econs; [eauto|..].
        + eapply rtc_join.
          eapply rtc_implies; try apply x0.
          eapply tau_lower_step_tau_step; eauto.
        + inv STEP. econs 2; eauto.
        + ii. econs 2; eauto. ss. inv PROMISES. auto.
      }
      { econs 2. econs; [eauto|..].
        + etrans.
          { eapply rtc_join.
            eapply rtc_implies; try apply x0.
            eapply tau_lower_step_tau_step; eauto.
          }
          { econs 2; [|refl]. econs; eauto. }
        + inv STEP. econs 2; eauto.
        + ii. econs 2; eauto. ss. inv PROMISES. auto.
      }
    - inv x0. destruct c1 as [threads mem]. ss.
      rewrite IdentMap.gsident; eauto.
  Qed.

  Lemma step_future c0 c1 e tid
        (STEP: step e tid c0 c1)
        (WF: Configuration.wf c0)
    :
      (<<WF2: Configuration.wf c1>>) /\
      (<<MEM_FUTURE: Global.future (Configuration.global c0) (Configuration.global c1)>>).
  Proof.
    inv WF. inv WF0. inv STEP; s.
    exploit THREADS; ss; eauto. i.
    hexploit dsteps_future; eauto. s. i. des.
    eapply dsteps_rtc_all_step in DSTEPS.
    splits; eauto. econs; ss. econs.
    - i. erewrite IdentMap.gsspec in *. des_ifs.
      + eapply inj_pair2 in H0. subst.
        exploit THREADS; try apply TH1; eauto. i.
        exploit Thread.rtc_all_step_disjoint; eauto. i. des. ss.
        symmetry. auto.
      + eapply inj_pair2 in H0. subst.
        exploit THREADS; try apply TH2; eauto. i. des.
        exploit Thread.rtc_all_step_disjoint; eauto. i. des.
        auto.
      + eapply DISJOINT; [|eauto|eauto]. auto.
    - i. erewrite IdentMap.gsspec in *. des_ifs.
      exploit THREADS; try apply TH; eauto. i.
      exploit Thread.rtc_all_step_disjoint; eauto. i. des.
      auto.
    - i. destruct (Local.promises lc2 loc) eqn:LGET.
      + exists tid, lang, st2, lc2. splits; ss.
        rewrite IdentMap.Facts.add_o. condtac; ss.
      + exploit Thread.rtc_all_step_promises_minus; try exact DSTEPS. s. i.
        eapply equal_f in x1.
        revert x1. unfold BoolMap.minus. rewrite GET, LGET. s. i.
        destruct (Global.promises (Configuration.global c0) loc) eqn:GET1; ss.
        destruct (Local.promises lc1 loc) eqn:LGET1; ss.
        exploit PROMISES; eauto. i. des.
        exists tid0, lang0, st, lc. splits; ss.
        rewrite IdentMap.Facts.add_o. condtac; ss. subst. congr.
  Qed.

  Lemma terminal_step_future c0 c1 tid
        (STEP: terminal_step tid c0 c1)
        (WF: Configuration.wf c0)
    :
      (<<WF2: Configuration.wf c1>>) /\
      (<<MEM_FUTURE: Global.future (Configuration.global c0) (Configuration.global c1)>>).
  Proof.
    inv WF. inv WF0. inv STEP; s.
    exploit THREADS; ss; eauto. i.
    exploit rtc_join.
    { eapply rtc_implies; [|apply STEPS].
      apply tau_lower_step_tau_step.
    }
    i. exploit Thread.rtc_tau_step_future; eauto. s. i. des.
    splits; eauto. econs; ss. econs.
    - i. erewrite IdentMap.gsspec in *. des_ifs.
      + eapply inj_pair2 in H0. subst.
        exploit THREADS; try apply TH1; eauto. i.
        exploit Thread.rtc_tau_step_disjoint; eauto. i. des. ss.
        symmetry. auto.
      + eapply inj_pair2 in H0. subst.
        exploit THREADS; try apply TH2; eauto. i. des.
        exploit Thread.rtc_tau_step_disjoint; eauto. i. des.
        auto.
      + eapply DISJOINT; [|eauto|eauto]. auto.
    - i. erewrite IdentMap.gsspec in *. des_ifs.
      exploit THREADS; try apply TH; eauto. i.
      exploit Thread.rtc_tau_step_disjoint; eauto. i. des.
      auto.
    - i. destruct (Local.promises lc2 loc) eqn:LGET.
      + exists tid, lang, st2, lc2. splits; ss.
        rewrite IdentMap.Facts.add_o. condtac; ss.
      + exploit Thread.rtc_tau_step_promises_minus; try exact x1. s. i.
        eapply equal_f in x2.
        revert x2. unfold BoolMap.minus. rewrite GET, LGET. s. i.
        destruct (Global.promises (Configuration.global c0) loc) eqn:GET1; ss.
        destruct (Local.promises lc1 loc) eqn:LGET1; ss.
        exploit PROMISES; eauto. i. des.
        exists tid0, lang0, st, lc. splits; ss.
        rewrite IdentMap.Facts.add_o. condtac; ss. subst. congr.
  Qed.

  Variant delayed_sl (gl_src gl_tgt: Global.t):
    forall (sl_src sl_tgt: {lang: language & Language.state lang} * Local.t), Prop :=
  | delayed_sl_intro
      lang st_src lc_src st_tgt lc_tgt
      (DELAYED:
        past_delayed_thread (Thread.mk lang st_src lc_src gl_src)
                       (Thread.mk lang st_tgt lc_tgt gl_tgt))
    :
    delayed_sl gl_src gl_tgt
          (existT _ lang st_src, lc_src)
          (existT _ lang st_tgt, lc_tgt)
  .

  Lemma delayed_sl_init lang st
    :
    delayed_sl Global.init Global.init (existT _ lang st, Local.init) (existT _ lang st, Local.init).
  Proof.
    econs.
    { econs.
      { eapply delayed_thread_init. }
      { refl. }
      { refl. }
      { refl. }
      { refl. }
      { eapply Local.init_wf. }
      { eapply Local.init_wf. }
      { eapply Global.init_wf. }
      { eapply Global.init_wf. }
    }
  Qed.

  Variant delayed_conf: forall (c_src c_tgt: Configuration.t), Prop :=
  | delayed_conf_intro
      ths_src gl_src
      ths_tgt gl_tgt
      (THS: forall tid,
          option_rel
            (delayed_sl gl_src gl_tgt)
            (IdentMap.find tid ths_src)
            (IdentMap.find tid ths_tgt))
      (GLOBAL: delayed_global_public gl_src gl_tgt)
    :
    delayed_conf (Configuration.mk ths_src gl_src)
                 (Configuration.mk ths_tgt gl_tgt)
  .

  Lemma delayed_conf_init s:
    delayed_conf (Configuration.init s) (Configuration.init s).
  Proof.
    econs.
    { i. unfold Threads.init.
      rewrite IdentMap.Facts.map_o. unfold option_map. des_ifs.
      ss. eapply delayed_sl_init.
    }
    { eapply delayed_global_public_init. }
  Qed.

  Lemma delayed_conf_step
        c1_src c1_tgt
        e tid c2_tgt
        (SIM: delayed_conf c1_src c1_tgt)
        (WF1_SRC: Configuration.wf c1_src)
        (WF1_TGT: Configuration.wf c1_tgt)
        (STEP: Configuration.step e tid c1_tgt c2_tgt):
    (exists c2_src,
        (<<STEP_SRC: step e tid c1_src c2_src>>) /\
          (<<SIM: delayed_conf c2_src c2_tgt>>)) \/
    (exists c2_src,
        (<<STEP_SRC: step MachineEvent.failure tid c1_src c2_src>>)).
  Proof.
    destruct c1_src as [ths1_src gl1_src],
             c1_tgt as [ths1_tgt gl1_tgt].
    inv SIM. inv STEP. ss.
    dup THS. specialize (THS tid). rewrite TID in THS.
    destruct (IdentMap.find tid ths1_src) as [[[lang_src st1_src] lc1_src]|] eqn:FIND_SRC; ss.
    inv THS. Configuration.simplify.
    dup WF1_SRC. inv WF1_SRC. ss.
    inv WF. exploit THREADS; eauto. intro WF1_SRC.
    clear DISJOINT THREADS.
    inv WF1_TGT. ss.
    inv WF. exploit THREADS; eauto. intro WF1_TGT.
    clear DISJOINT THREADS.
    inv DELAYED.
    hexploit Thread.rtc_tau_step_future; eauto. i. des.
    hexploit Thread.step_future; eauto. i. des.
    hexploit delayed_thread_steps_full; eauto. i. des; cycle 1.
    { destruct th_src1. right. esplits. econs; eauto. ss. }
    hexploit dsteps_future; eauto. i. des. ss.
    destruct th_src1.
    hexploit dsteps_strong_le; eauto. i. des; ss; cycle 1.
    { destruct th2'. right. esplits. econs; eauto. ss. }
    left. esplits.
    { econs; eauto. }
    { econs; eauto. i. rewrite ! IdentMap.gsspec. des_ifs.
      { econs; eauto. econs; eauto.
        { refl. }
        { refl. }
        { refl. }
        { refl. }
      }
      { specialize (THS0 tid0). ss. unfold option_rel in THS0. des_ifs.
        des. ss. inv THS0; ss. destruct lc1_src, lc_src.
        inv DELAYED1; ss. econs. econs; eauto.
        { etrans; eauto. }
        { etrans; eauto. eapply Global.future_le. etrans; eauto. }
        { etrans; eauto.
          eapply owned_future_global_promises_mon; eauto.
          eapply other_promise_included; eauto.
        }
        { etrans; eauto.
          eapply owned_future_global_promises_mon; eauto.
          eapply other_promise_included; eauto.
        }
      }
    }
  Qed.

  Lemma delayed_conf_terminal
        c_src c_tgt
        (LD: delayed_conf c_src c_tgt)
        (WF_SRC: Configuration.wf c_src)
        (WF_TGT: Configuration.wf c_tgt)
        (TERMINAL: Configuration.is_terminal c_tgt):
    exists c1_src,
      (<<STEP: terminal_steps
                 (IdentSet.elements (Threads.tids (Configuration.threads c_src)))
                 c_src c1_src>>).
  Proof.
    destruct c_src as [ths_src gl_src],
             c_tgt as [ths_tgt gl_tgt]. ss.
    remember (Threads.tids ths_src) as tids eqn:TIDS_SRC.
    assert (NOTIN: forall tid lang_src st_src lc_src
                     (FIND: IdentMap.find tid ths_src = Some (existT _ lang_src st_src, lc_src))
                     (TID: ~ List.In tid (IdentSet.elements tids)),
               Language.is_terminal _ st_src /\ Local.is_terminal lc_src).
    { i. destruct (IdentSet.mem tid tids) eqn:MEM.
      - exfalso. apply TID. rewrite IdentSet.mem_spec in MEM.
        rewrite <- IdentSet.elements_spec1 in MEM.
        clear - MEM. induction MEM; [econs 1|econs 2]; auto.
      - rewrite TIDS_SRC in MEM. rewrite Threads.tids_o in MEM.
        destruct (IdentMap.find tid ths_src) eqn:IFIND; [inv MEM|]. ss.
    }
    assert (IN: forall tid (TID: List.In tid (IdentSet.elements tids)),
               exists lang st_src lc_src st_tgt lc_tgt,
                 (<<FIND_SRC: IdentMap.find tid ths_src = Some (existT _ lang st_src, lc_src)>>) /\
                 (<<FIND_TGT: IdentMap.find tid ths_tgt = Some (existT _ lang st_tgt, lc_tgt)>>) /\
                 (<<LD_THREAD: past_delayed_thread
                                 (Thread.mk _ st_src lc_src gl_src)
                                 (Thread.mk _ st_tgt lc_tgt gl_tgt)>>)).
    { i. destruct (IdentSet.mem tid tids) eqn:MEM.
      - subst. dup MEM. rewrite Threads.tids_o in MEM0.
        inv LD. specialize (THS tid).
        destruct (IdentMap.find tid ths_src) as [[[lang_src st_src] lc_src]|] eqn:FIND_SRC; ss.
        destruct (IdentMap.find tid ths_tgt) as [[[lang_tgt st_tgt] lc_tgt]|] eqn:FIND_TGT; ss.
        inv THS. Configuration.simplify.
        esplits; eauto.
      - exfalso. subst.
        assert (SetoidList.InA eq tid (IdentSet.elements (Threads.tids ths_src))).
        { clear - TID. induction (IdentSet.elements (Threads.tids ths_src)); eauto. }
        rewrite IdentSet.elements_spec1 in H.
        rewrite <- IdentSet.mem_spec in H. congr.
    }
    assert (TIDS_MEM: forall tid, List.In tid (IdentSet.elements tids) -> IdentSet.mem tid tids = true).
    { i. rewrite IdentSet.mem_spec.
      rewrite <- IdentSet.elements_spec1.
      eapply SetoidList.In_InA; auto.
    }
    assert (NODUP: List.NoDup (IdentSet.elements tids)).
    { specialize (IdentSet.elements_spec2w tids). i.
      clear - H. induction H; econs; eauto.
    }
    assert (GLOBAL: delayed_global_public gl_src gl_tgt).
    { inv LD. eauto. }
    clear LD.
    revert NOTIN IN TIDS_MEM NODUP GLOBAL.
    revert ths_src gl_src WF_SRC TIDS_SRC WF_TGT.
    induction (IdentSet.elements tids); i.
    { esplits; [econs 1|..]. ii. eauto. }
    exploit (IN a); try by econs 1. i. des.
    exploit TERMINAL; eauto. i. des. inv THREAD.
    inv LD_THREAD.
    exploit delayed_thread_steps_terminal; try exact DELAYED; eauto; s.
    { eapply WF_SRC; eauto. }
    { eapply WF_TGT; eauto. }
    { eapply WF_SRC; eauto. }
    { eapply WF_TGT; eauto. }
    i. des; cycle 1.
    { destruct th_src1. esplits. econs 2; eauto.
      { inv NODUP. auto. }
      { econs; eauto. ss. }
    }
    hexploit lower_steps_future; eauto.
    { eapply WF_SRC; eauto. }
    { eapply WF_SRC; eauto. }
    i. des. ss.
    destruct th_src1 as [st1 lc1 gl1]. ss.
    hexploit rtc_tau_lower_step_strong_le; eauto.
    { eapply WF_SRC; eauto. }
    { eapply WF_SRC; eauto. }
    i. des; cycle 1.
    { destruct th1', th2'. esplits. econs 2; eauto.
      { inv NODUP. auto. }
      { econs; eauto.
        { econs; eauto. econs; eauto. }
        { ss. }
      }
    }
    assert (STEP_SRC: terminal_step
                        a
                        (Configuration.mk ths_src gl_src)
                        (Configuration.mk
                           (IdentMap.add a (existT _ _ st1, lc1) ths_src) gl1)).
    { econs; eauto. }
    exploit terminal_step_future; eauto. s. i. des.
    exploit IHl; try exact WF2; ss; eauto; i.
    { rewrite Threads.tids_add. rewrite IdentSet.add_mem; eauto. }
    { rewrite IdentMap.gsspec in FIND. revert FIND. condtac; ss; i.
      - subst. Configuration.simplify.
      - eapply NOTIN; eauto. ii. des; ss. subst. ss.
    }
    { exploit IN; eauto. i. des. inv NODUP.
      rewrite IdentMap.gso; try by (ii; subst; ss).
      esplits; eauto.
      inv LD_THREAD. destruct lc_src0, lc_src. ss. econs; eauto.
      { etrans; eauto. }
      { etrans; eauto.
        eapply owned_future_global_promises_mon; eauto.
        eapply other_promise_included; eauto.
        ii. subst. ss.
      }
    }
    { inv NODUP. ss. }
    des. esplits.
    econs 3; eauto. inv NODUP. ss.
    Unshelve. all: ss.
  Qed.

  Inductive delayed_behaviors:
    forall (conf:Configuration.t) (b:list Event.t) (f: bool), Prop :=
  | delayed_behaviors_nil
      c1 c2
      (STEP: terminal_steps
               (IdentSet.elements (Threads.tids (Configuration.threads c1)))
               c1 c2):
      delayed_behaviors c1 nil true
  | delayed_behaviors_syscall
      e1 e2 tid c1 c2 beh f
      (STEP: step (MachineEvent.syscall e2) tid c1 c2)
      (NEXT: delayed_behaviors c2 beh f)
      (EVENT: Event.le e1 e2):
      delayed_behaviors c1 (e1::beh) f
  | delayed_behaviors_failure
      tid c1 c2 beh f
      (STEP: step MachineEvent.failure tid c1 c2):
      delayed_behaviors c1 beh f
  | delayed_behaviors_tau
      tid c1 c2 beh f
      (STEP: step MachineEvent.silent tid c1 c2)
      (NEXT: delayed_behaviors c2 beh f):
      delayed_behaviors c1 beh f
  | delayed_behaviors_partial_term
      c:
      delayed_behaviors c [] false
  .

  Lemma delayed_conf_behavior
        c_src c_tgt
        (LD: delayed_conf c_src c_tgt)
        (WF_SRC: Configuration.wf c_src)
        (WF_tgt: Configuration.wf c_tgt):
    behaviors Configuration.step c_tgt <2= delayed_behaviors c_src.
  Proof.
    i. revert c_src LD WF_SRC. induction PR; i.
    - exploit delayed_conf_terminal; eauto. i. des.
      econs 1; eauto.
    - exploit delayed_conf_step; eauto. i. des; cycle 1.
      { eapply delayed_behaviors_failure; eauto. }
      exploit step_future; eauto. i. des.
      exploit Configuration.step_future; try exact STEP; eauto. i. des.
      econs 2; eauto.
    - exploit delayed_conf_step; eauto. i. des; cycle 1.
      { eapply delayed_behaviors_failure; eauto. }
      econs 3; eauto.
    - exploit delayed_conf_step; eauto. i. des; cycle 1.
      { eapply delayed_behaviors_failure; eauto. }
      exploit step_future; eauto. i. des.
      exploit Configuration.step_future; try exact STEP_SRC; eauto. i. des.
      econs 4; eauto.
    - econs 5.
  Qed.

  Lemma delayed_refinement
        s
    :
    behaviors Configuration.step (Configuration.init s) <2= delayed_behaviors (Configuration.init s).
  Proof.
    exploit delayed_conf_init; eauto. i.
    eapply delayed_conf_behavior; eauto.
    { eapply Configuration.init_wf. }
    { eapply Configuration.init_wf. }
  Qed.
End DConfiguration.


Require Import Relations.
Require Import EquivDec.
Require Import Equality.
Require Import List.
Require Import Bool.
Require Import Lia.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import sflib.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.
Require Import PromisingArch.promising.TsoPromising.
Require Import PromisingArch.promising.CommonPromising.
Require Import PromisingArch.promising.TsoStateExecFacts.

Set Implicit Arguments.

Lemma reorder_state_step_promise_step
      m1 m2 m3
      (WF: Machine.wf m1)
      (STEP1: Machine.step ExecUnit.state_step m1 m2)
      (STEP2: Machine.step ExecUnit.promise_step m2 m3):
  exists m2',
    <<STEP: Machine.step ExecUnit.promise_step m1 m2'>> /\
    <<STEP: Machine.step ExecUnit.state_step m2' m3>>.
Proof.
  destruct m1 as [tpool1 mem1].
  destruct m2 as [tpool2 mem2].
  destruct m3 as [tpool3 mem3].
  inv STEP1. inv STEP2. ss. subst.
  revert FIND0. rewrite IdMap.add_spec. condtac.
  - (* same thread *)
    inversion e. i. inv FIND0.
    inv STEP. inv STEP0. inv STEP1. inv LOCAL. inv MEM2. ss. subst.
    eexists (Machine.mk _ _). esplits.
    + econs; eauto; ss. econs; ss.
    + econs; ss.
      * rewrite IdMap.add_spec. instantiate (3 := tid). condtac; [|congr]. eauto.
      * econs. econs; eauto; ss.
        instantiate (1 :=
                       Local.mk
                         lc0.(Local.coh)
                         lc0.(Local.vrn)
                         lc0.(Local.vpr)
                         lc0.(Local.vpa)
                         lc0.(Local.vpc)
                         (Promises.set (S (length mem1)) lc0.(Local.promises))).
        inv LOCAL0.
        { econs 1; eauto. }
        { econs 2; eauto. instantiate (1 := ts). inv STEP. ss.
          exploit Memory.read_wf; try exact MSG. i.
          econs; eauto; ss.
          - ii. eapply LATEST; eauto.
            rewrite nth_error_app1 in MSG0; ss.
            eapply lt_le_trans; eauto.
            inv WF. exploit WF0; eauto. i. inv x. ss. inv LOCAL.
            repeat apply join_spec; viewtac.
          - apply Memory.read_mon. ss.
        }
        { econs 3; eauto. instantiate (1 := ts).
          inv STEP. inv WRITABLE. ss.
          exploit Memory.get_msg_wf; try exact MSG. i.
          econs; eauto; ss.
          - inv COHMAX. econs; eauto.
          - rewrite <- MSG. unfold Memory.get_msg. destruct ts; ss.
            rewrite nth_error_app1; [|lia]. ss.
          - rewrite Promises.set_o. condtac; ss. inversion e0. subst. ss.
          - f_equal. apply Promises.set_unset.
            ii. subst. lia.
        }
        { econs 4; eauto. instantiate (1 := ts). instantiate (1 := old_ts).
          inv STEP.
          exploit Memory.read_wf; try exact OLD_MSG. i.
          inv WRITABLE. ss.
          exploit Memory.get_msg_wf; try exact MSG. i.
          econs; try exact OLD_RANGE; ss.
          - ii. eapply EX; eauto.
            rewrite nth_error_app1 in MSG0; ss.
            eapply lt_le_trans; eauto.
          - apply Memory.read_mon. ss.
          - inv COHMAX. econs; eauto.
          - rewrite <- MSG. unfold Memory.get_msg. destruct ts; ss.
            rewrite nth_error_app1; [|lia]. ss.
          - rewrite Promises.set_o. condtac; ss. inversion e0. subst. ss.
          - f_equal. apply Promises.set_unset.
            ii. subst. lia.
        }
        { econs 5; eauto. instantiate (1 := old_ts). instantiate (1 := vold). inv STEP. ss.
          exploit Memory.read_wf; try exact OLD_MSG. i.
          econs; eauto; ss.
          - ii. eapply LATEST; eauto.
            rewrite nth_error_app1 in MSG; ss.
            eapply lt_le_trans; eauto.
            inv WF. exploit WF0; eauto. i. inv x. ss. inv LOCAL.
            repeat apply join_spec; viewtac.
          - apply Memory.read_mon. ss.
        }
        { econs 6; eauto. inv STEP. inv COHMAX. econs; ss. econs; eauto. }
        { econs 7; eauto. inv STEP. inv COHMAX. econs; ss. econs; eauto. }
        { econs 8; eauto. inv STEP. inv COHMAX. econs; ss. econs; eauto. }
        { econs 9; eauto. inv STEP. inv COHMAX_CL. econs; ss. econs; ss. }
      * rewrite ? IdMap.add_add. eauto.
  - (* diff thread *)
    inv STEP. inv STEP1. inv STEP0. inv LOCAL0. inv MEM2. ss. subst.
    eexists (Machine.mk _ _). esplits.
    + econs; eauto; ss. econs; ss.
    + econs; ss.
      * rewrite IdMap.add_spec. instantiate (3 := tid). condtac; [|by eauto].
        inversion e0. subst. congr.
      * econs. econs; eauto; ss.
        instantiate (1 := lc2). inv LOCAL.
        { econs 1; eauto. }
        { econs 2; eauto. inv STEP. econs; eauto.
          - ii. eapply LATEST; eauto.
            destruct (lt_dec ts0 (length mem1)).
            { rewrite nth_error_app1 in MSG0; ss. }
            contradict n.
            eapply Time.lt_le_trans; [apply TS2|].
            inv WF. exploit WF0; try exact FIND; eauto. i. inv x. inv LOCAL. ss.
          - apply Memory.read_mon. ss.
        }
        { econs 3; eauto. inv STEP. inv WRITABLE. econs; eauto.
          - econs; eauto.
          - apply Memory.get_msg_mon. ss.
        }
        { econs 4; eauto. instantiate (1 := ts).
          inv STEP. inv WRITABLE. econs; try exact OLD_RANGE; eauto.
          - ii. eapply EX; eauto.
            destruct (lt_dec ts0 (length mem1)).
            { rewrite nth_error_app1 in MSG0; ss. }
            contradict n.
            eapply Time.lt_le_trans; [apply TS2|].
            inv WF. exploit WF0; try exact FIND; eauto. i. inv x. inv LOCAL. ss.
            etrans. instantiate (1 := ts).
            + lia.
            + viewtac.
          - apply Memory.read_mon. ss.
          - econs; eauto.
          - apply Memory.get_msg_mon. ss.
        }
        { econs 5; eauto. instantiate (1 := old_ts). instantiate (1 := vold).
          inv STEP. econs; eauto.
          - ii. eapply LATEST; eauto.
            destruct (lt_dec ts (length mem1)).
            { rewrite nth_error_app1 in MSG; ss. }
            contradict n.
            eapply Time.lt_le_trans; [apply TS2|].
            inv WF. exploit WF0; try exact FIND; eauto. i. inv x. inv LOCAL. ss.
          - apply Memory.read_mon. ss.
        }
        { econs 6; eauto. }
        { econs 7; eauto. }
        { econs 8; eauto. }
        { econs 9; eauto. }
      * apply IdMap.add_add_diff. ss.
Qed.

Lemma reorder_state_step_rtc_promise_step
      m1 m2 m3
      (WF: Machine.wf m1)
      (STEP1: Machine.step ExecUnit.state_step m1 m2)
      (STEP2: rtc (Machine.step ExecUnit.promise_step) m2 m3):
  exists m2',
    <<STEP: rtc (Machine.step ExecUnit.promise_step) m1 m2'>> /\
    <<STEP: Machine.step ExecUnit.state_step m2' m3>>.
Proof.
  revert m1 WF STEP1. induction STEP2; eauto.
  i. exploit reorder_state_step_promise_step; eauto. i. des.
  exploit Machine.step_promise_step_wf; eauto. i.
  exploit IHSTEP2; eauto. i. des.
  esplits; cycle 1; eauto.
Qed.

Lemma split_rtc_step
      m1 m3
      (WF: Machine.wf m1)
      (STEP: rtc (Machine.step ExecUnit.step) m1 m3):
  exists m2,
    <<STEP: rtc (Machine.step ExecUnit.promise_step) m1 m2>> /\
    <<STEP: rtc (Machine.step ExecUnit.state_step) m2 m3>>.
Proof.
  revert WF. induction STEP; eauto. i.
  exploit Machine.step_step_wf; eauto. i.
  exploit IHSTEP; eauto. i. des.
  inv H. inv STEP2.
  - exploit reorder_state_step_rtc_promise_step; try exact WF; eauto. i. des.
    esplits; eauto.
  - esplits; cycle 1; eauto.
Qed.

Theorem promising_to_promising_pf
        p m
        (EXEC: Machine.exec p m):
  Machine.pf_exec p m.
Proof.
  inv EXEC. generalize (Machine.init_wf p). intro WF.
  exploit split_rtc_step; eauto. i. des.
  exploit Machine.rtc_step_promise_step_wf; eauto. i.
  exploit rtc_state_step_state_exec; eauto.
Qed.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import Morphisms.
From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICAst
     PCUICLiftSubst PCUICTyping PCUICSigmaCalculus
     PCUICClosed PCUICClosedConv PCUICClosedTyp PCUICWeakeningEnv PCUICWeakeningEnvTyp
     PCUICWeakeningConv PCUICWeakeningTyp PCUICInversion
     PCUICSubstitution PCUICReduction PCUICCumulativity PCUICGeneration
     PCUICUnivSubst PCUICUnivSubstitutionConv PCUICUnivSubstitutionTyp PCUICConfluence
     PCUICConversion PCUICContexts
     PCUICArities PCUICSpine PCUICInductives
     PCUICWellScopedCumulativity PCUICContexts PCUICWfUniverses.

From Equations Require Import Equations.
Require Import Equations.Prop.DepElim.
Require Import ssreflect ssrbool.

Derive Signature for typing.

Implicit Types (cf : checker_flags) (Σ : global_env_ext).

Arguments Nat.sub : simpl never.

Section Validity.
  Context `{cf : config.checker_flags}.

  Lemma isType_weaken_full : weaken_env_prop_full cumulSpec0 (lift_typing typing) (fun Σ Γ t T => isType Σ Γ T).
  Proof using Type.
    red. intros.
    apply infer_typing_sort_impl with id X2; intros Hs.
    unshelve eapply (weaken_env_prop_typing _ _ _ _ _ X1 _ _ (Typ (tSort _))); eauto with pcuic.
    red. simpl. destruct Σ. eapply Hs.
  Qed.

  Hint Resolve isType_weaken_full : pcuic.

  Lemma isType_weaken :
    weaken_env_prop cumulSpec0 (lift_typing typing)
      (lift_typing (fun Σ Γ (_ T : term) => isType Σ Γ T)).
  Proof using Type.
    red. intros.
    apply lift_typing_impl with (1 := X2); intros ? Hs.
    now eapply (isType_weaken_full (Σ, _)).
  Qed.
  Hint Resolve isType_weaken : pcuic.

  Lemma isType_extends (Σ : global_env) (Σ' : global_env) (φ : universes_decl) :
    wf Σ -> wf Σ' ->
    extends Σ Σ' ->
    forall Γ : context,
    forall t0 : term,
    isType (Σ, φ) Γ t0 -> isType (Σ', φ) Γ t0.
  Proof using Type.
    intros wfΣ wfΣ' ext Γ t Hty.
    apply infer_typing_sort_impl with id Hty; intros Hs.
    eapply (env_prop_typing weakening_env (Σ, φ)); auto.
  Qed.

  Lemma weaken_env_prop_isType :
    weaken_env_prop cumulSpec0 (lift_typing typing)
    (lift_typing
        (fun (Σ0 : PCUICEnvironment.global_env_ext)
          (Γ0 : PCUICEnvironment.context) (_ T : term) =>
        isType Σ0 Γ0 T)).
  Proof using Type.
    red. intros Σ Σ' ϕ wfΣ wfΣ' ext * Hty.
    apply lift_typing_impl with (1 := Hty); intros ? Hs.
    now eapply isType_extends with Σ.
  Qed.

  Lemma isType_Sort_inv {Σ : global_env_ext} {Γ s} : wf Σ -> isType Σ Γ (tSort s) -> wf_universe Σ s.
  Proof using Type.
    intros wfΣ [u Hu].
    now eapply inversion_Sort in Hu as [? [? ?]].
  Qed.

  Lemma isType_subst_instance_decl {Σ Γ T c decl u} :
    wf Σ.1 ->
    lookup_env Σ.1 c = Some decl ->
    isType (Σ.1, universes_decl_of_decl decl) Γ T ->
    consistent_instance_ext Σ (universes_decl_of_decl decl) u ->
    isType Σ (subst_instance u Γ) (subst_instance u T).
  Proof using Type.
    destruct Σ as [Σ φ]. intros X X0 Hty X1.
    eapply infer_typing_sort_impl with _ Hty; intros Hs.
    eapply (typing_subst_instance_decl _ _ _ (tSort _)); eauto.
  Qed.

  Lemma isWfArity_subst_instance_decl {Σ Γ T c decl u} :
    wf Σ.1 ->
    lookup_env Σ.1 c = Some decl ->
    isWfArity (Σ.1, universes_decl_of_decl decl) Γ T ->
    consistent_instance_ext Σ (universes_decl_of_decl decl) u ->
    isWfArity Σ (subst_instance u Γ) (subst_instance u T).
  Proof using Type.
    destruct Σ as [Σ φ]. intros X X0 [isTy [ctx [s eq]]] X1.
    split. eapply isType_subst_instance_decl; eauto.
    exists (subst_instance u ctx), (subst_instance_univ u s).
    rewrite (subst_instance_destArity []) eq. intuition auto.
  Qed.

  Lemma isType_weakening {Σ Γ T} :
    wf Σ.1 ->
    wf_local Σ Γ ->
    isType Σ [] T ->
    isType Σ Γ T.
  Proof using Type.
    intros wfΣ wfΓ HT.
    apply infer_typing_sort_impl with id HT; intros Hs.
    eapply (weaken_ctx (Γ:=[])); eauto.
  Qed.

  Lemma nth_error_All_local_env {P : context -> term -> typ_or_sort -> Type} {Γ n d} :
    nth_error Γ n = Some d ->
    All_local_env P Γ ->
    on_local_decl P (skipn (S n) Γ) d.
  Proof using Type.
    intros heq hΓ.
    epose proof (nth_error_Some_length heq).
    eapply (nth_error_All_local_env) in H; tea.
    now rewrite heq in H.
  Qed.

  Notation type_ctx := (type_local_ctx (lift_typing typing)).
  Lemma type_ctx_wf_univ Σ Γ Δ s : type_ctx Σ Γ Δ s -> wf_universe Σ s.
  Proof using Type.
    induction Δ as [|[na [b|] ty]]; simpl; auto with pcuic.
  Qed.
  Hint Resolve type_ctx_wf_univ : pcuic.

  Notation liat := ltac:(lia) (only parsing).

  Lemma eq_binder_annots_eq_ctx (Σ : global_env_ext) (Δ : context) (nas : list aname) :
    All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Δ ->
    PCUICEquality.eq_context_gen (PCUICEquality.eq_term Σ Σ) (PCUICEquality.eq_term Σ Σ)
      (map2 set_binder_name nas Δ) Δ.
  Proof using Type.
    induction Δ in nas |- * using PCUICInduction.ctx_length_rev_ind; simpl; intros hlen.
    - depelim hlen. simpl. reflexivity.
    - destruct nas as [|nas na] using rev_case => //;
      pose proof (All2_length hlen) as hlen';len in hlen'; simpl in hlen'; try lia.
      eapply All2_app_inv_l in hlen as (l1'&l2'&heq&alnas&allna).
      depelim allna. depelim allna.
      rewrite map2_app => /= //; try lia. unfold aname.
      eapply app_inj_tail in heq as [<- <-].
      simpl. eapply All2_fold_app; auto.
      constructor. constructor.
      destruct d as [na' [d|] ty]; constructor; cbn in *; auto;
      try reflexivity.
  Qed.

  Lemma eq_term_set_binder_name (Σ : global_env_ext) (Δ : context) T U (nas : list aname) :
    All2 (fun x y => eq_binder_annot x y.(decl_name)) nas Δ ->
    PCUICEquality.eq_term Σ Σ T U ->
    PCUICEquality.eq_term Σ Σ (it_mkProd_or_LetIn (map2 set_binder_name nas Δ) T) (it_mkProd_or_LetIn Δ U) .
  Proof using Type.
    intros a; unshelve eapply eq_binder_annots_eq_ctx in a; tea.
    eapply All2_fold_All2 in a.
    induction a in T, U |- *.
    - auto.
    - rewrite /= /mkProd_or_LetIn.
      destruct r => /=; intros; eapply IHa;
      constructor; auto.
  Qed.

  Lemma All2_eq_binder_subst_context_inst l s k i Δ Γ :
    All2
      (fun (x : binder_annot name) (y : context_decl) =>
        eq_binder_annot x (decl_name y)) l Γ ->
    All2
      (fun (x : binder_annot name) (y : context_decl) =>
      eq_binder_annot x (decl_name y)) l
        (subst_context s k
          (subst_instance i
              (expand_lets_ctx Δ Γ))).
  Proof using Type.
    intros. eapply All2_map_right in X.
    depind X.
    * destruct Γ => //. constructor.
    * destruct Γ => //.
      rewrite /expand_lets_ctx /expand_lets_k_ctx /=
        !lift_context_snoc; simpl.
      rewrite subst_context_snoc /= lift_context_length /=
        subst_instance_cons subst_context_snoc subst_instance_length
        subst_context_length lift_context_length.
        constructor. simpl. simpl in H. now noconf H.
        eapply IHX. simpl in H. now noconf H.
  Qed.

  Lemma wf_pre_case_predicate_context_gen {ci mdecl idecl} {p} :
    wf_predicate mdecl idecl p ->
    All2 (fun (x : binder_annot name) (y : context_decl) => eq_binder_annot x (decl_name y))
      (forget_types (pcontext p))
      (pre_case_predicate_context_gen ci mdecl idecl (pparams p) (puinst p)).
  Proof using Type.
    move=> [] hlen /Forall2_All2.
    rewrite /pre_case_predicate_context_gen /ind_predicate_context.
    intros a; depelim a.
    destruct (pcontext p); noconf H.
    cbn.
    rewrite /inst_case_context /= subst_instance_cons subst_context_snoc Nat.add_0_r /subst_decl /map_decl /=.
    constructor. cbn. apply e.
    now eapply All2_eq_binder_subst_context_inst.
  Qed.

  Lemma validity_wf_local {Σ} Γ Δ:
    All_local_env
      (fun (Γ0 : context) (t : term) (T : typ_or_sort) =>
      match T with
      | Typ T0 => isType Σ (Γ,,, Γ0) T0 × Σ ;;; (Γ ,,, Γ0) |- t : T0
      | Sort => isType Σ (Γ,,, Γ0) t
      end) Δ ->
    ∑ xs, sorts_local_ctx (lift_typing typing) Σ Γ Δ xs.
  Proof using Type.
    induction 1.
    - exists []; cbn; auto. exact tt.
    - destruct IHX as [xs Hxs].
      destruct t0 as [s Hs].
      exists (s :: xs). cbn. split; auto.
    - destruct IHX as [xs Hxs]. destruct t0 as [s Hs].
      exists xs; cbn. split; auto.
  Qed.

  Import PCUICOnFreeVars.

  Theorem validity_env :
    env_prop (fun Σ Γ t T => isType Σ Γ T)
      (fun Σ Γ => wf_local Σ Γ × All_local_env
        (fun Γ t T => match T with Typ T => (isType Σ Γ T × Σ ;;; Γ |- t : T) | Sort => isType Σ Γ t end) Γ).
  Proof using Type.
    apply typing_ind_env; intros; rename_all_hyps.

    - split => //. induction X; constructor; auto.

    - destruct X as [_ X].
      have hd := (nth_error_All_local_env heq_nth_error X).
      destruct decl as [na [b|] ty]; cbn -[skipn] in *; destruct hd.
      + eapply isType_lift; eauto.
        now apply nth_error_Some_length in heq_nth_error.
      + eapply isType_lift; eauto.
        now apply nth_error_Some_length in heq_nth_error.
        now exists x.

    - (* Universe *)
       exists (Universe.super (Universe.super u)).
       constructor; auto.
       now apply wf_universe_super.

    - (* Product *)
      eexists.
      eapply isType_Sort_inv in X1; eapply isType_Sort_inv in X3; auto.
      econstructor; eauto.
      now apply wf_universe_product.

    - (* Lambda *)
      destruct X3 as [bs tybs].
      eapply isType_Sort_inv in X1; auto.
      exists (Universe.sort_of_product s1 bs).
      constructor; auto.

    - (* Let *)
      apply infer_typing_sort_impl with id X5; unfold id in *; intros Hs.
      eapply type_Cumul.
      eapply type_LetIn; eauto.  econstructor; pcuic.
      eapply convSpec_cumulSpec, red1_cumulSpec; constructor.

    - (* Application *)
      apply infer_typing_sort_impl with id X3; unfold id in *; intros Hs'.
      move: (typing_wf_universe wf Hs') => wfs.
      eapply (substitution0 (n := na) (T := tSort _)); eauto.
      apply inversion_Prod in Hs' as [na' [s1 [s2 Hs]]]; tas. intuition.
      eapply (weakening_ws_cumul_pb (pb:=Cumul) (Γ' := []) (Γ'' := [vass na A])) in b0; pcuic.
      simpl in b0.
      eapply (type_ws_cumul_pb (pb:=Cumul)); eauto. pcuic.
      etransitivity; tea.
      eapply into_ws_cumul_pb => //.
      all:eauto with fvs.
      do 2 constructor.
      apply leq_universe_product.

    - destruct decl as [ty [b|] univs]; simpl in *.
      * eapply declared_constant_inv in X; eauto.
        red in X. simpl in X.
        eapply isType_weakening; eauto.
        eapply (isType_subst_instance_decl (Γ:=[])); eauto. simpl.
        eapply weaken_env_prop_isType.
      * have ond := on_declared_constant wf H.
        do 2 red in ond. simpl in ond.
        simpl in ond.
        eapply isType_weakening; eauto.
        eapply (isType_subst_instance_decl (Γ:=[])); eauto.

     - (* Inductive type *)
      destruct (on_declared_inductive isdecl); pcuic.
      destruct isdecl.
      apply onArity in o0.
      eapply isType_weakening; eauto.
      eapply (isType_subst_instance_decl (Γ:=[])); eauto.

    - (* Constructor type *)
      destruct (on_declared_constructor isdecl) as [[oni oib] [cs [declc onc]]].
      unfold type_of_constructor.
      eapply infer_typing_sort_impl with _ (on_ctype onc); intros Hs.
      eapply instantiate_minductive in Hs; eauto.
      2:(destruct isdecl as [[] ?]; eauto).
      simpl in Hs.
      eapply (weaken_ctx (Γ:=[]) Γ); eauto.
      eapply (substitution (Γ := []) (s := inds _ _ _) (Δ := []) (T := tSort _)); eauto.
      eapply subslet_inds; eauto. destruct isdecl; eauto.
      now rewrite app_context_nil_l.

    - (* Case predicate application *)
      assert (cu : consistent_instance_ext Σ (ind_universes mdecl) (puinst p)).
      { eapply (isType_mkApps_Ind_inv wf isdecl) in X7 as [parsubst [argsubst Hind]];
        repeat intuition auto. }
      eassert (ctx_inst Σ Γ _ (List.rev _)).
      { eapply ctx_inst_impl with (1 := X5); now intros t T [Hty _]. }
      clear X5; rename X6 into X5.
      unshelve epose proof (ctx_inst_spine_subst _ X5); tea.
      eapply weaken_wf_local; tea.
      now apply (on_minductive_wf_params_indices_inst isdecl _ cu).
      eapply spine_subst_smash in X6; tea.
      destruct X4.
      destruct (on_declared_inductive isdecl) as [onmind oib].
      rewrite /ptm. exists ps.
      eapply type_mkApps; eauto.
      eapply type_it_mkLambda_or_LetIn; tea.
      have typred : isType Σ Γ (it_mkProd_or_LetIn predctx (tSort ps)).
      { eapply All_local_env_app_inv in a0 as [_ onp].
        eapply validity_wf_local in onp as [xs Hs].
        eexists _.
        eapply type_it_mkProd_or_LetIn_sorts; tea.
        exact X3.π2. }
      have wfps : wf_universe Σ ps.
      { pcuic. }
      eapply typing_spine_strengthen; tea.
      2:{ rewrite /predctx /case_predicate_context /case_predicate_context_gen.
          eapply ws_cumul_pb_compare. 1-2:eauto with fvs.
          2:{ red.
              instantiate (1 :=
                it_mkProd_or_LetIn (pre_case_predicate_context_gen ci mdecl idecl (pparams p) (puinst p))
                    (tSort ps)).
            eapply PCUICEquality.eq_term_leq_term.
            eapply eq_term_set_binder_name. 2:reflexivity.
            now eapply wf_pre_case_predicate_context_gen. }
          rewrite subst_instance_app_ctx in X6.
          eapply spine_subst_smash_app_inv in X6 as [sppars spidx].
          epose proof (isType_case_predicate (puinst p) _ _ wfΓ isdecl cu wfps sppars).
          eauto with fvs. len.
          rewrite (wf_predicate_length_pars H0).
          now rewrite onmind.(onNpars). }
      eapply wf_arity_spine_typing_spine; auto.
      rewrite subst_instance_app_ctx in X6.
      eapply spine_subst_smash_app_inv in X6 as [sppars spidx].
      split; auto.
      apply (isType_case_predicate (puinst p) _ _ wfΓ isdecl cu wfps sppars).
      2:{ rewrite (wf_predicate_length_pars H0).
          rewrite context_assumptions_map.
          now rewrite onmind.(onNpars). }
      eapply arity_spine_case_predicate; tea.

    - (* Proj *)
      pose proof isdecl as isdecl'.
      eapply declared_projection_type in isdecl'; eauto.
      unshelve eapply isType_mkApps_Ind_inv in X2 as [parsubst [argsubst [sppar sparg
        lenpars lenargs cu]]]; eauto.
      2:eapply isdecl.p1.
      eapply infer_typing_sort_impl with _ isdecl'; intros Hs.
      eapply (typing_subst_instance_decl _ _ _ _ _ _ _ wf isdecl.p1.p1.p1) in Hs; eauto.
      simpl in Hs.
      eapply (weaken_ctx Γ) in Hs; eauto.
      rewrite -heq_length in sppar. rewrite firstn_all in sppar.
      rewrite subst_instance_cons in Hs.
      rewrite subst_instance_smash in Hs. simpl in Hs.
      eapply spine_subst_smash in sppar => //.
      eapply (substitution (Δ := [_]) sppar) in Hs.
      simpl in Hs.
      eapply (substitution (Γ' := [_]) (s := [c]) (Δ := [])) in Hs.
      simpl in Hs. rewrite (subst_app_simpl [_]) /=. eassumption.
      constructor. constructor.
      simpl. rewrite subst_empty.
      rewrite subst_instance_mkApps subst_mkApps /=.
      rewrite [subst_instance_instance _ _](subst_instance_id_mdecl Σ u _ cu); auto.
      rewrite subst_instance_to_extended_list.
      rewrite subst_instance_smash.
      rewrite (spine_subst_subst_to_extended_list_k sppar).
      assumption.

    - (* Fix *)
      eapply nth_error_all in X0 as [s Hs]; eauto.
      pcuic.

    - (* CoFix *)
      eapply nth_error_all in X0 as [s Hs]; pcuic.

    - (* Primitive *)
      destruct X0 as [s [hty hbod huniv]].
      exists s@[[]].
      change (tSort s@[[]]) with (tSort s)@[[]].
      rewrite -hty.
      refine (type_Const _ _ _ [] _ wfΓ H0 _).
      rewrite huniv //.

    - (* Conv *)
      now exists s.
  Qed.

End Validity.

Corollary validity {cf:checker_flags} {Σ} {wfΣ : wf Σ} {Γ t T} :
  Σ ;;; Γ |- t : T -> isType Σ Γ T.
Proof.
  intros. eapply validity_env; try eassumption.
Defined.

Lemma wf_local_validity `{cf : checker_flags} {Σ} {wfΣ : wf Σ} Γ Δ :
  wf_local Σ (Γ ,,, Δ) ->
  ∑ us, sorts_local_ctx (lift_typing typing) Σ Γ Δ us.
Proof.
  move=> wfΓΔ.
  apply: validity_wf_local.
  enough (h : wf_local_rel Σ Γ Δ).
  apply: All_local_env_impl; first exact h.
  1: move=> ?? [?|] //= ?; split=> //; apply: validity; eassumption.
  by apply: (wf_local_app_inv _).2.
Qed.

(* To deprecate *)
Notation validity_term wf Ht := (validity (wfΣ:=wf) Ht).

(* This corollary relies strongly on validity to ensure
   every type in the derivation is well-typed.
   It should be used instead of the weaker [invert_type_mkApps],
   which is only used as a stepping stone to validity.
 *)
Lemma inversion_mkApps {cf} {Σ} {wfΣ :  wf Σ.1} {Γ f u T} :
  Σ ;;; Γ |- mkApps f u : T ->
  ∑ A, Σ ;;; Γ |- f : A × typing_spine Σ Γ A u T.
Proof.
  induction u in f, T |- *. simpl. intros.
  { exists T. intuition pcuic. eapply typing_spine_refl.
    now eapply validity in X. }
  intros Hf. simpl in Hf.
  destruct u. simpl in Hf.
  - pose proof (validity Hf).
    eapply inversion_App in Hf as [na' [A' [B' [Hf' [Ha HA''']]]]]; tea.
    eexists _; intuition eauto.
    eapply validity in Hf'.
    econstructor; eauto with pcuic.
    constructor. all:eauto with pcuic.
    now eapply isType_apply in Hf'.
  - specialize (IHu (tApp f a) T).
    specialize (IHu Hf) as [T' [H' H'']].
    eapply inversion_App in H' as [na' [A' [B' [Hf' [Ha HA''']]]]]. 2:{ eassumption. }
    exists (tProd na' A' B'). intuition; eauto.
    eapply validity in Hf'.
    econstructor; eauto with wf.
    now eapply isType_ws_cumul_pb_refl.
    eapply isType_apply in Hf'; tea.
    eapply typing_spine_strengthen; tea.
Qed.

(** "Economical" typing rule for applications, not requiring to check the product type *)
Lemma type_App' {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t na A B u} :
  Σ;;; Γ |- t : tProd na A B ->
  Σ;;; Γ |- u : A -> Σ;;; Γ |- tApp t u : B {0 := u}.
Proof.
  intros Ht Hu.
  have [s Hs] := validity Ht.
  eapply type_App; eauto.
Qed.

(** This principle is useful when the type [tty] is an arity (of the form [it_mkProd_or_LetIn _ (tSort _)]),
    as it avoids having to give intermediate well-typing and cumulativity proofs. *)
Lemma type_mkApps_arity {cf} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ t u tty T} :
  Σ;;; Γ |- t : tty ->
  arity_spine Σ Γ tty u T ->
  Σ;;; Γ |- mkApps t u : T.
Proof.
  intros Ht Hty.
  pose proof (validity Ht).
  eapply type_mkApps; tea.
  eapply wf_arity_spine_typing_spine; tea.
  constructor; tas.
Qed.


(* En este archivo se demuestra que si el sistema parte de un estado inicial válido en el que existe
 * una aplicación A que es considerada vieja y no ha sido verificada, y luego de una serie de operaciones
 * dicha aplicación está en condiciones de ser ejecutada; es porque alguna de todas esas operaciones fue
 * la que verificó a la aplicación A. *)

Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import MyList.
Require Import ListAuxFuns.
Require Import ValidStateLemmas.
Require Import SameEnvLemmas.
Require Import Semantica.
Require Import RuntimePermissions.
Require Import EqTheorems.
Require Import Trace.
Require Import PropertiesAuxFuns.

Require Import TraceRelatedLemmas.
Require Import Coq.Arith.Lt.

Section IfOldAppRunThenVerified.

Lemma inductMe : forall
(initState : System)
(initStateValid : validstate initState)
(a : idApp)
(l : list Action)
(aIsTheSame : ~ In (uninstall a) l)
(notVerified : ~ In (verifyOldApp a) l)
(couldntRun : ~canRun a initState)
(aInstalled:
  In a (apps (state initState)) \/
  (exists x0, In x0 (systemImage (environment initState)) /\ idSI x0 = a)),
validstate ((last (trace initState l)) initState) /\
(In a (apps (state ((last (trace initState l)) initState))) \/ (exists x0, In x0 (systemImage (environment ((last (trace initState l)) initState))) /\ idSI x0 = a)) /\
(~canRun a ((last (trace initState l)) initState)).
Proof.
    intros.
    induction l using rev_ind.
  - simpl. split; auto.
  - assert (~In (uninstall a) l).
    unfold not;intros.
    apply aIsTheSame.
    rewrite in_app_iff.
    left;auto.
    assert (~In (verifyOldApp a) l).
    unfold not;intros.
    apply notVerified.
    rewrite in_app_iff.
    left;auto.
    specialize (IHl H H0).
    destruct IHl.
    split.
    rewrite (lastTraceApp initState l x initState).
    apply stepIsInvariant. auto.

    rewrite lastTraceApp.
    remember (last (trace initState l) initState) as lastSys.
    destruct H2.

    assert (x<>uninstall a) as xNotUninstallA.
    unfold not;intros.
    apply aIsTheSame.
    rewrite in_app_iff.
    right.
    rewrite H4.
    apply in_eq.

    assert (x<>verifyOldApp a) as xNotVerifyA.
    unfold not; intros.
    apply notVerified.
    rewrite in_app_iff.
    right.
    rewrite H4.
    apply in_eq.

    split.
    destruct H2.
    left.

    apply aInAppsAndNotUninstalled;auto.
    right.
    destruct H2.
    exists x0.
    destruct H2.
    split;auto.

    assert (systemImage (environment (system (step lastSys x))) = systemImage (environment lastSys)).
    destruct x;simpl.
    unfold install_safe; case_eq (install_pre i m c l0 lastSys);intros;simpl;auto.
    unfold uninstall_safe; case_eq (uninstall_pre i lastSys);intros;simpl;auto.
    unfold grant_safe; case_eq (grant_pre p i lastSys);intros;simpl;auto.
    unfold grantAuto_safe; case_eq (grantAuto_pre p i lastSys);intros;simpl;auto.
    unfold revoke_safe; case_eq (revoke_pre p i lastSys);intros;simpl;auto.
    unfold revokegroup_safe; case_eq (revokegroup_pre i i0 lastSys);intros;simpl;auto.
    auto.
    unfold read_safe; case_eq (read_pre i c u lastSys);intros;simpl;auto.
    unfold write_safe; case_eq (write_pre i c u v lastSys);intros;simpl;auto.
    unfold startActivity_safe; case_eq (startActivity_pre i i0 lastSys);intros;simpl;auto.
    unfold startActivity_safe; case_eq (startActivity_pre i i0 lastSys);intros;simpl;auto.
    unfold startService_safe; case_eq (startService_pre i i0 lastSys);intros;simpl;auto.
    unfold sendBroadcast_safe; case_eq (sendBroadcast_pre i i0 o lastSys);intros;simpl;auto.
    unfold sendBroadcast_safe; case_eq (sendBroadcast_pre i i0 o lastSys);intros;simpl;auto.
    unfold sendStickyBroadcast_safe; case_eq (sendStickyBroadcast_pre i i0 lastSys);intros;simpl;auto.
    unfold resolveIntent_safe; case_eq (resolveIntent_pre i i0 lastSys);intros;simpl;auto.
    unfold receiveIntent_safe; case_eq (receiveIntent_pre i i0 i1 lastSys);intros;simpl;auto.
    unfold receiveIntent_post.
    destruct (maybeIntentForAppCmp i i1 i0 lastSys);auto.
    unfold stop_safe; case_eq (stop_pre i lastSys);intros;simpl;auto.
    unfold grantP_safe; case_eq (grantP_pre i c i0 u p lastSys);intros;simpl;auto.
    unfold revokeDel_safe; case_eq (revokeDel_pre i c u p lastSys);intros;simpl;auto.
    unfold call_safe; case_eq (call_pre i s lastSys);intros;simpl;auto.
    unfold verifyOldApp_safe; case_eq (verifyOldApp_pre i lastSys);intros;simpl;auto.
    rewrite H5;auto.

    assert (x <> verifyOldApp a) as xNotVerifyOldApp.
    unfold not;intros.
    apply notVerified.
    rewrite in_app_iff.
    right.
    rewrite H4.
    apply in_eq.

    unfold not; intros.
    apply H3.
    unfold canRun in H4.
    unfold canRun.
    destruct H4. left.
 (* Caso alreadyVerifiedIsTheSame*)
 -- apply (alreadyVerifiedSame x a); auto.
 (* Caso manifestIsTheSame *)
 -- destruct H4 as [m [n [H4 [H5 H6]]]].
    right. exists m, n.
    split; auto.
    unfold isManifestOfApp.
    destruct H4.

    left. apply (manifestsSame x); auto.

    right. clear H5 H6.
    destruct H4 as [sysapp [H4 [H5 H6]]].
    exists sysapp.
    split; auto.
    apply (sysImgSame x lastSys H1 sysapp);auto.
Qed.

Theorem ifOldAppRunThenWasVerifiedProof :
  forall
    (initState lastState: System)
    (a: idApp)
    (l: list Action)
    (aInstalled:In a (apps (state initState)) \/ (exists x0, In x0 (systemImage (environment initState)) /\ idSI x0 = a))
    (vsInit: validstate initState)
    (oldApp: isOldApp a initState)
    (notVerified: ~(In a (alreadyVerified (state initState))))
    (canRunLastState: canRun a lastState)
    (aIsTheSame : ~ In (uninstall a) l)
    (fromInitToLast: last (trace initState l) initState  = lastState),
    In (verifyOldApp a) l.
Proof.
    intros.
    apply NNPP.
    unfold not;intros.
    assert (validstate (last (trace initState l) initState) /\ (In a (apps (state (last (trace initState l) initState))) \/ (exists x0, In x0 (systemImage (environment (last (trace initState l) initState))) /\ idSI x0 = a)) /\ ~ (canRun a (last (trace initState l) initState))).
    apply inductMe;auto.
    unfold canRun. unfold not.
    intros. destruct H0.
    contradiction.
    unfold isOldApp in oldApp.
    destruct oldApp as [m [n [H1 [H2 nLTVulnerableSdk]]]].
    destruct H0 as [m' [n' [H3 [H4 nGTVulnerableSdk]]]].

    assert (m=m').
    apply (sameAppSameManifest initState vsInit a); auto.

    rewrite <- H0 in H4.
    rewrite H2 in H4.
    inversion H4.
    rewrite <- H6 in nGTVulnerableSdk.
    assert (n<n).
    apply (lt_trans n vulnerableSdk); auto.
    apply lt_irrefl in H5; auto.

    destruct H0.
    destruct H1.
    rewrite fromInitToLast in H2.
    contradiction.
Qed.

End IfOldAppRunThenVerified.