Require Export Arith.EqNat.
Require Export Arith.Lt.
Require Export Arith.Compare_dec.
Require Export List.
Require Import String.
Open Scope string_scope.
Require Import TacticsSF.
Require Import TacticsCPDT.
Require Import Process.
Require Import List.
Require Import PrettyPrinter.
Require Import TypeAssignmentPoly.
Require Import ResultBasics.
Require Import ExampleCommon.
Require Import ExampleRecursion.

Lemma abp_sendB_Nack_procR_typing :
  forall i k r r' (xc:free_id) (xerr1:free_id) (x:free_id) (xin:free_id),
    r --(MInp (TSingleton k))--> r'
    ->
    ~ In xc ("send_true" :: "send_false" :: nil)
    ->
    ~ In x (xc :: "send_true" :: "send_false" :: nil)
    ->
    ~ In xin (x :: xc :: "send_true" :: "send_false" :: nil)
    ->
    ~ In xerr1 (xin :: x :: xc :: "send_true" :: "send_false" :: nil)
    ->
    (CTX.add(ValVariable (Var (Free xerr1)),
        TChannel (SNack r k r' (token_of_bool i)))
      (CTX.add(ValVariable (Var (Free xc)), TChannel SEpsilon)
      (CTX.add(ValVariable (Var (Free xin)), TChannel (SToks (r')))
      (CTX.add(ValVariable (Var (Free x)), TSingleton k)
      (CTX.add(ValName (Nm (Free (String.append "send_" (string_of_bool i)))),
        (TChannel (SFwd (SSend i))))
      (CTX.add(ValName(CoNm (Free (String.append "send_" (string_of_bool i)))),
        (TChannel (SDual (SFwd (SSend i)))))
      (CTX.add(ValName (CoNm (Free (String.append "send_"
        (string_of_bool (negb i))))),
        (TChannel (SDual (SFwd (SSend (negb i))))))
      CTX.empty)))))))
    |-p Var (Free xerr1) ? ;
      (IsEq (Var (Bound 0))
        (Token (if if i then false else true then "true" else "false"))
      (New
      (CoNm (Free (String.append "send_" (if i then "true" else "false")))
        ! Nm (Bound 0);
      (CoNm (Bound 0) ! Var (Free x);
      (CoNm (Bound 0) ! Var (Free xin);
      (CoNm (Bound 0) ! Var (Free xerr1);
      Zero)))))).

Proof.
  intros i k r r' xc xerr1 x xin Htrans Hxc_nin Hx_nin Hxin_nin Hxerr1_nin.
  compute.
  apply TypPrefixInput  with (s:=SNack r k r' (token_of_bool i))
      (L:=xc :: xerr1 :: xin :: x :: "send_true" :: "send_false" :: nil);
    [constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | free_vals_in_ctx |].
  intros G' rho t z H_z_nin Htrans4 G'def; compute; subst G'.
  inversion Htrans4; subst.
  Case "Htrans4 : TRNackB".
    apply TypIsEq with (K:=Token (string_of_negb_string (string_of_bool i)))
        (L:=token_of_bool (negb i));
      [constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | apply LToken; destruct i; ctx_wf; discriminate_w_list
        | free_vals_in_ctx |].
    intro H_i_tok_eq.
    apply TypNew  with (s:=SSend i)
        (L:=z :: xc :: xerr1 :: xin :: x :: "send_true" :: "send_false"
          :: nil).
    intros d G' H_d_nin G'def; compute; subst G'.
    eapply TypPrefixOutput with (s:=SDual (SFwd (SSend i)))
        (rho:=TChannel (SSend i)) (t:=SDual (SFwd (SSend i)));
      [apply trdual_w_mdual_involution; constructor
        | left; discriminate
        | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | left; reflexivity
        | reflexivity | ].
    eapply TypPrefixOutput with (s:=SDual (SSend i)) (rho:=TSingleton k)
        (t:=SDual (SSend1 i r' (SNack r k r' (token_of_bool i))));
      [apply trdual_w_mdual_involution; constructor; assumption
        | left; discriminate
        | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | right; split; [reflexivity | constructor]
        | reflexivity | ].
    eapply TypPrefixOutput with
        (s:=SDual (SSend1 i r' (SNack r k r' (token_of_bool i))))
        (rho:=TChannel (SToks r'))
        (t:=SDual (SSend2 i (SNack r k r' (token_of_bool i))));
      [apply trdual_w_mdual_involution; constructor; assumption
        | left; discriminate
        | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | left; reflexivity
        | reflexivity | ].
    eapply TypPrefixOutput with
        (s:=SDual (SSend2 i (SNack r k r' (token_of_bool i))))
        (rho:=TChannel (SNack r k r' (token_of_bool i)))
        (t:=SDual SEpsilon);
      [apply trdual_w_mdual_involution; constructor; assumption
        | left; discriminate
        | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | left; reflexivity
        | reflexivity | ].
    apply TypZero;
      destruct i;
      ctx_wf;
      discriminate_w_list.

  Case "Htrans4 : TRNackC".
    apply TypIsEq with (K:=token_of_bool i) (L:=token_of_bool (negb i));
      [constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
        | apply LToken; destruct i; ctx_wf; discriminate_w_list
        | free_vals_in_ctx |].
      intro H_bad;
        destruct i in H_bad;
        contradict H_bad;
        discriminate.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal21.

Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj2synthconj4 : forall  (lv0 : lst) (lv1 : lst), (@eq lst (append Nil lv0) (append (append Nil lv0) lv1)).
Admitted.
QuickChick conj2synthconj4.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Coqlib.
Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import Values.

Require Import EvalTac.

Require Import SplitAt.

Lemma eval_d :
  eval_expr ge empty d (bits (v 4)).
Proof.
  g.
  e. e. e. e. e. g.
  e. e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. e. g.
  e. e. e. repeat e. e.
  repeat e.
  e. e. e. e. e. e.
  e. e. e. e.
  e. simpl. reflexivity.
  e. e. e. g.
  e. e. e. e. e. e. e. e.
  e.
  e. repeat e.
  e.
  eapply select_slice. e.
  reflexivity.
  e. e.
  e. e.
  e. e.
  e. e.
  Unshelve.
  all: try exact nz; simpl; unfold Pos.to_nat; simpl; try congruence.
Qed.


Require Import String.
Import List.
Import ListNotations.

Require Import Flood_Properties.
Require Import List_Properties.

(* Not needed but it's sanity *)
Lemma flood_safety_concat:
  forall trace trace',
  flood_safety trace ->
  flood_safety trace' ->
  flood_safety (trace ++ trace').
Proof.
  unfold flood_safety.
  intros.
  apply nth_index_in_concat in H1.
  destruct H1.
  - assert (exists t1 : nat, t1 < t2 /\ nth_error trace t1 = Some (Flood_Input i (m, c))).
    + eapply H.
      eassumption.
    + destruct H2.
      exists x.
      destruct H2.
      split.
      * assumption.
      * rewrite nth_error_app1.
        -- assumption.
        -- apply nth_error_Some.
           rewrite H3.
           discriminate.
  - destruct H1.
    destruct H1.
    assert (exists t1 : nat, t1 < x /\ nth_error trace' t1 = Some (Flood_Input i (m, c))).
    + eapply H0.
      eassumption.
    + destruct H3.
      destruct H3.
      exists (x0 + Datatypes.length trace).
      split.
      * rewrite <- H1.
        apply Plus.plus_lt_compat_r.
        assumption.
      * rewrite nth_error_app2.
        -- rewrite PeanoNat.Nat.add_sub.
           assumption.
        -- apply Plus.le_plus_r.
Qed.

Lemma flood_safety_append_not_output: forall trace t,
  flood_safety trace ->
  (forall i j m c, t <> Flood_Output i j (m, c)) ->
  flood_safety (trace ++ [t]).
Proof.
  intros trace t.
  unfold flood_safety in * |- *.
  intros H_trace_safety H_not_output.
  intros i j m c t2 H_nth.
  specialize (H_trace_safety i j m c t2).
  assert (exists t1 : nat, t1 < t2 /\ nth_error trace t1 = Some (Flood_Input i (m, c))).
  - apply H_trace_safety.
    apply nth_different_tail_smaller with t.
    + apply H_not_output.
    + assumption.
  - destruct H as [t1 H].
    destruct H.
    exists t1.
    split.
    + assumption.
    + apply nth_succes_larger.
      assumption.
Qed.

Lemma flood_safety_append_input: forall trace i m c,
  flood_safety trace ->
  flood_safety (trace ++ [Flood_Input i (m, c)]).
Proof.
  intros.
  apply flood_safety_append_not_output.
  assumption.
  intros.
  discriminate.
Qed.

Lemma flood_safety_append_leak: forall trace i m c,
  flood_safety trace ->
  flood_safety (trace ++ [Flood_Leak i (m, c)]).
Proof.
  intros.
  apply flood_safety_append_not_output.
  assumption.
  intros.
  discriminate.
Qed.

Lemma flood_safety_append_deliver: forall trace i j m c,
  flood_safety trace ->
  flood_safety (trace ++ [Flood_Deliver i j (m, c)]).
Proof.
  intros.
  apply flood_safety_append_not_output.
  assumption.
  intros.
  discriminate.
Qed.

Lemma flood_safety_append_output:
  forall trace t i j m c,
  flood_safety trace ->
  nth_error trace t = Some (Flood_Input i (m, c)) ->
  flood_safety (trace ++ [Flood_Output i j (m, c)]).
Proof.
  intros trace t i j m c.
  intros H_safe_trace H_nth_input.
  unfold flood_safety in * |- *.
  intros i' j' m' c' t2.
  intros H_nth_output.
  assert (t2 < Datatypes.length trace \/ Datatypes.length trace <= t2)
    as H_t2_lt_ge
    by (apply PeanoNat.Nat.lt_ge_cases).
  destruct H_t2_lt_ge as [H_t2_lt | H_t2_ge].
  - assert (nth_error trace t2 = Some (Flood_Output i' j' (m', c'))).
    + erewrite <- nth_error_app1;
      eassumption.
    + assert (exists t1 : nat, t1 < t2 /\ nth_error trace t1 = Some (Flood_Input i' (m', c')))
        as H_input_in_trace
        by (eapply H_safe_trace;
            try eassumption).
      destruct H_input_in_trace as [t1 H_input_in_trace].
      destruct H_input_in_trace as [H_t1_lt H_input_in_trace].
      exists t1.
      split.
      * assumption.
      * rewrite nth_error_app1.
        -- assumption.
        -- eapply PeanoNat.Nat.lt_trans;
           eassumption.
  - rewrite nth_error_app2 in H_nth_output.
    + exists t.
      split.
      * assert (t < Datatypes.length trace).
        -- apply nth_error_Some.
           unfold not.
           intros H_is_none.
           rewrite H_is_none in H_nth_input.
           discriminate.
        -- eapply PeanoNat.Nat.lt_le_trans;
           eassumption.
      * apply nth_succes_larger.
        assert (t2 - Datatypes.length trace < Datatypes.length [Flood_Output i j (m, c)])
          as H_t2_lt_length.
        -- apply nth_error_Some.
           unfold not.
           intros H_is_none.
           rewrite H_is_none in H_nth_output.
           discriminate.
        -- simpl in H_t2_lt_length.
           destruct (t2 - Datatypes.length trace).
           ++ simpl in H_nth_output.
              inversion H_nth_output.
              subst. clear H_nth_output.
              assumption.
           ++ inversion H_t2_lt_length.
              apply Le.le_n_0_eq in H0.
              inversion H0.
    + assumption.
Qed.


Require Import Bool.
Require Import RelationClasses.

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

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

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

Set Implicit Arguments.

Variant tau T (step: forall (e:ThreadEvent.t) (th1 th2:T), Prop) (th1 th2:T): Prop :=
| tau_intro
    e
    (TSTEP: step e th1 th2)
    (EVENT: ThreadEvent.get_machine_event e = MachineEvent.silent)
.
#[export] Hint Constructors tau: core.

Variant union E T (step: forall (e:E) (th1 th2:T), Prop) (th1 th2:T): Prop :=
| union_intro
    e
    (USTEP: step e th1 th2)
.
#[export] Hint Constructors union: core.

Variant pstep E T (step: forall (e: E) (th1 th2: T), Prop) (P: E -> Prop) (th1 th2: T): Prop :=
| pstep_intro
    e
    (STEP: step e th1 th2)
    (EVENT: P e)
.
#[export] Hint Constructors pstep: core.

Lemma tau_mon T (step1 step2: forall (e:ThreadEvent.t) (th1 th2:T), Prop)
      (STEP: step1 <3= step2):
  tau step1 <2= tau step2.
Proof.
  i. inv PR. econs; eauto.
Qed.

Lemma union_mon E T (step1 step2: forall (e:E) (th1 th2:T), Prop)
      (STEP: step1 <3= step2):
  union step1 <2= union step2.
Proof.
  i. inv PR. econs; eauto.
Qed.

Lemma pstep_mon E T (step1 step2: forall (e:E) (th1 th2:T), Prop) P1 P2
      (STEP: step1 <3= step2)
      (P: P1 <1= P2):
  pstep step1 P1 <2= pstep step2 P2.
Proof.
  i. inv PR. econs; eauto.
Qed.

Lemma tau_union: tau <4= (@union ThreadEvent.t).
Proof.
  ii. inv PR. econs. eauto.
Qed.

Lemma pstep_union E T step P:
  @pstep E T step P <2= @union E T step.
Proof.
  i. inv PR. eauto.
Qed.

Module Thread.
  Section Thread.
    Variable (lang: language).

    Structure t := mk {
      state: (Language.state lang);
      local: Local.t;
      global: Global.t;
    }.

    Variant step: forall (e: ThreadEvent.t) (th1 th2: t), Prop :=
    | step_internal
        e st lc1 gl1 lc2 gl2
        (LOCAL: Local.internal_step e lc1 gl1 lc2 gl2):
      step e (mk st lc1 gl1) (mk st lc2 gl2)
    | step_program
        e st1 lc1 gl1 st2 lc2 gl2
        (STATE: Language.step lang (ThreadEvent.get_program_event e) st1 st2)
        (LOCAL: Local.program_step e lc1 gl1 lc2 gl2):
      step e (mk st1 lc1 gl1) (mk st2 lc2 gl2)
    .
    Hint Constructors step: core.

    Definition tau_step := tau step.
    Hint Unfold tau_step: core.

    Definition all_step := union step.
    Hint Unfold all_step: core.

    Variant opt_step: forall (e:ThreadEvent.t) (th1 th2:t), Prop :=
      | step_none
          th:
        opt_step ThreadEvent.silent th th
      | step_some
          e th1 th2
          (STEP: step e th1 th2):
        opt_step e th1 th2
    .
    Hint Constructors opt_step: core.

    Variant internal_step: forall (th1 th2: t), Prop :=
    | interal_step_intro
        e st lc1 gl1 lc2 gl2
        (LOCAL: Local.internal_step e lc1 gl1 lc2 gl2):
      internal_step (mk st lc1 gl1) (mk st lc2 gl2)
    .
    Hint Constructors internal_step: core.

    Variant program_step: forall (e: ThreadEvent.t) (th1 th2: t), Prop :=
    | program_step_intro
        e st1 lc1 gl1 st2 lc2 gl2
        (STATE: Language.step lang (ThreadEvent.get_program_event e) st1 st2)
        (LOCAL: Local.program_step e lc1 gl1 lc2 gl2):
      program_step e (mk st1 lc1 gl1) (mk st2 lc2 gl2)
    .
    Hint Constructors program_step: core.

    Lemma tau_opt_tau
          th1 th2 th3 e
          (STEPS: rtc tau_step th1 th2)
          (STEP: opt_step e th2 th3)
          (EVENT: ThreadEvent.get_machine_event e = MachineEvent.silent):
      rtc tau_step th1 th3.
    Proof.
      induction STEPS.
      - inv STEP; eauto.
      - exploit IHSTEPS; eauto.
    Qed.

    Lemma tau_opt_all
          th1 th2 th3 e
          (STEPS: rtc tau_step th1 th2)
          (STEP: opt_step e th2 th3):
      rtc all_step th1 th3.
    Proof.
      induction STEPS.
      - inv STEP; eauto.
      - exploit IHSTEPS; eauto. i.
        econs 2; eauto.
        inv H. econs. eauto.
    Qed.

    (* consistency *)

    Definition cap_of (th: t): t :=
      mk (state th) (local th) (Global.cap_of (global th)).

    Variant steps_failure (th1: t): Prop :=
      | steps_failure_intro
          e th2 th3
          (STEPS: rtc tau_step th1 th2)
          (STEP_FAILURE: step e th2 th3)
          (EVENT_FAILURE: ThreadEvent.get_machine_event e = MachineEvent.failure)
    .

    Variant consistent (th: t): Prop :=
      | consistent_failure
          (FAILURE: steps_failure (cap_of th))
      | consistent_fulfill
          th2
          (STEPS: rtc tau_step (cap_of th) th2)
          (PROMISES: Local.promises (Thread.local th2) = BoolMap.bot)
    .

    Lemma cap_wf
          th
          (LC_WF: Local.wf (local th) (global th))
          (GL_WF: Global.wf (global th)):
      (<<LC_WF_CAP: Local.wf (local (cap_of th)) (global (cap_of th))>>) /\
      (<<GL_WF_CAP: Global.wf (global (cap_of th))>>).
    Proof.
      exploit Local.cap_wf; eauto.
      exploit Global.cap_wf; eauto.
    Qed.

    (* step_future *)

    Lemma step_future
          e th1 th2
          (STEP: step e th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.future (global th1) (global th2)>>.
    Proof.
      inv STEP; ss.
      - eauto using Local.internal_step_future.
      - eauto using Local.program_step_future.
    Qed.

    Lemma opt_step_future
          e th1 th2
          (STEP: opt_step e th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.future (global th1) (global th2)>>.
    Proof.
      inv STEP; eauto using step_future.
      esplits; eauto; refl.
    Qed.

    Lemma rtc_all_step_future
          th1 th2
          (STEP: rtc all_step th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.future (global th1) (global th2)>>.
    Proof.
      revert LC_WF1. induction STEP; i.
      - splits; ss; refl.
      - inv H. exploit step_future; eauto. i. des.
        exploit IHSTEP; eauto. i. des.
        splits; ss; etrans; eauto.
    Qed.

    Lemma rtc_tau_step_future
          th1 th2
          (STEP: rtc tau_step th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.future (global th1) (global th2)>>.
    Proof.
      apply rtc_all_step_future; auto.
      eapply rtc_implies; [|eauto].
      apply tau_union.
    Qed.

    Lemma internal_step_future
          th1 th2
          (STEP: internal_step th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.future (global th1) (global th2)>>.
    Proof.
      inv STEP; ss.
      eauto using Local.internal_step_future.
    Qed.

    Lemma rtc_internal_step_future
          th1 th2
          (STEP: rtc internal_step th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.future (global th1) (global th2)>>.
    Proof.
      revert LC_WF1. induction STEP; i.
      - splits; ss; refl.
      - exploit internal_step_future; eauto. i. des.
        exploit IHSTEP; eauto. i. des.
        splits; ss; etrans; eauto.
    Qed.

    Lemma program_step_future
          e th1 th2
          (STEP: program_step e th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.future (global th1) (global th2)>>.
    Proof.
      inv STEP; ss.
      eauto using Local.program_step_future.
    Qed.

    Lemma rtc_program_step_future
          th1 th2
          (STEP: rtc (tau program_step) th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.future (global th1) (global th2)>>.
    Proof.
      revert LC_WF1. induction STEP; i.
      - splits; ss; refl.
      - inv H. exploit program_step_future; eauto. i. des.
        exploit IHSTEP; eauto. i. des.
        splits; ss; etrans; eauto.
    Qed.

    (* step_inhabited *)

    Lemma step_inhabited
          e th1 th2
          (STEP: step e th1 th2)
          (INHABITED1: Memory.inhabited (Global.memory (global th1))):
      <<INHABITED2: Memory.inhabited (Global.memory (global th2))>>.
    Proof.
      inv STEP.
      - eapply Local.internal_step_inhabited; eauto.
      - eapply Local.program_step_inhabited; eauto.
    Qed.

    (* step_disjoint *)

    Lemma step_disjoint
          e th1 th2 lc
          (STEP: step e th1 th2)
          (DISJOINTH1: Local.disjoint (local th1) lc)
          (LC_WF: Local.wf lc (global th1)):
      <<DISJOINTH2: Local.disjoint (local th2) lc>> /\
      <<LC_WF: Local.wf lc (global th2)>>.
    Proof.
      inv STEP.
      - eapply Local.internal_step_disjoint; eauto.
      - eapply Local.program_step_disjoint; eauto.
    Qed.

    Lemma opt_step_disjoint
          e th1 th2 lc
          (STEP: opt_step e th1 th2)
          (DISJOINTH1: Local.disjoint (local th1) lc)
          (LC_WF: Local.wf lc (global th1)):
      <<DISJOINTH2: Local.disjoint (local th2) lc>> /\
      <<LC_WF: Local.wf lc (global th2)>>.
    Proof.
      inv STEP.
      - esplits; eauto.
      - eapply step_disjoint; eauto.
    Qed.

    Lemma rtc_all_step_disjoint
          th1 th2 lc
          (STEP: rtc all_step th1 th2)
          (DISJOINTH1: Local.disjoint (local th1) lc)
          (LC_WF: Local.wf lc (global th1)):
      <<DISJOINTH2: Local.disjoint (local th2) lc>> /\
      <<LC_WF: Local.wf lc (global th2)>>.
    Proof.
      revert DISJOINTH1 LC_WF. induction STEP; eauto. i.
      inv H. exploit step_disjoint; eauto. i. des. eauto.
    Qed.

    Lemma rtc_tau_step_disjoint
          th1 th2 lc
          (STEP: rtc tau_step th1 th2)
          (DISJOINTH1: Local.disjoint (local th1) lc)
          (LC_WF: Local.wf lc (global th1)):
      <<DISJOINTH2: Local.disjoint (local th2) lc>> /\
      <<LC_WF: Local.wf lc (global th2)>>.
    Proof.
      eapply rtc_all_step_disjoint; cycle 1; eauto.
      eapply rtc_implies; [|eauto].
      apply tau_union.
    Qed.

    Lemma program_step_promises
          e th1 th2
          (STEP: Thread.step e th1 th2)
          (EVENT: ThreadEvent.is_program e):
      BoolMap.le (Local.promises (local th2)) (Local.promises (local th1)) /\
      BoolMap.le (Global.promises (global th2)) (Global.promises (global th1)).
    Proof.
      inv STEP; try by (inv LOCAL; ss).
      eapply Local.program_step_promises; eauto.
    Qed.

    Lemma step_promises_minus
          e th1 th2
          (STEP: step 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.
      inv STEP; s.
      - eapply Local.internal_step_promises_minus; eauto.
      - eapply Local.program_step_promises_minus; eauto.
    Qed.

    Lemma rtc_all_step_promises_minus
          th1 th2
          (STEPS: rtc all_step 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.
      induction STEPS; ss. inv H.
      exploit step_promises_minus; eauto. i. congr.
    Qed.

    Lemma rtc_tau_step_promises_minus
          th1 th2
          (STEPS: rtc tau_step 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.
      apply rtc_all_step_promises_minus.
      eapply rtc_implies; try exact STEPS.
      apply tau_union.
    Qed.

    (* step_strong_le *)

    Lemma step_strong_le
          e th1 th2
          (STEP: step e th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.strong_le (global th1) (global th2)>>
      \/
      exists e_race th2',
        <<STEP: step e_race th1 th2'>> /\
        <<EVENT: ThreadEvent.get_program_event e_race = ThreadEvent.get_program_event e>> /\
        <<RACE: ThreadEvent.get_machine_event e_race = MachineEvent.failure>>
    .
    Proof.
      inv STEP; ss.
      - eauto using Local.internal_step_strong_le.
      - hexploit Local.program_step_strong_le; eauto. i. des.
        { left. esplits; eauto. }
        { right. exists e_race. esplits; eauto. econs 2; eauto.
          rewrite EVENT. eauto.
        }
    Qed.

    Lemma opt_step_strong_le
          e th1 th2
          (STEP: opt_step e th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.strong_le (global th1) (global th2)>>
      \/
      exists e_race th2',
        <<STEP: step e_race th1 th2'>> /\
        <<EVENT: ThreadEvent.get_program_event e_race = ThreadEvent.get_program_event e>> /\
        <<RACE: ThreadEvent.get_machine_event e_race = MachineEvent.failure>>
    .
    Proof.
      inv STEP; eauto using step_strong_le.
      left. esplits; eauto; refl.
    Qed.

    Lemma rtc_tau_step_strong_le
          th1 th2
          (STEP: rtc tau_step th1 th2)
          (LC_WF1: Local.wf (local th1) (global th1))
          (GL_WF1: Global.wf (global th1)):
      <<LC_WF2: Local.wf (local th2) (global th2)>> /\
      <<GL_WF2: Global.wf (global th2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (local th1)) (Local.tview (local th2))>> /\
      <<GL_FUTURE: Global.strong_le (global th1) (global th2)>>
          \/
      <<FAILURE: steps_failure th1>>
    .
    Proof.
      revert LC_WF1. induction STEP; i.
      - left. splits; ss; refl.
      - inv H. exploit step_strong_le; eauto. i. des.
        2:{ right. repeat red. econs; [refl| |]; eauto. }
        exploit IHSTEP; eauto. i. des.
        { left. splits; auto; etrans; eauto. }
        { inv FAILURE. right. econs.
          { econs 2.
            { econs; eauto. }
            { eauto. }
          }
          { eauto. }
          { eauto. }
        }
    Qed.

    (* internal and program step *)

    Lemma internal_step_tau_thread_step
          th1 th2
          (STEP: internal_step th1 th2)
      :
      tau_step th1 th2.
    Proof.
      inv STEP. econs 1; eauto. inv LOCAL; ss.
    Qed.

    Lemma program_step_thread_step
          e th1 th2
          (STEP: program_step e th1 th2)
      :
      step e th1 th2.
    Proof.
      inv STEP. econs 2; eauto.
    Qed.

    Lemma rtc_internal_step_rtc_tau_thread_step
          th1 th2
          (STEPS: rtc internal_step th1 th2)
      :
      rtc tau_step th1 th2.
    Proof.
      induction STEPS; eauto. econs 2; [|eauto].
      eapply internal_step_tau_thread_step; eauto.
    Qed.

    Lemma rtc_tau_program_step_rtc_tau_thread_step
          th1 th2
          (STEPS: rtc (tau program_step) th1 th2)
      :
      rtc tau_step th1 th2.
    Proof.
      induction STEPS; eauto. econs 2; [|eauto].
      inv H. econs; eauto. eapply program_step_thread_step; eauto.
    Qed.

  End Thread.
End Thread.
#[export] Hint Constructors Thread.step: core.
#[export] Hint Constructors Thread.opt_step: core.
#[export] Hint Constructors Thread.steps_failure: core.
#[export] Hint Constructors Thread.consistent: core.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model SC, no co generated *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition WW r := r ⊓ [W] ⋅ top ⋅ [W].
Definition RW r := r ⊓ [R] ⋅ top ⋅ [W].
Definition U0 := po_loc ⊔ (rf ⊔ co0).
Inductive U : relation _ := U_c : incl (U0 ⊔ (WW (U ⋅ rf°) ⊓ !id ⊔ (RW (rf° ⋅ U) ⊓ !id ⊔ U ⋅ U))) U.
Section scheme.
Variables U' : relation events.
Variable HU' : incl (U0 ⊔ (WW (U' ⋅ rf°) ⊓ !id ⊔ (RW (rf° ⋅ U') ⊓ !id ⊔ U' ⋅ U'))) U'.

  Fixpoint U_ind' x y (r : U x y) : U' x y.
  Proof.
    destruct r as [x y r]; apply HU'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
       destruct r as [r1 r2]; split.
        destruct r1 as [r11 r12]; split.
         destruct r11 as [x_y r111 r112]; exists x_y.
          apply U_ind'; exact r111.
          exact r112.
         exact r12.
        exact r2.
      destruct r as [r | r]; [ left | right ].
        destruct r as [r1 r2]; split.
         destruct r1 as [r11 r12]; split.
          destruct r11 as [x_y r111 r112]; exists x_y.
           exact r111.
           apply U_ind'; exact r112.
          exact r12.
         exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply U_ind'; exact r1.
        apply U_ind'; exact r2.
  Qed.
End scheme.
Definition sc_per_location := acyclic U.
Definition co := WW U.
Definition fr := RW U.
Definition mfence : relation events := (*failed: try fencerel MFENCE with 0*) 0.
Definition lfence : relation events := (*failed: try fencerel LFENCE with 0*) 0.
Definition sfence : relation events := (*failed: try fencerel SFENCE with 0*) 0.
Definition dmb_st : relation events := (*failed: try fencerel DMB.ST with 0*) 0.
Definition dsb_st : relation events := (*failed: try fencerel DSB.ST with 0*) 0.
Definition dmb : relation events := (*failed: try fencerel DMB with 0*) 0.
Definition dsb : relation events := (*failed: try fencerel DSB with 0*) 0.
Definition isb : relation events := (*failed: try fencerel ISB with 0*) 0.
Definition ctrlisb : relation events := (*failed: try ctrlcfence ISB with 0*) 0.
Definition sync : relation events := (*failed: try fencerel SYNC with 0*) 0.
Definition lwsync : relation events := (*failed: try fencerel LWSYNC with 0*) 0.
Definition eieio : relation events := (*failed: try fencerel EIEIO with 0*) 0.
Definition isync : relation events := (*failed: try fencerel ISYNC with 0*) 0.
Definition ctrlisync : relation events := (*failed: try ctrlcfence ISYNC with 0*) 0.
Definition DMB_ISH := (*failed: try DMB.ISH with emptyset_0*) emptyset_0.
Definition DMB_ISHLD := (*failed: try DMB.ISHLD with emptyset_0*) emptyset_0.
Definition DMB_ISHST := (*failed: try DMB.ISHST with emptyset_0*) emptyset_0.
Definition DSB_ISH := (*failed: try DSB.ISH with emptyset_0*) emptyset_0.
Definition DSB_ISHLD := (*failed: try DSB.ISHLD with emptyset_0*) emptyset_0.
Definition DSB_ISHST := (*failed: try DSB.ISHST with emptyset_0*) emptyset_0.
Definition DMB_SY := (*failed: try DMB.SY with emptyset_0*) emptyset_0.
Definition DMB_ST := (*failed: try DMB.ST with emptyset_0*) emptyset_0.
Definition DMB_LD := (*failed: try DMB.LD with emptyset_0*) emptyset_0.
Definition DSB_SY := (*failed: try DSB.SY with emptyset_0*) emptyset_0.
Definition DSB_ST := (*failed: try DSB.ST with emptyset_0*) emptyset_0.
Definition DSB_LD := (*failed: try DSB.LD with emptyset_0*) emptyset_0.
Definition DMB_OSH := (*failed: try DMB.OSH with emptyset_0*) emptyset_0.
Definition DSB_OSH := (*failed: try DSB.OSH with emptyset_0*) emptyset_0.
Definition DMB_OSHLD := (*failed: try DMB.OSHLD with emptyset_0*) emptyset_0.
Definition DSB_OSHLD := (*successful: try DSB.OSH with emptyset_0*) DSB_OSH.
Definition DMB_OSHST := (*failed: try DMB.OSHST with emptyset_0*) emptyset_0.
Definition DSB_OSHST := (*failed: try DSB.OSHST with emptyset_0*) emptyset_0.
Definition ISB := (*failed: try ISB with emptyset_0*) emptyset_0.
Definition A := (*failed: try A with emptyset_0*) emptyset_0.
Definition L := (*failed: try L with emptyset_0*) emptyset_0.
Definition Q := (*failed: try Q with emptyset_0*) emptyset_0.
Definition NoRet := (*failed: try NoRet with emptyset_0*) emptyset_0.
Definition dmb_ish := fencerel DMB_ISH.
Definition dmb_ishld := fencerel DMB_ISHLD.
Definition dmb_ishst := fencerel DMB_ISHST.
Definition dmb_fullsy := fencerel DMB_SY.
Definition dmb_fullst := fencerel DMB_ST.
Definition dmb_fullld := fencerel DMB_LD.
Definition dmb_sy := dmb_fullsy ⊔ dmb_ish.
Definition dmb_st_0 := dmb_fullst ⊔ dmb_ishst.
Definition dmb_ld := dmb_fullld ⊔ dmb_ishld.
Definition dsb_sy := fencerel DSB_SY.
Definition dsb_st_0 := fencerel DSB_ST.
Definition dsb_ld := fencerel DSB_LD.
Definition isb_0 := fencerel ISB.
Definition ctrlisb_0 := (*successful: try ctrlcfence ISB with 0*) ctrlcfence ISB.
Definition ctrlcfence_0 := ctrlisb_0 ⊔ ctrlisync.
Definition S0 := po ⊔ U.
Inductive S : relation _ := S_c : incl (S0 ⊔ (WW (Sloc ⋅ rf°) ⊓ !id ⊔ (RW (rf° ⋅ Sloc) ⊓ !id ⊔ S ⋅ S))) S
     with Sloc : relation _ := Sloc_c : incl (S ⊓ loc) Sloc.
Section scheme.
Variables S' Sloc' : relation events.
Variable HS' : incl (S0 ⊔ (WW (Sloc' ⋅ rf°) ⊓ !id ⊔ (RW (rf° ⋅ Sloc') ⊓ !id ⊔ S' ⋅ S'))) S'.
Variable HSloc' : incl (S' ⊓ loc) Sloc'.

  Fixpoint S_ind' x y (r : S x y) : S' x y
      with Sloc_ind' x y (r : Sloc x y) : Sloc' x y.
  Proof.
    destruct r as [x y r]; apply HS'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
       destruct r as [r1 r2]; split.
        destruct r1 as [r11 r12]; split.
         destruct r11 as [x_y r111 r112]; exists x_y.
          apply Sloc_ind'; exact r111.
          exact r112.
         exact r12.
        exact r2.
      destruct r as [r | r]; [ left | right ].
        destruct r as [r1 r2]; split.
         destruct r1 as [r11 r12]; split.
          destruct r11 as [x_y r111 r112]; exists x_y.
           exact r111.
           apply Sloc_ind'; exact r112.
          exact r12.
         exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply S_ind'; exact r1.
        apply S_ind'; exact r2.
    destruct r as [x y r]; apply HSloc'.
    destruct r as [r1 r2]; split.
     apply S_ind'; exact r1.
     exact r2.
  Qed.
End scheme.
Definition sc := acyclic S.
Definition co_0 := WW Sloc.
Definition fr_0 := RW Sloc.
Definition coe := co_0 ⊓ ext.
Definition fre := fr_0 ⊓ ext.
Definition atom := is_empty (rmw ⊓ fre ⋅ coe).
Definition witness_conditions := True.
Definition model_conditions := sc_per_location /\ (sc /\ atom).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW WW RW U0 sc_per_location co fr mfence lfence sfence dmb_st dsb_st dmb dsb isb ctrlisb sync lwsync eieio isync ctrlisync DMB_ISH DMB_ISHLD DMB_ISHST DSB_ISH DSB_ISHLD DSB_ISHST DMB_SY DMB_ST DMB_LD DSB_SY DSB_ST DSB_LD DMB_OSH DSB_OSH DMB_OSHLD DSB_OSHLD DMB_OSHST DSB_OSHST ISB A L Q NoRet dmb_ish dmb_ishld dmb_ishst dmb_fullsy dmb_fullst dmb_fullld dmb_sy dmb_st_0 dmb_ld dsb_sy dsb_st_0 dsb_ld isb_0 ctrlisb_0 ctrlcfence_0 S0 sc co_0 fr_0 coe fre atom witness_conditions model_conditions : cat.

Definition valid (c : candidate) := model_conditions c.

(* End of translation of model SC, no co generated *)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* TABLE ACTIONS *)

(*definit les actions elementaires sur les tables et leurs
consequences*)

Require Export DistributedReferenceCounting.machine0.machine.

Section T_ACTION.

Definition Update_table (d0 : Date_table) (s0 : Site)
  (new_date : nat) := change_site nat d0 s0 new_date.

Definition Set_rec_table (r0 : Rec_table) (s0 : Site) :=
  change_site bool r0 s0 true.

Definition Reset_rec_table (r0 : Rec_table) (s0 : Site) :=
  change_site bool r0 s0 false.

Definition Inc_send_table (t0 : Send_table) (s0 : Site) :=
  change_site Z t0 s0 (t0 s0 + 1)%Z.

Definition Dec_send_table (t0 : Send_table) (s0 : Site) :=
  change_site Z t0 s0 (t0 s0 - 1)%Z.

End T_ACTION.

Section DT_EFFECT.

Lemma update_here :
 forall (d0 : Date_table) (s0 : Site) (newdate : nat),
 Update_table d0 s0 newdate s0 = newdate.
Proof.
 intros; unfold Update_table in |- *; apply that_site.
Qed.

Lemma update_elsewhere :
 forall (d0 : Date_table) (s0 s1 : Site) (newdate : nat),
 s0 <> s1 -> Update_table d0 s0 newdate s1 = d0 s1.
Proof.
 intros; unfold Update_table in |- *; apply other_site; trivial.
Qed.

End DT_EFFECT.

Section ST_EFFECT.

Lemma S_inc_send_table :
 forall (t0 : Send_table) (s0 : Site),
 Inc_send_table t0 s0 s0 = (t0 s0 + 1)%Z.
Proof.
 intros; unfold Inc_send_table in |- *; apply that_site.
Qed.

Lemma no_inc_send_table :
 forall (t0 : Send_table) (s0 s1 : Site),
 s0 <> s1 -> Inc_send_table t0 s0 s1 = t0 s1.
Proof.
 intros; unfold Inc_send_table in |- *; apply other_site; auto.
Qed.

Lemma pred_dec_send_table :
 forall (t0 : Send_table) (s0 : Site),
 Dec_send_table t0 s0 s0 = (t0 s0 - 1)%Z.
Proof.
 intros; unfold Dec_send_table in |- *; apply that_site.
Qed.

Lemma no_dec_send_table :
 forall (t0 : Send_table) (s0 s1 : Site),
 s0 <> s1 -> Dec_send_table t0 s0 s1 = t0 s1.
Proof.
 intros; unfold Dec_send_table in |- *; apply other_site; auto.
Qed.

End ST_EFFECT.

Section RT_EFFECT.

Lemma true_set_rec_table :
 forall (r0 : Rec_table) (s0 : Site), Set_rec_table r0 s0 s0 = true.
Proof.
 intros; unfold Set_rec_table in |- *; apply that_site.
Qed.

Lemma S_set_rec_table :
 forall (r0 : Rec_table) (s0 : Site),
 r0 s0 = false -> Int (Set_rec_table r0 s0 s0) = (Int (r0 s0) + 1)%Z.
Proof.
 intros; rewrite true_set_rec_table; rewrite H; auto.
Qed.

Lemma inch_set_rec_table :
 forall (r0 : Rec_table) (s0 s1 : Site),
 s0 <> s1 -> Set_rec_table r0 s0 s1 = r0 s1.
Proof.
 intros; unfold Set_rec_table in |- *; apply other_site; trivial.
Qed.

Lemma no_set_rec_table :
 forall (r0 : Rec_table) (s0 s1 : Site),
 s0 <> s1 -> Int (Set_rec_table r0 s0 s1) = Int (r0 s1).
Proof.
 intros; rewrite inch_set_rec_table; trivial.
Qed.

Remark false_reset_rec_table :
 forall (r0 : Rec_table) (s0 : Site), Reset_rec_table r0 s0 s0 = false.
Proof.
 intros; unfold Reset_rec_table in |- *; apply that_site.
Qed.

Lemma pred_reset_rec_table :
 forall (r0 : Rec_table) (s0 : Site),
 r0 s0 = true -> Int (Reset_rec_table r0 s0 s0) = (Int (r0 s0) - 1)%Z.
Proof.
 intros; rewrite false_reset_rec_table; rewrite H; auto.
Qed.

Lemma inch_reset_rec_table :
 forall (r0 : Rec_table) (s0 s1 : Site),
 s0 <> s1 -> Reset_rec_table r0 s0 s1 = r0 s1.
Proof.
 intros; unfold Reset_rec_table in |- *; apply other_site; auto.
Qed.

Lemma no_reset_rec_table :
 forall (r0 : Rec_table) (s0 s1 : Site),
 s0 <> s1 -> Int (Reset_rec_table r0 s0 s1) = Int (r0 s1).
Proof.
 intros; rewrite inch_reset_rec_table; trivial.
Qed.

End RT_EFFECT.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Tools for small-step operational semantics *)

(** This module defines generic operations and theorems over
  the one-step transition relations that are used to specify
  operational semantics in small-step style. *)

Require Import Relations.
Require Import Wellfounded.
Require Import Coqlib.
Require Import Events.
Require Import Globalenvs.
Require Import Integers.
Require Import Smallstep.

(*Require Import compcert.lib.Coqlib.
Require Import compcert.common.Events.
Require Import compcert.common.Globalenvs.
Require Import compcert.lib.Integers.
Require Import compcert.common.Smallstep.
*)

Set Nested Proofs Allowed.

Require Import compcert.common.Values. (*for meminj, compose_meminj,...*)

Set Implicit Arguments.

(** * Transition semantics *)

(** The general form of a transition semantics. *)
Require Import compcert.common.Memory.

Section ExposingMemory.

  Variables L1 L2: semantics.
  Variable get_mem1: state L1 -> mem.
  Variable get_mem2: state L2 -> mem.

  Definition preserves_atx {index:Type} {L1 L2} match_states
    :=
      forall (i:index) s1 s2,
        match_states i s1 s2 ->
        forall f args,
          @at_external L1 s1 = Some (f,args) ->
          exists args',
            @at_external L2 s2 = Some (f,args') /\
            Val.lessdef_list args args'.

  Definition simulation_atx {index:Type} {L1 L2} (match_states: index -> _ -> _ -> Prop)
    :=
        forall s1 f args,
          @at_external L1 s1 = Some (f,args) ->
          forall t s1', Step L1 s1 t s1' ->
                  forall i s2, match_states i s1 s2 ->
                          exists i', exists s2', Step L2 s2 t s2' /\
                                       match_states i' s1' s2'.

  (** *Equality Phases*)
  Section Equality.
    Record fsim_properties_eq: Type :=
      {
        Eqindex: Type;
        Eqorder: Eqindex -> Eqindex -> Prop;
        Eqmatch_states: Eqindex -> state L1 -> state L2 -> Prop;
        Eqfsim_order_wf: well_founded Eqorder;
        Eqfsim_match_meminj: forall i s1 s2, Eqmatch_states i s1 s2 ->  (get_mem1 s1) = (get_mem2 s2);
        (*    fsim_match_initial_states:
      forall s1 m1 f m2, initial_state L1 (s1,m1) -> Mem.inject f m1 m2 ->
      exists i, exists s2, initial_state L2 (s2,m2) /\ match_states i f (s1,m1) (s2,m2);*)
        Eqfsim_match_initial_states:
          forall s1, initial_state L1 s1 ->
                exists i s2, initial_state L2 s2 /\ Eqmatch_states i s1 s2;
        Eqfsim_match_final_states:
          forall i s1 s2 r ,
            Eqmatch_states i s1 s2 -> final_state L1 s1 r -> (final_state L2 s2 r);
        Eqfsim_simulation:
          forall s1 t s1', Step L1 s1 t s1' ->
                      forall i s2, Eqmatch_states i s1 s2 ->
                              exists i', exists s2',
                                  (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ Eqorder i' i))
                                  /\ Eqmatch_states i' s1' s2';
        Eqfsim_simulation_atx:
          simulation_atx Eqmatch_states;
        Eqfsim_atx:
          preserves_atx Eqmatch_states;
        Eqfsim_public_preserved:
          forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id
      }.

    Lemma sim_eqSim':
      forall index order (match_states:index -> state L1 -> state L2 -> Prop),
        (simulation_atx match_states) ->
        (preserves_atx match_states) ->
      (forall i s1 s2, match_states i s1 s2 ->  (get_mem1 s1) = (get_mem2 s2)) ->
      fsim_properties L1 L2 index order match_states ->
      fsim_properties_eq.
    Proof.
      intros ? ? ? ? ? H HH; inv HH.
      econstructor; eauto.
    Qed.

  End Equality.

  (** *Extension Phases*)
  Section Extensions.

   Record fsim_properties_ext: Type :=
  {
    Extindex: Type;
    Extorder: Extindex -> Extindex -> Prop;
    Extmatch_states: Extindex -> state L1 -> state L2 -> Prop;
    Extfsim_order_wf: well_founded Extorder;
    Extfsim_match_meminj: forall i s1 s2, Extmatch_states i s1 s2 ->  Mem.extends (get_mem1 s1) (get_mem2 s2);
(*    fsim_match_initial_states:
      forall s1 m1 f m2, initial_state L1 (s1,m1) -> Mem.inject f m1 m2 ->
      exists i, exists s2, initial_state L2 (s2,m2) /\ match_states i f (s1,m1) (s2,m2);*)
    Extfsim_match_initial_states:
      forall s1, initial_state L1 s1 ->
               exists i s2, initial_state L2 s2 /\ Extmatch_states i s1 s2;
    Extfsim_match_final_states:
      forall i s1 s2 r ,
      Extmatch_states i s1 s2 -> final_state L1 s1 r -> (final_state L2 s2 r);
    Extfsim_simulation:
      forall s1 t s1', Step L1 s1 t s1' ->
      forall i s2, Extmatch_states i s1 s2 ->
      exists i', exists s2',
         (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ Extorder i' i))
         /\ Extmatch_states i' s1' s2';
    Extfsim_simulation_atx:
          simulation_atx Extmatch_states;
    Extfsim_atx:
          preserves_atx Extmatch_states;
    Extfsim_public_preserved:
      forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id
  }.

   (** An alternate form of the simulation diagram *)
   Lemma Extfsim_simulation':
       forall (SIM:fsim_properties_ext),
       forall i s1 t s1',
         Step L1 s1 t s1' ->
         forall s2, Extmatch_states SIM i s1 s2 ->
               (exists i', exists s2', Plus L2 s2 t s2' /\
                                   Extmatch_states SIM i' s1' s2')
               \/ (exists i', Extorder SIM i' i /\ t = E0 /\ Extmatch_states SIM i' s1' s2).
   Proof.
     intros. exploit Extfsim_simulation; eauto.
     intros [i' [s2' [A B ]]]. intuition.
     left; exists i'; exists s2'; auto .
     inv H2.
     right; exists i'; eauto.
     left; exists i'; exists s2'; split; auto. econstructor; eauto.
   Qed.

   (** *Star version of simulation*)
    Lemma Extsimulation_star:
      forall (SIM:fsim_properties_ext),
      forall s1 t s1', Star L1 s1 t s1' ->
                  forall i s2,
                    Extmatch_states SIM  i s1 s2 ->
                    exists i', exists s2', Star L2 s2 t s2' /\ Extmatch_states SIM  i' s1' s2'.
    Proof.
      intros S.
      induction 1; intros.
      exists i; exists s2; split; auto. apply star_refl.

      (*split; auto; constructor.
      apply inject_incr_refl. constructor.*)

      exploit Extfsim_simulation; eauto.
      intros [i' [s2' [A B]]].
      exploit IHstar; eauto. intros [i'' [s2'' [E F ]]].
      exists i'';exists s2''; split; auto. eapply star_trans; eauto.
      intuition auto. apply plus_star; auto.
    Qed.

    (** *Plus version of simulation*)
    Lemma Extsimulation_plus:
      forall (SIM: fsim_properties_ext),
      forall s1 t s1', Plus L1 s1 t s1' ->
                  forall i s2, Extmatch_states SIM  i s1 s2 ->
            (exists i', exists s2', Plus L2 s2 t s2' /\ Extmatch_states SIM  i' s1' s2')
            \/ (exists i', clos_trans _ (Extorder SIM) i' i /\ t = E0 /\ Extmatch_states SIM  i' s1' s2).
    Proof.
      intros S.
      induction 1 using plus_ind2; intros.
      (* base case *)
      exploit Extfsim_simulation'; eauto.
      intros [[i' [s2' [A B ]]] | [i'  A]].
      left. exists i', s2'; auto.
      right; exists i'; intuition.
      (* inductive case *)
      exploit Extfsim_simulation'; eauto.
      intros [[i' [s2' [A B]]] | [i' [A [B C] ]]].
      exploit Extsimulation_star; eauto. apply plus_star; eauto. eauto.
      intros [i'' [s2'' [P Q ]]].
      left; exists i''; exists s2''; split; auto. eapply plus_star_trans; eauto.
      repeat split; auto.

      exploit IHplus; eauto.
      intros [[i'' [s2'' [P Q ]]] | [i'' [P Q]]].
      subst. simpl. left; exists i''; exists s2''; auto.
      repeat split; eauto.

      subst. simpl. right; exists i''; intuition auto.
      eapply t_trans; eauto. eapply t_step; eauto.
    Qed.

    Lemma EqEx_sim':
        fsim_properties_eq ->
        fsim_properties_ext.
    Proof.
      intros H; inv H.
      econstructor; eauto.
      intros.
      erewrite Eqfsim_match_meminj0; eauto.
      eapply Mem.extends_refl.
    Qed.

    Lemma sim_extSim:
      forall index order (match_states:index -> state L1 -> state L2 -> Prop),
        (simulation_atx match_states) ->
        (preserves_atx match_states) ->
      (forall i s1 s2, match_states i s1 s2 ->  Mem.extends (get_mem1 s1) (get_mem2 s2)) ->
      fsim_properties L1 L2 index order match_states ->
      fsim_properties_ext.
    Proof.
      intros ? ? ? ? ? H HH; inv HH.
      econstructor; eauto.
    Qed.

  End Extensions.

  (** *Injection Phases*)
  Section Injection.

    Definition preserves_atx_inj {index:Type} {L1 L2} match_states
        :=
          forall (i:index)(j:meminj) s1 s2,
            match_states i j s1 s2 ->
            forall f args,
              @at_external L1 s1 = Some (f,args) ->
          exists args',
            @at_external L2 s2 = Some (f,args') /\
            Val.inject_list j args args'.

    Definition simulation_atx_inj {index:Type} {L1 L2}
               (match_states: index -> meminj -> _ -> _ -> Prop)
      :=
        forall s1 f args,
          @at_external L1 s1 = Some (f,args) ->
          forall t s1', Step L1 s1 t s1' ->
                    forall i f s2, match_states i f s1 s2 ->
                              exists i', exists s2' f' t',
                                  Step L2 s2 t' s2' /\
                                  match_states i' f' s1' s2' /\
                                  Values.inject_incr f f' /\
                                  inject_trace_strong f' t t'.

    Record fsim_properties_inj: Type :=
      {  Injindex: Type;
        Injorder: Injindex -> Injindex -> Prop;
        Injmatch_states: Injindex -> meminj -> state L1 -> state L2 -> Prop;
        Injfsim_order_wf: well_founded Injorder;
        Injfsim_match_meminj: forall i f s1 s2, Injmatch_states i f s1 s2 ->  Mem.inject f (get_mem1 s1) (get_mem2 s2);
        Injfsim_match_full: forall i f s1 s2, Injmatch_states i f s1 s2 ->  injection_full f (get_mem1 s1);
        Injfsim_match_initial_states:
          forall s1, initial_state L1 s1 ->
                exists i f s2, initial_state L2 s2 /\ Injmatch_states i f s1 s2;
        Injfsim_match_final_states:
          forall i s1 s2 r f,
            Injmatch_states i f s1 s2 -> final_state L1 s1 r -> (final_state L2 s2 r);
        Injfsim_simulation:
          forall s1 t s1' f, Step L1 s1 t s1' ->
                        forall i s2, Injmatch_states i f s1 s2 ->
                                exists i', exists s2' f' t',
                                    (Plus L2 s2 t' s2' \/ (Star L2 s2 t' s2' /\ Injorder i' i))
                                    /\ Injmatch_states i' f' s1' s2' /\
                                    Values.inject_incr f f' /\
                                    inject_trace_strong f' t t';
        Injsim_simulation_atx:
          simulation_atx_inj Injmatch_states;
        Injsim_atx:
            preserves_atx_inj Injmatch_states;
        Injfsim_public_preserved:
          forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id
      }.

        Definition simulation_atx_inj_relaxed {index:Type} {L1 L2}
               (match_states: index -> meminj -> _ -> _ -> Prop)
      :=
        forall s1 f args,
          @at_external L1 s1 = Some (f,args) ->
          forall t s1', Step L1 s1 t s1' ->
                   forall i f s2, match_states i f s1 s2 ->
                             exists f',
                               Values.inject_incr f f' /\
                               (exists i' s2' t',
                                   Step L2 s2 t' s2' /\
                                   match_states i' f' s1' s2' /\
                                   inject_trace_strong f' t t') /\
                               forall t',
                                 inject_trace f' t t' ->
                                 exists i', exists s2',
                                     Step L2 s2 t' s2' /\
                                     match_states i' f' s1' s2'.

        Record fsim_properties_inj_relaxed: Type :=
      {  InjindexX: Type;
        InjorderX: InjindexX -> InjindexX -> Prop;
        Injmatch_statesX: InjindexX -> meminj -> state L1 -> state L2 -> Prop;
        Injfsim_order_wfX: well_founded InjorderX;
        Injfsim_match_meminjX: forall i f s1 s2, Injmatch_statesX i f s1 s2 ->  Mem.inject f (get_mem1 s1) (get_mem2 s2);
        Injfsim_match_fullX: forall i f s1 s2, Injmatch_statesX i f s1 s2 ->  injection_full f (get_mem1 s1);
        Injfsim_match_initial_statesX:
          forall s1, initial_state L1 s1 ->
                exists i f s2, initial_state L2 s2 /\ Injmatch_statesX i f s1 s2;
        Injfsim_match_final_statesX:
          forall i s1 s2 r f,
            Injmatch_statesX i f s1 s2 -> final_state L1 s1 r -> (final_state L2 s2 r);
        Injfsim_simulationX:
          forall s1 t s1' f, Step L1 s1 t s1' ->
                        forall i s2, Injmatch_statesX i f s1 s2 ->
                                exists i', exists s2' f' t',
                                    (Plus L2 s2 t' s2' \/ (Star L2 s2 t' s2' /\ InjorderX i' i))
                                    /\ Injmatch_statesX i' f' s1' s2' /\
                                    Values.inject_incr f f' /\
                                    inject_trace f' t t';
        Injsim_simulation_atxX:
          simulation_atx_inj_relaxed Injmatch_statesX;
        Injsim_atxX:
          preserves_atx_inj Injmatch_statesX;
        Injfsim_public_preservedX:
          forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id
      }.

   (** An alternate form of the simulation diagram *)

    Lemma Injfsim_simulation':
        forall (SIM:fsim_properties_inj),
        forall i s1 t s1' f,
          Step L1 s1 t s1' ->
          forall s2, Injmatch_states SIM i f s1 s2 ->
                (exists i', exists s2' f' t',
                      Plus L2 s2 t' s2' /\
                      Injmatch_states SIM i' f' s1' s2'
                      /\ inject_incr f f' /\ inject_trace_strong f' t t')
                \/ (exists i' f', Injorder SIM i' i /\ t = E0 /\ Injmatch_states SIM i' f' s1' s2
                  /\ inject_incr f f').
    Proof.
      intros. exploit Injfsim_simulation; eauto.
      intros [i' [s2' [f' [t'[A [B [C D]]]]]]]. intuition.
      left; exists i'; exists s2'; auto. exists f', t'; eauto.
      inv H2. inversion D; subst.
      right; exists i'; eauto.
      left; exists i'; exists s2',f', (t1 ** t2); split; auto. econstructor; eauto.
    Qed.

    (** *Star version of simulation*)
    Lemma Injsimulation_star:
        forall (SIM:fsim_properties_inj),
      forall s1 t s1', Star L1 s1 t s1' ->
                  forall i f s2,
                    Injmatch_states SIM i f s1 s2 ->
                    exists i' f', exists s2' t', Star L2 s2 t' s2' /\ Injmatch_states SIM i' f' s1' s2'
                                       /\ inject_incr f f' /\ inject_trace f' t t'.
    Proof.
      intros S.
      induction 1; intros.
      exists i, f; exists s2 , nil; split; auto. apply star_refl.
      split; auto; constructor.
      apply inject_incr_refl. constructor.
      exploit Injfsim_simulation; eauto.
      intros [i' [s2' [f'[t' [A [B [C D]]]]]]].
      exploit IHstar; eauto. intros [i'' [f'' [s2'' [t'' [E [F [G HH]]]]]]].
      exists i'';exists f''; exists s2'', (t' ** t''); split; auto. eapply star_trans; eauto.
      intuition auto. apply plus_star; auto.
      split; auto. subst t.
      split; auto.
      eapply inject_incr_trans; eauto.
      admit. (*inject trace properties*)
    Admitted.

    (** *Plus version of simulation*)
    Lemma Injsimulation_plus:
      forall (SIM:fsim_properties_inj),
      forall s1 t s1', Plus L1 s1 t s1' ->
                  forall i f s2, Injmatch_states SIM i f s1 s2 ->
            (exists i', exists f', exists s2' t', Plus L2 s2 t' s2' /\ Injmatch_states SIM i' f' s1' s2'
            /\ inject_incr f f' /\ inject_trace_strong f' t t')
            \/ (exists i', exists f', clos_trans _ (Injorder SIM) i' i /\ t = E0 /\ Injmatch_states SIM i' f' s1' s2
                           /\ inject_incr f f').
    Proof.
      intros S.
      induction 1 using plus_ind2; intros.
      (* base case *)
      exploit Injfsim_simulation'; eauto.
      intros [[i' [s2' [f' [t' [A [B [C D]]]]]]] | [i' [f' [t' A]]]].
      left. exists i', f', s2', t'; auto.
      right; exists i', f' ; intuition.
      (* inductive case *)
      exploit Injfsim_simulation'; eauto.
      intros [[i' [s2' [f' [t' [A [B [C D]]]]]]] | [i' [f' [A [B [C D]]]]]].
      exploit Injsimulation_star; eauto. apply plus_star; eauto. eauto.
      intros [i'' [f'' [s2'' [t'' [P [Q [R SS]]]]]]].
      left; exists i''; exists f''; exists s2'', (t'**t''); split; auto. eapply plus_star_trans; eauto.
      repeat split; auto.
      eapply inject_incr_trans; eauto.
      subst t.
      admit. (*Some properties about inject_trace_strong*)

      exploit IHplus; eauto.
      intros [[i'' [f'' [s2'' [t' [P [Q [R SS]]]]]]] | [i'' [f'' [P [Q R]]]]].
      subst. simpl. left; exists i''; exists f''; exists s2'', (t'); auto.
      repeat split; eauto.
      eapply inject_incr_trans; eauto.
      subst. simpl. right; exists i''; exists f''; intuition auto.
      eapply t_trans; eauto. eapply t_step; eauto.
      eapply inject_incr_trans; eauto.
    Admitted.

    Lemma Injsimulation_plus_relaxed:
      forall (SIM:fsim_properties_inj_relaxed),
      forall s1 t s1', Plus L1 s1 t s1' ->
                  forall i f s2, Injmatch_statesX SIM i f s1 s2 ->
                  (exists i', exists f', exists s2' t',
                          Plus L2 s2 t' s2' /\ Injmatch_statesX SIM i' f' s1' s2'
                          /\ inject_incr f f' /\ inject_trace f' t t')
                  \/ (exists i', exists f',
                          clos_trans _ (InjorderX SIM) i' i /\ t = E0 /\
                          Injmatch_statesX SIM i' f' s1' s2 /\ inject_incr f f').
      Admitted.

  End Injection.
End ExposingMemory.

(*
Section InductiveDefinitions.

  Variables L1 L2: semantics.
  Variable get_mem1: state L1 -> mem.
  Variable get_mem2: state L2 -> mem.

Arguments fsim_properties_eq: clear implicits.

Inductive forward_equality: Prop :=
  Forward_equality (index: Type)
                   (order: index -> index -> Prop)
                   (match_states: index -> state L1 -> state L2 -> Prop)
                   (props: fsim_properties_eq
                             L1 L2 get_mem1 get_mem2
                             index order match_states).

Arguments fsim_properties_ext: clear implicits.

Inductive forward_extension: Prop :=
  Forward_extension (index: Type)
                   (order: index -> index -> Prop)
                   (match_states: index -> state L1 -> state L2 -> Prop)
                   (props: fsim_properties_ext
                             L1 L2 get_mem1 get_mem2
                             index order match_states).

Lemma EqEx_sim: forward_equality -> forward_extension.
Proof.
  intros H; inv H.
  apply EqEx_sim' in props; econstructor; eauto.
Qed.

Arguments fsim_properties_inj: clear implicits.

Inductive forward_injection: Prop :=
  Forward_injection (index: Type)
                   (order: index -> index -> Prop)
                   (match_states: index -> meminj -> state L1 -> state L2 -> Prop)
                   (props: fsim_properties_inj
                             L1 L2 get_mem1 get_mem2
                             index order match_states).

End InductiveDefinitions. *)

Section Composition.

  Variables L1 L2 L3: semantics.
  Variable get_mem1: state L1 -> mem.
  Variable get_mem2: state L2 -> mem.
  Variable get_mem3: state L3 -> mem.

  Lemma injection_extension_composition:
    @fsim_properties_inj L1 L2 get_mem1 get_mem2 ->
    @fsim_properties_ext L2 L3 get_mem2 get_mem3 ->
    @fsim_properties_inj L1 L3 get_mem1 get_mem3.
  Proof.
    intros SIM12 SIM23.
    set (index13:= (Extindex SIM23 * Injindex SIM12)%type).
    set (order13:=  (lex_ord (clos_trans _ (Extorder SIM23)) (Injorder SIM12))).
    set (match_states13:=
           (fun (i: _ ) f (s1: state L1) (s3: state L3) =>
              exists s2, Injmatch_states SIM12 (snd i) f s1 s2 /\ Extmatch_states SIM23 (fst i) s2 s3) ).
    eapply Build_fsim_properties_inj with (Injindex:= index13) (Injorder:=order13) (Injmatch_states:=match_states13).
- (* well founded *)
  apply wf_lex_ord. apply wf_clos_trans.
  eapply Extfsim_order_wf; eauto. eapply Injfsim_order_wf; eauto.
- (* inject. *)
  intros ? ? ? ? [s2' [MATCH12 MATCH23]].
  eapply Mem.inject_extends_compose; [eapply SIM12| eapply SIM23]; eauto.
- (* Full *)
  intros ? ? ? ? [s2' [MATCH12 MATCH23]] b VALID.
  eapply SIM12; eauto.
- (* initial states *)
  intros. exploit (Injfsim_match_initial_states SIM12); eauto. intros [i [ f [s2 [A B]]]].
  exploit (Extfsim_match_initial_states SIM23); eauto. intros [i' [s3 [C D]]].
  exists (i', i); exists f; exists s3; split; auto. exists s2; auto.
- (* final states *)
  intros. destruct H as [s3 [A B]].
  eapply (Extfsim_match_final_states SIM23); eauto.
  eapply (Injfsim_match_final_states SIM12); eauto.
- (* simulation *)
    intros. destruct H0 as [s3 [A B]]. destruct i as [i2 i1]; simpl in *.
  exploit (Injfsim_simulation' SIM12); eauto.
  intros [[i1' [s3'[ f' [t' [C [D [E F]]]]]]] | [i1' [f' [C [D [E F]]]]]].
  + (* L2 makes one or several steps. *)
    exploit Extsimulation_plus; eauto. intros [[i2' [s2' [P Q]]] | [i2' [P [Q R]]]].
* (* L3 makes one or several steps *)
  exists (i2', i1'); exists s2'; exists f', t'. repeat (split; auto).
  exists s3'; auto.
* (* L3 makes no step *)
  exists (i2', i1'); exists s2; exists f', t'. repeat (split; auto).
  right; split. subst t'; apply star_refl. left. auto.
  exists s3'; auto.
+ (* L2 makes no step *)
  exists (i2, i1'); exists s2; exists f', t. repeat (split; auto).
  right; split. subst t; apply star_refl. right. auto.
  exists s3; auto.
  subst t; constructor.
- (*simulation at_external*)
  unfold simulation_atx_inj; intros.
  destruct H1 as [s3 [A B]]. destruct i as [i2 i1]; simpl in *.
  exploit (Injsim_simulation_atx SIM12); eauto.
  intros [i1' [s2'[ f' [t' [C [D [E F]]]]]]].
  eapply Injsim_atx in H; eauto.
  destruct H as (?&?&?).
  exploit (Extfsim_simulation_atx); eauto.
  intros [i2' [s3' [P Q]]].
  exists (i2', i1'); exists s3'; exists f', t'. repeat (split; auto).
  exists s2'; auto.

- (*match_states preserves at_external *)
  unfold preserves_atx_inj; intros.
  destruct H as (?&?&?).
  assert (Hat_ext:=H0).
  eapply Injsim_atx in H0; try apply H.
  destruct H0 as (args'&Hatx&Hinj).
  eapply Extfsim_atx in Hatx; eauto.
  destruct Hatx as (args''&Hatx''&Hless_def).

  exists args''. split; auto.
  Lemma list_val_inject_lessdef_compose
     : forall (f : meminj) (v1 v2 v3 : list val),
      Val.inject_list f v1 v2 -> Val.lessdef_list v2 v3 -> Val.inject_list f v1 v3.
  Proof.
    induction v1; intros.
    - inversion H; subst; inversion H0. constructor.
    - inversion H; subst; inversion H0; subst.
      constructor; auto.
      eapply Mem.val_inject_lessdef_compose; eauto.
      eapply IHv1; eauto.
  Qed.

  eapply list_val_inject_lessdef_compose; eauto.

- (* symbols *)
  intros. transitivity (Senv.public_symbol (symbolenv L2) id);
            [eapply Extfsim_public_preserved|eapply Injfsim_public_preserved]; eauto.
  Qed.

  (*
  Lemma injection_extension_composition:
    forward_injection L1 L2 get_mem1 get_mem2 ->
    forward_extension L2 L3 get_mem2 get_mem3 ->
    forward_injection L1 L3 get_mem1 get_mem3.
  Proof.
    intros S12 S23.
    inv S12; inv S23.
    econstructor.
    eapply injection_extension_composition'; eauto.
  Qed. *)

    Lemma extension_injection_composition:
    @fsim_properties_ext L1 L2 get_mem1 get_mem2 ->
    @fsim_properties_inj L2 L3 get_mem2 get_mem3 ->
    @fsim_properties_inj L1 L3 get_mem1 get_mem3.
  Proof.
    intros SIM12 SIM23.
    set (index13:= (Injindex SIM23 * Extindex SIM12)%type).
    set (order13:=  (lex_ord (clos_trans _ (Injorder SIM23)) (Extorder SIM12))).
    set (match_states13:=
           (fun (i: _ ) f (s1: state L1) (s3: state L3) =>
              exists s2, Extmatch_states SIM12 (snd i) s1 s2 /\ Injmatch_states SIM23 (fst i) f s2 s3) ).

    eapply Build_fsim_properties_inj with (Injindex:= index13) (Injorder:=order13) (Injmatch_states:=match_states13).
- (* well founded *)
  apply wf_lex_ord. apply wf_clos_trans.
  eapply Injfsim_order_wf; eauto. eapply Extfsim_order_wf; eauto.
- (* inject. *)
  intros ? ? ? ? [s2' [MATCH12 MATCH23]].
  eapply Mem.extends_inject_compose; [eapply SIM12| eapply SIM23]; eauto.
- (* Full *)
  intros ? ? ? ? [s2' [MATCH12 MATCH23]] b VALID.
  eapply SIM23; eauto.
  eapply Extfsim_match_meminj in MATCH12; eauto.
  inv MATCH12. unfold Mem.valid_block; rewrite <- mext_next; auto.

- (* initial states *)
  intros. exploit (Extfsim_match_initial_states SIM12); eauto. intros [i [s2 [A B]]].
  exploit (Injfsim_match_initial_states SIM23); eauto. intros [i' [f [s3 [C D]]]].
  exists (i', i); exists f; exists s3; split; auto. exists s2; auto.
- (* final states *)
  intros. destruct H as [s3 [A B]].
  eapply (Injfsim_match_final_states SIM23); eauto.
  eapply (Extfsim_match_final_states SIM12); eauto.
- (* simulation *)
    intros. destruct H0 as [s3 [A B]]. destruct i as [i2 i1]; simpl in *.
  exploit (Extfsim_simulation' SIM12); eauto.
  intros [[i1' [s3'[C D ]]] | [i1' [C [D E]]]].
  + (* L2 makes one or several steps. *)
    exploit Injsimulation_plus; eauto.
    intros [[i2' [f' [s2' [t' [P [Q [? ?]]]]]]] | [i2' [f' [P [Q [R ?]]]]]].
* (* L3 makes one or several steps *)
  exists (i2', i1'); exists s2'; exists f', t'. repeat (split; auto).
  exists s3'; repeat (split; auto).
* (* L3 makes no step *)
  exists (i2', i1'); exists s2; exists f', t. repeat (split; auto).
  right; split. subst t; apply star_refl. left. auto.
  exists s3'; (split; auto).
  subst t; constructor.
+ (* L2 makes no step *)
  exists (i2, i1'); exists s2; exists f, t. repeat (split; auto).
  right; split. subst t; apply star_refl. right. auto.
  exists s3; auto.
  subst t; constructor.
- (*simulation at_external*)
  unfold simulation_atx_inj; intros.
  destruct H1 as [s3 [A B]]. destruct i as [i2 i1]; simpl in *.
  exploit (Extfsim_simulation_atx); eauto.
  intros [i1' [s2' [P Q]]].
  eapply Extfsim_atx in H; eauto.
  destruct H as (args'&Hatx2&Hlessdef).
  exploit (Injsim_simulation_atx SIM23); eauto.
  intros [i2' [s3'[ f' [t' [C [D [E F]]]]]]].
  exists (i2', i1'); exists s3'; exists f', t'. repeat (split; auto).
  exists s2'; auto.
- (*match_states preserves at_external *)
  unfold preserves_atx_inj; intros.
  destruct H as (?&?&?).
  eapply Extfsim_atx in H0; eauto.
  destruct H0 as (args2&Hatx2&Hlessdef2).
  eapply Injsim_atx in Hatx2; eauto.
  destruct Hatx2 as (args3&Hatx3&Hlessdef3).
  exists args3; split; eauto.
  Lemma list_lessdef_val_inject_compose
     : forall (f : meminj) (v1 v2 v3 : list val),
      Val.lessdef_list v1 v2 ->  Val.inject_list f v2 v3 -> Val.inject_list f v1 v3.
  Proof.
    induction v1; intros.
    - inversion H; subst; inversion H0. constructor.
    - inversion H; subst; inversion H0; subst.
      constructor; auto.
      eapply Mem.val_lessdef_inject_compose; eauto.
      eapply IHv1; eauto.
  Qed.
  eapply list_lessdef_val_inject_compose; eauto.
- (* symbols *)
  intros. transitivity (Senv.public_symbol (symbolenv L2) id);
            [eapply Injfsim_public_preserved|eapply Extfsim_public_preserved]; eauto.
  Qed.

 (* Lemma extension_injection_composition:
    forward_extension L1 L2 get_mem1 get_mem2 ->
    forward_injection L2 L3 get_mem2 get_mem3 ->
    forward_injection L1 L3 get_mem1 get_mem3.
  Proof.
    intros S12 S23.
    inv S12; inv S23.
    econstructor.
    eapply extension_injection_composition'; eauto.
  Qed. *)

  Lemma compose_inject_incr: forall f1 f2 f1' f2',
      inject_incr f1 f1' ->
      inject_incr f2 f2' ->
      inject_incr (compose_meminj f1 f2) (compose_meminj f1' f2').
  Proof.
    intros.
    unfold compose_meminj;
              intros b b' ofs AA.
    destruct (f1 b) eqn:F1; try solve[inv AA]; destruct p.
    eapply H in F1. rewrite F1.
    destruct (f2 b0) eqn:F2; inv AA; destruct p.
    eapply H0 in F2.
    rewrite F2.
    reflexivity.
  Qed.

  Lemma inject_trace_strong_trans:
    forall f12 f23 t1 t2 t3,
      inject_trace_strong f12 t1 t2 ->
      inject_trace_strong f23 t2 t3 ->
      inject_trace_strong (compose_meminj f12 f23) t1 t3.
  Proof.
  Admitted.

  Lemma inject_trace_compose:
    forall f12 f23 t1 t2 t3,
      inject_trace f12 t1 t2 ->
      inject_trace f23 t2 t3 ->
      inject_trace (compose_meminj f12 f23) t1 t3.
  Proof.
  Admitted.

  Lemma injection_injection_composition:
    @fsim_properties_inj L1 L2 get_mem1 get_mem2->
    @fsim_properties_inj L2 L3 get_mem2 get_mem3 ->
    @fsim_properties_inj L1 L3 get_mem1 get_mem3.

    intros SIM12 SIM23.
    set (index13:= (Injindex SIM23 * Injindex SIM12)%type).
    set (order13:=  (lex_ord (clos_trans _ (Injorder SIM23)) (Injorder SIM12))).
    set (match_states13:=
           (fun (i: _ ) f (s1: state L1) (s3: state L3) =>
              exists s2 f12 f23,  Injmatch_states SIM12 (snd i) f12 s1 s2 /\ Injmatch_states SIM23 (fst i) f23 s2 s3
        /\ f = compose_meminj f12 f23)).
    eapply Build_fsim_properties_inj with (Injindex:= index13) (Injorder:=order13) (Injmatch_states:=match_states13).
- (* well founded *)
  apply wf_lex_ord. apply wf_clos_trans.
  eapply Injfsim_order_wf; eauto. eapply Injfsim_order_wf; eauto.
- (* inject. *)
  intros ? ? ? ? [s2' [f12 [f23 [MATCH12 [MATCH23 INJCOMP]]]]].
  subst.
  eapply Mem.inject_compose; [eapply SIM12| eapply SIM23]; eauto.
- (* Full *)
  intros ? ? ? s3 [s2 [f12 [f23 [MATCH12 [MATCH23 INJCOMP]]]]] b VALID.
  subst f.
  eapply SIM12 in VALID; try (exact MATCH12).
  destruct (f12 b) eqn:F12; auto. destruct p.
  unfold compose_meminj; rewrite F12.
  assert (VALID2 : Mem.valid_block (get_mem2 s2) b0).
  { eapply SIM12; eauto. }
  eapply SIM23 in VALID2; try (exact MATCH23).
  intros HH. apply VALID2. destruct (f23 b0); inversion HH; auto.
  destruct p. inversion HH.
- (* initial states *)
  intros. exploit (Injfsim_match_initial_states SIM12); eauto.
  intros [i [ f12 [s2 [A B]]]].
  exploit (Injfsim_match_initial_states SIM23); eauto. intros [i' [f23 [s3 [C D]]]].
  exists (i', i); exists (compose_meminj f12 f23); exists s3; split; auto. exists s2; auto.
  exists f12, f23; repeat (split; auto).
- (* final states *)
  intros. destruct H as [s3 [ f12 [ f23 [A [B C]]]]].
  eapply (Injfsim_match_final_states SIM23); eauto.
  eapply (Injfsim_match_final_states SIM12); eauto.
- (* simulation *)
  intros. destruct H0 as [s3 [f12 [f23 [A [B C]]]]].
  destruct i as [i2 i1]; simpl in *.
  exploit (Injfsim_simulation' SIM12); eauto.
  intros [[i1' [s3'[ f' [t' [D [E [F G]]]]]]] | [i1' [f' [D [E [F G]]]]]].
  + (* L2 makes one or several steps. *)
    exploit Injsimulation_plus; eauto.
    intros [[i2' [f'' [s2' [t'' [P [? [? ?]]]]]]] | [i2' [f'' [P [Q [R SS]]]]]].
* (* L3 makes one or several steps *)
  exists (i2', i1').
  exists s2'; exists (compose_meminj f' f''), t''. repeat (split; auto).
  exists s3', f', f''; repeat (split; auto).
  subst f.
  eapply compose_inject_incr; eauto.

  eapply inject_trace_strong_trans; eauto.

* (* L3 makes no step *)
  exists (i2', i1'); exists s2; exists (compose_meminj f' f''), t'. repeat (split; auto).
  right; split. subst t'; apply star_refl. left. auto.
  exists s3', f', f''; auto.
  repeat (split;auto).
  subst f.
  eapply compose_inject_incr; eauto.
  subst t'; inv G. constructor.
+ (* L2 makes no step *)
  exists (i2, i1'); exists s2; exists (compose_meminj f' f23), t. repeat (split; auto).
  right; split. subst t; apply star_refl. right. auto.
  exists s3, f', f23; auto.
  subst f.
  eapply compose_inject_incr; eauto.
  subst t; constructor.
- (*simulation at_external*)
  unfold simulation_atx_inj; intros.
  destruct H1 as [s3 [f12 [f23 [A [B C]]]]]. destruct i as [i2 i1]; simpl in *.

  exploit (Injsim_simulation_atx SIM12); eauto.
  intros [i1' [s2'[ f12' [t2' [? [? [? ?]]]]]]].

  eapply Injsim_atx in H; eauto.
  destruct H as (?&?&?).
  exploit (Injsim_simulation_atx SIM23); eauto.
  intros [i2' [s3'[ f23' [t3' [? [? [? ?]]]]]]].
  exists (i2', i1'); exists s3'; exists (compose_meminj f12' f23'), t3'. repeat (split; auto).
  + exists s2',f12', f23'; auto.
  + subst; eapply compose_inject_incr; auto.
  + subst; eapply inject_trace_strong_trans ; eauto.

- (*match_states preserves at_external *)
  unfold preserves_atx_inj; intros.
  destruct H as (?&?&?&?&?&?).
  eapply Injsim_atx in H0; try eapply H.
  destruct H0 as (?&?&?).
  eapply Injsim_atx in H0; eauto.
  destruct H0 as (args'&Hatx&Hinj).
  exists args'.
  split; eauto.
  Lemma inject_compose_meminj:
    forall v1 v2 v3 j12 j23 j13,
      Val.inject j12 v1 v2 ->
      Val.inject j23 v2 v3 ->
      j13 = compose_meminj j12 j23 ->
      Val.inject j13 v1 v3.
  Proof.
  Admitted.
  Lemma inject_list_compose_meminj:
    forall lv1 lv2 lv3 j12 j23 j13,
      Val.inject_list j12 lv1 lv2 ->
      Val.inject_list j23 lv2 lv3 ->
      j13 = compose_meminj j12 j23 ->
      Val.inject_list j13 lv1 lv3.
  Proof.
    induction lv1.
    - intros. inversion H; subst; inversion H0; constructor.
    - intros. inversion H; subst; inversion H0; subst; constructor.
      + eapply inject_compose_meminj; eauto.
      + eapply IHlv1; eauto.
  Qed.
  eapply inject_list_compose_meminj; eassumption.

- (* symbols *)
  intros. transitivity (Senv.public_symbol (symbolenv L2) id);
            [eapply Injfsim_public_preserved|eapply Injfsim_public_preserved]; eauto.
  Qed.

   Lemma injection_injection_relaxed_composition:
    @fsim_properties_inj L1 L2 get_mem1 get_mem2->
    @fsim_properties_inj_relaxed L2 L3 get_mem2 get_mem3 ->
    @fsim_properties_inj_relaxed L1 L3 get_mem1 get_mem3.
   Proof.
    intros SIM12 SIM23.
    set (index13:= (InjindexX SIM23 * Injindex SIM12)%type).
    set (order13:=  (lex_ord (clos_trans _ (InjorderX SIM23)) (Injorder SIM12))).
    set (match_states13:=
           (fun (i: _ ) f (s1: state L1) (s3: state L3) =>
              exists s2 f12 f23,  Injmatch_states SIM12 (snd i) f12 s1 s2 /\ Injmatch_statesX SIM23 (fst i) f23 s2 s3
        /\ f = compose_meminj f12 f23)).
    eapply Build_fsim_properties_inj_relaxed with (InjindexX:= index13) (InjorderX:=order13) (Injmatch_statesX:=match_states13).
- (* well founded *)
  apply wf_lex_ord. apply wf_clos_trans.
  eapply Injfsim_order_wfX; eauto. eapply Injfsim_order_wf; eauto.
- (* inject. *)
  intros ? ? ? ? [s2' [f12 [f23 [MATCH12 [MATCH23 INJCOMP]]]]].
  subst.
  eapply Mem.inject_compose; [eapply SIM12| eapply SIM23]; eauto.
- (* Full *)
  intros ? ? ? s3 [s2 [f12 [f23 [MATCH12 [MATCH23 INJCOMP]]]]] b VALID.
  subst f.
  eapply SIM12 in VALID; try (exact MATCH12).
  destruct (f12 b) eqn:F12; auto. destruct p.
  unfold compose_meminj; rewrite F12.
  assert (VALID2 : Mem.valid_block (get_mem2 s2) b0).
  { eapply SIM12; eauto. }
  eapply SIM23 in VALID2; try (exact MATCH23).
  intros HH. apply VALID2. destruct (f23 b0); inversion HH; auto.
  destruct p. inversion HH.
- (* initial states *)
  intros. exploit (Injfsim_match_initial_states SIM12); eauto.
  intros [i [ f12 [s2 [A B]]]].
  exploit (Injfsim_match_initial_statesX SIM23); eauto. intros [i' [f23 [s3 [C D]]]].
  exists (i', i); exists (compose_meminj f12 f23); exists s3; split; auto. exists s2; auto.
  exists f12, f23; repeat (split; auto).
- (* final states *)
  intros. destruct H as [s3 [ f12 [ f23 [A [B C]]]]].
  eapply (Injfsim_match_final_statesX SIM23); eauto.
  eapply (Injfsim_match_final_states SIM12); eauto.
- (* simulation *)
  intros. destruct H0 as [s3 [f12 [f23 [A [B C]]]]].
  destruct i as [i2 i1]; simpl in *.
  exploit (Injfsim_simulation' SIM12); eauto.
  intros [[i1' [s3'[ f' [t' [D [E [F G]]]]]]] | [i1' [f' [D [E [F G]]]]]].
  + (* L2 makes one or several steps. *)
    exploit Injsimulation_plus_relaxed; eauto.
    intros [[i2' [f'' [s2' [t'' [P [? [? ?]]]]]]] | [i2' [f'' [P [Q [R SS]]]]]].
  * (* L3 makes one or several steps *)
  exists (i2', i1').
  exists s2'; exists (compose_meminj f' f''), t''. repeat (split; auto).
  exists s3', f', f''; repeat (split; auto).
  subst f.
  eapply compose_inject_incr; eauto.
  eapply inject_trace_strong_compose; eauto.

* (* L3 makes no step *)
  exists (i2', i1'); exists s2; exists (compose_meminj f' f''), t'. repeat (split; auto).
  right; split. subst t'; apply star_refl. left. auto.
  exists s3', f', f''; auto.
  repeat (split;auto).
  subst f.
  eapply compose_inject_incr; eauto.
  subst t'; inv G. constructor.
+ (* L2 makes no step *)
  exists (i2, i1'); exists s2; exists (compose_meminj f' f23), t. repeat (split; auto).
  right; split. subst t; apply star_refl. right. auto.
  exists s3, f', f23; auto.
  subst f.
  eapply compose_inject_incr; eauto.
  subst t; constructor.
- (*simulation at_external *)
  unfold simulation_atx_inj_relaxed; intros.
  destruct H1 as [s3 [f12 [f23 [A [B C]]]]]. destruct i as [i2 i1]; simpl in *.

  exploit (Injsim_simulation_atx SIM12); eauto.
  intros [i1' [s2'[ f12' [t2' [? [? [? ?]]]]]]].

  eapply Injsim_atx in H; eauto.
  destruct H as (?&?&?).
  exploit (Injsim_simulation_atxX SIM23); eauto.
  intros (f23'&Hincr&Hstrong_sim&Hsim23).
  destruct Hstrong_sim as (i2_str&s2_str&t_str&Step_str&Hinj_str&Htrace_str).
  exists (compose_meminj f12' f23').
  repeat split.
  + subst; eapply compose_inject_incr; auto.
  + exists (i2_str, i1'), s2_str, t_str.
    repeat split; eauto.
    * econstructor.
      do 2 eexists.
      repeat split; eauto.
    * eapply inject_trace_strong_trans; eassumption.
  + intros t' Htrace.
    destruct (inject_trace_strong_interpolation Htrace) as (t2&Htrace12&Htrace23).
    assert (t2 = t2') by (eapply inject_trace_strong_determ; eassumption).
    subst t2'.
    destruct (Hsim23 t' Htrace23) as
        [i2' [s3' [? ?]]].
    exists (i2', i1'); exists s3'. repeat (split; auto).
    exists s2',f12', f23'; auto.

- (*match_states preserves at_external *)
  unfold preserves_atx_inj; intros.
  destruct H as (?&?&?&?&?&?).
  eapply Injsim_atx in H0; try eapply H.
  destruct H0 as (?&?&?).
  eapply Injsim_atxX in H0; eauto.
  destruct H0 as (args'&Hatx&Hinj).
  exists args'.
  split; eauto.

  eapply inject_list_compose_meminj; eassumption.

- (* symbols *)
  intros. transitivity (Senv.public_symbol (symbolenv L2) id);
            [eapply Injfsim_public_preservedX|eapply Injfsim_public_preserved]; eauto.
   Qed.

  End Composition.