Require Import sflib.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import Loc.
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 NPThread.
Require Import Configuration.
Require Import MsgMapping.
Require Import DelaySet.
Require Import NPConfiguration.

Require Import LocalSim.
Require Import GlobSim.
Require Import ww_RF.

Require Import LibTactics.
Require Import ConfigInitLemmas.
Require Import CompThreadSteps.
Require Import CompAuxDef.
Require Import WFConfig.

Require Import Reordering.
Require Import ps_to_np_thread.
Require Import np_to_ps_thread.

Require Import simPromiseCertified.
Require Import Mem_at_eq_lemmas.
Require Import ConsistentProp.

(** * Compositionality Proof *)

(** This file contains the proof of compositionality of our thread-local simulation.

    The theorem [compositionality] in this file shows the compositionality of our thread-local simulation.
    It says that,
    if each target thread has thread-local simulation with
    its corresponding source thread
    and the source program is safe and write-write race free,
    then the whole target program simulates the whole source program.

    The theorem [compositionality] is a part of proof in Lemma 6.2 in our paper and
    also shown as a part of proof of the step 3 in Figure 6 (Our proof path) in our paper.
 *)

Lemma compositionality_aux:
      forall (index: Type) (index_order: index -> index -> Prop)
        (I: Invariant) (lo: Ordering.LocOrdMap) (b b': bool) inj
        (ths_tgt ths_src: Threads.t) (ctid: IdentMap.key)
        (sc_tgt sc_src: TimeMap.t) (mem_tgt mem_src: Memory.t)
        (WELL_FOUNDED_ORDER: well_founded index_order)
        (WELL_FORMED_INV: wf_I I)
        (READY_THRDS:
           forall tid (READY_TID: tid <> ctid) lang st_tgt lc_tgt
             (READY_TGT_THD: IdentMap.find tid ths_tgt = Some (existT _ lang st_tgt, lc_tgt)),
           exists st_src lc_src,
             IdentMap.find tid ths_src = Some (existT _ lang st_src, lc_src) /\
             @rely_local_sim_state index index_order lang I lo inj
                                   (Thread.mk lang st_tgt lc_tgt sc_tgt mem_tgt)
                                   (Thread.mk lang st_src lc_src sc_src mem_src) /\
             Local.promise_consistent lc_tgt)
        (CUR_THRD:
           forall lang st_tgt lc_tgt
             (CUR_TGT_THRD: IdentMap.find ctid ths_tgt = Some (existT _ lang st_tgt, lc_tgt)),
           exists st_src lc_src dset,
             IdentMap.find ctid ths_src = Some (existT _ lang st_src, lc_src) /\
             @local_sim_state index index_order lang I lo inj dset b
                              (Thread.mk lang st_tgt lc_tgt sc_tgt mem_tgt)
                              (Thread.mk lang st_src lc_src sc_src mem_src) /\
             (b = true -> dset = dset_init) /\
             Local.promise_consistent lc_tgt)
        (COMPLETE_THRDS_MAP:
           forall tid
             (IN_SRC_THRDS: IdentMap.mem tid ths_src = true),
             IdentMap.mem tid ths_tgt = true)
        (SAFE: ~(exists npc,
                    rtc (NPConfiguration.all_step lo)
                        (NPConfiguration.mk (Configuration.mk ths_src ctid sc_src mem_src) b') npc /\
                    Configuration.is_abort (NPConfiguration.cfg npc) lo))
        (WWRF: ~(exists npc,
                    rtc (NPConfiguration.all_step lo)
                        (NPConfiguration.mk (Configuration.mk ths_src ctid sc_src mem_src) b') npc /\
                    aux_ww_race lo (NPConfiguration.cfg npc)))
        (WF_CONFIG_TGT: Configuration.wf (Configuration.mk ths_tgt ctid sc_tgt mem_tgt))
        (WF_CONFIG_SRC: Configuration.wf (Configuration.mk ths_src ctid sc_src mem_src))
        (WF_ATM_BIT: b = true -> b' = true)
        (*(CTID_IN: IdentMap.mem ctid ths_tgt = true)*)
        (INV_OUT_ATM: b = true ->
                      (Mem_at_eq lo mem_tgt mem_src /\ I lo inj (Build_Rss sc_tgt mem_tgt sc_src mem_src)))
        (MONOTONIC_INJ: monotonic_inj inj),
        glob_sim_state lo (NPConfiguration.mk (Configuration.mk ths_tgt ctid sc_tgt mem_tgt) b)
                       (NPConfiguration.mk (Configuration.mk ths_src ctid sc_src mem_src) b').
Proof.
  cofix Hcofix; ii.
  econs; ss; ii.
  + (* tau step *)
    inv TGT_TAU; ss.
    assert(T_STEPS: rtc (NPAuxThread.tau_step lang lo)
                        (NPAuxThread.mk lang (Thread.mk lang st1 lc1 sc_tgt mem_tgt) b)
                        (NPAuxThread.mk lang (Thread.mk lang st2 lc2 sc2 m2) b0)).
    {
      eapply rtc_n1; [eapply STEPS | eapply STEP].
    }
    exploit wf_config_rtc_NPThread_tau_steps_prsv; [ | | eapply T_STEPS | eauto..]; eauto.
    introv T_CONFIG_WF'.
    eapply rtc_rtcn in T_STEPS. des.
    exploit CUR_THRD; [eapply TID1 | eauto..]. ii; des.
    assert(TGT_PROM_CONS: Local.promise_consistent lc2).
    {
      eapply consistent_nprm_promise_consistent in CONSISTENT; eauto; ss.
      eapply wf_config_to_local_wf; eauto.
      instantiate (3 := ctid). rewrite IdentMap.gss; eauto.
      inv T_CONFIG_WF'; eauto. inv T_CONFIG_WF'; eauto.
    }
    exploit sim_tau_steps; [eapply T_STEPS | eauto..]; ss.
    eapply wf_config_to_local_wf; eauto.
    inv WF_CONFIG_TGT; eauto.
    inv WF_CONFIG_TGT; eauto.
    ii; des.
    {
      (* not abort *)
      destruct e_src'.
      exploit wf_config_rtc_NPThread_tau_steps_prsv; [ | | eapply S_STEPS | eauto..]; eauto.
      introv S_CONFIG_WF'.
      eapply rtc_rtcn in S_STEPS. destruct S_STEPS as (n0 & S_STEPS).
      destruct n0.
      {
        (* source takes zero step *)
        inv S_STEPS.
        eexists. split. eauto.
        eapply Hcofix with (b' := b_src') (inj := inj'); eauto.
        {
          ii.
          erewrite IdentMap.gso in READY_TGT_THD; eauto.
          lets READY_SRC_THD: READY_TGT_THD.
          eapply READY_THRDS in READY_SRC_THD; eauto. des.
          do 2 eexists.
          split; eauto.
          split; eauto.
          eapply local_sim_rely_condition with (n_tgt := n) (n_src := 0) (lang2 := lang0); eauto.
          eapply wf_config_to_local_wf; eauto.
          clear S_CONFIG_WF'. eapply wf_config_to_local_wf; eauto.
          inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_SRC; eauto.
          inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_SRC; eauto.
          clear S_CONFIG_WF'. eapply wf_config_to_local_wf; eauto.
          instantiate (3 := tid). erewrite IdentMap.gso; eauto.
          clear S_CONFIG_WF'. eapply wf_config_to_local_wf; eauto.
          inv T_CONFIG_WF'; eauto.
          inv S_CONFIG_WF'; eauto.
          inv T_CONFIG_WF'; eauto.
          inv S_CONFIG_WF'; eauto.
        }
        {
          ii.
          rewrite IdentMap.gss in CUR_TGT_THRD. inv CUR_TGT_THRD.
          eapply inj_pair2 in H1. subst.
          do 3 eexists. split. eauto. split; eauto.
        }
        {
          ii. rewrite IdentMap.mem_find.
          destruct (Loc.eq_dec tid ctid); subst.
          rewrite IdentMap.gss; eauto.
          rewrite IdentMap.gso; eauto.
          eapply COMPLETE_THRDS_MAP in IN_SRC_THRDS.
          rewrite IdentMap.mem_find in IN_SRC_THRDS. eauto.
        }
        {
          inv LOCAL_SIM_PSV; ss.
          contradiction SAFE. eexists. split. eauto. ss.
          econs; ss.
          eapply NPAuxThread_tau_steps_2_Thread_tau_steps in NP_STEPS; ss.
          do 3 eexists. split. eauto.
          split.
          eapply NP_STEPS. eauto.
          clear - STEP_INV RELY_STEP.
          ii. exploit RELY_STEP; eauto. ii; des.
          inv STEP_INV. eauto.
        }
      }
      {
        (* source takes multiply steps *)
        exploit Behavior.rtcn_tail; [eapply S_STEPS | eauto..].
        introv S_STEPS_CONS.
        destruct S_STEPS_CONS as (npc & S_STEPS_CONS & S_STEP).
        destruct npc.
        assert(CONSISTENT_S:
                 NPAuxThread.consistent lang (Thread.mk lang state local sc memory) lo).
        {
          eapply promise_certified_prsv; [ | eapply CONSISTENT | eauto..]; eauto.
          {
            clear - SAFE S_STEPS x.
            eapply rtcn_rtc in S_STEPS.
            introv S_ABORT. destruct S_ABORT as (e_src' & S_STEPS_TO_ABORT & S_ABORT).
            contradiction SAFE.
            eexists. split; eauto; ss.
            eapply NPAuxThread_tau_steps_2_Thread_tau_steps in S_STEPS; ss.
            econs; ss.
            do 3 eexists.
            split. eapply x.
            split. eapply rtc_compose; [eapply S_STEPS | eapply S_STEPS_TO_ABORT].
            eauto.
          }
          {
            eapply aux_ww_race_to_thrd_ww_race; eauto; ss.
            eapply rtcn_rtc in S_STEPS.
            eapply NPAuxThread_tau_steps_2_Thread_tau_steps in S_STEPS; ss.
          }
          {
            eapply wf_config_to_local_wf; eauto.
            instantiate (3 := ctid). erewrite IdentMap.gss; eauto.
          }
          {
            eapply wf_config_to_local_wf; eauto.
            instantiate (3 := ctid). erewrite IdentMap.gss; eauto.
          }
          {
            inv T_CONFIG_WF'; eauto.
          }
          {
            inv S_CONFIG_WF'; eauto.
          }
          {
            inv T_CONFIG_WF'; eauto.
          }
          {
            inv S_CONFIG_WF'; eauto.
          }
        }
        eexists. split.
        {
          eapply rtcn_rtc in S_STEPS_CONS.
          eapply Operators_Properties.clos_rt1n_step.
          eapply NPConfiguration.step_tau; ss; [ | eapply S_STEPS_CONS | eapply S_STEP | eauto..]; eauto.
        }
        eapply Hcofix; eauto.
        {
          ii.
          rewrite IdentMap.gso in READY_TGT_THD; eauto.
          rewrite IdentMap.gso; eauto.
          lets READY_SRC_THD: READY_TGT_THD.
          eapply READY_THRDS in READY_SRC_THD; eauto. des.
          do 2 eexists.
          split; eauto.
          split; eauto.
          eapply local_sim_rely_condition with (n_tgt := n) (n_src := (S n0)) (lang2 := lang0); eauto.
          eapply wf_config_to_local_wf; eauto.
          eapply wf_config_to_local_wf; eauto.
          inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_SRC; eauto.
          inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_SRC; eauto.
          eapply wf_config_to_local_wf; eauto.
          instantiate (3 := tid). erewrite IdentMap.gso; eauto.
          eapply wf_config_to_local_wf; eauto.
          instantiate (3 := tid). erewrite IdentMap.gso; eauto.
          inv T_CONFIG_WF'; eauto.
          inv S_CONFIG_WF'; eauto.
          inv T_CONFIG_WF'; eauto.
          inv S_CONFIG_WF'; eauto.
        }
        {
          ii. rewrite IdentMap.gss in CUR_TGT_THRD.
          inv CUR_TGT_THRD.
          eapply inj_pair2 in H1. subst.
          do 3 eexists. split.
          rewrite IdentMap.gss; eauto.
          split; eauto.
        }
        {
          ii. rewrite IdentMap.mem_find.
          destruct (Loc.eq_dec tid ctid); subst.
          rewrite IdentMap.gss; eauto.
          rewrite IdentMap.gso; eauto.
          rewrite IdentMap.mem_find in IN_SRC_THRDS.
          rewrite IdentMap.gso in IN_SRC_THRDS; eauto.
          rewrite <- IdentMap.mem_find in IN_SRC_THRDS.
          eapply COMPLETE_THRDS_MAP in IN_SRC_THRDS.
          rewrite IdentMap.mem_find in IN_SRC_THRDS. eauto.
        }
        {
          clear - SAFE S_STEPS x CONSISTENT_S.
          eapply rtcn_rtc in S_STEPS. ii. des.
          contradiction SAFE.
          eapply rtc_rtcn in S_STEPS. des.
          destruct n.
          inv S_STEPS.
          erewrite IdentMap.gsident in H; eauto.
          eapply Behavior.rtcn_tail in S_STEPS. des. destruct a2. destruct state0.
          eapply rtcn_rtc in S_STEPS.
          eexists. split.
          eapply Relation_Operators.rt1n_trans.
          econs; eauto.
          eapply NPConfiguration.step_tau; ss; eauto.
          eapply H. eauto.
        }
        {
          ii; des. contradiction WWRF.
          clear - S_STEPS H H0 CONSISTENT_S x.
          eapply Behavior.rtcn_tail in S_STEPS. des. destruct a2. destruct state0.
          eapply rtcn_rtc in S_STEPS.
          eexists. split.
          eapply Relation_Operators.rt1n_trans.
          econs; eauto.
          eapply NPConfiguration.step_tau; ss; eauto.
          eapply H. eauto.
        }
        {
          inv LOCAL_SIM_PSV; ss.
          contradiction SAFE.
          eapply rtcn_rtc in S_STEPS.
          eexists. split. eauto. ss.
          eapply NPAuxThread_tau_steps_2_Thread_tau_steps in S_STEPS; ss.
          eapply NPAuxThread_tau_steps_2_Thread_tau_steps in NP_STEPS; ss.
          econs; ss. do 3 eexists.
          split. eauto. split.
          eapply rtc_compose. eapply S_STEPS. eapply NP_STEPS. eauto.
          clear - STEP_INV RELY_STEP.
          ii. exploit RELY_STEP; eauto. ii; des.
          inv STEP_INV. eauto.
        }
      }
    }
    {
      (* abort *)
      clear - x SAFE S_STEPS ABORT.
      contradiction SAFE.
      eexists. split; eauto. ss.
      econs; ss.
      eapply NPAuxThread_tau_steps_2_Thread_tau_steps in S_STEPS; ss.
      do 3 eexists.
      split; eauto.
    }
  + (* output step *)
    inv TGT_OUT; ss.
    exploit CUR_THRD; [eapply TID1 | eauto..]. ii; des.
    exploit sim_output_steps; [eapply STEP | eauto..]. ii; des.
    {
      (* not abort *)
      assert(CONSISTENT_S': Local.promises (Thread.local e_src0) = Memory.bot /\
                            Local.promises (Thread.local e_src') = Memory.bot).
      {
        clear - S_OUT. inv S_OUT; ss. inv H. inv OUT; ss.
        inv LOCAL; ss. inv LOCAL0; ss. exploit PROMISES; eauto.
      }
      destruct CONSISTENT_S' as (CONSISTENT_S' & CONSISTENT_S'').
      exploit wf_config_NPThread_out_step_prsv; [ | | eapply STEP | eauto..]; eauto.
      introv WF_CONFIG_TGT'.
      destruct e_src0, e_src'.
      exploit wf_config_rtc_NPThread_tau_steps_prsv; [ | | eapply S_STEPS | eauto..]; eauto.
      introv WF_CONFIG_SRC'.
      exploit wf_config_NPThread_out_step_prsv; [ | | eapply S_OUT | eauto..]; eauto.
      instantiate (1 := ctid). rewrite IdentMap.gss; eauto.
      introv WF_CONFIG_SRC''.
      erewrite IdentMap.add_add_eq in WF_CONFIG_SRC''; eauto.
      assert (T_PROM_CONS: Local.promise_consistent lc2).
      {
        inv STEP; ss. inv H; ss. inv OUT; ss.
        inv LOCAL; ss. inv LOCAL0; ss.
        exploit PROMISES; eauto. introv T_BOT.
        unfold Local.promise_consistent; ss.
        rewrite T_BOT; ss. ii. rewrite Memory.bot_get in PROMISE; ss.
      }
      eapply rtc_rtcn in S_STEPS. des. destruct n.
      {
        inv S_STEPS; ss.
        do 2 eexists. split. eauto.
        split.
        econs; ss. eapply x. eapply S_OUT.
        ss. econs. split. eauto. ss.
        eapply Hcofix with (inj := inj'); eauto.
        {
          ii.
          rewrite IdentMap.gso in READY_TGT_THD; eauto.
          rewrite IdentMap.gso; eauto. ss.
          exploit READY_THRDS; [eapply READY_TID | eapply READY_TGT_THD | eauto..]. ii; des.
          do 2 eexists. split. eauto.
          split; eauto.
          eapply local_sim_out_rely_condition in x4; eauto.
          eapply wf_config_to_local_wf; eauto.
          eapply wf_config_to_local_wf; eauto. instantiate (3 := ctid). erewrite IdentMap.gss; eauto.
          inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_TGT; eauto.
          ss. inv WF_CONFIG_SRC'.
          ss. inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_SRC'; eauto.
          eapply wf_config_to_local_wf; eauto.
          instantiate (3 := tid). erewrite IdentMap.gso; eauto.
          eapply wf_config_to_local_wf; eauto.
          instantiate (3 := tid). erewrite IdentMap.gso; eauto.
          inv WF_CONFIG_TGT'; eauto.
          inv WF_CONFIG_SRC'; eauto.
          inv WF_CONFIG_TGT'; eauto.
          inv WF_CONFIG_SRC''; eauto.
          inv WF_CONFIG_SRC''; eauto.
        }
        {
          ii. rewrite IdentMap.gss in CUR_TGT_THRD; eauto.
          inv CUR_TGT_THRD. eapply inj_pair2 in H1. subst.
          do 3 eexists. split. rewrite IdentMap.gss; eauto.
          split; eauto.
        }
        {
          ii. rewrite IdentMap.mem_find.
          destruct (Loc.eq_dec tid ctid); subst.
          rewrite IdentMap.gss; eauto.
          rewrite IdentMap.gso; eauto.
          rewrite IdentMap.mem_find in IN_SRC_THRDS.
          rewrite IdentMap.gso in IN_SRC_THRDS; eauto.
          rewrite <- IdentMap.mem_find in IN_SRC_THRDS.
          eapply COMPLETE_THRDS_MAP in IN_SRC_THRDS.
          rewrite IdentMap.mem_find in IN_SRC_THRDS. eauto.
        }
        {
          introv ABORT. destruct ABORT as (npc & TO_ABORT & ABORT).
          contradiction SAFE. exists npc.
          split. eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_out; ss; eauto.
          ss. unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ii; ss.
          eexists. split; eauto.
          eauto. eauto.
        }
        {
          introv WW_RACE. destruct WW_RACE as (npc & TO_WW_RACE & WW_RACE).
          contradiction WWRF. exists npc.
          split. eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_out; ss; eauto.
          ss. unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ii; ss.
          eexists. split; eauto.
          eauto. eauto.
        }
        {
          inv LOCAL_SIM_PSV; ss.
          contradiction SAFE.
          eexists. split.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_out; eauto.
          ss. unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss. ii.
          eexists. split. eauto. ss.
          ss. eauto. ss.
          eapply NPAuxThread_tau_steps_2_Thread_tau_steps in NP_STEPS; ss.
          econs; ss. do 3 eexists.
          erewrite IdentMap.gss; eauto.
          clear - STEP_INV RELY_STEP.
          ii. exploit RELY_STEP; eauto. ii; des.
          inv STEP_INV. eauto.
        }
        {
          inv LOCAL_SIM_PSV; ss.
          contradiction SAFE.
          eexists. split.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_out; eauto.
          ss. unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss. ii.
          eexists. split. eauto. ss.
          ss. eauto. ss.
          eapply NPAuxThread_tau_steps_2_Thread_tau_steps in NP_STEPS; ss.
          econs; ss. do 3 eexists.
          erewrite IdentMap.gss; eauto.
          clear - WELL_FORMED_INV RELY_STEP.
          exploit RELY_STEP; eauto. intros. des. clear x0 RELY_STEP.
          unfold wf_I in WELL_FORMED_INV. eapply WELL_FORMED_INV in x; eauto; ss.
          inv x; eauto.
        }
      }
      {
        ss.
        exploit Behavior.rtcn_tail; [eapply S_STEPS | eauto..].
        introv S_STEPS_CONS.
        destruct S_STEPS_CONS as (npc & S_STEPS_CONS & S_STEP).
        eapply rtcn_rtc in S_STEPS_CONS.
        do 2 eexists. split.
        eapply Relation_Operators.rt1n_trans. 2: eauto.
        eapply NPConfiguration.step_tau; ss.
        2: eapply S_STEPS_CONS. 2: eapply S_STEP. eauto.
        unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ii; ss.
        eexists. split; eauto; ss.
        split.
        econs; ss; eauto. rewrite IdentMap.gss; eauto.
        ss. unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ii; ss; eauto.
        eapply Hcofix with (inj := inj'); eauto.
        {
          ii. rewrite IdentMap.gso in READY_TGT_THD; eauto.
          rewrite IdentMap.add_add_eq; eauto.
          rewrite IdentMap.gso; eauto.
          exploit READY_THRDS; eauto. ii; des.
          do 2 eexists. split; eauto.
          split; eauto.
          eapply local_sim_out_rely_condition with (n_src := S n) in x4; eauto.
          eapply wf_config_to_local_wf; eauto.
          eapply wf_config_to_local_wf; eauto.
          inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_SRC; eauto.
          inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_SRC; eauto.
          eapply wf_config_to_local_wf; eauto.
          instantiate (3 := tid). rewrite IdentMap.gso; eauto.
          eapply wf_config_to_local_wf; eauto.
          instantiate (3 := tid). rewrite IdentMap.gso; eauto.
          inv WF_CONFIG_TGT'; eauto.
          inv WF_CONFIG_TGT'; eauto.
          inv WF_CONFIG_SRC''; eauto.
          inv WF_CONFIG_SRC''; eauto.
        }
        {
          ii. rewrite IdentMap.add_add_eq; eauto.
          try rewrite IdentMap.gss in *; eauto.
          inv CUR_TGT_THRD. eapply inj_pair2 in H1. subst.
          do 3 eexists. split; eauto.
        }
        {
          rewrite IdentMap.add_add_eq; eauto.
          ii. rewrite IdentMap.mem_find.
          destruct (Loc.eq_dec tid ctid); subst.
          rewrite IdentMap.gss; eauto.
          rewrite IdentMap.gso; eauto.
          rewrite IdentMap.mem_find in IN_SRC_THRDS.
          rewrite IdentMap.gso in IN_SRC_THRDS; eauto.
          rewrite <- IdentMap.mem_find in IN_SRC_THRDS.
          eapply COMPLETE_THRDS_MAP in IN_SRC_THRDS.
          rewrite IdentMap.mem_find in IN_SRC_THRDS. eauto.
        }
        {
          introv ABORT. destruct ABORT as (npc' & TO_ABORT & ABORT).
          contradiction SAFE.
          exists npc'.
          split.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_tau; eauto.
          unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ii; eauto.
          ss. eapply Relation_Operators.rt1n_trans. 2: eauto.
          econs. eapply NPConfiguration.step_out; ss; eauto; ss.
          rewrite IdentMap.gss; eauto.
          unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ii; eauto.
          eauto.
        }
        {
          introv WW_RACE. destruct WW_RACE as (npc' & TO_WW_RACE & WW_RACE).
          contradiction WWRF.
          exists npc'.
          split.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_tau; eauto.
          unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ii; eauto.
          ss. eapply Relation_Operators.rt1n_trans. 2: eauto.
          econs. eapply NPConfiguration.step_out; ss; eauto; ss.
          rewrite IdentMap.gss; eauto.
          unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ii; eauto.
          eauto.
        }
        {
          rewrite IdentMap.add_add_eq; eauto.
        }
        {
          inv LOCAL_SIM_PSV; ss.
          contradiction SAFE.
          eexists. split.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_tau; eauto.
          unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss.
          ii. eexists. split. eauto. ss.
          ss.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_out; eauto.
          ss. rewrite IdentMap.gss; eauto.
          ss. unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss. ii.
          eexists. split. eauto. ss.
          ss. eauto. ss.
          eapply NPAuxThread_tau_steps_2_Thread_tau_steps in NP_STEPS; ss.
          econs; ss. do 3 eexists.
          split.
          erewrite IdentMap.gss; eauto.
          split; eauto.
          clear - STEP_INV RELY_STEP.
          ii. exploit RELY_STEP; eauto. ii; des.
          inv STEP_INV. eauto.
        }
        {
          inv LOCAL_SIM_PSV; ss.
          contradiction SAFE.
          eexists. split.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_tau; eauto.
          unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss.
          ii. eexists. split. eauto. ss.
          ss.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_out; eauto.
          ss. rewrite IdentMap.gss; eauto.
          ss. unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss. ii.
          eexists. split. eauto. ss.
          ss. eauto. ss.
          eapply NPAuxThread_tau_steps_2_Thread_tau_steps in NP_STEPS; ss.
          econs; ss. do 3 eexists.
          split.
          erewrite IdentMap.gss; eauto.
          split; eauto.
          clear - WELL_FORMED_INV RELY_STEP.
          exploit RELY_STEP; eauto. intros; des. clear RELY_STEP x0.
          unfold wf_I in WELL_FORMED_INV.
          eapply WELL_FORMED_INV in x; ss. inv x; eauto.
        }
      }
    }
    {
      (* abort *)
      clear - x SAFE S_STEPS ABORT.
      contradiction SAFE.
      eexists. split; eauto. ss.
      econs; ss.
      eapply NPAuxThread_tau_steps_2_Thread_tau_steps in S_STEPS; ss.
      do 3 eexists.
      split; eauto.
    }
  + (* switch *)
    destruct npc_tgt'. destruct cfg.
    destruct (Loc.eq_dec tid ctid).
    {
      (* switch to the same thread *)
      subst.
      inv TGT_SW; ss.
      {
        (* thread not term *)
        inv NPC2; ss.
        exploit CUR_THRD; eauto. ii; des.
        do 2 eexists.
        split. eauto.
        split.
        econs; ss; eauto.
        eapply Hcofix; eauto.
        {
          introv ABORT.
          destruct ABORT as (npc & TO_ABORT & ABORT).
          contradiction SAFE.
          eexists.
          split.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_sw; ss; eauto.
          eauto. eauto.
        }
        {
          introv WW_RACE.
          destruct WW_RACE as (npc' & TO_WW_RACE & WW_RACE).
          contradiction WWRF.
          exists npc'.
          split.
          eapply Relation_Operators.rt1n_trans.
          econs. eapply NPConfiguration.step_sw; ss; eauto.
          eauto. eauto.
        }
      }
      {
        (* thread term: contradiction *)
        inv NPC2.
        rewrite IdentMap.grs in NEW_TID_OK. ss.
      }
    }
    {
      (* switch to another thread *)
      inv TGT_SW; ss; subst.
      {
        (* thread not term *)
        inv NPC2; ss.
        exploit READY_THRDS; eauto. ii; des.
        assert(I_INV: I lo inj (Build_Rss sc_tgt mem_tgt sc_src mem_src) /\
                      Mem_at_eq lo mem_tgt mem_src).
        {
          exploit INV_OUT_ATM; eauto. ii. des. split; eauto.
        }
        destruct I_INV as (I_INV & MEM_AT_EQ).
        exploit rely_local_sim_state_to_local_sim_state; eauto.
        eapply wf_config_to_local_wf; eauto.
        eapply wf_config_to_local_wf; eauto.
        inv WF_CONFIG_TGT; eauto.
        inv WF_CONFIG_SRC; eauto.
        inv WF_CONFIG_TGT; eauto.
        inv WF_CONFIG_SRC; eauto.
        introv NEW_TH_LOCAL_SIM.
        do 2 eexists.
        split. eauto.
        split.
        econs; eauto; ss.
        ss.
        eapply Hcofix; eauto.
        {
          ii.
          destruct (Loc.eq_dec tid ctid); subst.
          {
            exploit CUR_THRD; [eapply READY_TGT_THD | eauto..].
            ii; des.
            do 2 eexists. split; eauto.
            exploit x4; eauto. ii; subst.
            split; eauto.
            eapply local_sim_state_to_rely_local_sim_state; eauto.
            instantiate (1 := ctid).
            introv ABORT. destruct ABORT as (npc' & TO_ABORT & ABORT).
            contradiction SAFE. clear SAFE.
            exploit WF_ATM_BIT; eauto. ii; subst.
            exists npc'.
            split. eauto.
            eapply NPConfig_abort_to_Config_abort; eauto.
          }
          {
            exploit READY_THRDS; eauto.
          }
        }
        {
          ii.
          exploit READY_THRDS; eauto. ii; des.
          exploit rely_local_sim_state_to_local_sim_state; eauto.
          eapply wf_config_to_local_wf; eauto.
          eapply wf_config_to_local_wf; eauto.
          inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_SRC; eauto.
          inv WF_CONFIG_TGT; eauto.
          inv WF_CONFIG_SRC; eauto.
          ii; des.
          do 3 eexists.
          split. eauto.
          split. eauto.
          eauto.
        }
        {
          introv ABORT. destruct ABORT as (npc & TO_ABORT & ABORT).
          contradiction SAFE.
          exists npc.
          split.
          eapply Relation_Operators.rt1n_trans.
          econs.
          eapply NPConfiguration.step_sw; eauto.
          ss. eauto.
        }
        {
          introv WW_RACE. destruct WW_RACE as (npc & TO_WW_RACE & WW_RACE).
          contradiction WWRF.
          exists npc.
          split.
          eapply Relation_Operators.rt1n_trans.
          econs.
          eapply NPConfiguration.step_sw; eauto.
          ss. eauto.
        }
        {
          eapply wf_config_sw_prsv; eauto.
        }
        {
          eapply wf_config_sw_prsv; eauto.
        }
      }
      {
        (* thread term *)
        inv NPC2; ss.
        exploit CUR_THRD; eauto. ii. des.
        inv x0; ss.
        {
          (* source will abort *)
          contradiction SAFE.
          eexists. split. eauto. ss.
          eapply NPAuxThread_tau_steps_2_Thread_tau_steps in NP_STEPS. ss.
          econs; ss.
          do 3 eexists.
          split. eauto.
          split. eapply NP_STEPS. eauto.
        }
        {
          (* source not abort *)
          clear THRD_STEP RELY_STEP THRD_ABORT.
          exploit THRD_DONE0; eauto. ii; des.
          rewrite IdentMap.gro in NEW_TID_OK; eauto.
          exploit READY_THRDS; eauto. ii; des.
          exploit na_steps_dset_to_NPThread_tau_steps; eauto.
          instantiate (1 := b'). introv Hprefix_tau_steps. des.
          eapply rtc_rtcn in Hprefix_tau_steps.
          destruct Hprefix_tau_steps as (n0 & Hprefix_tau_steps).
          destruct n0.
          {
            inv Hprefix_tau_steps; ss.
            do 2 eexists.
            split. eauto.
            split.
            eapply NPConfiguration.step_thread_term; eauto; ss.
            instantiate (3 := tid2). rewrite IdentMap.gro; eauto.
            ss.
            eapply Hcofix with (inj := inj'); eauto.
            {
              ii.
              destruct (Loc.eq_dec tid ctid); subst.
              rewrite IdentMap.grs in READY_TGT_THD; ss.
              rewrite IdentMap.gro in READY_TGT_THD; eauto.
              rewrite IdentMap.gro; eauto.
              exploit READY_THRDS; eauto. ii; des.
              eapply local_sim_rely_condition with (n_tgt := 0) (n_src := 0) in x10; eauto.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
            }
            {
              ii.
              try rewrite IdentMap.gro in *; eauto.
              exploit READY_THRDS; eauto. ii; des.
              eapply local_sim_rely_condition with
                  (n_tgt := 0) (n_src := 0) (lc_tgt1 := lc1) (lc_src1 := lc_src) in x10; eauto.
              rewrite NEW_TID_OK in CUR_TGT_THRD.
              inv CUR_TGT_THRD. eapply inj_pair2 in H1. subst.
              eapply rely_local_sim_state_to_local_sim_state in x10; eauto.
              do 3 eexists.
              split. eauto.
              split. eauto.
              eauto.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              inv STEP_INV; ss.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
            }
            {
              ii. rewrite IdentMap.mem_find in IN_SRC_THRDS.
              destruct (Loc.eq_dec tid ctid); subst.
              rewrite IdentMap.grs in IN_SRC_THRDS; ss.
              rewrite IdentMap.mem_find.
              try rewrite IdentMap.gro in *; eauto.
              try rewrite <- IdentMap.mem_find in *.
              eauto.
            }
            {
              introv ABORT. destruct ABORT as (npc & TO_ABORT & ABORT).
              contradiction SAFE.
              exists npc.
              split.
              eapply Relation_Operators.rt1n_trans.
              econs. eapply NPConfiguration.step_thread_term; eauto.
              ss. instantiate (3 := tid2). rewrite IdentMap.gro; eauto.
              ss. eauto.
            }
            {
              introv WW_RACE. destruct WW_RACE as (npc & TO_WW_RACE & WW_RACE).
              contradiction WWRF.
              exists npc.
              split.
              eapply Relation_Operators.rt1n_trans.
              econs. eapply NPConfiguration.step_thread_term; eauto.
              ss. instantiate (3 := tid2). rewrite IdentMap.gro; eauto.
              ss. eauto.
            }
            {
              eapply wf_config_rm_prsv; eauto.
            }
            {
              eapply wf_config_rm_prsv; eauto.
            }
            {
              ii. split; eauto.
              inv STEP_INV; eauto.
            }
            {
              clear - WELL_FORMED_INV x5.
              unfold wf_I in WELL_FORMED_INV.
              eapply WELL_FORMED_INV in x5; ss. inv x5; eauto.
            }
          }
          {
            exploit Behavior.rtcn_tail; [eapply Hprefix_tau_steps | eauto..].
            introv Hprefix_tau_steps'.
            destruct Hprefix_tau_steps' as (npc' & PREFIX_STEPS & PREFIX_STEP).
            destruct npc'. destruct state.
            eapply rtcn_rtc in PREFIX_STEPS.
            assert(CONSISTENT_T: Local.promises (Thread.local e_src) = Memory.bot).
            {
              clear - x3. inv x3. eauto.
            }
            exploit rtcn_rtc; [eapply Hprefix_tau_steps | eauto..]. introv PROFIX_STEPS_TEMP.
            destruct e_src.
            exploit wf_config_rtc_NPThread_tau_steps_prsv; [ | | eapply PROFIX_STEPS_TEMP | eauto..]; eauto.
            introv WF_CONFIG_SRC'.
            do 2 eexists.
            split. clear PROFIX_STEPS_TEMP.
            eapply Relation_Operators.rt1n_trans.
            eapply NPConfiguration.step_tau; eauto.
            unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss. ii.
            eexists. split; eauto.
            ss. eauto.
            split.
            eapply NPConfiguration.step_thread_term; ss; eauto.
            rewrite IdentMap.gss; eauto.
            ss. instantiate (3 := tid2).
            rewrite IdentMap.gro; eauto.
            rewrite IdentMap.gso; eauto.
            eapply Hcofix with (inj := inj'); eauto.
            {
              ii.
              destruct (Loc.eq_dec tid ctid); subst.
              rewrite IdentMap.grs in READY_TGT_THD; ss.
              try rewrite IdentMap.gro in *; eauto.
              rewrite IdentMap.gso; eauto.
              exploit READY_THRDS; eauto. ii; des.
              clear PREFIX_STEPS PREFIX_STEP.
              eapply local_sim_rely_condition with (n_tgt := 0) (n_src := (S n0)) in x10; eauto.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              instantiate (3 := tid). rewrite IdentMap.gso; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC'; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC'; eauto.
            }
            {
              ss. clear PREFIX_STEPS PREFIX_STEP. ii.
              destruct (Loc.eq_dec tid2 ctid); subst.
              rewrite IdentMap.grs in CUR_TGT_THRD. ss.
              try rewrite IdentMap.gro in *; eauto.
              rewrite IdentMap.gso; eauto.
              exploit READY_THRDS; eauto. ii; des.
              eapply local_sim_rely_condition with (n_tgt := 0) (n_src := (S n0)) in x10; eauto.
              eapply rely_local_sim_state_to_local_sim_state in x10; eauto.
              do 3 eexists.
              split. eauto.
              split. eauto.
              eauto.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              instantiate (3 := tid2). rewrite IdentMap.gso; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC'; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC'; eauto.
              inv STEP_INV; ss; eauto.
              clear - x0 ATOMIC_COVER.
              eapply na_steps_dset_to_Thread_na_steps in x0.
              eapply Mem_at_eq_na_steps_prsv with (m := mem_tgt) in x0; ss; eauto.
              eapply Mem_at_eq_reflexive; eauto.
              eapply Mem_at_eq_reflexive; eauto.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC; eauto.
              eapply wf_config_to_local_wf; eauto.
              eapply wf_config_to_local_wf; eauto.
              instantiate (3 := tid2). rewrite IdentMap.gso; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC'; eauto.
              inv WF_CONFIG_TGT; eauto.
              inv WF_CONFIG_SRC'; eauto.
            }
            {
              ii. try rewrite IdentMap.mem_find in *.
              destruct (Loc.eq_dec tid ctid); subst.
              rewrite IdentMap.grs in IN_SRC_THRDS; eauto.
              try rewrite IdentMap.gro in *; eauto.
              rewrite IdentMap.gso in IN_SRC_THRDS; eauto.
              try rewrite <- IdentMap.mem_find in *.
              eauto.
            }
            {
              introv ABORT. destruct ABORT as (npc' & TO_ABORT & ABORT).
              contradiction SAFE. clear PROFIX_STEPS_TEMP.
              eexists npc'. split; eauto.
              eapply Relation_Operators.rt1n_trans.
              econs. eapply NPConfiguration.step_tau; eauto.
              unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss. ii.
              eexists. split; eauto.
              ss. eapply Relation_Operators.rt1n_trans.
              econs. eapply NPConfiguration.step_thread_term; ss; eauto.
              rewrite IdentMap.gss; eauto.
              ss. instantiate (3 := tid2).
              rewrite IdentMap.gro; eauto.
              rewrite IdentMap.gso; eauto.
              eauto.
            }
            {
              introv WW_RACE. destruct WW_RACE as (npc' & TO_WW_RACE & WW_RACE).
              contradiction WWRF. clear PROFIX_STEPS_TEMP.
              exists npc'. split; eauto.
              eapply Relation_Operators.rt1n_trans.
              econs. eapply NPConfiguration.step_tau; eauto.
              unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss. ii.
              eexists. split; eauto.
              ss. eapply Relation_Operators.rt1n_trans.
              econs. eapply NPConfiguration.step_thread_term; ss; eauto.
              rewrite IdentMap.gss; eauto.
              ss. instantiate (3 := tid2).
              rewrite IdentMap.gro; eauto.
              rewrite IdentMap.gso; eauto.
              eauto.
            }
            {
              eapply wf_config_rm_prsv; eauto.
            }
            {
              eapply wf_config_rm_prsv; eauto.
            }
            {
              ss. ii.
              split; eauto.
              inv STEP_INV.
              eapply na_steps_dset_to_Thread_na_steps in x0.
              eapply Mem_at_eq_na_steps_prsv with (m := mem_tgt) in x0; eauto; ss.
              eapply Mem_at_eq_reflexive; eauto.
              eapply Mem_at_eq_reflexive; eauto.
            }
            {
              clear - WELL_FORMED_INV x5; ss.
              unfold wf_I in WELL_FORMED_INV.
              eapply WELL_FORMED_INV in x5; ss. inv x5; eauto.
            }
          }
        }
      }
    }
  + (* program done *)
    inv TGT_DONE; ss. des.
    exploit CUR_THRD; eauto. ii. des.
    inv x1; ss.
    {
      (* source will abort *)
      contradiction SAFE.
      eexists. split. eauto. ss.
      eapply NPAuxThread_tau_steps_2_Thread_tau_steps in NP_STEPS. ss.
      econs; ss.
      do 3 eexists.
      split. eauto.
      split. eapply NP_STEPS. eauto.
    }
    {
      (* source not abort *)
      clear THRD_STEP RELY_STEP THRD_ABORT.
      exploit THRD_DONE; eauto. ii; des. clear THRD_DONE.
      exploit na_steps_dset_to_NPThread_tau_steps; eauto.
      instantiate (1 := b'). introv Hprefix_tau_steps. des. renames x to lang.
      eapply rtc_rtcn in Hprefix_tau_steps.
      destruct Hprefix_tau_steps as (n0 & Hprefix_tau_steps).
      assert(TO_DONE_S: IdentMap.is_empty (IdentMap.remove ctid ths_src) = true).
      {
        eapply IdentMap.is_empty_1.
        eapply IdentMap.is_empty_2 in H1.
        unfold IdentMap.Empty in *. ii.
        eapply IdentMap.find_1 in H2.
        destruct (Loc.eq_dec a ctid); subst.
        rewrite IdentMap.grs in H2; ss.
        rewrite IdentMap.gro in H2; eauto.
        assert(CONRT_SRC: IdentMap.mem a ths_src = true).
        {
          rewrite IdentMap.mem_find. rewrite H2; eauto.
        }
        exploit COMPLETE_THRDS_MAP; eauto. introv CONTR_TGT.
        rewrite IdentMap.mem_find in CONTR_TGT.
        destruct (IdentMap.find a ths_tgt) eqn: CONTR_TGT_TID; ss.
        specialize (H1 a p).
        contradiction H1.
        eapply IdentMap.find_2. rewrite IdentMap.gro; eauto.
      }
      assert(CONSISTENT_S: Local.promises (Thread.local e_src) = Memory.bot).
      {
        clear - x4. inv x4. eauto.
      }
      destruct n0.
      {
        inv Hprefix_tau_steps; ss.
        eexists. split. eauto.
        econs; eauto.
      }
      {
        exploit Behavior.rtcn_tail; eauto. ii; des.
        destruct e_src.
        eexists.
        split.
        eapply Relation_Operators.rt1n_trans.
        eapply rtcn_rtc in x7.
        eapply NPConfiguration.step_tau; eauto.
        unfold NPAuxThread.consistent. unfold Thread.consistent_nprm; ss. ii.
        eexists. split. eauto. ss.
        ss. eauto.
        econs; eauto.
        ss.
        rewrite IdentMap.gss.
        do 2 eexists. split. eauto.
        split; eauto.
        eapply IdentMap.is_empty_2 in TO_DONE_S.
        eapply IdentMap.is_empty_1; eauto.
        unfold IdentMap.Empty in *. ii.
        specialize (TO_DONE_S a e). contradiction TO_DONE_S.
        eapply IdentMap.find_1 in H2.
        eapply IdentMap.find_2.
        destruct (Loc.eq_dec a ctid); subst.
        rewrite IdentMap.grs in H2; ss.
        rewrite IdentMap.gro in H2; eauto.
        rewrite IdentMap.gso in H2; eauto.
        rewrite IdentMap.gro; eauto.
      }
    }
  + (* abort *)
    inv TGT_ABORT; ss. des; subst; ss.
    exploit CUR_THRD; eauto. ii; des.
    eapply rtc_rtcn in H2; des.
    exploit sim_tau_steps; eauto; ss.
    eapply wf_config_to_local_wf; eauto.
    inv WF_CONFIG_TGT; eauto. inv WF_CONFIG_TGT; eauto.
    inv H3. des; eauto.
    ii; des.
    {
      inv LOCAL_SIM_PSV; ss.
      {
        (* source thread abort *)
        contradiction SAFE.
        eapply NPAuxThread_tau_steps_2_Thread_tau_steps in S_STEPS; ss.
        eapply NPAuxThread_tau_steps_2_Thread_tau_steps in NP_STEPS; ss.
        eexists.
        split. eauto. ss.
        econs; ss.
        do 3 eexists.
        split. eapply x0.
        split. eapply rtc_compose. eapply S_STEPS. eapply NP_STEPS.
        eauto.
      }
      {
        (* target not promise consistent *)
        inv H3; ss.
      }
      {
        (* source thread not abort *)
        clear THRD_STEP RELY_STEP THRD_DONE.
        exploit THRD_ABORT; eauto. ii; des.
        eapply rtc_rtcn in x4. des.
        eapply rtc_na_p_to_np with (b := b_src') in x4; eauto. des.
        eapply np_na_steps_is_tau_steps in x4.
        eexists. split. eauto.
        econs; ss.
        do 6 eexists.
        split. eauto. ss.
        split. eapply x0.
        split. eauto.
        split.
        eapply rtc_compose. eapply S_STEPS. eapply x4.
        eauto.
      }
    }
    {
      contradiction SAFE.
      eexists. split. eauto. ss.
      eapply NPAuxThread_tau_steps_2_Thread_tau_steps in S_STEPS. ss.
      econs; ss.
      do 3 eexists.
      split. eauto.
      split. eapply S_STEPS. eauto.
    }
    Unshelve.
    exact state.
    exact true.
    exact lang.
    exact st_src0.
    exact true.
    exact st_src0.
    exact true.
    exact lang.
    exact st_src.
    exact true.
    exact st_src.
    exact true.
    exact st_src.
    exact true.
    exact st_src.
    exact true.
Qed.

(** ** Compositionality *)
(** It depicts the following conclusion, if
    - [LOCAL_SIM]: local simulation holds;
    - [SAFE_NP_SRC]: source program is safe under the non-preemptive semantics;
    - [WW_RF_NP_SRC]: source progra is write-write race freedom;
    then the global simulation holds. *)
Theorem compositionality
        (lang: language) (index: Type) (index_order: index -> index -> Prop)
        (I: Invariant) (lo: Ordering.LocOrdMap)
        (code_t code_s: Language.syntax lang) (fs: list IdentMap.key) (ctid: IdentMap.key)
        (LOCAL_SIM: @local_sim index index_order lang I lo code_t code_s)
        (SAFE_NP_SRC: NPConfiguration.safe lo fs code_s ctid)
        (WW_RF_NP_SRC: ww_rf_np lo fs code_s ctid):
  glob_sim lang lo fs ctid code_t code_s.
Proof.
  intros.
  inv LOCAL_SIM.
  unfold glob_sim.
  introv TGT_INIT.

  (* destruct the target initial state *)
  unfolds NPConfiguration.init.
  destruct (Configuration.init fs code_t ctid) eqn:H_tgt_init; tryfalse.
  inv TGT_INIT.
  renames t to c_tgt.

  (* construct the source initial state *)
  lets H_src_init : H_tgt_init.
  eapply cons_source_init_from_target_init_program in H_src_init; eauto.
  destruct H_src_init as (c_src & H_src_init & Htgt_2_src & Hsrc_2_tgt).
  rewrite H_src_init.
  eexists. split; eauto.

  (* construct global simulation *)
  destruct c_tgt, c_src; simpls.
  renames threads to ths_tgt, sc to sc_tgt, memory to mem_tgt.
  renames threads0 to ths_src, sc0 to sc_src, memory0 to mem_src.
  assert (Hctid: tid = ctid /\ tid0 = ctid).
  {
    clear - H_tgt_init H_src_init.
    unfolds Configuration.init.
    destruct (Threads.init fs code_t); tryfalse.
    inv H_tgt_init.
    destruct (Threads.init fs code_s); tryfalse.
    inv H_src_init; eauto.
  }
  destruct Hctid; subst.
  eapply config_init_ths_sc_mem in H_tgt_init; simpl in H_tgt_init.
  destruct H_tgt_init as (Hths_tgt_init & Hsc_tgt_init & Hmem_tgt_init); subst.
  eapply config_init_ths_sc_mem in H_src_init; simpl in H_src_init.
  destruct H_src_init as (Hths_src_init & Hsc_src_init & Hmem_src_init); subst.
  assert (NP_CONFIG_INIT: NPConfiguration.init fs code_s ctid =
                          Some (NPConfiguration.mk (Configuration.mk ths_src ctid TimeMap.bot Memory.init) true)).
  {
    clear - Hths_src_init.
    unfold NPConfiguration.init, Configuration.init; simpl.
    rewrite Hths_src_init; eauto.
  }
  eapply compositionality_aux with (I := I) (inj := inj_init); eauto.
  {
    (* ready threads *)
    introv Hready_tid Hready_th.
    assert (lang0 = lang).
    {
      clear - Hths_tgt_init Hready_th.
      eapply thread_init_same_lang in Hths_tgt_init; eauto.
    }
    subst.
    eapply Htgt_2_src in Hready_th.
    destruct Hready_th as (st_src & lc_src & Hlc_tgt_init & Hlc_src_init & Hsrc_ready_th & Hlocal_sim_state); subst.
    do 2 eexists.
    split. eapply Hsrc_ready_th.
    split; eauto.
    eapply local_sim_state_to_rely_local_sim_state; eauto.
    instantiate (1 := ctid).
    clear - SAFE_NP_SRC NP_CONFIG_INIT.
    inv SAFE_NP_SRC.
    eapply SAFE_EXEC in NP_CONFIG_INIT. ii. des.
    contradiction NP_CONFIG_INIT. econs; eauto.
    unfold Local.promise_consistent, Local.init; ii; ss.
    rewrite Memory.bot_get in PROMISE; eauto. ss.
    unfold Local.promise_consistent, Local.init; ii; ss.
    rewrite Memory.bot_get in PROMISE; eauto. ss.
  }
  {
    (* current thread *)
    introv Hcur_th.
    assert (lang0 = lang).
    {
      clear - Hths_tgt_init Hcur_th.
      eapply thread_init_same_lang in Hths_tgt_init; eauto.
    }
    subst.
    eapply Htgt_2_src in Hcur_th.
    destruct Hcur_th as(st_src & lc_src & Hlc_tgt_init & Hlc_src_init & Hsrc_cur_th & Hlocal_sim_state); subst.
    do 3 eexists.
    split; eauto. split; eauto.
    split; eauto.
    unfold Local.promise_consistent, Local.init; ii; ss.
    rewrite Memory.bot_get in PROMISE; eauto. ss.
  }
  {
    (* safe *)
    eapply sound_np_abort; eauto.
    clear - SAFE_NP_SRC NP_CONFIG_INIT.
    inv SAFE_NP_SRC.
    eapply SAFE_EXEC in NP_CONFIG_INIT; eauto.
    clear - NP_CONFIG_INIT.
    introv Hnp_abort.
    contradict NP_CONFIG_INIT.
    destruct Hnp_abort as (npc' & Hrtc_steps & Habort).
    econstructor; eauto.
  }
  {
    (* write-write race free *)
    eapply sound_np_aux_wwrf; eauto.
    eapply wf_config_init with (fs := fs) (code := code_s) (ctid := ctid); eauto.
    clear - NP_CONFIG_INIT.
    unfolds NPConfiguration.init; eauto.
    destruct (Configuration.init fs code_s ctid); tryfalse.
    inv NP_CONFIG_INIT; eauto.
    clear - WW_RF_NP_SRC NP_CONFIG_INIT.
    unfolds ww_rf_np.
    introv Haux_ww_race.
    contradict WW_RF_NP_SRC.
    destruct Haux_ww_race as (npc' & Hrtc & Haux_ww_race).
    econstructor.
    Focus 2. eapply Hrtc.
    eauto.
    eauto.
  }
  {
    (* well-formed target configuraiton in initialization *)
    eapply wf_config_init with (fs := fs) (code := code_t) (ctid := ctid); eauto.
    unfold Configuration.init.
    rewrite Hths_tgt_init; eauto.
  }
  {
    (* well-formed source configuration in initialization *)
    eapply wf_config_init with (fs := fs) (code := code_s) (ctid := ctid); eauto.
    unfold Configuration.init.
    rewrite Hths_src_init; eauto.
  }
  {
    (* init Mem_at_eq I *)
    ii. split; eauto.
    eapply Mem_at_eq_init.
  }
  {
    (* monotonic inj *)
    unfold monotonic_inj. unfold inj_init; ss. ii.
    des_ifH INJ1; ss; subst. inv INJ1.
    des_ifH INJ2; ss; subst. inv INJ2.
    auto_solve_time_rel.
  }
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^256 - 4294968273
Base: 25.6
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 25 + 3/5;
    bitwidth := 64;
    s := 2^256;
    c := [(1, 4294968273)];
    carry_chains := Some [seq 0 (pred 10); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import VST.concurrency.common.core_semantics.
Require Import VST.concurrency.common.semantics.
Require Import VST.sepcomp.event_semantics.

(*

{ initial_core : nat -> M -> C -> Values.val -> list Values.val -> Prop;
    at_external : C -> M -> option (AST.external_function * AST.signature * list Values.val);
    after_external : option Values.val -> C -> M -> option C;
    halted : C -> Integers.Int.int -> Prop;
    corestep : G -> C -> M -> C -> M -> Prop;
    corestep_not_at_external : forall (ge : G) (m : M) (q : C) (m' : M) (q' : C),
                               corestep ge q m q' m' -> at_external q m = None }

 *)

Inductive state_sum (Cs Ct:Type): Type :=
| SState (c:Cs)
| TState (c:Ct).

Definition state_sum_options {Cs Ct:Type} (cso: option Cs): option (state_sum Cs Ct) :=
  match cso with
  | Some cs => Some (SState _ _ cs)
  | _ => None
  end.
Definition state_sum_optiont {Cs Ct:Type} (cto: option Ct): option (state_sum Cs Ct) :=
  match cto with
  | Some ct => Some (TState _ _ ct)
  | _ => None
  end.

Definition state_sum_optionms {Cs Ct M:Type} (cso: option (Cs * option M)): option (state_sum Cs Ct * option M) :=
  match cso with
  | Some (cs, m) => Some (SState _ _ cs, m)
  | _ => None
  end.
Definition state_sum_optionmt {Cs Ct M:Type} (cto: option (Ct * option M)): option (state_sum Cs Ct * option M) :=
  match cto with
  | Some (ct, m) => Some (TState _ _ ct, m)
  | _ => None
  end.

Definition lt_op (n: nat) (no:option nat): Prop :=
  match no with
    | None => False
    | Some n' => n < n'
  end.

Definition initial_core_sum (no:option nat) (Cs Ct:Type) (M: Type)
           (sinitial_core : nat -> M -> Cs -> M -> Values.val -> list Values.val -> Prop)
           (tinitial_core : nat -> M -> Ct -> M -> Values.val -> list Values.val -> Prop):
  nat -> M -> state_sum Cs Ct -> M -> Values.val -> list Values.val -> Prop :=
  fun (n:nat) m c m' val vals =>
    match c with
    | SState c => lt_op n no /\ sinitial_core n m c m' val vals
    | TState c => ~lt_op n no /\ tinitial_core n m c m' val vals
    end.

Definition sum_func {Cs Ct X:Type} (fs:Cs -> X) (ft:Ct-> X) s:=
  match s with
  | SState c => (fs c)
  | TState c => (ft c)
  end.

Definition sum_func_option {Cs Ct Cs' Ct':Type}
           (fs: Cs -> option Cs') (ft: Ct-> option Ct') s:=
  match s with
  | SState c => state_sum_options (fs c)
  | TState c => state_sum_optiont (ft c)
  end.

Definition at_external_sum (Cs Ct M: Type)
           (sat_external: Cs -> M -> option (AST.external_function * list Values.val))
           (tat_external: Ct -> M -> option (AST.external_function * list Values.val))
           :=
  sum_func sat_external tat_external.

Definition after_external_sum (Cs Ct M: Type)
           (safter_external: option Values.val -> Cs -> M -> option Cs)
           (tafter_external: option Values.val -> Ct -> M -> option Ct)
           :=
  fun vals c m => sum_func_option (fun c => safter_external vals c m)
                                  (fun c => tafter_external vals c m) c.

Definition halted_sum Cs Ct
           (shalted: Cs -> Integers.Int.int -> Prop)
           (thalted: Ct -> Integers.Int.int -> Prop) :=
  sum_func shalted thalted.

Inductive corestep_sum {M Cs Ct}
          (scorestep: Cs -> M -> Cs -> M -> Prop)
          (tcorestep: Ct -> M -> Ct -> M -> Prop):
  state_sum Cs Ct -> M -> state_sum Cs Ct -> M -> Prop:=
| SCorestep: forall s m s' m',
    scorestep s m s' m' ->
    corestep_sum scorestep tcorestep (SState _ _ s) m (SState _ _ s') m'
| TCorestep: forall s m s' m',
    tcorestep s m s' m' ->
    corestep_sum scorestep tcorestep (TState _ _ s) m (TState _ _ s') m'.

Lemma corestep_not_at_external_sum:
  forall M Cs Ct
    {scorestep: Cs -> M -> Cs -> M -> Prop}
    {sat_external: Cs -> M -> option (AST.external_function * list Values.val)}
    (scorestep_not_at_external: forall (m : M) (q : Cs) (m' : M) (q' : Cs),
        scorestep q m q' m' -> sat_external q m = None)
    {tcorestep: Ct -> M -> Ct -> M -> Prop}
    {tat_external: Ct -> M -> option (AST.external_function * list Values.val)}
    (tcorestep_not_at_external: forall (m : M) (q : Ct) (m' : M) (q' : Ct),
        tcorestep q m q' m' -> tat_external q m = None),
  forall (m : M) (q : state_sum Cs Ct) (m' : M) (q' : state_sum Cs Ct),
    corestep_sum scorestep tcorestep q m q' m' ->
    at_external_sum _ _ _ sat_external tat_external q m = None.
Proof.
  intros.
  inversion H; subst; simpl in *.
  - eapply scorestep_not_at_external; eauto.
  - eapply tcorestep_not_at_external; eauto.
Qed.

Lemma corestep_not_halted_sum:
  forall  M Cs Ct
    (scorestep: Cs -> M -> Cs -> M -> Prop)
    (shalted : Cs -> Integers.Int.int -> Prop)
    (scorestep_not_halted: forall (m : M) (q : Cs) (m' : M) (q' : Cs) n,
        scorestep q m q' m' -> ~ shalted q n)
    (tcorestep: Ct -> M -> Ct -> M -> Prop)
    (thalted : Ct -> Integers.Int.int -> Prop)
    (tcorestep_not_halted: forall (m : M) (q : Ct) (m' : M) (q' : Ct) n,
        tcorestep q m q' m' -> ~ thalted q n),
  forall (m : M) (q : state_sum Cs Ct) (m' : M) (q' : state_sum Cs Ct) n,
    corestep_sum scorestep tcorestep q m q' m' ->
    ~ halted_sum _ _ shalted thalted q n.
Proof.
  intros.
  inversion H; subst; simpl; eauto.
Qed.

(*
Lemma at_external_halted_excl_sum:
  forall M Cs Ct
    (scorestep: Cs -> M -> Cs -> M -> Prop)
    (shalted : Cs -> Integers.Int.int -> option Values.val)
    (sat_external: Cs -> M -> option (AST.external_function * list Values.val))
    (sat_external_halted_excl : forall ge (q : Cs) m, sat_external q m = None \/ shalted q )
    (tcorestep: Ct -> M -> Ct -> M -> Prop)
    (thalted : Ct -> Integers.Int.int -> option Values.val)
    (tat_external: Ct -> M -> option (AST.external_function * list Values.val))
    (tat_external_halted_excl : forall ge (q : Ct) m, tat_external q m = None \/ thalted q = None),
  forall  (m : M) (q : state_sum Cs Ct),
    at_external_sum _ _ _ sat_external tat_external q m = None \/
    halted_sum _ _ shalted thalted q = None.
Proof.
  intros.
  destruct q; simpl; auto.
Qed.*)

Program Definition CoreSemanticsSum hb M Cs Ct
        (CSs: CoreSemantics Cs M )
        (CSt: CoreSemantics Ct M ): CoreSemantics (state_sum Cs Ct) M:=
  Build_CoreSemantics _ _
    (initial_core_sum hb _ _ _ (initial_core CSs) (initial_core CSt))
    (at_external_sum _ _ _ (at_external CSs) (at_external CSt))
    (after_external_sum _ _ _ (after_external CSs) (after_external CSt))
    (halted_sum _ _  (halted CSs) (halted CSt))
    (corestep_sum (corestep CSs) (corestep CSt))
    _
    _.
Next Obligation.
  eapply corestep_not_halted_sum; try eapply H.
  - eapply CSs.
  - eapply CSt.
Qed.
Next Obligation.
  intros; eapply corestep_not_at_external_sum; eauto; first [apply CSs|apply CSt].
Qed.

Program Definition MemSemanticsSum (hb:option nat) Cs Ct
        (CSs: MemSem Cs )
        (CSt: MemSem Ct ): MemSem (state_sum Cs Ct):=
  Build_MemSem _ (CoreSemanticsSum hb Memory.Mem.mem Cs Ct CSs CSt) _.
Next Obligation.
  intros.
  inversion CS; subst.
  - eapply CSs; eassumption.
  - eapply CSt; eassumption.
Defined.

Inductive ev_step_sum {Cs Ct:Type}
          (ESs: Cs -> Memory.Mem.mem -> list mem_event -> Cs -> Memory.Mem.mem -> Prop)
          (ESt: Ct -> Memory.Mem.mem -> list mem_event -> Ct -> Memory.Mem.mem -> Prop):
  (state_sum Cs Ct) -> Memory.Mem.mem -> list mem_event -> (state_sum Cs Ct) -> Memory.Mem.mem -> Prop
  :=
| SEvstep: forall s m t s' m',
    ESs s m t s' m' ->
    ev_step_sum ESs ESt (SState _ _ s) m t (SState _ _ s') m'
| TEvstep: forall s m t s' m',
    ESt s m t s' m' ->
    ev_step_sum ESs ESt (TState _ _ s) m t (TState _ _ s') m'.

Program Definition EvSemanticsSum (hb:option nat) Cs Ct
        (CSs: @EvSem Cs )
        (CSt: @EvSem Ct ): @EvSem (state_sum Cs Ct):=
  Build_EvSem _ (MemSemanticsSum hb Cs Ct CSs CSt) (ev_step_sum (ev_step CSs) (ev_step CSt)) _ _ _ _.
Next Obligation.
  intros.
  inversion H; subst.
  - constructor; eapply CSs; eauto.
  - constructor; eapply CSt; eauto.
Defined.
Next Obligation.
  intros.
  inversion H; subst.
  - eapply CSs in H0; destruct H0 as [T ?].
    exists T; constructor; eauto.
  - eapply CSt in H0; destruct H0 as [T ?].
    exists T; constructor; eauto.
Defined.
Next Obligation.
  intros.
  inversion H; subst;
  inversion H0; subst.
  - eapply CSs; eauto.
  - eapply CSt; eauto.
Defined.
Next Obligation.
  intros.
  inversion STEP; subst.
  -  eapply (ev_step_elim CSs) in H. (*destruct H as [HH1 HH2];
       split; eauto; intros.
     apply HH2 in H.
     destruct H as [cc' HH].
     eexists; constructor; eauto.*) trivial.
  -  eapply (ev_step_elim CSt) in H. (*destruct H as [HH1 HH2];
       split; eauto; intros.
     apply HH2 in H.
     destruct H as [cc' HH].
     eexists; constructor; eauto.*) trivial.
Defined.

Definition CoreSem_Sum (hb:option nat) (Sems Semt: Semantics): Semantics:=
  Build_Semantics _ _
                  (EvSemanticsSum hb _ _ (@semSem Sems) (@semSem Semt))
                  (@the_ge Sems, @the_ge Semt) .
(* they have different genv...*)


(** * Projection functors from comma categories *)
Require Import Category.Core Functor.Core.
Require Import Category.Prod Functor.Prod.Core.
Require Import Functor.Composition.Core Functor.Identity.
Require Import InitialTerminalCategory.Functors.
Require Comma.Core.
Require Import Types.Prod.
Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *)
Import Comma.Core.
Local Set Warnings Append "notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *)

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.
Local Open Scope category_scope.

(** ** First projection [(S / T) → A × B] (for [S : A → C ← B : T]) *)
Section comma_category.
  Variables A B C : PreCategory.
  Variable S : Functor A C.
  Variable T : Functor B C.

  Definition comma_category_projection : Functor (S / T) (A * B)
    := Build_Functor
         (S / T) (A * B)
         (fun abf => (CommaCategory.a abf, CommaCategory.b abf)%core)
         (fun _ _ m => (CommaCategory.g m, CommaCategory.h m)%core)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).
End comma_category.

(** ** First projections [(S / a) → A] and [(a / S) → A] *)
Section slice_category.
  Variable A : PreCategory.

  Local Arguments Functor.Composition.Core.compose / .
  Local Arguments Functor.Composition.Core.compose_composition_of / .
  Local Arguments Functor.Composition.Core.compose_identity_of / .
  Local Arguments path_prod / .
  Local Arguments path_prod' / .
  Local Arguments path_prod_uncurried / .

  Definition arrow_category_projection : Functor (arrow_category A) A
    := Eval simpl in fst o comma_category_projection _ 1.

  Definition slice_category_over_projection (a : A) : Functor (A / a) A
    := Eval simpl in fst o comma_category_projection 1 _.

  Definition coslice_category_over_projection (a : A) : Functor (a \ A) A
    := Eval simpl in snd o comma_category_projection _ 1.

  Section slice_coslice.
    Variable C : PreCategory.
    Variable a : C.
    Variable S : Functor A C.

    Definition slice_category_projection : Functor (S / a) A
      := Eval simpl in fst o comma_category_projection S !a.

    Definition coslice_category_projection : Functor (a / S) A
      := Eval simpl in snd o comma_category_projection !a S.
  End slice_coslice.
End slice_category.


Require Import Undecidability.SystemF.SysF Undecidability.SystemF.Autosubst.syntax Undecidability.SystemF.Autosubst.unscoped.
Import UnscopedNotations.
Require Import Undecidability.SystemF.Util.typing_facts Undecidability.SystemF.Util.term_facts.

Inductive step : term -> term -> Prop :=
| step_beta s P Q :
    step (app (abs s P) Q) (subst_term poly_var (scons Q var) P)
| step_ty_beta P s :
    step (ty_app (ty_abs P) s) (subst_term (scons s poly_var) var P)
| step_appL P P' Q :
    step P P' -> step (app P Q) (app P' Q)
| step_appR P P' Q :
    step P P' -> step (app Q P) (app Q P')
| step_ty_app P P' s :
    step P P' -> step (ty_app P s) (ty_app P' s)
| step_lam s P P' :
    step P P' -> step (abs s P) (abs s P')
| step_ty_lam P P' :
    step P P' -> step (ty_abs P) (ty_abs P').

Inductive sn x : Prop :=
| SNI : (forall y, step x y -> sn y) -> sn x.

Local Hint Constructors step normal_form head_form : core.

Require Import Coq.Relations.Relation_Operators.

Ltac inv_step :=
  match goal with
    [ H : step ?P ?Q |- _] => inversion H; subst; clear H; try now firstorder
  end.

Lemma progress P :
  (forall Q, ~ step P Q) \/ exists Q, step P Q.
Proof.
  induction P.
  - firstorder inv_step.
  - destruct IHP1 as [H1 | [Q1 H1]]; eauto.
    destruct IHP2 as [H2 | [Q2 H2]]; eauto.
    destruct P1. 3:eauto.
    all: firstorder inv_step.
  - destruct IHP as [H1 | [Q1 H1]]; eauto. firstorder inv_step.
  - destruct IHP as [H1 | [Q1 H1]]; eauto.
    destruct P. 5:eauto.
    all: firstorder inv_step.
  - destruct IHP as [H1 | [Q1 H1]]; eauto. firstorder inv_step.
Qed.

Lemma preservation P Q Γ s :
  typing Γ P s -> step P Q -> typing Γ Q s.
Proof.
  induction 1 in Q |- *.
  - inversion 1.
  - inversion 1; subst.
    + inversion H; subst.
      eapply typing_subst_term. eassumption.
      intros [] ? [=]; subst; cbn;
      eauto using typing.
    + eauto using typing.
    + eauto using typing.
  - inversion 1; subst. eauto using typing.
  - inversion 1; subst.
    + inversion H; subst.
      evar (Gamma' : environment).
      replace Gamma with Gamma'. all: subst Gamma'.
      eapply typing_subst_poly_type. eassumption.
      erewrite List.map_map, List.map_ext, List.map_id.
      reflexivity. intros. now asimpl.
    + eauto using typing.
  - inversion 1; subst. eauto using typing.
Qed.

Lemma preservation_star P Q Γ s :
  typing Γ P s -> Relation_Operators.clos_refl_trans term step P Q -> typing Γ Q s.
Proof.
  intros H. induction 1; eauto using preservation.
Qed.

Lemma step_ext_2 P Q1 Q2 :
  step P Q1 -> Q1 = Q2 -> step P Q2.
Proof.
  now intros ? ->.
Qed.

Ltac now_asimpl := asimpl; ( (reflexivity || eapply ext_term; now intros []; repeat asimpl) ||
                   f_equal; (reflexivity || eapply ext_term; now intros []; repeat asimpl)).

Lemma step_subst P Q σ τ :
  step P Q -> step (subst_term σ τ P) (subst_term σ τ Q).
Proof.
  induction 1 in σ, τ |- *; cbn; asimpl; eauto using step.
  - eapply step_ext_2.
    econstructor. now_asimpl.
  - eapply step_ext_2.
    econstructor. now_asimpl.
Qed.

Require Import Coq.Program.Equality.

Ltac inv H := inversion H; subst; clear H.

Lemma step_subst_inv P Q σ τ :
  step (subst_term σ (τ >> var) P) Q -> exists P', step P P' /\ subst_term σ (τ >> var) P' = Q.
Proof with eexists; split; [eauto | now_asimpl].
  intros H. dependent induction H; rename x into Eqn.
  - destruct P; inv Eqn. destruct P1; inv H0...
  - destruct P; inv Eqn. destruct P; inv H0...
  - destruct P; inv Eqn. destruct (IHstep _ _ _ eq_refl) as (P1' & H1 & <-)...
  - destruct P; inv Eqn. destruct (IHstep _ _ _ eq_refl) as (P1' & H1 & <-)...
  - destruct P; inv Eqn. destruct (IHstep _ _ _ eq_refl) as (P1' & H1 & <-)...
  - destruct P; inv Eqn.
    edestruct (IHstep P (up_term_poly_type σ) (0 .: τ >> shift))  as (P1' & H1 & <-).
    now_asimpl. exists (abs p P1'). split. eauto. now_asimpl.
  - destruct P; inv Eqn.  destruct (IHstep _ _ _ eq_refl) as (P1' & H1 & <-)...
Qed.

Definition nf P := match P with abs s P => normal_form P
                           | ty_abs P => normal_form P | P => head_form P end.

Lemma nf_normal_form P :
  nf P -> normal_form P.
Proof.
  destruct P; cbn; eauto.
Qed.

Lemma sn_normal_form Γ P s :
  typing Γ P s -> (forall Q, ~ step P Q) -> nf P.
Proof.
  intros H Hstep.
  induction H; cbn in *.
  - eauto.
  - econstructor.
    destruct P.
    all: try now (eapply IHtyping1; intros ? ?; eapply Hstep; eauto).
    + exfalso. eapply Hstep; eauto.
    + inversion H.
    + eapply nf_normal_form, IHtyping2. intros ? ?; eapply Hstep; eauto.
  - eapply nf_normal_form, IHtyping. intros ? ?. eapply Hstep. eauto.
  - econstructor.
    destruct P.
    all: try now (eapply IHtyping; intros ? ?; eapply Hstep; eauto).
    + inversion H.
    + exfalso. eapply Hstep. eauto.
  - eapply nf_normal_form, IHtyping. intros ? ?. eapply Hstep. eauto.
Qed.

Lemma sn_normal Γ P s :
  typing Γ P s ->
  sn P -> exists Q, clos_refl_trans _ step P Q /\ normal_form Q.
Proof.
  intros H.
  induction 1 as [P Hsn IH] in s, H |- *.
  destruct (progress P) as [Hstep | [Q Hstep]].
  - exists P. split. econstructor 2.
    eauto using nf_normal_form, sn_normal_form.
  - pose proof (Hstep' := Hstep).
    eapply IH in Hstep as (Q' & H1 & H2).
    + exists Q'. split. econstructor 3. econstructor 1. all: eauto.
    + eauto using preservation.
Qed.


From iris.bi Require Export derived_connectives extensions updates internal_eq plainly.
From iris.base_logic Require Export upred.
From iris.prelude Require Import options.
Import uPred_primitive.

(** BI instances for [uPred], and re-stating the remaining primitive laws in
terms of the BI interface. This file does *not* unseal. *)

Definition uPred_emp {M} : uPred M := uPred_pure True.

Local Existing Instance entails_po.

Lemma uPred_bi_mixin (M : ucmra) :
  BiMixin
    uPred_entails uPred_emp uPred_pure uPred_and uPred_or uPred_impl
    (@uPred_forall M) (@uPred_exist M) uPred_sep uPred_wand
    uPred_persistently.
Proof.
  split.
  - exact: entails_po.
  - exact: equiv_entails.
  - exact: pure_ne.
  - exact: and_ne.
  - exact: or_ne.
  - exact: impl_ne.
  - exact: forall_ne.
  - exact: exist_ne.
  - exact: sep_ne.
  - exact: wand_ne.
  - exact: persistently_ne.
  - exact: pure_intro.
  - exact: pure_elim'.
  - exact: and_elim_l.
  - exact: and_elim_r.
  - exact: and_intro.
  - exact: or_intro_l.
  - exact: or_intro_r.
  - exact: or_elim.
  - exact: impl_intro_r.
  - exact: impl_elim_l'.
  - exact: @forall_intro.
  - exact: @forall_elim.
  - exact: @exist_intro.
  - exact: @exist_elim.
  - exact: sep_mono.
  - exact: True_sep_1.
  - exact: True_sep_2.
  - exact: sep_comm'.
  - exact: sep_assoc'.
  - exact: wand_intro_r.
  - exact: wand_elim_l'.
  - exact: persistently_mono.
  - exact: persistently_idemp_2.
  - (* emp ⊢ <pers> emp (ADMISSIBLE) *)
    trans (uPred_forall (M:=M) (λ _ : False, uPred_persistently uPred_emp)).
    + apply forall_intro=>-[].
    + etrans; first exact: persistently_forall_2.
      apply persistently_mono. exact: pure_intro.
  - (* ((<pers> P) ∧ (<pers> Q)) ⊢ <pers> (P ∧ Q) (ADMISSIBLE) *)
    intros P Q.
    trans (uPred_forall (M:=M) (λ b : bool, uPred_persistently (if b then P else Q))).
    + apply forall_intro=>[[]].
      * apply and_elim_l.
      * apply and_elim_r.
    + etrans; first exact: persistently_forall_2.
      apply persistently_mono. apply and_intro.
      * etrans; first apply (forall_elim true). done.
      * etrans; first apply (forall_elim false). done.
  - exact: @persistently_exist_1.
  - (* <pers> P ∗ Q ⊢ <pers> P (ADMISSIBLE) *)
    intros. etrans; first exact: sep_comm'.
    etrans; last exact: True_sep_2.
    apply sep_mono; last done.
    exact: pure_intro.
  - exact: persistently_and_sep_l_1.
Qed.

Lemma uPred_bi_later_mixin (M : ucmra) :
  BiLaterMixin
    uPred_entails uPred_pure uPred_or uPred_impl
    (@uPred_forall M) (@uPred_exist M) uPred_sep uPred_persistently uPred_later.
Proof.
  split.
  - apply contractive_ne, later_contractive.
  - exact: later_mono.
  - exact: later_intro.
  - exact: @later_forall_2.
  - exact: @later_exist_false.
  - exact: later_sep_1.
  - exact: later_sep_2.
  - exact: later_persistently_1.
  - exact: later_persistently_2.
  - exact: later_false_em.
Qed.

Canonical Structure uPredI (M : ucmra) : bi :=
  {| bi_ofe_mixin := ofe_mixin_of (uPred M);
     bi_bi_mixin := uPred_bi_mixin M;
     bi_bi_later_mixin := uPred_bi_later_mixin M |}.

Lemma uPred_internal_eq_mixin M : BiInternalEqMixin (uPredI M) (@uPred_internal_eq M).
Proof.
  split.
  - exact: internal_eq_ne.
  - exact: @internal_eq_refl.
  - exact: @internal_eq_rewrite.
  - exact: @fun_ext.
  - exact: @sig_eq.
  - exact: @discrete_eq_1.
  - exact: @later_eq_1.
  - exact: @later_eq_2.
Qed.
Global Instance uPred_internal_eq M : BiInternalEq (uPredI M) :=
  {| bi_internal_eq_mixin := uPred_internal_eq_mixin M |}.

Lemma uPred_plainly_mixin M : BiPlainlyMixin (uPredI M) uPred_plainly.
Proof.
  split.
  - exact: plainly_ne.
  - exact: plainly_mono.
  - exact: plainly_elim_persistently.
  - exact: plainly_idemp_2.
  - exact: @plainly_forall_2.
  - exact: plainly_impl_plainly.
  - (* P ⊢ ■ emp (ADMISSIBLE) *)
    intros P.
    trans (uPred_forall (M:=M) (λ _ : False , uPred_plainly uPred_emp)).
    + apply forall_intro=>[[]].
    + etrans; first exact: plainly_forall_2.
      apply plainly_mono. exact: pure_intro.
  - (* ■ P ∗ Q ⊢ ■ P (ADMISSIBLE) *)
    intros P Q. etrans; last exact: True_sep_2.
    etrans; first exact: sep_comm'.
    apply sep_mono; last done.
    exact: pure_intro.
  - exact: later_plainly_1.
  - exact: later_plainly_2.
Qed.
Global Instance uPred_plainly M : BiPlainly (uPredI M) :=
  {| bi_plainly_mixin := uPred_plainly_mixin M |}.

Lemma uPred_bupd_mixin M : BiBUpdMixin (uPredI M) uPred_bupd.
Proof.
  split.
  - exact: bupd_ne.
  - exact: bupd_intro.
  - exact: bupd_mono.
  - exact: bupd_trans.
  - exact: bupd_frame_r.
Qed.
Global Instance uPred_bi_bupd M : BiBUpd (uPredI M) := {| bi_bupd_mixin := uPred_bupd_mixin M |}.

(** extra BI instances *)

Global Instance uPred_affine M : BiAffine (uPredI M) | 0.
Proof. intros P. exact: pure_intro. Qed.
(* Also add this to the global hint database, otherwise [eauto] won't work for
many lemmas that have [BiAffine] as a premise. *)
Global Hint Immediate uPred_affine : core.

Global Instance uPred_persistently_forall M : BiPersistentlyForall (uPredI M).
Proof. exact: @persistently_forall_2. Qed.

Global Instance uPred_pure_forall M : BiPureForall (uPredI M).
Proof. exact: @pure_forall_2. Qed.

Global Instance uPred_later_contractive {M} : BiLaterContractive (uPredI M).
Proof. apply later_contractive. Qed.

Global Instance uPred_persistently_impl_plainly M : BiPersistentlyImplPlainly (uPredI M).
Proof. exact: persistently_impl_plainly. Qed.

Global Instance uPred_plainly_exist_1 M : BiPlainlyExist (uPredI M).
Proof. exact: @plainly_exist_1. Qed.

Global Instance uPred_prop_ext M : BiPropExt (uPredI M).
Proof. exact: prop_ext_2. Qed.

Global Instance uPred_bi_bupd_plainly M : BiBUpdPlainly (uPredI M).
Proof. exact: bupd_plainly. Qed.

(** Re-state/export lemmas about Iris-specific primitive connectives (own, valid) *)

Module uPred.

Section restate.
  Context {M : ucmra}.
  Implicit Types φ : Prop.
  Implicit Types P Q : uPred M.
  Implicit Types A : Type.

  (* Force implicit argument M *)
  Notation "P ⊢ Q" := (bi_entails (PROP:=uPredI M) P%I Q%I).
  Notation "P ⊣⊢ Q" := (equiv (A:=uPredI M) P%I Q%I).

  Global Instance ownM_ne : NonExpansive (@uPred_ownM M) := uPred_primitive.ownM_ne.
  Global Instance cmra_valid_ne {A : cmra} : NonExpansive (@uPred_cmra_valid M A) :=
    uPred_primitive.cmra_valid_ne.

  (** Re-exporting primitive lemmas that are not in any interface *)
  Lemma ownM_op (a1 a2 : M) :
    uPred_ownM (a1 ⋅ a2) ⊣⊢ uPred_ownM a1 ∗ uPred_ownM a2.
  Proof. exact: uPred_primitive.ownM_op. Qed.
  Lemma persistently_ownM_core (a : M) : uPred_ownM a ⊢ <pers> uPred_ownM (core a).
  Proof. exact: uPred_primitive.persistently_ownM_core. Qed.
  Lemma ownM_unit P : P ⊢ (uPred_ownM ε).
  Proof. exact: uPred_primitive.ownM_unit. Qed.
  Lemma later_ownM a : ▷ uPred_ownM a ⊢ ∃ b, uPred_ownM b ∧ ▷ (a ≡ b).
  Proof. exact: uPred_primitive.later_ownM. Qed.
  Lemma bupd_ownM_updateP x (Φ : M → Prop) :
    x ~~>: Φ → uPred_ownM x ⊢ |==> ∃ y, ⌜Φ y⌝ ∧ uPred_ownM y.
  Proof. exact: uPred_primitive.bupd_ownM_updateP. Qed.

  (** This is really just a special case of an entailment
  between two [siProp], but we do not have the infrastructure
  to express the more general case. This temporary proof rule will
  be replaced by the proper one eventually. *)
  Lemma internal_eq_entails {A B : ofe} (a1 a2 : A) (b1 b2 : B) :
    (a1 ≡ a2 ⊢ b1 ≡ b2) ↔ (∀ n, a1 ≡{n}≡ a2 → b1 ≡{n}≡ b2).
  Proof. exact: uPred_primitive.internal_eq_entails. Qed.

  Lemma ownM_valid (a : M) : uPred_ownM a ⊢ ✓ a.
  Proof. exact: uPred_primitive.ownM_valid. Qed.
  Lemma cmra_valid_intro {A : cmra} P (a : A) : ✓ a → P ⊢ (✓ a).
  Proof. exact: uPred_primitive.cmra_valid_intro. Qed.
  Lemma cmra_valid_elim {A : cmra} (a : A) : ¬ ✓{0} a → ✓ a ⊢ False.
  Proof. exact: uPred_primitive.cmra_valid_elim. Qed.
  Lemma plainly_cmra_valid_1 {A : cmra} (a : A) : ✓ a ⊢ ■ ✓ a.
  Proof. exact: uPred_primitive.plainly_cmra_valid_1. Qed.
  Lemma cmra_valid_weaken {A : cmra} (a b : A) : ✓ (a ⋅ b) ⊢ ✓ a.
  Proof. exact: uPred_primitive.cmra_valid_weaken. Qed.
  Lemma discrete_valid {A : cmra} `{!CmraDiscrete A} (a : A) : ✓ a ⊣⊢ ⌜✓ a⌝.
  Proof. exact: uPred_primitive.discrete_valid. Qed.

  (** This is really just a special case of an entailment
  between two [siProp], but we do not have the infrastructure
  to express the more general case. This temporary proof rule will
  be replaced by the proper one eventually. *)
  Lemma valid_entails {A B : cmra} (a : A) (b : B) :
    (∀ n, ✓{n} a → ✓{n} b) → ✓ a ⊢ ✓ b.
  Proof. exact: uPred_primitive.valid_entails. Qed.

  (** Consistency/soundness statement *)
  Lemma pure_soundness φ : (⊢@{uPredI M} ⌜ φ ⌝) → φ.
  Proof. apply pure_soundness. Qed.

  Lemma internal_eq_soundness {A : ofe} (x y : A) : (⊢@{uPredI M} x ≡ y) → x ≡ y.
  Proof. apply internal_eq_soundness. Qed.

  Lemma later_soundness P : (⊢ ▷ P) → ⊢ P.
  Proof. apply later_soundness. Qed.

  (** We restate the unsealing lemmas for the BI layer. The sealing lemmas
  are partially applied so that they also rewrite under binders. *)
  Local Lemma uPred_emp_unseal : bi_emp = @upred.uPred_pure_def M True.
  Proof. by rewrite -upred.uPred_pure_unseal. Qed.
  Local Lemma uPred_pure_unseal : bi_pure = @upred.uPred_pure_def M.
  Proof. by rewrite -upred.uPred_pure_unseal. Qed.
  Local Lemma uPred_and_unseal : bi_and = @upred.uPred_and_def M.
  Proof. by rewrite -upred.uPred_and_unseal. Qed.
  Local Lemma uPred_or_unseal : bi_or = @upred.uPred_or_def M.
  Proof. by rewrite -upred.uPred_or_unseal. Qed.
  Local Lemma uPred_impl_unseal : bi_impl = @upred.uPred_impl_def M.
  Proof. by rewrite -upred.uPred_impl_unseal. Qed.
  Local Lemma uPred_forall_unseal : @bi_forall _ = @upred.uPred_forall_def M.
  Proof. by rewrite -upred.uPred_forall_unseal. Qed.
  Local Lemma uPred_exist_unseal : @bi_exist _ = @upred.uPred_exist_def M.
  Proof. by rewrite -upred.uPred_exist_unseal. Qed.
  Local Lemma uPred_internal_eq_unseal :
    @internal_eq _ _ = @upred.uPred_internal_eq_def M.
  Proof. by rewrite -upred.uPred_internal_eq_unseal. Qed.
  Local Lemma uPred_sep_unseal : bi_sep = @upred.uPred_sep_def M.
  Proof. by rewrite -upred.uPred_sep_unseal. Qed.
  Local Lemma uPred_wand_unseal : bi_wand = @upred.uPred_wand_def M.
  Proof. by rewrite -upred.uPred_wand_unseal. Qed.
  Local Lemma uPred_plainly_unseal : plainly = @upred.uPred_plainly_def M.
  Proof. by rewrite -upred.uPred_plainly_unseal. Qed.
  Local Lemma uPred_persistently_unseal :
    bi_persistently = @upred.uPred_persistently_def M.
  Proof. by rewrite -upred.uPred_persistently_unseal. Qed.
  Local Lemma uPred_later_unseal : bi_later = @upred.uPred_later_def M.
  Proof. by rewrite -upred.uPred_later_unseal. Qed.
  Local Lemma uPred_bupd_unseal : bupd = @upred.uPred_bupd_def M.
  Proof. by rewrite -upred.uPred_bupd_unseal. Qed.

  Local Definition uPred_unseal :=
    (uPred_emp_unseal, uPred_pure_unseal, uPred_and_unseal, uPred_or_unseal,
    uPred_impl_unseal, uPred_forall_unseal, uPred_exist_unseal,
    uPred_internal_eq_unseal, uPred_sep_unseal, uPred_wand_unseal,
    uPred_plainly_unseal, uPred_persistently_unseal, uPred_later_unseal,
    upred.uPred_ownM_unseal, upred.uPred_cmra_valid_unseal, @uPred_bupd_unseal).
End restate.

(** A tactic for rewriting with the above lemmas. Unfolds [uPred] goals that use
the BI layer. This is used by [base_logic.algebra] and [base_logic.bupd_alt]. *)
Ltac unseal := rewrite !uPred_unseal /=.
End uPred.