(* *********************************************************************)
(*                                                                     *)
(*              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.
(*NEW*) Require Import AST.
(*NEW*) Require Import Values.
(*NEW*) Require Import Memory. (* To specify injections*)

Set Implicit Arguments.

(** * Closures of transitions relations *)

Section CLOSURES.

Variable genv: Type.
Variable state: Type.

(** A one-step transition relation has the following signature.
  It is parameterized by a global environment, which does not
  change during the transition.  It relates the initial state
  of the transition with its final state.  The [trace] parameter
  captures the observable events possibly generated during the
  transition. *)

Variable step: state -> trace -> state -> Prop.

(** No transitions: stuck state *)

Definition nostep (s: state) : Prop :=
  forall t s', ~(step s t s').

(** Zero, one or several transitions.  Also known as Kleene closure,
    or reflexive transitive closure. *)

Inductive star : state -> trace -> state -> Prop :=
  | star_refl: forall s,
      star s E0 s
  | star_step: forall s1 t1 s2 t2 s3 t,
      step s1 t1 s2 -> star s2 t2 s3 -> t = t1 ** t2 ->
      star s1 t s3.

Lemma star_one:
  forall s1 t s2, step s1 t s2 -> star s1 t s2.
Proof.
  intros. eapply star_step; eauto. apply star_refl. traceEq.
Qed.

Lemma star_two:
  forall s1 t1 s2 t2 s3 t,
  step s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  star s1 t s3.
Proof.
  intros. eapply star_step; eauto. apply star_one; auto.
Qed.

Lemma star_three:
  forall s1 t1 s2 t2 s3 t3 s4 t,
  step s1 t1 s2 -> step s2 t2 s3 -> step s3 t3 s4 -> t = t1 ** t2 ** t3 ->
  star s1 t s4.
Proof.
  intros. eapply star_step; eauto. eapply star_two; eauto.
Qed.

Lemma star_four:
  forall s1 t1 s2 t2 s3 t3 s4 t4 s5 t,
  step s1 t1 s2 -> step s2 t2 s3 ->
  step s3 t3 s4 -> step s4 t4 s5 -> t = t1 ** t2 ** t3 ** t4 ->
  star s1 t s5.
Proof.
  intros. eapply star_step; eauto. eapply star_three; eauto.
Qed.

Lemma star_trans:
  forall s1 t1 s2, star s1 t1 s2 ->
  forall t2 s3 t, star s2 t2 s3 -> t = t1 ** t2 -> star s1 t s3.
Proof.
  induction 1; intros.
  rewrite H0. simpl. auto.
  eapply star_step; eauto. traceEq.
Qed.

Lemma star_left:
  forall s1 t1 s2 t2 s3 t,
  step s1 t1 s2 -> star s2 t2 s3 -> t = t1 ** t2 ->
  star s1 t s3.
Proof star_step.

Lemma star_right:
  forall s1 t1 s2 t2 s3 t,
  star s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  star s1 t s3.
Proof.
  intros. eapply star_trans. eauto. apply star_one. eauto. auto.
Qed.

Lemma star_E0_ind:
  forall (P: state -> state -> Prop),
  (forall s, P s s) ->
  (forall s1 s2 s3, step s1 E0 s2 -> P s2 s3 -> P s1 s3) ->
  forall s1 s2, star s1 E0 s2 -> P s1 s2.
Proof.
  intros P BASE REC.
  assert (forall s1 t s2, star s1 t s2 -> t = E0 -> P s1 s2).
    induction 1; intros; subst.
    auto.
    destruct (Eapp_E0_inv _ _ H2). subst. eauto.
  eauto.
Qed.

(** One or several transitions.  Also known as the transitive closure. *)

Inductive plus : state -> trace -> state -> Prop :=
  | plus_left: forall s1 t1 s2 t2 s3 t,
      step s1 t1 s2 -> star s2 t2 s3 -> t = t1 ** t2 ->
      plus s1 t s3.

Lemma plus_one:
  forall s1 t s2,
  step s1 t s2 -> plus s1 t s2.
Proof.
  intros. econstructor; eauto. apply star_refl. traceEq.
Qed.

Lemma plus_two:
  forall s1 t1 s2 t2 s3 t,
  step s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  plus s1 t s3.
Proof.
  intros. eapply plus_left; eauto. apply star_one; auto.
Qed.

Lemma plus_three:
  forall s1 t1 s2 t2 s3 t3 s4 t,
  step s1 t1 s2 -> step s2 t2 s3 -> step s3 t3 s4 -> t = t1 ** t2 ** t3 ->
  plus s1 t s4.
Proof.
  intros. eapply plus_left; eauto. eapply star_two; eauto.
Qed.

Lemma plus_four:
  forall s1 t1 s2 t2 s3 t3 s4 t4 s5 t,
  step s1 t1 s2 -> step s2 t2 s3 ->
  step s3 t3 s4 -> step s4 t4 s5 -> t = t1 ** t2 ** t3 ** t4 ->
  plus s1 t s5.
Proof.
  intros. eapply plus_left; eauto. eapply star_three; eauto.
Qed.

Lemma plus_star:
  forall s1 t s2, plus s1 t s2 -> star s1 t s2.
Proof.
  intros. inversion H; subst.
  eapply star_step; eauto.
Qed.

Lemma plus_right:
  forall s1 t1 s2 t2 s3 t,
  star s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  plus s1 t s3.
Proof.
  intros. inversion H; subst. simpl. apply plus_one. auto.
  rewrite Eapp_assoc. eapply plus_left; eauto.
  eapply star_right; eauto.
Qed.

Lemma plus_left':
  forall s1 t1 s2 t2 s3 t,
  step s1 t1 s2 -> plus s2 t2 s3 -> t = t1 ** t2 ->
  plus s1 t s3.
Proof.
  intros. eapply plus_left; eauto. apply plus_star; auto.
Qed.

Lemma plus_right':
  forall s1 t1 s2 t2 s3 t,
  plus s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  plus s1 t s3.
Proof.
  intros. eapply plus_right; eauto. apply plus_star; auto.
Qed.

Lemma plus_star_trans:
  forall s1 t1 s2 t2 s3 t,
  plus s1 t1 s2 -> star s2 t2 s3 -> t = t1 ** t2 -> plus s1 t s3.
Proof.
  intros. inversion H; subst.
  econstructor; eauto. eapply star_trans; eauto.
  traceEq.
Qed.

Lemma star_plus_trans:
  forall s1 t1 s2 t2 s3 t,
  star s1 t1 s2 -> plus s2 t2 s3 -> t = t1 ** t2 -> plus s1 t s3.
Proof.
  intros. inversion H; subst.
  simpl; auto.
  rewrite Eapp_assoc.
  econstructor. eauto. eapply star_trans. eauto.
  apply plus_star. eauto. eauto. auto.
Qed.

Lemma plus_trans:
  forall s1 t1 s2 t2 s3 t,
  plus s1 t1 s2 -> plus s2 t2 s3 -> t = t1 ** t2 -> plus s1 t s3.
Proof.
  intros. eapply plus_star_trans. eauto. apply plus_star. eauto. auto.
Qed.

Lemma plus_inv:
  forall s1 t s2,
  plus s1 t s2 ->
  step s1 t s2 \/ exists s', exists t1, exists t2, step s1 t1 s' /\ plus s' t2 s2 /\ t = t1 ** t2.
Proof.
  intros. inversion H; subst. inversion H1; subst.
  left. rewrite E0_right. auto.
  right. exists s3; exists t1; exists (t0 ** t3); split. auto.
  split. econstructor; eauto. auto.
Qed.

Lemma star_inv:
  forall s1 t s2,
  star s1 t s2 ->
  (s2 = s1 /\ t = E0) \/ plus s1 t s2.
Proof.
  intros. inv H. left; auto. right; econstructor; eauto.
Qed.

Lemma plus_ind2:
  forall (P: state -> trace -> state -> Prop),
  (forall s1 t s2, step s1 t s2 -> P s1 t s2) ->
  (forall s1 t1 s2 t2 s3 t,
   step s1 t1 s2 -> plus s2 t2 s3 -> P s2 t2 s3 -> t = t1 ** t2 ->
   P s1 t s3) ->
  forall s1 t s2, plus s1 t s2 -> P s1 t s2.
Proof.
  intros P BASE IND.
  assert (forall s1 t s2, star s1 t s2 ->
         forall s0 t0, step s0 t0 s1 ->
         P s0 (t0 ** t) s2).
  induction 1; intros.
  rewrite E0_right. apply BASE; auto.
  eapply IND. eauto. econstructor; eauto. subst t. eapply IHstar; eauto. auto.

  intros. inv H0. eauto.
Qed.

Lemma plus_E0_ind:
  forall (P: state -> state -> Prop),
  (forall s1 s2 s3, step s1 E0 s2 -> star s2 E0 s3 -> P s1 s3) ->
  forall s1 s2, plus s1 E0 s2 -> P s1 s2.
Proof.
  intros. inv H0. exploit Eapp_E0_inv; eauto. intros [A B]; subst. eauto.
Qed.

(** Counted sequences of transitions *)

Inductive starN : nat -> state -> trace -> state -> Prop :=
  | starN_refl: forall s,
      starN O s E0 s
  | starN_step: forall n s t t1 s' t2 s'',
      step s t1 s' -> starN n s' t2 s'' -> t = t1 ** t2 ->
      starN (S n) s t s''.

Remark starN_star:
  forall n s t s', starN n s t s' -> star s t s'.
Proof.
  induction 1; econstructor; eauto.
Qed.

Remark star_starN:
  forall s t s', star s t s' -> exists n, starN n s t s'.
Proof.
  induction 1.
  exists O; constructor.
  destruct IHstar as [n P]. exists (S n); econstructor; eauto.
Qed.

(** Infinitely many transitions *)

CoInductive forever : state -> traceinf -> Prop :=
  | forever_intro: forall s1 t s2 T,
      step s1 t s2 -> forever s2 T ->
      forever s1 (t *** T).

Lemma star_forever:
  forall s1 t s2, star s1 t s2 ->
  forall T, forever s2 T ->
  forever s1 (t *** T).
Proof.
  induction 1; intros. simpl. auto.
  subst t. rewrite Eappinf_assoc.
  econstructor; eauto.
Qed.

(** An alternate, equivalent definition of [forever] that is useful
    for coinductive reasoning. *)

Variable A: Type.
Variable order: A -> A -> Prop.

CoInductive forever_N : A -> state -> traceinf -> Prop :=
  | forever_N_star: forall s1 t s2 a1 a2 T1 T2,
      star s1 t s2 ->
      order a2 a1 ->
      forever_N a2 s2 T2 ->
      T1 = t *** T2 ->
      forever_N a1 s1 T1
  | forever_N_plus: forall s1 t s2 a1 a2 T1 T2,
      plus s1 t s2 ->
      forever_N a2 s2 T2 ->
      T1 = t *** T2 ->
      forever_N a1 s1 T1.

Hypothesis order_wf: well_founded order.

Lemma forever_N_inv:
  forall a s T,
  forever_N a s T ->
  exists t, exists s', exists a', exists T',
  step s t s' /\ forever_N a' s' T' /\ T = t *** T'.
Proof.
  intros a0. pattern a0. apply (well_founded_ind order_wf).
  intros. inv H0.
  (* star case *)
  inv H1.
  (* no transition *)
  change (E0 *** T2) with T2. apply H with a2. auto. auto.
  (* at least one transition *)
  exists t1; exists s0; exists x; exists (t2 *** T2).
  split. auto. split. eapply forever_N_star; eauto.
  apply Eappinf_assoc.
  (* plus case *)
  inv H1.
  exists t1; exists s0; exists a2; exists (t2 *** T2).
  split. auto.
  split. inv H3. auto.
  eapply forever_N_plus. econstructor; eauto. eauto. auto.
  apply Eappinf_assoc.
Qed.

Lemma forever_N_forever:
  forall a s T, forever_N a s T -> forever s T.
Proof.
  cofix COINDHYP; intros.
  destruct (forever_N_inv H) as [t [s' [a' [T' [P [Q R]]]]]].
  rewrite R. apply forever_intro with s'. auto.
  apply COINDHYP with a'; auto.
Qed.

(** Yet another alternative definition of [forever]. *)

CoInductive forever_plus : state -> traceinf -> Prop :=
  | forever_plus_intro: forall s1 t s2 T1 T2,
      plus s1 t s2 ->
      forever_plus s2 T2 ->
      T1 = t *** T2 ->
      forever_plus s1 T1.

Lemma forever_plus_inv:
  forall s T,
  forever_plus s T ->
  exists s', exists t, exists T',
  step s t s' /\ forever_plus s' T' /\ T = t *** T'.
Proof.
  intros. inv H. inv H0. exists s0; exists t1; exists (t2 *** T2).
  split. auto.
  split. exploit star_inv; eauto. intros [[P Q] | R].
    subst. simpl. auto. econstructor; eauto.
  traceEq.
Qed.

Lemma forever_plus_forever:
  forall s T, forever_plus s T -> forever s T.
Proof.
  cofix COINDHYP; intros.
  destruct (forever_plus_inv H) as [s' [t [T' [P [Q R]]]]].
  subst. econstructor; eauto.
Qed.

(** Infinitely many silent transitions *)

CoInductive forever_silent : state -> Prop :=
  | forever_silent_intro: forall s1 s2,
      step s1 E0 s2 -> forever_silent s2 ->
      forever_silent s1.

(** An alternate definition. *)

CoInductive forever_silent_N : A -> state -> Prop :=
  | forever_silent_N_star: forall s1 s2 a1 a2,
      star s1 E0 s2 ->
      order a2 a1 ->
      forever_silent_N a2 s2 ->
      forever_silent_N a1 s1
  | forever_silent_N_plus: forall s1 s2 a1 a2,
      plus s1 E0 s2 ->
      forever_silent_N a2 s2 ->
      forever_silent_N a1 s1.

Lemma forever_silent_N_inv:
  forall a s,
  forever_silent_N a s ->
  exists s', exists a',
  step s E0 s' /\ forever_silent_N a' s'.
Proof.
  intros a0. pattern a0. apply (well_founded_ind order_wf).
  intros. inv H0.
  (* star case *)
  inv H1.
  (* no transition *)
  apply H with a2. auto. auto.
  (* at least one transition *)
  exploit Eapp_E0_inv; eauto. intros [P Q]. subst.
  exists s0; exists x.
  split. auto. eapply forever_silent_N_star; eauto.
  (* plus case *)
  inv H1. exploit Eapp_E0_inv; eauto. intros [P Q]. subst.
  exists s0; exists a2.
  split. auto. inv H3. auto.
  eapply forever_silent_N_plus. econstructor; eauto. eauto.
Qed.

Lemma forever_silent_N_forever:
  forall a s, forever_silent_N a s -> forever_silent s.
Proof.
  cofix COINDHYP; intros.
  destruct (forever_silent_N_inv H) as [s' [a' [P Q]]].
  apply forever_silent_intro with s'. auto.
  apply COINDHYP with a'; auto.
Qed.

(** Infinitely many non-silent transitions *)

CoInductive forever_reactive : state -> traceinf -> Prop :=
  | forever_reactive_intro: forall s1 s2 t T,
      star s1 t s2 -> t <> E0 -> forever_reactive s2 T ->
      forever_reactive s1 (t *** T).

Lemma star_forever_reactive:
  forall s1 t s2 T,
  star s1 t s2 -> forever_reactive s2 T ->
  forever_reactive s1 (t *** T).
Proof.
  intros. inv H0. rewrite <- Eappinf_assoc. econstructor.
  eapply star_trans; eauto.
  red; intro. exploit Eapp_E0_inv; eauto. intros [P Q]. contradiction.
  auto.
Qed.

End CLOSURES.

(** * Transition semantics *)

(** The general form of a transition semantics. *)

Record part_semantics : Type :=
  {
  state: Type;
  genvtype: Type;
  get_mem: state -> Memory.mem;
  set_mem: state -> Memory.mem -> state;
  step : state -> trace -> state -> Prop;
  entry_point: Memory.mem -> state -> val -> list val -> Prop;
  at_external : state ->  option (external_function * list val);
  after_external : option val -> state -> Memory.mem -> option state;
  final_state: state -> int -> Prop;
  globalenv: genvtype;
  symbolenv: Senv.t
  (*TODO: External call states must exectue the function in one step*)
  (* Need to see what the hybrid machine needs. *)
  (*external_step_lemma:
    forall g s1 ef args t s2,
      at_external g s1 = Some (ef, args) ->
      step sem g s1 t s2 ->
      exists vr,
        external_call ef (symbolenv sem) args (get_mem s1) t (Val.maketotal vr) (get_mem s2) /\
        after_external g vr (set_mem s1 (get_mem s2)) = Some s2  *)
}.
Arguments get_mem {_} _.
Arguments set_mem {_} _ _.

(* Full semantics are for closed, complete programs. *)
(* It contains a main function and an inital_mem     *)
Record semantics : Type := {
  part_sem:> part_semantics;
  main_block: option block; (*location of main.*)
  init_mem: option Memory.mem
                          }.

(*We can recover initial_states from entry_point *)
Inductive initial_state (sem:semantics): state sem -> Prop :=
| initial_state_derived_intro': forall st0 m0 b,
    init_mem sem = Some m0 ->
    (main_block sem) = Some b ->
  entry_point sem m0 st0 (Vptr b (Ptrofs.zero)) nil ->
  initial_state sem st0.

(** The form used in earlier CompCert versions, for backward compatibility. *)
Definition Semantics {state funtype vartype: Type}
                     (get_mem: state -> Memory.mem)
                     (set_mem: state -> Memory.mem -> state)
                     (step: state -> trace -> state -> Prop)
                     (entry_point: Memory.mem -> state -> val -> list val  -> Prop)
                     (at_external : state -> option (external_function * list val))
                     (after_external : option val -> state -> Memory.mem -> option state)
                     (final_state: state -> int -> Prop)
                     (globalenv: Genv.t funtype vartype)
                     (main_block: option block)
                     (init_mem: option Memory.mem):=
  Build_semantics
  {| state := state;
     genvtype := Genv.t funtype vartype;
     get_mem:= get_mem;
     set_mem:= set_mem;
     step := step;
     entry_point := entry_point;
     at_external := at_external;
     after_external := after_external;
     final_state := final_state;
     globalenv := globalenv;
     symbolenv := Genv.to_senv globalenv |}
  main_block init_mem.

Definition Semantics_gen (state genvtype: Type)
                     (get_mem: state -> Memory.mem)
                     (set_mem: state -> Memory.mem -> state)
                     (step: state -> trace -> state -> Prop)
                     (entry_point: Memory.mem -> state -> val -> list val  -> Prop)
                     (at_external : state ->  option (external_function * list val))
                     (after_external : option val -> state -> Memory.mem -> option state)
                     (final_state: state -> int -> Prop)
                     (globalenv: genvtype)
                     (main_block: option block)
                     (init_mem: option Memory.mem)
                     (symbolenv: Senv.t):=
  Build_semantics
  {| state := state;
     genvtype := genvtype;
     get_mem:= get_mem;
     set_mem:= set_mem;
     step := step;
     entry_point := entry_point;
     at_external := at_external;
     after_external := after_external;
     final_state := final_state;
     globalenv := globalenv;
     symbolenv := symbolenv |}
  main_block init_mem.

(** Handy notations. *)

Notation " 'Step' L " := (step L) (at level 1) : smallstep_scope.
Notation " 'Star' L " := (star (step L)) (at level 1) : smallstep_scope.
Notation " 'Plus' L " := (plus (step L)) (at level 1) : smallstep_scope.
Notation " 'Forever_silent' L " := (forever_silent (step L)) (at level 1) : smallstep_scope.
Notation " 'Forever_reactive' L " := (forever_reactive (step L)) (at level 1) : smallstep_scope.
Notation " 'Nostep' L " := (nostep (step L)) (at level 1) : smallstep_scope.

Open Scope smallstep_scope.

(** * Forward simulations between two transition semantics. *)

(*Following definition mimics *_not_fresh lemmas from common/Globalenvs.v*)
(* genv_next bounds all global blocks *)
(* This should be part of GENV file?   *)
Definition globals_not_fresh {F V} (ge:Genv.t F V) m:=
  Ple (Genv.genv_next ge) (Mem.nextblock m).

 Lemma len_defs_genv_next:
      forall {F1 V1 F2 V2} (p1:AST.program F1 V1) (p2:AST.program F2 V2),
        length (AST.prog_defs p1) =length (AST.prog_defs p2) ->
        Genv.genv_next (Genv.globalenv p1) = Genv.genv_next (Genv.globalenv p2).
    Proof.
      intros. unfold Genv.globalenv.
      do 2 rewrite Genv.genv_next_add_globals.
      remember (Genv.empty_genv F1 V1 (AST.prog_public p1)) as base1.
      remember (Genv.empty_genv F2 V2 (AST.prog_public p2)) as base2.
      replace (Genv.genv_next base1) with (Genv.genv_next base2) by (subst; reflexivity).
      remember (Genv.genv_next base2) as X.
      remember (AST.prog_defs p1) as ls1.
      remember (AST.prog_defs p2) as ls2.
      generalize X ls2 H.
      clear.
      induction ls1.
      - intros; destruct ls2; inversion H; auto.
      - intros. destruct ls2; inversion H; auto.
        simpl. eapply IHls1; auto.
    Qed.

    Lemma globals_not_fresh_preserve:
      forall {F1 V1 F2 V2} (p1:AST.program F1 V1) (p2:AST.program F2 V2),
        length (AST.prog_defs p1) = length (AST.prog_defs p2) ->
        forall m0, globals_not_fresh (Genv.globalenv p1) m0 ->
              globals_not_fresh (Genv.globalenv p2) m0.
    Proof.
      unfold globals_not_fresh; intros until m0.
      erewrite len_defs_genv_next; eauto.
    Qed.

 Section ForwardSimulations.
   Context (L1 L2: semantics).

(** The general form of a forward simulation. *)
(** NEW: I will tolerate the duplication of entry_points/initial_states, while
    we find a better abstraction. *)
Record fsim_properties (index: Type)
          (order: index -> index -> Prop)
          (match_states: index -> state L1 -> state L2 -> Prop) : Prop := {
    fsim_order_wf: well_founded order;
    fsim_match_entry_points:
      forall s1 f arg m0, entry_point L1 m0 s1 f arg  ->
                  exists i, exists s2, entry_point L2 m0 s2 f arg /\ match_states i s1 s2;
    fsim_match_initial_states:
      forall s1, initial_state L1 s1  ->
            exists i, exists s2, initial_state L2 s2 /\ match_states i s1 s2;
    fsim_match_final_states:
      forall i s1 s2 r,
        match_states i s1 s2 -> final_state L1 s1 r -> final_state L2 s2 r;
    fsim_simulation:
      forall s1 t s1', Step L1 s1 t s1' ->
                  forall i s2, match_states i s1 s2 ->
                          exists i', exists s2',
                              (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ order i' i))
                              /\ match_states i' s1' s2';
    fsim_public_preserved:
      forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id
                                                                }.

(*In the case where initial_memories are equal, initial_states follows from entry_points. *)
Lemma init_states_from_entry_index:
  forall (INIT_MEM:
       forall m, init_mem L1 = Some m ->
            init_mem L2 = Some m)
   (INIT_BLOCK: main_block L1 = main_block L2),
    forall index match_states
  (fsim_match_entry_points:
      forall (s1:state L1) f arg m0, entry_point L1 m0 s1 f arg  ->
                     exists i, exists s2, entry_point L2 m0 s2 f arg /\ match_states i s1 s2),
    forall s1, initial_state L1 s1  ->
          exists (i:index), exists s2, initial_state L2 s2 /\ match_states i s1 s2.
Proof.
  intros. inv H. rewrite INIT_BLOCK in *.
  eapply fsim_match_entry_points0 in H2. destruct H2 as (i&s2&init_core&MATCH).
  exists i, s2; split; eauto.
  econstructor; eauto.
Qed.

Lemma init_states_from_entry:
  forall (INIT_MEM:
       forall m, init_mem L1 = Some m ->
            init_mem L2 = Some m)
   (INIT_BLOCK: main_block L1 = main_block L2),
    forall match_states
  (fsim_match_entry_points:
      forall (s1:state L1) f arg m0, entry_point L1 m0 s1 f arg  ->
                     exists s2, entry_point L2 m0 s2 f arg /\ match_states s1 s2),
    forall s1, initial_state L1 s1  ->
          exists s2, initial_state L2 s2 /\ match_states s1 s2.
Proof.
  intros. inv H. rewrite INIT_BLOCK in *.
  eapply fsim_match_entry_points0 in H2. destruct H2 as (s2&init_core&MATCH).
  exists s2; split; eauto.
  econstructor; eauto.
Qed.

 End ForwardSimulations.

Arguments fsim_properties: clear implicits.

Inductive forward_simulation (L1 L2: semantics) : Prop :=
  Forward_simulation (index: Type)
                     (order: index -> index -> Prop)
                     (match_states: index -> state L1 -> state L2 -> Prop)
                     (props: fsim_properties L1 L2 index order match_states).

Arguments Forward_simulation {L1 L2 index} order match_states props.

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

Lemma fsim_simulation':
  forall L1 L2 index order match_states, fsim_properties L1 L2 index order match_states ->
  forall i s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states i s1 s2 ->
  (exists i', exists s2', Plus L2 s2 t s2' /\ match_states i' s1' s2')
  \/ (exists i', order i' i /\ t = E0 /\ match_states i' s1' s2).
Proof.
  intros. exploit fsim_simulation; eauto.
  intros [i' [s2' [A B]]]. intuition.
  left; exists i'; exists s2'; auto.
  inv H3.
  right; exists i'; auto.
  left; exists i'; exists s2'; split; auto. econstructor; eauto.
Qed.

(** ** Forward simulation diagrams. *)

(** Various simulation diagrams that imply forward simulation *)

Section FORWARD_SIMU_DIAGRAMS.

Variable L1: semantics.
Variable L2: semantics.

Hypothesis public_preserved:
  forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id.

Variable match_states: state L1 -> state L2 -> Prop.

Hypothesis match_entry_points:
  forall s1 f arg m0, entry_point L1 m0 s1 f arg  ->
  exists s2, entry_point L2 m0 s2 f arg /\ match_states s1 s2.
Hypothesis match_initial_states:
  forall s1, initial_state L1 s1  ->
  exists s2, initial_state L2 s2 /\ match_states s1 s2.

Hypothesis match_final_states:
  forall s1 s2 r,
  match_states s1 s2 ->
  final_state L1 s1 r ->
  final_state L2 s2 r.

(** Simulation when one transition in the first program
    corresponds to zero, one or several transitions in the second program.
    However, there is no stuttering: infinitely many transitions
    in the source program must correspond to infinitely many
    transitions in the second program. *)

Section SIMULATION_STAR_WF.

(** [order] is a well-founded ordering associated with states
  of the first semantics.  Stuttering steps must correspond
  to states that decrease w.r.t. [order]. *)

Variable order: state L1 -> state L1 -> Prop.
Hypothesis order_wf: well_founded order.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  exists s2',
  (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ order s1' s1))
  /\ match_states s1' s2'.

Lemma forward_simulation_star_wf: forward_simulation L1 L2.
Proof.
  apply Forward_simulation with order (fun idx s1 s2 => idx = s1 /\ match_states s1 s2);
  constructor.
- auto.
- intros. exploit match_entry_points; eauto. intros [s2 [A B]].
  exists s1; exists s2; repeat (split; auto).
- intros. exploit match_initial_states; eauto. intros [s2 [A B]].
  exists s1; exists s2; repeat (split; auto).
- intros. destruct H. eapply match_final_states; eauto.
- intros. destruct H0. subst i. exploit simulation; eauto. intros [s2' [A B]].
  exists s1'; exists s2'; intuition auto.
- auto.
Qed.

Notation match_states':=
  (fun (idx s1 : state L1) (s2 : state L2) => idx = s1 /\ match_states s1 s2).

Lemma fsim_properties_star_wf:
   fsim_properties L1 L2 _ order match_states'.
Proof.
  constructor.
- auto.
- intros. exploit match_entry_points; eauto. intros [s2 [A B]].
    exists s1; exists s2; auto.
- intros. exploit match_initial_states; eauto. intros [s2 [A B]].
    exists s1; exists s2; auto.
- intros. destruct H. eapply match_final_states; eauto.
- intros. destruct H0. subst i. exploit simulation; eauto. intros [s2' [A B]].
  exists s1'; exists s2'; intuition auto.
- auto.
Qed.

End SIMULATION_STAR_WF.

Section SIMULATION_STAR.

(** We now consider the case where we have a nonnegative integer measure
  associated with states of the first semantics.  It must decrease when we take
  a stuttering step. *)

Variable measure: state L1 -> nat.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  (exists s2', Plus L2 s2 t s2' /\ match_states s1' s2')
  \/ (measure s1' < measure s1 /\ t = E0 /\ match_states s1' s2)%nat.

Lemma forward_simulation_star: forward_simulation L1 L2.
Proof.
  apply forward_simulation_star_wf with (ltof _ measure).
  apply well_founded_ltof.
  intros. exploit simulation; eauto. intros [[s2' [A B]] | [A [B C]]].
  exists s2'; auto.
  exists s2; split. right; split. rewrite B. apply star_refl. auto. auto.
Qed.

Lemma fsim_properties_star:
  fsim_properties L1 L2 _ (ltof _ measure)
(fun (idx s1 : state L1) (s2 : state L2) => idx = s1 /\ match_states s1 s2).
Proof.
  apply fsim_properties_star_wf.
  apply well_founded_ltof.
  intros. exploit simulation; eauto. intros [[s2' [A B]] | [A [B C]]].
  exists s2'; auto.
  exists s2; split. right; split. rewrite B. apply star_refl. auto. auto.
Qed.

End SIMULATION_STAR.

(** Simulation when one transition in the first program corresponds
    to one or several transitions in the second program. *)

Section SIMULATION_PLUS.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  exists s2', Plus L2 s2 t s2' /\ match_states s1' s2'.

Lemma forward_simulation_plus: forward_simulation L1 L2.
Proof.
  apply forward_simulation_star with (measure := fun _ => O).
  intros. exploit simulation; eauto.
Qed.

Lemma fsim_properties_plus:
  fsim_properties L1 L2 _ (ltof _ ( fun _ => O))
(fun (idx s1 : state L1) (s2 : state L2) => idx = s1 /\ match_states s1 s2).
Proof.
  apply fsim_properties_star with (measure := fun _ => O).
  intros. exploit simulation; eauto.
Qed.

End SIMULATION_PLUS.

(** Lock-step simulation: each transition in the first semantics
    corresponds to exactly one transition in the second semantics. *)

Section SIMULATION_STEP.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  exists s2', Step L2 s2 t s2' /\ match_states s1' s2'.

Lemma forward_simulation_step: forward_simulation L1 L2.
Proof.
  apply forward_simulation_plus.
  intros. exploit simulation; eauto. intros [s2' [A B]].
  exists s2'; split; auto. apply plus_one; auto.
Qed.

Lemma fsim_properties_step: fsim_properties L1 L2 _ (ltof _ ( fun _ => O))
(fun (idx s1 : state L1) (s2 : state L2) => idx = s1 /\ match_states s1 s2).
Proof.
  apply fsim_properties_plus.
  intros. exploit simulation; eauto. intros [s2' [A B]].
  exists s2'; split; auto. apply plus_one; auto.
Qed.

End SIMULATION_STEP.

(** Simulation when one transition in the first program
    corresponds to zero or one transitions in the second program.
    However, there is no stuttering: infinitely many transitions
    in the source program must correspond to infinitely many
    transitions in the second program. *)

Section SIMULATION_OPT.

Variable measure: state L1 -> nat.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  (exists s2', Step L2 s2 t s2' /\ match_states s1' s2')
  \/ (measure s1' < measure s1 /\ t = E0 /\ match_states s1' s2)%nat.

Lemma forward_simulation_opt: forward_simulation L1 L2.
Proof.
  apply forward_simulation_star with measure.
  intros. exploit simulation; eauto. intros [[s2' [A B]] | [A [B C]]].
  left; exists s2'; split; auto. apply plus_one; auto.
  right; auto.
Qed.

Lemma fsim_properties_opt:
  fsim_properties L1 L2 _ (ltof _ measure)
(fun (idx s1 : state L1) (s2 : state L2) => idx = s1 /\ match_states s1 s2).
Proof.
  apply fsim_properties_star.
  intros. exploit simulation; eauto. intros [[s2' [A B]] | [A [B C]]].
  left; exists s2'; split; auto. apply plus_one; auto.
  right; auto.
Qed.

End SIMULATION_OPT.

End FORWARD_SIMU_DIAGRAMS.

(** ** Forward simulation of transition sequences *)

Section SIMULATION_SEQUENCES.

Context L1 L2 index order match_states (S: fsim_properties L1 L2 index order match_states).

Lemma simulation_star:
  forall s1 t s1', Star L1 s1 t s1' ->
  forall i s2, match_states i s1 s2 ->
  exists i', exists s2', Star L2 s2 t s2' /\ match_states i' s1' s2'.
Proof.
  induction 1; intros.
  exists i; exists s2; split; auto. apply star_refl.
  exploit fsim_simulation; eauto. intros [i' [s2' [A B]]].
  exploit IHstar; eauto. intros [i'' [s2'' [C D]]].
  exists i''; exists s2''; split; auto. eapply star_trans; eauto.
  intuition auto. apply plus_star; auto.
Qed.

Lemma simulation_plus:
  forall s1 t s1', Plus L1 s1 t s1' ->
  forall i s2, match_states i s1 s2 ->
  (exists i', exists s2', Plus L2 s2 t s2' /\ match_states i' s1' s2')
  \/ (exists i', clos_trans _ order i' i /\ t = E0 /\ match_states i' s1' s2).
Proof.
  induction 1 using plus_ind2; intros.
(* base case *)
  exploit fsim_simulation'; eauto. intros [A | [i' A]].
  left; auto.
  right; exists i'; intuition.
(* inductive case *)
  exploit fsim_simulation'; eauto. intros [[i' [s2' [A B]]] | [i' [A [B C]]]].
  exploit simulation_star. apply plus_star; eauto. eauto.
  intros [i'' [s2'' [P Q]]].
  left; exists i''; exists s2''; split; auto. eapply plus_star_trans; eauto.
  exploit IHplus; eauto. intros [[i'' [s2'' [P Q]]] | [i'' [P [Q R]]]].
  subst. simpl. left; exists i''; exists s2''; auto.
  subst. simpl. right; exists i''; intuition auto.
  eapply t_trans; eauto. eapply t_step; eauto.
Qed.

Lemma simulation_forever_silent:
  forall i s1 s2,
  Forever_silent L1 s1 -> match_states i s1 s2 ->
  Forever_silent L2 s2.
Proof.
  assert (forall i s1 s2,
          Forever_silent L1 s1 -> match_states i s1 s2 ->
          forever_silent_N (step L2) order i s2).
    cofix COINDHYP; intros.
    inv H. destruct (fsim_simulation S _ _ _ H1 _ _ H0) as [i' [s2' [A B]]].
    destruct A as [C | [C D]].
    eapply forever_silent_N_plus; eauto.
    eapply forever_silent_N_star; eauto.
  intros. eapply forever_silent_N_forever; eauto. eapply fsim_order_wf; eauto.
Qed.

Lemma simulation_forever_reactive:
  forall i s1 s2 T,
  Forever_reactive L1 s1 T -> match_states i s1 s2 ->
  Forever_reactive L2 s2 T.
Proof.
  cofix COINDHYP; intros.
  inv H.
  edestruct simulation_star as [i' [st2' [A B]]]; eauto.
  econstructor; eauto.
Qed.

End SIMULATION_SEQUENCES.

(** ** Composing two forward simulations *)

Ltac supertransitivity:=
  repeat match goal with
  |[|- ?x = ?y] =>
   match goal with
   | [|- x = x] => reflexivity
   | [ H: x = _ |- _ ] => rewrite H in *; clear H
   | [ H: _ = x |- _ ] => rewrite H in *; clear H
   end
  end.
Lemma compose_forward_simulations:
  forall L1 L2 L3, forward_simulation L1 L2 -> forward_simulation L2 L3 -> forward_simulation L1 L3.
Proof.
  intros L1 L2 L3 S12 S23.
  destruct S12 as [index order match_states props].
  destruct S23 as [index' order' match_states' props'].

  set (ff_index := (index' * index)%type).
  set (ff_order := lex_ord (clos_trans _ order') order).
  set (ff_match_states := fun (i: ff_index) (s1: state L1) (s3: state L3) =>
                             exists s2, match_states (snd i) s1 s2 /\ match_states' (fst i) s2 s3).
  apply Forward_simulation with ff_order ff_match_states; constructor.
- (* well founded *)
  unfold ff_order. apply wf_lex_ord. apply wf_clos_trans.
  eapply fsim_order_wf; eauto. eapply fsim_order_wf; eauto.
- (* initial cores *)
  intros. exploit (fsim_match_entry_points props); eauto. intros [i [s2 [A B]]].
  exploit (fsim_match_entry_points props'); eauto. intros [i' [s3 [C D]]].
  exists (i', i); exists s3; repeat(split; auto).
  supertransitivity.
  exists s2; auto.
- (* initial states *)
  intros. exploit (fsim_match_initial_states props); eauto. intros [i [s2 [A B]]].
  exploit (fsim_match_initial_states props'); eauto. intros [i' [s3 [C D]]].
  exists (i', i); exists s3; repeat(split; auto).
  exists s2; auto.
- (* final states *)
  intros. destruct H as [s3 [A B]].
  eapply (fsim_match_final_states props'); eauto.
  eapply (fsim_match_final_states props); eauto.
- (* simulation *)
  intros. destruct H0 as [s3 [A B]]. destruct i as [i2 i1]; simpl in *.
  exploit (fsim_simulation' props); eauto. intros [[i1' [s3' [C D]]] | [i1' [C [D E]]]].
+ (* L2 makes one or several steps. *)
  exploit simulation_plus; eauto. intros [[i2' [s2' [P Q]]] | [i2' [P [Q R]]]].
* (* L3 makes one or several steps *)
  exists (i2', i1'); exists s2'; split. auto. exists s3'; auto.
* (* L3 makes no step *)
  exists (i2', i1'); exists s2; split.
  right; split. subst t; apply star_refl. red. left. auto.
  exists s3'; auto.
+ (* L2 makes no step *)
  exists (i2, i1'); exists s2; split.
  right; split. subst t; apply star_refl. red. right. auto.
  exists s3; auto.
- (* symbols *)
  intros. transitivity (Senv.public_symbol (symbolenv L2) id); eapply fsim_public_preserved; eauto.
Qed.

(** * Receptiveness and determinacy *)

Definition single_events (L: semantics) : Prop :=
  forall s t s', Step L s t s' -> (length t <= 1)%nat.

Record receptive (L: semantics) : Prop :=
  Receptive {
    sr_receptive: forall s t1 s1 t2,
      Step L s t1 s1 -> match_traces (symbolenv L) t1 t2 -> exists s2, Step L s t2 s2;
    sr_traces:
      single_events L
  }.

Record determinate (L: semantics) : Prop :=
  Determinate {
    sd_determ: forall s t1 s1 t2 s2,
      Step L s t1 s1 -> Step L s t2 s2 ->
      match_traces (symbolenv L) t1 t2 /\ (t1 = t2 -> s1 = s2);
    sd_traces:
      single_events L;
    sd_initial_determ: forall s1 s2 f arg m0,
        entry_point L m0 s1 f arg -> entry_point L m0 s2 f arg ->
        s1 = s2;
    sd_final_nostep: forall s r,
      final_state L s r -> Nostep L s;
    sd_final_determ: forall s r1 r2,
      final_state L s r1 -> final_state L s r2 -> r1 = r2
  }.

Lemma sd_initial_state_determ:
  forall L, determinate L ->
  forall s1 s2, initial_state L s1 -> initial_state L s2 ->
           s1 = s2.
Proof.
  intros. inv H0; inv H1.
  eapply sd_initial_determ; eauto.
  rewrite H3 in H5; inv H5.
  rewrite H2 in H0; inv H0; auto.
Qed.

Section DETERMINACY.

Variable L: semantics.
Hypothesis DET: determinate L.

Lemma sd_determ_1:
  forall s t1 s1 t2 s2,
  Step L s t1 s1 -> Step L s t2 s2 -> match_traces (symbolenv L) t1 t2.
Proof.
  intros. eapply sd_determ; eauto.
Qed.

Lemma sd_determ_2:
  forall s t s1 s2,
  Step L s t s1 -> Step L s t s2 -> s1 = s2.
Proof.
  intros. eapply sd_determ; eauto.
Qed.

Lemma star_determinacy:
  forall s t s', Star L s t s' ->
  forall s'', Star L s t s'' -> Star L s' E0 s'' \/ Star L s'' E0 s'.
Proof.
  induction 1; intros.
  auto.
  inv H2.
  right. eapply star_step; eauto.
  exploit sd_determ_1. eexact H. eexact H3. intros MT.
  exploit (sd_traces DET). eexact H. intros L1.
  exploit (sd_traces DET). eexact H3. intros L2.
  assert (t1 = t0 /\ t2 = t3).
    destruct t1. inv MT. auto.
    destruct t1; simpl in L1; try omegaContradiction.
    destruct t0. inv MT. destruct t0; simpl in L2; try omegaContradiction.
    simpl in H5. split. congruence. congruence.
  destruct H1; subst.
  assert (s2 = s4) by (eapply sd_determ_2; eauto). subst s4.
  auto.
Qed.

End DETERMINACY.

(** * Backward simulations between two transition semantics. *)

Definition safe (L: semantics) (s: state L) : Prop :=
  forall s',
  Star L s E0 s' ->
  (exists r, final_state L s' r)
  \/ (exists t, exists s'', Step L s' t s'').

Lemma star_safe:
  forall (L: semantics) s s',
  Star L s E0 s' -> safe L s -> safe L s'.
Proof.
  intros; red; intros. apply H0. eapply star_trans; eauto.
Qed.

(** The general form of a backward simulation. *)

Record bsim_properties (L1 L2: semantics) (index: Type)
                       (order: index -> index -> Prop)
                       (match_states: index -> state L1 -> state L2 -> Prop) : Prop := {
    bsim_order_wf: well_founded order;
    bsim_entry_points_exist:
      forall s1 f arg m0, entry_point L1 m0 s1 f arg ->
                     exists s2, entry_point L2 m0 s2 f arg;
    bsim_initial_states_exist:
      forall s1, initial_state L1 s1 ->
                     exists s2, initial_state L2 s2;
    bsim_match_entry_points:
      forall s1 s2 f arg m0, entry_point L1 m0 s1 f arg  ->
                  entry_point L2 m0 s2 f arg  ->
                  exists i, exists s1', entry_point L1 m0 s1' f arg /\ match_states i s1' s2;
    bsim_match_initial_states:
      forall s1 s2, initial_state L1 s1  ->
                  initial_state L2 s2  ->
                  exists i, exists s1', initial_state L1 s1' /\ match_states i s1' s2;
    bsim_match_final_states:
      forall i s1 s2 r,
      match_states i s1 s2 -> safe L1 s1 -> final_state L2 s2 r ->
      exists s1', Star L1 s1 E0 s1' /\ final_state L1 s1' r;
    bsim_progress:
      forall i s1 s2,
      match_states i s1 s2 -> safe L1 s1 ->
      (exists r, final_state L2 s2 r) \/
      (exists t, exists s2', Step L2 s2 t s2');
    bsim_simulation:
      forall s2 t s2', Step L2 s2 t s2' ->
      forall i s1, match_states i s1 s2 -> safe L1 s1 ->
      exists i', exists s1',
         (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ order i' i))
      /\ match_states i' s1' s2';
    bsim_public_preserved:
      forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id
  }.

Arguments bsim_properties: clear implicits.

Inductive backward_simulation (L1 L2: semantics) : Prop :=
  Backward_simulation (index: Type)
                      (order: index -> index -> Prop)
                      (match_states: index -> state L1 -> state L2 -> Prop)
                      (props: bsim_properties L1 L2 index order match_states).

Arguments Backward_simulation {L1 L2 index} order match_states props.

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

Lemma bsim_simulation':
  forall L1 L2 index order match_states, bsim_properties L1 L2 index order match_states ->
  forall i s2 t s2', Step L2 s2 t s2' ->
  forall s1, match_states i s1 s2 -> safe L1 s1 ->
  (exists i', exists s1', Plus L1 s1 t s1' /\ match_states i' s1' s2')
  \/ (exists i', order i' i /\ t = E0 /\ match_states i' s1 s2').
Proof.
  intros. exploit bsim_simulation; eauto.
  intros [i' [s1' [A B]]]. intuition.
  left; exists i'; exists s1'; auto.
  inv H4.
  right; exists i'; auto.
  left; exists i'; exists s1'; split; auto. econstructor; eauto.
Qed.

(** ** Backward simulation diagrams. *)

(** Various simulation diagrams that imply backward simulation. *)

Section BACKWARD_SIMU_DIAGRAMS.

Variable L1: semantics.
Variable L2: semantics.

Hypothesis public_preserved:
  forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id.

Variable match_states: state L1 -> state L2 -> Prop.

Hypothesis entry_points_exist:
  forall s1 f arg m0, entry_point L1 m0 s1 f arg ->
                 exists s2, entry_point L2 m0 s2 f arg.

Hypothesis initial_states_exist:
  forall s1, initial_state L1 s1 ->
                 exists s2, initial_state L2 s2.

Hypothesis match_entry_points:
  forall s1 s2 f arg m0, entry_point L1 m0 s1 f arg  ->
                    entry_point L2 m0 s2 f arg  ->
                 exists s1', entry_point L1 m0 s1' f arg /\ match_states s1' s2.

Hypothesis match_initial_state:
  forall s1 s2, initial_state L1 s1  ->
                 initial_state L2 s2  ->
                 exists s1', initial_state L1 s1' /\ match_states s1' s2.

Hypothesis match_final_states:
  forall s1 s2 r,
  match_states s1 s2 -> final_state L2 s2 r -> final_state L1 s1 r.

Hypothesis progress:
  forall s1 s2,
  match_states s1 s2 -> safe L1 s1 ->
  (exists r, final_state L2 s2 r) \/
  (exists t, exists s2', Step L2 s2 t s2').

Section BACKWARD_SIMULATION_PLUS.

Hypothesis simulation:
  forall s2 t s2', Step L2 s2 t s2' ->
  forall s1, match_states s1 s2 -> safe L1 s1 ->
  exists s1', Plus L1 s1 t s1' /\ match_states s1' s2'.

Lemma backward_simulation_plus: backward_simulation L1 L2.
Proof.
  apply Backward_simulation with
    (fun (x y: unit) => False)
    (fun (i: unit) s1 s2 => match_states s1 s2);
  constructor; auto.
- red; intros; constructor; intros. contradiction.
- intros. exists tt; eauto.
- intros. exists tt; eauto.
- intros. exists s1; split. apply star_refl. eauto.
- intros. exploit simulation; eauto. intros [s1' [A B]].
  exists tt; exists s1'; auto.
Qed.

End BACKWARD_SIMULATION_PLUS.

End BACKWARD_SIMU_DIAGRAMS.

(** ** Backward simulation of transition sequences *)

Section BACKWARD_SIMULATION_SEQUENCES.

Context L1 L2 index order match_states (S: bsim_properties L1 L2 index order match_states).

Lemma bsim_E0_star:
  forall s2 s2', Star L2 s2 E0 s2' ->
  forall i s1, match_states i s1 s2 -> safe L1 s1 ->
  exists i', exists s1', Star L1 s1 E0 s1' /\ match_states i' s1' s2'.
Proof.
  intros s20 s20' STAR0. pattern s20, s20'. eapply star_E0_ind; eauto.
- (* base case *)
  intros. exists i; exists s1; split; auto. apply star_refl.
- (* inductive case *)
  intros. exploit bsim_simulation; eauto. intros [i' [s1' [A B]]].
  assert (Star L1 s0 E0 s1'). intuition. apply plus_star; auto.
  exploit H0. eauto. eapply star_safe; eauto. intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto. eapply star_trans; eauto.
Qed.

Lemma bsim_safe:
  forall i s1 s2,
  match_states i s1 s2 -> safe L1 s1 -> safe L2 s2.
Proof.
  intros; red; intros.
  exploit bsim_E0_star; eauto. intros [i' [s1' [A B]]].
  eapply bsim_progress; eauto. eapply star_safe; eauto.
Qed.

Lemma bsim_E0_plus:
  forall s2 t s2', Plus L2 s2 t s2' -> t = E0 ->
  forall i s1, match_states i s1 s2 -> safe L1 s1 ->
     (exists i', exists s1', Plus L1 s1 E0 s1' /\ match_states i' s1' s2')
  \/ (exists i', clos_trans _ order i' i /\ match_states i' s1 s2').
Proof.
  induction 1 using plus_ind2; intros; subst t.
- (* base case *)
  exploit bsim_simulation'; eauto. intros [[i' [s1' [A B]]] | [i' [A [B C]]]].
+ left; exists i'; exists s1'; auto.
+ right; exists i'; intuition.
- (* inductive case *)
  exploit Eapp_E0_inv; eauto. intros [EQ1 EQ2]; subst.
  exploit bsim_simulation'; eauto. intros [[i' [s1' [A B]]] | [i' [A [B C]]]].
+ exploit bsim_E0_star. apply plus_star; eauto. eauto. eapply star_safe; eauto. apply plus_star; auto.
  intros [i'' [s1'' [P Q]]].
  left; exists i''; exists s1''; intuition. eapply plus_star_trans; eauto.
+ exploit IHplus; eauto. intros [P | [i'' [P Q]]].
  left; auto.
  right; exists i''; intuition. eapply t_trans; eauto. apply t_step; auto.
Qed.

Lemma star_non_E0_split:
  forall s2 t s2', Star L2 s2 t s2' -> (length t = 1)%nat ->
  exists s2x, exists s2y, Star L2 s2 E0 s2x /\ Step L2 s2x t s2y /\ Star L2 s2y E0 s2'.
Proof.
  induction 1; intros.
  simpl in H; discriminate.
  subst t.
  assert (EITHER: t1 = E0 \/ t2 = E0).
    unfold Eapp in H2; rewrite app_length in H2.
    destruct t1; auto. destruct t2; auto. simpl in H2; omegaContradiction.
  destruct EITHER; subst.
  exploit IHstar; eauto. intros [s2x [s2y [A [B C]]]].
  exists s2x; exists s2y; intuition. eapply star_left; eauto.
  rewrite E0_right. exists s1; exists s2; intuition. apply star_refl.
Qed.

End BACKWARD_SIMULATION_SEQUENCES.

(** ** Composing two backward simulations *)

Section COMPOSE_BACKWARD_SIMULATIONS.

Variable L1: semantics.
Variable L2: semantics.
Variable L3: semantics.
Hypothesis L3_single_events: single_events L3.
Context index order match_states (S12: bsim_properties L1 L2 index order match_states).
Context index' order' match_states' (S23: bsim_properties L2 L3 index' order' match_states').

Let bb_index : Type := (index * index')%type.

Definition bb_order : bb_index -> bb_index -> Prop := lex_ord (clos_trans _ order) order'.

Inductive bb_match_states: bb_index -> state L1 -> state L3 -> Prop :=
  | bb_match_later: forall i1 i2 s1 s3 s2x s2y,
      match_states i1 s1 s2x -> Star L2 s2x E0 s2y -> match_states' i2 s2y s3 ->
      bb_match_states (i1, i2) s1 s3.

Lemma bb_match_at: forall i1 i2 s1 s3 s2,
  match_states i1 s1 s2 -> match_states' i2 s2 s3 ->
  bb_match_states (i1, i2) s1 s3.
Proof.
  intros. econstructor; eauto. apply star_refl.
Qed.

Lemma bb_simulation_base:
  forall s3 t s3', Step L3 s3 t s3' ->
  forall i1 s1 i2 s2, match_states i1 s1 s2 -> match_states' i2 s2 s3 -> safe L1 s1 ->
  exists i', exists s1',
    (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ bb_order i' (i1, i2)))
    /\ bb_match_states i' s1' s3'.
Proof.
  intros.
  exploit (bsim_simulation' S23); eauto. eapply bsim_safe; eauto.
  intros [ [i2' [s2' [PLUS2 MATCH2]]] | [i2' [ORD2 [EQ MATCH2]]]].
- (* 1 L2 makes one or several transitions *)
  assert (EITHER: t = E0 \/ (length t = 1)%nat).
  { exploit L3_single_events; eauto.
    destruct t; auto. destruct t; auto. simpl. intros. omegaContradiction. }
  destruct EITHER.
+ (* 1.1 these are silent transitions *)
  subst t. exploit (bsim_E0_plus S12); eauto.
  intros [ [i1' [s1' [PLUS1 MATCH1]]] | [i1' [ORD1 MATCH1]]].
* (* 1.1.1 L1 makes one or several transitions *)
  exists (i1', i2'); exists s1'; split. auto. eapply bb_match_at; eauto.
* (* 1.1.2 L1 makes no transitions *)
  exists (i1', i2'); exists s1; split.
  right; split. apply star_refl. left; auto.
  eapply bb_match_at; eauto.
+ (* 1.2 non-silent transitions *)
  exploit star_non_E0_split. apply plus_star; eauto. auto.
  intros [s2x [s2y [P [Q R]]]].
  exploit (bsim_E0_star S12). eexact P. eauto. auto. intros [i1' [s1x [X Y]]].
  exploit (bsim_simulation' S12). eexact Q. eauto. eapply star_safe; eauto.
  intros [[i1'' [s1y [U V]]] | [i1'' [U [V W]]]]; try (subst t; discriminate).
  exists (i1'', i2'); exists s1y; split.
  left. eapply star_plus_trans; eauto. eapply bb_match_later; eauto.
- (* 2. L2 makes no transitions *)
  subst. exists (i1, i2'); exists s1; split.
  right; split. apply star_refl. right; auto.
  eapply bb_match_at; eauto.
Qed.

Lemma bb_simulation:
  forall s3 t s3', Step L3 s3 t s3' ->
  forall i s1, bb_match_states i s1 s3 -> safe L1 s1 ->
  exists i', exists s1',
    (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ bb_order i' i))
    /\ bb_match_states i' s1' s3'.
Proof.
  intros. inv H0.
  exploit star_inv; eauto. intros [[EQ1 EQ2] | PLUS].
- (* 1. match at *)
  subst. eapply bb_simulation_base; eauto.
- (* 2. match later *)
  exploit (bsim_E0_plus S12); eauto.
  intros [[i1' [s1' [A B]]] | [i1' [A B]]].
+ (* 2.1 one or several silent transitions *)
  exploit bb_simulation_base. eauto. auto. eexact B. eauto.
    eapply star_safe; eauto. eapply plus_star; eauto.
  intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto.
  left. eapply plus_star_trans; eauto.
  destruct C as [P | [P Q]]. apply plus_star; eauto. eauto.
  traceEq.
+ (* 2.2 no silent transition *)
  exploit bb_simulation_base. eauto. auto. eexact B. eauto. auto.
  intros [i'' [s1'' [C D]]].
  exists i''; exists s1''; split; auto.
  intuition. right; intuition.
  inv H6. left. eapply t_trans; eauto. left; auto.
Qed.

End COMPOSE_BACKWARD_SIMULATIONS.

Lemma compose_backward_simulation:
  forall L1 L2 L3,
  single_events L3 -> backward_simulation L1 L2 -> backward_simulation L2 L3 ->
  backward_simulation L1 L3.
Proof.
  intros L1 L2 L3 L3single S12 S23.
  destruct S12 as [index order match_states props].
  destruct S23 as [index' order' match_states' props'].
  apply Backward_simulation with (bb_order order order') (bb_match_states L1 L2 L3 match_states match_states');
  constructor.
- (* well founded *)
  unfold bb_order. apply wf_lex_ord. apply wf_clos_trans. eapply bsim_order_wf; eauto. eapply bsim_order_wf; eauto.
- (* initial cores exist *)
  intros. exploit (bsim_entry_points_exist props); eauto. intros [s2 ].
  exploit (bsim_entry_points_exist props'); eauto; intros (s3&?&?).
- (* initial states exist *)
  intros. exploit (bsim_initial_states_exist props); eauto. intros [s2 ].
  exploit (bsim_initial_states_exist props'); eauto; intros (s3&?&?).
- (* match entry points *)
  intros s1 s3 f arg m0 INIT1 INIT3.
  exploit (bsim_entry_points_exist props); eauto. intros [s2 INIT2].
  exploit (bsim_match_entry_points props'); eauto.
  intros [i2 [s2' [INIT2' M2]]].
  exploit (bsim_match_entry_points props); eauto; supertransitivity.
    intros [i1 [s1' [INIT1' M1]]].
  exists (i1, i2); exists s1'; intuition auto.
  eapply bb_match_at; eauto.
- (* match initial states *)
  intros s1 s3 INIT1 INIT3.
  exploit (bsim_initial_states_exist props); eauto. intros [s2 INIT2].
  exploit (bsim_match_initial_states props'); eauto. supertransitivity.
  intros [i2 [s2' [INIT2' M2]]].
  exploit (bsim_match_initial_states props); eauto; supertransitivity.
  intros [i1 [s1' [INIT1' M1]]].
  exists (i1, i2); exists s1'; intuition auto. supertransitivity.
  eapply bb_match_at; eauto.
- (* match final states *)
  intros i s1 s3 r MS SAFE FIN. inv MS.
  exploit (bsim_match_final_states props'); eauto.
    eapply star_safe; eauto. eapply bsim_safe; eauto.
  intros [s2' [A B]].
  exploit (bsim_E0_star props). eapply star_trans. eexact H0. eexact A. auto. eauto. auto.
  intros [i1' [s1' [C D]]].
  exploit (bsim_match_final_states props); eauto. eapply star_safe; eauto.
  intros [s1'' [P Q]].
  exists s1''; split; auto. eapply star_trans; eauto.
- (* progress *)
  intros i s1 s3 MS SAFE. inv MS.
  eapply (bsim_progress props'). eauto. eapply star_safe; eauto. eapply bsim_safe; eauto.
- (* simulation *)
  apply bb_simulation; auto.
- (* symbols *)
  intros. transitivity (Senv.public_symbol (symbolenv L2) id); eapply bsim_public_preserved; eauto.
Qed.

(** ** Converting a forward simulation to a backward simulation *)

Section FORWARD_TO_BACKWARD.

Context L1 L2 index order match_states (FS: fsim_properties L1 L2 index order match_states).
Hypothesis L1_receptive: receptive L1.
Hypothesis L2_determinate: determinate L2.

(** Exploiting forward simulation *)

Inductive f2b_transitions: state L1 -> state L2 -> Prop :=
  | f2b_trans_final: forall s1 s2 s1' r,
      Star L1 s1 E0 s1' ->
      final_state L1 s1' r ->
      final_state L2 s2 r ->
      f2b_transitions s1 s2
  | f2b_trans_step: forall s1 s2 s1' t s1'' s2' i' i'',
      Star L1 s1 E0 s1' ->
      Step L1 s1' t s1'' ->
      Plus L2 s2 t s2' ->
      match_states i' s1' s2 ->
      match_states i'' s1'' s2' ->
      f2b_transitions s1 s2.

Lemma f2b_progress:
  forall i s1 s2, match_states i s1 s2 -> safe L1 s1 -> f2b_transitions s1 s2.
Proof.
  intros i0; pattern i0. apply well_founded_ind with (R := order).
  eapply fsim_order_wf; eauto.
  intros i REC s1 s2 MATCH SAFE.
  destruct (SAFE s1) as [[r FINAL] | [t [s1' STEP1]]]. apply star_refl.
- (* final state reached *)
  eapply f2b_trans_final; eauto.
  apply star_refl.
  eapply fsim_match_final_states; eauto.
- (* L1 can make one step *)
  exploit (fsim_simulation FS); eauto. intros [i' [s2' [A MATCH']]].
  assert (B: Plus L2 s2 t s2' \/ (s2' = s2 /\ t = E0 /\ order i' i)).
    intuition auto.
    destruct (star_inv H0); intuition auto.
  clear A. destruct B as [PLUS2 | [EQ1 [EQ2 ORDER]]].
+ eapply f2b_trans_step; eauto. apply star_refl.
+ subst. exploit REC; eauto. eapply star_safe; eauto. apply star_one; auto.
  intros TRANS; inv TRANS.
* eapply f2b_trans_final; eauto. eapply star_left; eauto.
* eapply f2b_trans_step; eauto. eapply star_left; eauto.
Qed.

Lemma fsim_simulation_not_E0:
  forall s1 t s1', Step L1 s1 t s1' -> t <> E0 ->
  forall i s2, match_states i s1 s2 ->
  exists i', exists s2', Plus L2 s2 t s2' /\ match_states i' s1' s2'.
Proof.
  intros. exploit (fsim_simulation FS); eauto. intros [i' [s2' [A B]]].
  exists i'; exists s2'; split; auto.
  destruct A. auto. destruct H2. exploit star_inv; eauto. intros [[EQ1 EQ2] | P]; auto.
  congruence.
Qed.

(** Exploiting determinacy *)

Remark silent_or_not_silent:
  forall t, t = E0 \/ t <> E0.
Proof.
  intros; unfold E0; destruct t; auto; right; congruence.
Qed.

Remark not_silent_length:
  forall t1 t2, (length (t1 ** t2) <= 1)%nat -> t1 = E0 \/ t2 = E0.
Proof.
  unfold Eapp, E0; intros. rewrite app_length in H.
  destruct t1; destruct t2; auto. simpl in H. omegaContradiction.
Qed.

Lemma f2b_determinacy_inv:
  forall s2 t' s2' t'' s2'',
  Step L2 s2 t' s2' -> Step L2 s2 t'' s2'' ->
  (t' = E0 /\ t'' = E0 /\ s2' = s2'')
  \/ (t' <> E0 /\ t'' <> E0 /\ match_traces (symbolenv L1) t' t'').
Proof.
  intros.
  assert (match_traces (symbolenv L2) t' t'').
    eapply sd_determ_1; eauto.
  destruct (silent_or_not_silent t').
  subst. inv H1.
  left; intuition. eapply sd_determ_2; eauto.
  destruct (silent_or_not_silent t'').
  subst. inv H1. elim H2; auto.
  right; intuition.
  eapply match_traces_preserved with (ge1 := (symbolenv L2)); auto.
  intros; symmetry; apply (fsim_public_preserved FS).
Qed.

Lemma f2b_determinacy_star:
  forall s s1, Star L2 s E0 s1 ->
  forall t s2 s3,
  Step L2 s1 t s2 -> t <> E0 ->
  Star L2 s t s3 ->
  Star L2 s1 t s3.
Proof.
  intros s0 s01 ST0. pattern s0, s01. eapply star_E0_ind; eauto.
  intros. inv H3. congruence.
  exploit f2b_determinacy_inv. eexact H. eexact H4.
  intros [[EQ1 [EQ2 EQ3]] | [NEQ1 [NEQ2 MT]]].
  subst. simpl in *. eauto.
  congruence.
Qed.

(** Orders *)

Inductive f2b_index : Type :=
  | F2BI_before (n: nat)
  | F2BI_after (n: nat).

Inductive f2b_order: f2b_index -> f2b_index -> Prop :=
  | f2b_order_before: forall n n',
      (n' < n)%nat ->
      f2b_order (F2BI_before n') (F2BI_before n)
  | f2b_order_after: forall n n',
      (n' < n)%nat ->
      f2b_order (F2BI_after n') (F2BI_after n)
  | f2b_order_switch: forall n n',
      f2b_order (F2BI_before n') (F2BI_after n).

Lemma wf_f2b_order:
  well_founded f2b_order.
Proof.
  assert (ACC1: forall n, Acc f2b_order (F2BI_before n)).
    intros n0; pattern n0; apply lt_wf_ind; intros.
    constructor; intros. inv H0. auto.
  assert (ACC2: forall n, Acc f2b_order (F2BI_after n)).
    intros n0; pattern n0; apply lt_wf_ind; intros.
    constructor; intros. inv H0. auto. auto.
  red; intros. destruct a; auto.
Qed.

(** Constructing the backward simulation *)

Inductive f2b_match_states: f2b_index -> state L1 -> state L2 -> Prop :=
  | f2b_match_at: forall i s1 s2,
      match_states i s1 s2 ->
      f2b_match_states (F2BI_after O) s1 s2
  | f2b_match_before: forall s1 t s1' s2b s2 n s2a i,
      Step L1 s1 t s1' ->  t <> E0 ->
      Star L2 s2b E0 s2 ->
      starN (step L2) n s2 t s2a ->
      match_states i s1 s2b ->
      f2b_match_states (F2BI_before n) s1 s2
  | f2b_match_after: forall n s2 s2a s1 i,
      starN (step L2) (S n) s2 E0 s2a ->
      match_states i s1 s2a ->
      f2b_match_states (F2BI_after (S n)) s1 s2.

Remark f2b_match_after':
  forall n s2 s2a s1 i,
  starN (step L2) n s2 E0 s2a ->
  match_states i s1 s2a ->
  f2b_match_states (F2BI_after n) s1 s2.
Proof.
  intros. inv H.
  econstructor; eauto.
  econstructor; eauto. econstructor; eauto.
Qed.

(** Backward simulation of L2 steps *)

Lemma f2b_simulation_step:
  forall s2 t s2', Step L2 s2 t s2' ->
  forall i s1, f2b_match_states i s1 s2 -> safe L1 s1 ->
  exists i', exists s1',
    (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ f2b_order i' i))
     /\ f2b_match_states i' s1' s2'.
Proof.
  intros s2 t s2' STEP2 i s1 MATCH SAFE.
  inv MATCH.
- (* 1. At matching states *)
  exploit f2b_progress; eauto. intros TRANS; inv TRANS.
+ (* 1.1  L1 can reach final state and L2 is at final state: impossible! *)
  exploit (sd_final_nostep L2_determinate); eauto. contradiction.
+ (* 1.2  L1 can make 0 or several steps; L2 can make 1 or several matching steps. *)
  inv H2.
  exploit f2b_determinacy_inv. eexact H5. eexact STEP2.
  intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]].
* (* 1.2.1  L2 makes a silent transition *)
  destruct (silent_or_not_silent t2).
  (* 1.2.1.1  L1 makes a silent transition too: perform transition now and go to "after" state *)
  subst. simpl in *. destruct (star_starN H6) as [n STEPS2].
  exists (F2BI_after n); exists s1''; split.
  left. eapply plus_right; eauto.
  eapply f2b_match_after'; eauto.
  (* 1.2.1.2 L1 makes a non-silent transition: keep it for later and go to "before" state *)
  subst. simpl in *. destruct (star_starN H6) as [n STEPS2].
  exists (F2BI_before n); exists s1'; split.
  right; split. auto. constructor.
  econstructor. eauto. auto. apply star_one; eauto. eauto. eauto.
* (* 1.2.2 L2 makes a non-silent transition, and so does L1 *)
  exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ].
  congruence.
  subst t2. rewrite E0_right in H1.
  (* Use receptiveness to equate the traces *)
  exploit (sr_receptive L1_receptive); eauto. intros [s1''' STEP1].
  exploit fsim_simulation_not_E0. eexact STEP1. auto. eauto.
  intros [i''' [s2''' [P Q]]]. inv P.
  (* Exploit determinacy *)
  exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ].
  subst t0. simpl in *. exploit sd_determ_1. eauto. eexact STEP2. eexact H2.
  intros. elim NOT2. inv H8. auto.
  subst t2. rewrite E0_right in *.
  assert (s4 = s2'). eapply sd_determ_2; eauto. subst s4.
  (* Perform transition now and go to "after" state *)
  destruct (star_starN H7) as [n STEPS2]. exists (F2BI_after n); exists s1'''; split.
  left. eapply plus_right; eauto.
  eapply f2b_match_after'; eauto.

- (* 2. Before *)
  inv H2. congruence.
  exploit f2b_determinacy_inv. eexact H4. eexact STEP2.
  intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]].
+ (* 2.1 L2 makes a silent transition: remain in "before" state *)
  subst. simpl in *. exists (F2BI_before n0); exists s1; split.
  right; split. apply star_refl. constructor. omega.
  econstructor; eauto. eapply star_right; eauto.
+ (* 2.2 L2 make a non-silent transition *)
  exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ].
  congruence.
  subst. rewrite E0_right in *.
  (* Use receptiveness to equate the traces *)
  exploit (sr_receptive L1_receptive); eauto. intros [s1''' STEP1].
  exploit fsim_simulation_not_E0. eexact STEP1. auto. eauto.
  intros [i''' [s2''' [P Q]]].
  (* Exploit determinacy *)
  exploit f2b_determinacy_star. eauto. eexact STEP2. auto. apply plus_star; eauto.
  intro R. inv R. congruence.
  exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ].
  subst. simpl in *. exploit sd_determ_1. eauto. eexact STEP2. eexact H2.
  intros. elim NOT2. inv H7; auto.
  subst. rewrite E0_right in *.
  assert (s3 = s2'). eapply sd_determ_2; eauto. subst s3.
  (* Perform transition now and go to "after" state *)
  destruct (star_starN H6) as [n STEPS2]. exists (F2BI_after n); exists s1'''; split.
  left. apply plus_one; auto.
  eapply f2b_match_after'; eauto.

- (* 3. After *)
  inv H. exploit Eapp_E0_inv; eauto. intros [EQ1 EQ2]; subst.
  exploit f2b_determinacy_inv. eexact H2. eexact STEP2.
  intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]].
  subst. exists (F2BI_after n); exists s1; split.
  right; split. apply star_refl. constructor; omega.
  eapply f2b_match_after'; eauto.
  congruence.
Qed.

End FORWARD_TO_BACKWARD.

(** The backward simulation *)

Lemma forward_to_backward_simulation:
  forall L1 L2,
  forward_simulation L1 L2 -> receptive L1 -> determinate L2 ->
  backward_simulation L1 L2.
Proof.
  intros L1 L2 FS L1_receptive L2_determinate.
  destruct FS as [index order match_states FS].
  apply Backward_simulation with f2b_order (f2b_match_states L1 L2 match_states); constructor.
- (* well founded *)
  apply wf_f2b_order.
- (* initial cores exist *)
  intros. exploit (fsim_match_entry_points FS); eauto. intros [i [s2 [A B]]].
  exists s2; auto.
- (* initial states exist *)
  intros. exploit (fsim_match_initial_states FS); eauto. intros [i [s2 [A B]]].
  exists s2; auto.
- (* initial cores *)
  intros. exploit (fsim_match_entry_points FS); eauto. intros [i [s2' [A B]]].
  assert (s2 = s2') by (eapply sd_initial_determ; eauto; supertransitivity). subst s2.
  exists (F2BI_after O); exists s1; repeat(split; auto). econstructor; eauto.
- (* initial states *)
  intros. exploit (fsim_match_initial_states FS); eauto. intros [i [s2' [A B]]].
  assert (s2 = s2') by (eapply sd_initial_state_determ; eauto; supertransitivity). subst s2.
  exists (F2BI_after O); exists s1; repeat(split; auto). econstructor; eauto.
- (* final states *)
  intros. inv H.
  exploit f2b_progress; eauto. intros TRANS; inv TRANS.
  assert (r0 = r) by (eapply (sd_final_determ L2_determinate); eauto). subst r0.
  exists s1'; auto.
  inv H4. exploit (sd_final_nostep L2_determinate); eauto. contradiction.
  inv H5. congruence. exploit (sd_final_nostep L2_determinate); eauto. contradiction.
  inv H2. exploit (sd_final_nostep L2_determinate); eauto. contradiction.
- (* progress *)
  intros. inv H.
  exploit f2b_progress; eauto. intros TRANS; inv TRANS.
  left; exists r; auto.
  inv H3. right; econstructor; econstructor; eauto.
  inv H4. congruence. right; econstructor; econstructor; eauto.
  inv H1. right; econstructor; econstructor; eauto.
- (* simulation *)
  eapply f2b_simulation_step; eauto.
- (* symbols preserved *)
  exact (fsim_public_preserved FS).
Qed.

(** * Transforming a semantics into a single-event, equivalent semantics *)

Definition well_behaved_traces (L: semantics) : Prop :=
  forall s t s', Step L s t s' ->
  match t with nil => True | ev :: t' => output_trace t' end.

Section ATOMIC.

Variable L: semantics.

Hypothesis Lwb: well_behaved_traces L.

Inductive atomic_step : (trace * state L) -> trace -> (trace * state L) -> Prop :=
  | atomic_step_silent: forall s s',
      Step L s E0 s' ->
      atomic_step (E0, s) E0 (E0, s')
  | atomic_step_start: forall s ev t s',
      Step L s (ev :: t) s' ->
      atomic_step (E0, s) (ev :: nil) (t, s')
  | atomic_step_continue: forall ev t s,
      output_trace (ev :: t) ->
      atomic_step (ev :: t, s) (ev :: nil) (t, s).

Definition part_atomic : part_semantics := {|
  state := (trace * state L)%type;
  get_mem := fun s => get_mem (snd s) ;
  set_mem := fun s m => (fst s, set_mem (snd s) m);
  genvtype := genvtype L;
  step := atomic_step;
  entry_point := fun m0 s f args => entry_point L m0 (snd s) f args /\ fst s = E0;
  at_external := fun s => at_external _ (snd s) ;
  after_external := fun ret s m => option_map (fun x => (fst s, x)) (after_external _ ret (snd s) m);
  final_state := fun s r => final_state L (snd s) r /\ fst s = E0;
  globalenv := globalenv L;
  symbolenv := symbolenv L
                                          |}.

Definition atomic : semantics := {|
  part_sem := part_atomic;
  main_block := main_block L;
  init_mem := init_mem L;
                                  |}.

End ATOMIC.

(** A forward simulation from a semantics [L1] to a single-event semantics [L2]
  can be "factored" into a forward simulation from [atomic L1] to [L2]. *)

Section FACTOR_FORWARD_SIMULATION.

Variable L1: semantics.
Variable L2: semantics.
Context index order match_states (sim: fsim_properties L1 L2 index order match_states).
Hypothesis L2single: single_events L2.

Inductive ffs_match: index -> (trace * state L1) -> state L2 -> Prop :=
  | ffs_match_at: forall i s1 s2,
      match_states i s1 s2 ->
      ffs_match i (E0, s1) s2
  | ffs_match_buffer: forall i ev t s1 s2 s2',
      Star L2 s2 (ev :: t) s2' -> match_states i s1 s2' ->
      ffs_match i (ev :: t, s1) s2.

Lemma star_non_E0_split':
  forall s2 t s2', Star L2 s2 t s2' ->
  match t with
  | nil => True
  | ev :: t' => exists s2x, Plus L2 s2 (ev :: nil) s2x /\ Star L2 s2x t' s2'
  end.
Proof.
  induction 1. simpl. auto.
  exploit L2single; eauto. intros LEN.
  destruct t1. simpl in *. subst. destruct t2. auto.
  destruct IHstar as [s2x [A B]]. exists s2x; split; auto.
  eapply plus_left. eauto. apply plus_star; eauto. auto.
  destruct t1. simpl in *. subst t. exists s2; split; auto. apply plus_one; auto.
  simpl in LEN. omegaContradiction.
Qed.

Lemma ffs_simulation:
  forall s1 t s1', Step (atomic L1) s1 t s1' ->
  forall i s2, ffs_match i s1 s2 ->
  exists i', exists s2',
     (Plus L2 s2 t s2' \/ (Star L2 s2 t s2') /\ order i' i)
  /\ ffs_match i' s1' s2'.
Proof.
  induction 1; intros.
- (* silent step *)
  inv H0.
  exploit (fsim_simulation sim); eauto.
  intros [i' [s2' [A B]]].
  exists i'; exists s2'; split. auto. constructor; auto.
- (* start step *)
  inv H0.
  exploit (fsim_simulation sim); eauto.
  intros [i' [s2' [A B]]].
  destruct t as [ | ev' t].
+ (* single event *)
  exists i'; exists s2'; split. auto. constructor; auto.
+ (* multiple events *)
  assert (C: Star L2 s2 (ev :: ev' :: t) s2'). intuition. apply plus_star; auto.
  exploit star_non_E0_split'. eauto. simpl. intros [s2x [P Q]].
  exists i'; exists s2x; split. auto. econstructor; eauto.
- (* continue step *)
  inv H0.
  exploit star_non_E0_split'. eauto. simpl. intros [s2x [P Q]].
  destruct t.
  exists i; exists s2'; split. left. eapply plus_star_trans; eauto. constructor; auto.
  exists i; exists s2x; split. auto. econstructor; eauto.
Qed.

End FACTOR_FORWARD_SIMULATION.

Theorem factor_forward_simulation:
  forall L1 L2,
  forward_simulation L1 L2 -> single_events L2 ->
  forward_simulation (atomic L1) L2.
Proof.
  intros L1 L2 FS L2single.
  destruct FS as [index order match_states sim].
  apply Forward_simulation with order (ffs_match L1 L2 match_states); constructor.
- (* wf *)
  eapply fsim_order_wf; eauto.
- (* initial core *)
  intros. destruct s1 as [t1 s1]. simpl in H. destruct H. subst.
  exploit (fsim_match_entry_points sim); eauto. intros [i [s2 [A B]]].
  exists i; exists s2; repeat(split; auto). constructor; auto.
- (* initial states *)
  intros. destruct s1 as [t1 s1]. inv H.
  destruct H2; simpl in *; subst.
  exploit (fsim_match_initial_states sim); eauto.
  econstructor; eauto.
  intros [i [s2 [A B]]].
  exists i; exists s2; split; auto.
  constructor; auto.
- (* final states *)
  intros. destruct s1 as [t1 s1]. simpl in H0; destruct H0; subst. inv H.
  eapply (fsim_match_final_states sim); eauto.
- (* simulation *)
  eapply ffs_simulation; eauto.
- (* symbols preserved *)
  simpl. exact (fsim_public_preserved sim).
Qed.

(** Likewise, a backward simulation from a single-event semantics [L1] to a semantics [L2]
  can be "factored" as a backward simulation from [L1] to [atomic L2]. *)

Section FACTOR_BACKWARD_SIMULATION.

Variable L1: semantics.
Variable L2: semantics.
Context index order match_states (sim: bsim_properties L1 L2 index order match_states).
Hypothesis L1single: single_events L1.
Hypothesis L2wb: well_behaved_traces L2.

Inductive fbs_match: index -> state L1 -> (trace * state L2) -> Prop :=
  | fbs_match_intro: forall i s1 t s2 s1',
      Star L1 s1 t s1' -> match_states i s1' s2 ->
      t = E0 \/ output_trace t ->
      fbs_match i s1 (t, s2).

Lemma fbs_simulation:
  forall s2 t s2', Step (atomic L2) s2 t s2' ->
  forall i s1, fbs_match i s1 s2 -> safe L1 s1 ->
  exists i', exists s1',
     (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ order i' i))
     /\ fbs_match i' s1' s2'.
Proof.
  induction 1; intros.
- (* silent step *)
  inv H0.
  exploit (bsim_simulation sim); eauto. eapply star_safe; eauto.
  intros [i' [s1'' [A B]]].
  exists i'; exists s1''; split.
  destruct A as [P | [P Q]]. left. eapply star_plus_trans; eauto. right; split; auto. eapply star_trans; eauto.
  econstructor. apply star_refl. auto. auto.
- (* start step *)
  inv H0.
  exploit (bsim_simulation sim); eauto. eapply star_safe; eauto.
  intros [i' [s1'' [A B]]].
  assert (C: Star L1 s1 (ev :: t) s1'').
    eapply star_trans. eauto. destruct A as [P | [P Q]]. apply plus_star; eauto. eauto. auto.
  exploit star_non_E0_split'; eauto. simpl. intros [s1x [P Q]].
  exists i'; exists s1x; split.
  left; auto.
  econstructor; eauto.
  exploit L2wb; eauto.
- (* continue step *)
  inv H0. unfold E0 in H8; destruct H8; try congruence.
  exploit star_non_E0_split'; eauto. simpl. intros [s1x [P Q]].
  exists i; exists s1x; split. left; auto. econstructor; eauto. simpl in H0; tauto.
Qed.

Lemma fbs_progress:
  forall i s1 s2,
  fbs_match i s1 s2 -> safe L1 s1 ->
  (exists r, final_state (atomic L2) s2 r) \/
  (exists t, exists s2', Step (atomic L2) s2 t s2').
Proof.
  intros. inv H. destruct t.
- (* 1. no buffered events *)
  exploit (bsim_progress sim); eauto. eapply star_safe; eauto.
  intros [[r A] | [t [s2' A]]].
+ (* final state *)
  left; exists r; simpl; auto.
+ (* L2 can step *)
  destruct t.
  right; exists E0; exists (nil, s2'). constructor. auto.
  right; exists (e :: nil); exists (t, s2'). constructor. auto.
- (* 2. some buffered events *)
  unfold E0 in H3; destruct H3. congruence.
  right; exists (e :: nil); exists (t, s3). constructor. auto.
Qed.

End FACTOR_BACKWARD_SIMULATION.

Lemma atomic_initial: forall L s,
   initial_state L s ->  initial_state (atomic L) (E0, s).
Proof. intros ? ? H; inv H. econstructor; simpl; eauto. Qed.

Lemma atomic_initial': forall L s t,
   initial_state (atomic L) (t, s) ->  initial_state L s.
Proof.
  intros ? ? ? H; inv H. destruct H2; simpl in *.
  econstructor; simpl; eauto.
Qed.

Theorem factor_backward_simulation:
  forall L1 L2,
  backward_simulation L1 L2 -> single_events L1 -> well_behaved_traces L2 ->
  backward_simulation L1 (atomic L2).
Proof.
  intros L1 L2 BS L1single L2wb.
  destruct BS as [index order match_states sim].
  apply Backward_simulation with order (fbs_match L1 L2 match_states); constructor.
- (* wf *)
  eapply bsim_order_wf; eauto.
- (* initial cores exist *)
  intros. exploit (bsim_entry_points_exist sim); eauto. intros [s2 A].
  exists (E0, s2). simpl; auto.
- (* initial states exist *)
  intros. exploit (bsim_initial_states_exist sim); eauto. intros [s2 A].
  exists (E0, s2). simpl. eapply atomic_initial; eauto.
- (* initial cores match *)
  intros. destruct s2 as [t s2]; simpl in H0; destruct H0; subst.
  exploit (bsim_match_entry_points sim); eauto. intros [i [s1' [A B]]].
  exists i; exists s1'; repeat(split; auto). econstructor. apply star_refl. auto. auto.
- (* initial states match *)
  intros. destruct s2 as [t s2]; simpl in H0; inv H0; subst.
  destruct H3; simpl in *; subst.
  exploit (bsim_match_initial_states sim); eauto.
  + econstructor; eauto.
  + intros [i [s1' [A B]]].
    exists i; exists s1'; repeat(split; auto). econstructor. apply star_refl. auto. auto.
- (* final states match *)
  intros. destruct s2 as [t s2]; simpl in H1; destruct H1; subst.
  inv H. exploit (bsim_match_final_states sim); eauto. eapply star_safe; eauto.
  intros [s1'' [A B]]. exists s1''; split; auto. eapply star_trans; eauto.
- (* progress *)
  eapply fbs_progress; eauto.
- (* simulation *)
  eapply fbs_simulation; eauto.
- (* symbols *)
  simpl. exact (bsim_public_preserved sim).
Qed.

(** Receptiveness of [atomic L]. *)

Record strongly_receptive (L: semantics) : Prop :=
  Strongly_receptive {
    ssr_receptive: forall s ev1 t1 s1 ev2,
      Step L s (ev1 :: t1) s1 ->
      match_traces (symbolenv L) (ev1 :: nil) (ev2 :: nil) ->
      exists s2, exists t2, Step L s (ev2 :: t2) s2;
    ssr_well_behaved:
      well_behaved_traces L
  }.

Theorem atomic_receptive:
  forall L, strongly_receptive L -> receptive (atomic L).
Proof.
  intros. constructor; intros.
(* receptive *)
  inv H0.
  (* silent step *)
  inv H1. exists (E0, s'). constructor; auto.
  (* start step *)
  assert (exists ev2, t2 = ev2 :: nil). inv H1; econstructor; eauto.
  destruct H0 as [ev2 EQ]; subst t2.
  exploit ssr_receptive; eauto. intros [s2 [t2 P]].
  exploit ssr_well_behaved. eauto. eexact P. simpl; intros Q.
  exists (t2, s2). constructor; auto.
  (* continue step *)
  simpl in H2; destruct H2.
  assert (t2 = ev :: nil). inv H1; simpl in H0; tauto.
  subst t2. exists (t, s0). constructor; auto. simpl; auto.
(* single-event *)
  red. intros. inv H0; simpl; omega.
Qed.

(** * Connections with big-step semantics *)

(** The general form of a big-step semantics *)

Record bigstep_semantics : Type :=
  Bigstep_semantics {
    bigstep_terminates: trace -> int -> Prop;
    bigstep_diverges: traceinf -> Prop
  }.

(** Soundness with respect to a small-step semantics *)

Record bigstep_sound (B: bigstep_semantics) (L: semantics) : Prop :=
  Bigstep_sound {
    bigstep_terminates_sound:
      forall t r,
      bigstep_terminates B t r ->
      exists s1, exists s2, initial_state L s1 /\ Star L s1 t s2 /\ final_state L s2 r;
    bigstep_diverges_sound:
      forall T,
      bigstep_diverges B T ->
      exists s1, initial_state L s1 /\ forever (step L) s1 T
}.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Proset.
Require Import Blech.Proset.Complete.
Require Import Blech.Proset.Op.
Require Import Blech.Proset.Sub.
Require Import Blech.Category.
Require Import Blech.Category.PreOrd.
Require Import Blech.Category.Bsh.
Require Import Blech.Category.Over.
Require Import Blech.Monic.
Require Import Blech.Monic.Mono.
Require Import Blech.Type.Some.
Require Blech.Reflect.

Import BishopNotations.
Import CategoryNotations.
Import ProsetNotations.
Import OpNotations.
Import OverNotations.
Import SomeNotations.

Open Scope category_scope.
Open Scope bishop_scope.

(* The powerset can be considered the free CABA *)
#[program]
 Definition Powerset (S: Proset): Complete := {|
  P :=
    {|
      T := S → Prop ;
      preorder p q := ∀ x, q x → p x ;
    |}
|}.

Next Obligation.
Proof.
  exists.
  - intros ? ? t.
    apply t.
  - intros ? ? ? p q ? ?.
    apply p.
    apply q.
    assumption.
Qed.

Next Obligation.
Proof.
  destruct X.
  cbn in *.
  apply (∀ a, x a X0).
Qed.

Next Obligation.
Proof.
  destruct X.
  cbn in *.
  apply (∀ a, x a X0).
Qed.

(* Doesn't seem right to me ? *)
#[program]
Definition Yo (S: Proset): PreOrd (S ᵒᵖ) (Powerset S) := λ x y, y ⊑ x.

Next Obligation.
Proof.
  intros ? ? p ? q.
  cbn in *.
  rewrite q.
  apply p.
Qed.

#[program]
 Definition Spec S: PreOrd (Powerset (S ᵒᵖ)) (Powerset S) := λ p x, p x.

Next Obligation.
Proof.
  intros ? ? p ? x.
  cbn in *.
  apply (p _ x).
Defined.

#[program]
 Definition Cospec S: PreOrd (Powerset S) (Powerset (S ᵒᵖ)) := λ p x, p x.

Next Obligation.
Proof.
  intros ? ? p ? x.
  cbn in *.
  apply (p _ x).
Defined.


From st.thms Require Import back_ctx_st_sem back_ctx_sem_syn.
From st.embedding Require Import types expressions typed.
From st.STLCmuST Require Import lang types typing.
From st.STLCmuVS Require Import lang typing contexts scopedness.
From st.STLCmu Require Import types.
From st.STLCmuST Require Import contexts.
From st.backtranslations.st_sem Require Import scoped.

Section back_ctx_st_syn.

  (* Given any syntactically-typed context in STLCmuST, ⊢ₛₜ C : ([[Γ]];[[τ]]) ⇒ ([];1), *)
  Context (C : ctx)
          (Γ : list type) (pΓ : Forall Closed Γ) (τ : type) (pτ : Closed τ)
          (pC : typed_ctx C (embed <$> Γ) (embed τ) [] (embed TUnit)).

  (* we have a syntactically typed context, C_b, *)
  Definition back_ctx_st_syn : STLCmuVS.contexts.ctx :=
    (back_ctx_sem_syn (back_ctx_st_sem C) Γ τ).

  (* It is indeed syntactically typed of (Γ;τ) ⇒ ([];1) *)
  Lemma back_ctx_st_syn_syn_typed :
    |C> [] ⊢ₙₒ back_ctx_st_syn ☾ Γ ; τ ☽ : TUnit.
  Proof.
    apply back_ctx_sem_syn_typed; auto.
    change 0 with (length ([] : list STLCmuST.types.type)).
    replace (length Γ) with (length (embed <$> Γ)) by by rewrite fmap_length.
    eapply back_ctx_scope; eauto.
  Qed.

  (* Furthermore, the backtranslated contexts successfully emulates the original (when interacting with syntactically typed terms in STLCmuVS). *)
  (* That is, for all syntactically typed e, Γ ⊢ₙₒ e : τ, C_b[e]⇓ ⇔ C[[[e]]]⇓ *)

  Lemma back_ctx_st_syn_correct_emulation :
    ∀ (e : expr) (de : Γ ⊢ₙₒ e : τ),
      STLCmuVS_halts (STLCmuVS.contexts.fill_ctx back_ctx_st_syn e) <-> STLCmuST_halts (fill_ctx C (embd_expr e)).
  Proof.
    assert (H1 : |sC> 0 ⊢ₙₒ back_ctx_st_sem C ☾ length Γ ☽).
    { change 0 with (length ([] : list STLCmuST.types.type)).
      replace (length Γ) with (length (embed <$> Γ)) by by rewrite fmap_length.
      eapply back_ctx_scope; eauto. }
    pose proof (back_ctx_st_sem_sem_typed C Γ τ).
    intros e de.
    split; intros.
      eapply back_ctx_st_sem_correct_emulation, back_ctx_sem_syn_correct_emulation; eauto.
      eapply back_ctx_sem_syn_correct_emulation, back_ctx_st_sem_correct_emulation; eauto.
  Qed.

End back_ctx_st_syn.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD : Universe, ((wd_ IAB IAC /\ (wd_ IAB IBD /\ (wd_ B1 B2 /\ (wd_ D1 D2 /\ (wd_ A1 A2 /\ (wd_ C1 C2 /\ (col_ A1 A2 IAB /\ (col_ B1 B2 IAB /\ (col_ A1 A2 IAC /\ (col_ C1 C2 IAC /\ (col_ B1 B2 IBD /\ col_ D1 D2 IBD))))))))))) -> col_ IAB IAC A1)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import ssreflect ssrbool ssrnat eqtype seq fintype tuple.
Require Import procstate procstatemonad bitsops bitsprops bitsopsprops.
Require Import SPred septac spec safe basic basicprog program macros.
Require Import instr instrsyntax instrcodec instrrules reader pointsto cursor.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope instr_scope.

(* Example: It is safe to sit forever in a tight loop. *)
Example safe_loop (p q: DWORD) :
  |-- safe @ (EIP ~= p ** p -- q :-> JMP p).
Proof.
  apply: spec_lob.
  have H := @JMP_I_rule p p q.
  rewrite ->spec_reads_entails_at in H; [|apply _].
  autorewrite with push_at in H. apply landAdj in H.
  etransitivity; [|apply H]. apply: landR; [sbazooka | reflexivity].
Qed.

(* We can package up jumpy code in a triple by using labels. *)
Example basic_loop:
  |-- basic empSP (LOCAL l; l:;; JMP l) lfalse.
Proof.
  rewrite /basic. specintros => i j.
  unfold_program. specintros => _ _ <- <-.
  rewrite /spec_reads. specintros => code Hcode.
  autorewrite with push_at.
  apply: limplAdj. apply: landL1.
  etransitivity; [apply safe_loop|]. cancel1. rewrite ->Hcode. by ssimpl.
Qed.

(* Show off the sequencing rule for [basic]. *)
Example basic_inc3 x:
  |-- basic (EAX ~= x)
            (INC EAX;; INC EAX;; INC EAX)
            (EAX ~= x +# 3) @ OSZCP?.
Proof.
  autorewrite with push_at. rewrite /stateIsAny.
  specintros => o s z c p.
  try_basicapply INC_R_rule. rewrite /OSZCP; sbazooka.
  try_basicapply INC_R_rule. rewrite /OSZCP; sbazooka.
  try_basicapply INC_R_rule. rewrite /OSZCP; sbazooka.
  rewrite /OSZCP addIsIterInc/iter; sbazooka.
Qed.

Example incdec_while c a:
  |-- basic
    (ECX ~= c ** EAX ~= a)
    (
      while (TEST ECX, ECX) CC_Z false (
        DEC ECX;;
        INC EAX
      )
    )
    (ECX ~= #0 ** EAX ~= addB c a)
    @ OSZCP?.
Proof.
  autorewrite with push_at.
  set (I := fun b => Exists c', Exists a',
    (c' == #0) = b /\\ addB c' a' = addB c a /\\
    ECX ~= c' ** EAX ~= a' **
    OF? ** SF? ** CF? ** PF?).
  eapply basic_basic_context; first apply (while_rule_ro (I:=I));
      first 2 last.
  - reflexivity.
  - subst I. rewrite /stateIsAny/ConditionIs. sbazooka.
  - subst I; cbv beta. sdestructs => c' a' Hzero Hadd.
    rewrite ->(eqP Hzero) in *. rewrite add0B in Hadd.
    subst a'. rewrite /ConditionIs/stateIsAny. by sbazooka.
  - specintros => b1 b2. subst I; cbv beta. specintros => c' a' Hzero Hadd.
    eapply basic_basic; first eapply TEST_self_rule.
    + rewrite /ConditionIs/stateIsAny. by sbazooka.
    rewrite /OSZCP/ConditionIs/stateIsAny. by sbazooka.
  - subst I; cbv beta. specintros => c' a' Hzero Hadd.
    rewrite /stateIsAny. specintros => fo fs fc fp. eapply basic_seq.
    + eapply basic_basic; first eapply DEC_R_rule.
      * rewrite /OSZCP/ConditionIs. by ssimpl.
      done.
    try_basicapply INC_R_rule.
    by rewrite addB_decB_incB.
    rewrite /OSZCP/ConditionIs.
    sbazooka.
Qed.


(***********************************************************************

Copyright (c) 2014 Jonathan Leivent

Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

***********************************************************************)

Require Export sorted.
Require Export solvesorted.
Export ListNotations.
Require Export erasable.
Export ErasableNotation.

Global Opaque NotIn.

Section defs.
  Context {A : Set}.
  Context {ordA : Ordered A}.

  Definition Esorted := (liftP1 sorted).

  Definition Eapp := (lift2 (@app A)).

  Definition ENotIn(x : A) := liftP1 (NotIn x).
End defs.

Hint Extern 2 (ENotIn _ _) => unerase.

(* Some nice syntax for erasable lists.  Note the use of ^x instead
  of [x] - because for some reason [x] wouldn't work in all cases. *)
Infix "++" := Eapp (right associativity, at level 60) : EL_scope.
Notation " [ ] " := (# nil) : EL_scope.
Notation "^ x" := (# (cons x nil)) (at level 59) : EL_scope.
Delimit Scope EL_scope with eln.
Bind Scope EL_scope with Erasable.
Bind Scope list_scope with list.
Open Scope EL_scope.

(* Hint Extern 30 => unerase; simplify_hyps. *)

Section EL_lemmas.
  Context {A : Set}.

  Notation EL := (## (list A)).

  Lemma Eapp_assoc: forall {p q r : EL}, (p++q)++r=p++(q++r).
  Proof.
    intros.
    unerase.
    rewrite <- app_assoc.
    reflexivity.
  Qed.

  Lemma group3Eapp: forall (p q r s : EL), p++q++r++s=(p++q++r)++s.
  Proof.
    intros.
    rewrite ?Eapp_assoc.
    reflexivity.
  Qed.

  Lemma Eapp_nil_l : forall (l : EL), []++l=l.
  Proof.
    unerase.
    reflexivity.
  Qed.

  Lemma Eapp_nil_r : forall (l : EL), l++[]=l.
  Proof.
    unerase.
    intros.
    rewrite app_nil_r.
    reflexivity.
  Qed.

End EL_lemmas.

Require Import memo.

Create HintDb Reassoc discriminated.

(* The following tactic steps through all top-level associations:

Ltac reassociate_step :=
  match goal with
      |- _ (?A++?B++?C) =>
      rewrite <- Eapp_assoc; pattern (A++B);
      match goal with
          |- ?F (A++B) =>
          let H:=fresh in
          set (H:=F); rewrite ?Eapp_assoc; subst H; cbv beta
      end
  end.

But, as a hint, it's considerably slower than the following 4 hints
that only examine the re-associations needed by the tree proofs.  *)

Hint Extern 996 => match goal with |- _ (_++_) =>
                                   domemoed rewrite !Eapp_assoc end : Reassoc.
Hint Extern 997 => match goal with |- _ (_++_) =>
                                   domemoed rewrite !Eapp_assoc; rewrite group3Eapp end : Reassoc.
Hint Extern 998 => match goal with |- _ (_++_) =>
                                   domemoed rewrite group3Eapp end : Reassoc.
Hint Extern 999 => match goal with |- _ (_++_) =>
                                   domemoed rewrite <- Eapp_assoc end : Reassoc.

Ltac zauto := typeclasses eauto with core Reassoc.

(**********************************************************************)

Notation EN := (## nat).

Definition ES := (lift1 S).

Ltac denil1 :=
  match goal with
    | H : context[[]++_] |- _ => rewrite Eapp_nil_l in H
    | H : context[_++[]] |- _ => rewrite Eapp_nil_r in H
    | |- context[[]++_] => rewrite Eapp_nil_l
    | |- context[_++[]] => rewrite Eapp_nil_r
  end.

Hint Extern 900 => denil1.

Ltac denil := repeat denil1.


Require Export SystemFR.RedTactics.

Opaque reducible_values.

Lemma open_reducible_add_equality:
  forall Θ Γ e1 e2 e1' e2' x,
    ~ x ∈ pfv e1' term_var ->
    ~ x ∈ pfv e2' term_var ->
    ~ x ∈ pfv e1 term_var ->
    ~ x ∈ pfv e2 term_var ->
    ~ x ∈ pfv_context Γ term_var ->
    [ Θ; (x, T_equiv e1' e2') :: Γ ⊨ e1 ≡ e2 ] ->
    [ Θ; Γ ⊨ e1' ≡ e2' ] ->
    [ Θ; Γ ⊨ e1 ≡ e2 ].
Proof.
  unfold open_equivalent; steps.

  unshelve epose proof (H4 _ ((x, uu) :: l) _ _ eq_refl);
    repeat step || apply SatCons || list_utils || simp_red || t_substitutions;
    eauto.
Qed.