Require Import compcert.lib.Axioms.
Require Export compcert.common.Errors.
Require Import liblayers.lib.ExtensionalityAxioms.
Require Export liblayers.lib.Functor.
Require Export liblayers.lib.Monad.
Require Import liblayers.lib.Decision.
Require Import liblayers.logic.Structures.
Require Import liblayers.logic.LayerData.

(** * [res] is a monad *)

Global Instance res_functor_ops: FunctorOps res :=
  {
    fmap A B f x := Errors.bind x (fun x => Errors.OK (f x))
  }.

Global Instance res_functor_prf: Functor res.
Proof.
  split.
  * intros A x.
    destruct x; reflexivity.
  * intros A B C f g x.
    destruct x; reflexivity.
Qed.

Global Instance res_monad_ops: MonadOps res :=
  {
    ret := Errors.OK;
    bind A B f x := Errors.bind x f
  }.

Global Instance res_monad_prf: Monad res.
Proof.
  split; try typeclasses eauto.
  * intros A B f.
    extensionality mx.
    destruct mx; reflexivity.
  * intros A B f x.
    reflexivity.
  * intros A mx.
    destruct mx; reflexivity.
  * intros A B C f g mx.
    destruct mx; reflexivity.
Qed.

Global Instance res_monad_inv_ret:
  MonadInvRet res.
Proof.
  intros A x y Hxy.
  inversion Hxy.
  reflexivity.
Qed.

Global Instance res_monad_inv_bind:
  MonadInvBind res.
Proof.
  intros A B f ma b H.
  unfold ret, bind in H; simpl in *.
  destruct ma; try discriminate.
  eauto.
Qed.

Lemma res_bind_error {A B} (f: A -> res B) msg:
  bind f (Error msg) = Error msg.
Proof.
  reflexivity.
Qed.

Hint Rewrite @res_bind_error : monad.

(** * Lifting orders on [res] *)

(** TODO: define [res_rel] as well? *)

(** We need failure on top: <explain>. *)

Inductive res_le {A B} (R: rel A B): rel (res A) (res B) :=
  | res_le_ok_def:
      (R ++> res_le R)%rel (@OK A) (@OK B)
  | res_le_error (msg: errmsg):
      UpperBound (res_le R) (Error msg).

Global Existing Instance res_le_error.

Global Instance res_le_ok:
  Monotonic (@OK) (forallr R, R ++> res_le R).
Proof.
  exact @res_le_ok_def.
Qed.

Global Instance res_le_bind:
  Monotonic
    (@Errors.bind)
    (forallr RA, forallr RB, res_le RA ++> (RA ++> res_le RB) ++> res_le RB).
Proof.
  unfold Errors.bind.
  rauto.
Qed.

Global Instance res_le_monad:
  MonadRel (@res_le).
Proof.
  split; simpl; rauto.
Qed.

Local Instance res_le_op `(Le): Le (res A) :=
  { le := res_le (≤) }.

Global Instance res_le_monotonic {A B}:
  Monotonic (@res_le A B) (subrel ++> subrel).
Proof.
  intros R1 R2 HR x y H.
  destruct H; constructor.
  apply HR; assumption.
Qed.

Global Instance res_le_monotonic_params:
  Params (@res_le) 3.

Lemma res_le_refl `(Reflexive):
  Reflexive (res_le R).
Proof.
  intros [x | msg].
  - constructor; reflexivity.
  - constructor.
Qed.

Hint Extern 1 (Reflexive (res_le _)) =>
  apply res_le_refl : typeclass_instances.

Lemma res_le_trans `(Transitive):
  Transitive (res_le R).
Proof.
  intros x y z Hxy Hyz.
  destruct Hxy as [x y Hxy | x msg].
  - inversion Hyz.
    + constructor.
      transitivity y; trivial.
    + constructor.
  - inversion Hyz.
    constructor.
Qed.

Hint Extern 1 (Transitive (res_le _)) =>
  apply res_le_trans : typeclass_instances.

Global Instance res_le_htrans {A B C} RAB RBC RAC:
  HTransitive (A:=A) (B:=B) (C:=C) RAB RBC RAC ->
  HTransitive (res_le RAB) (res_le RBC) (res_le RAC).
Proof.
  intros HR x y z Hxy Hyz.
  destruct Hyz as [ y z Hyz | ]; try constructor.
  inversion Hxy as [ x' y' Hxy' | ]; subst; try constructor.
  htransitivity y; assumption.
Qed.

Global Instance res_le_rtrans {A B C} RAB RBC RAC:
  RTransitive (A:=A) (B:=B) (C:=C) RAB RBC RAC ->
  RTransitive (res_le RAB) (res_le RBC) (res_le RAC).
Proof.
  intros HR x z Hxz.
  destruct Hxz as [ a c Hac | ].
  * apply rtransitivity in Hac.
    destruct Hac as (b & Hab & Hbc).
    exists (OK b).
    split; constructor; assumption.
  * exists (Error msg).
    split; constructor.
Qed.

Global Instance res_lower_bound {A B} (R: rel A B) (x: A):
  LowerBound R x ->
  LowerBound (res_le R) (OK x).
Proof.
  intros H [y|m]; constructor.
  apply lower_bound.
Qed.

(** ** Data-indexed version *)

Local Instance res_sim_op `(Tsim: Sim): Sim _ (fun D => res (T D)) :=
  { simRR D1 D2 R := res_le (sim R) }.

(** I'm not sure if those are still necessary now that we use the
  generalized [rel]. *)

Global Instance OK_sim_monotonic `(Tsim: Sim):
  Monotonic
    (fun D => @OK (T D))
    (forallr R, sim R ++> sim R).
Proof.
  intros D1 D2 R.
  apply res_le_ok.
Qed.

Global Instance res_sim_bind {V E} {A B: V -> Type}:
  forall (RA: sim_relation E A) (RB: sim_relation E B),
    Monotonic
      (fun (v : V) => bind (A := A v) (B := B v))
      (forallr e @ v1 v2 : E,
         (RA v1 v2 e ++> res_le (RB v1 v2 e)) ++>
         (res_le (RA v1 v2 e) ++> res_le (RB v1 v2 e))).
Proof.
  intros RA RB v1 v2 e.
  intros f g Hfg x y Hxy.
  destruct Hxy as [x y Hxy | y msg].
  * monad_norm.
    apply Hfg.
    assumption.
  * monad_norm.
    constructor.
Qed.

Global Instance res_sim_fmap {V E} {A B: V -> Type}:
  forall (RA: sim_relation E A) (RB: sim_relation E B),
    Monotonic
      (fun (v : V) => fmap (A := A v) (B := B v))
      (forallr e @ v1 v2 : E,
         (RA v1 v2 e ++> RB v1 v2 e) ++>
         (res_le (RA v1 v2 e) ++> res_le (RB v1 v2 e))).
Proof.
  intros RA RB v1 v2 e.
  intros f g Hfg x y Hxy.
  destruct Hxy as [x y Hxy | y msg].
  * monad_norm.
    constructor.
    apply Hfg.
    assumption.
  * monad_norm.
    constructor.
Qed.

(** * Orders for [res ∘ option] *)

Require Import OptionOrders.

Lemma res_option_le_ok_none {A} (R: relation A) (y: res (option A)):
  res_le (option_le R) (OK None) y.
Proof.
  apply lower_bound.
Qed.

Hint Resolve res_option_le_ok_none: liblayers.

(** * Decision-related definitions *)

(** ** The [res] version of [assert]. *)

Definition eassert (e: errmsg) P `{HP: Decision P}: res P :=
  match decide P with
    | left H => ret H
    | right H => Error e
  end.

Lemma eassert_inv `{Pdec: Decision} {A} m (f: P -> res A) (r: A):
  bind f (eassert m P) = ret r <->
  exists H, f H = ret r.
Proof.
  unfold eassert.
  destruct (decide P) as [HP | HP];
  unfold bind; simpl.
  * split; eauto.
    intros [H Hf].
    assert (H = HP) by apply proof_irr; congruence.
  * split; try discriminate.
    intros [H Hf].
    tauto.
Qed.

Instance eassert_le:
  Monotonic eassert (⊤ ++> forallr P Q : flip impl, ⊤ ++> res_le ⊤).
Proof.
  intros msg1 msg2 _ P Q HPQ Pdec Qdec _.
  unfold eassert, flip, impl in *.
  destruct (decide Q) as [HQ | HQ]; try constructor.
  destruct (decide P) as [HP | HP]; try tauto.
  constructor.
  apply I.
Qed.

Hint Rewrite @eassert_inv using typeclasses eauto : monad.

(** These tactics make it easy to reduce subexpressions of the form
  [H <- eassert msg P; M] in the goal by proving or disproving [P]. *)

Lemma eassert_true msg P `{Pdec: Decision P}:
  P -> exists H, eassert msg P = OK H.
Proof.
  intros.
  unfold eassert.
  destruct (decide P); try contradiction.
  eauto.
Defined.

Ltac eassert_true_aux msg P Pdec :=
  let H := fresh "Hasserted" in
  let HH := fresh "Hassert_eq" in
  destruct (eassert_true msg P (Pdec := Pdec)) as [H HH];
    [ idtac (* The user will prove [P] *)
    | rewrite !HH in *;
      clear HH;
      monad_norm;
      try clear H ].

Ltac eassert_true :=
  lazymatch goal with
    | |- context [@eassert ?msg ?P ?Pdec] =>
      eassert_true_aux msg P Pdec
  end.

Lemma eassert_false msg P `{Pdec: Decision P}:
  ~P -> eassert msg P = Error msg.
Proof.
  intros.
  unfold eassert.
  destruct (decide P); try contradiction.
  eauto.
Defined.

Ltac eassert_false_aux msg P Pdec :=
  let H := fresh in
  assert (H: ~P);
    [ idtac (* The user will prove [~P] *)
    | rewrite !(eassert_false msg P (Pdec:=Pdec) H);
      monad_norm;
      clear H ].

Ltac eassert_false :=
  lazymatch goal with
    | |- context [@eassert ?msg ?P ?Pdec] =>
      eassert_false_aux msg P Pdec
  end.

(** ** Whether a [res A] is [OK] or [Error] *)

Definition isOK {A} (x: res A): Prop :=
  exists (a: A), x = OK a.

Definition isError {A} (x: res A): Prop :=
  exists (m: errmsg), x = Error m.

Definition isOKNone {A} (x: res (option A)) :=
  x = OK None.

Global Instance isOK_dec {A} (x: res A): Decision (isOK x) :=
  match x with
    | OK _ => left _
    | Error _ => right _
  end.
Proof.
  abstract (red; eauto).
  abstract (intros [a Ha]; discriminate).
Defined.

Global Instance isError_dec {A} (x: res A): Decision (isError x) :=
  match x with
    | OK _ => right _
    | Error _ => left _
  end.
Proof.
  abstract (intros [msg Hmsg]; discriminate).
  abstract (red; eauto).
Defined.

Global Instance isOKNone_dec {A} (x: res (option A)):
  Decision (isOKNone x) :=
  match x with
    | OK None => left _
    | _ => right _
  end.
Proof.
  abstract (unfold isOKNone; simpl; congruence).
  abstract reflexivity.
  abstract (unfold isOKNone; simpl; congruence).
Defined.

Global Instance isOK_le:
  Monotonic (@isOK) (forallr R, res_le R --> impl).
Proof.
  intros B A R x y Hxy [x' Hx].
  subst.
  inversion Hxy.
  exists x.
  reflexivity.
Qed.

Global Instance isError_le:
  Monotonic (@isError) (forallr R, res_le R ++> impl).
Proof.
  intros A B R x y Hxy Hx.
  destruct Hx as [err Hx]; subst.
  inversion Hxy as [| err' x]; subst.
  eexists.
  reflexivity.
Qed.

Instance isOKNone_le:
  Monotonic (@isOKNone) (forallr R, res_le (option_le R) --> impl).
Proof.
  unfold isOKNone.
  intros A1 A2 RA x y Hxy Hx.
  destruct Hxy as [x y Hxy | ]; try discriminate.
  destruct Hxy as [x y Hxy | ]; try discriminate.
  reflexivity.
Qed.

(** *** Some lemmas and [eauto] hints. *)

Lemma isOK_OK {A} (a: A):
  isOK (OK a).
Proof.
  eexists.
  reflexivity.
Qed.

Lemma isOK_Error {A} msg:
  ~ isOK (@Error A msg).
Proof.
  intros [a Ha].
  discriminate.
Qed.

Hint Resolve isOK_OK.

Lemma isOKNone_OKNone {A}:
  isOKNone (OK (@None A)).
Proof.
  reflexivity.
Qed.

Hint Resolve isOKNone_OKNone.

Lemma isError_Error {A} msg:
  isError (@Error A msg).
Proof.
  eexists.
  reflexivity.
Qed.

Hint Resolve isError_Error.

(** * Miscellaneous helpers *)

Definition fallback {A} (x: A) (y: res A): A :=
  match y with
    | OK a => a
    | Error _ => x
  end.

(** ** Flip [option (res -)] <-> [res (option -)] *)

(** Overall, [res ∘ option] is more convenient to manipulate and
  that's what we have in most places. However, it is more
  straightforward to store into [PTree]s as [option ∘ res].
  Fortunately these wrappers can be used to flip between the two
  representations. *)

Definition res_option_flip {A} (roa: res (option A)): option (res A) :=
  match roa with
    | OK None => None
    | OK (Some a) => Some (OK a)
    | Error msg => Some (Error msg)
  end.

Global Instance res_option_flip_le:
  Monotonic
    (@res_option_flip)
    (forallr R, res_le (option_le R) ++> option_le (res_le R)).
Proof.
  intros A1 A2 RA _ _ [_ _ [y | x y Hxy] | msg [[|]|]];
  simpl;
  rauto.
Qed.

Definition option_res_flip {A} (ora: option (res A)): res (option A) :=
  match ora with
    | None => OK None
    | Some (OK a) => OK (Some a)
    | Some (Error msg) => Error msg
  end.

Lemma option_res_le_flip {A B} (R: rel A B) x y:
  res_le (option_le R) (option_res_flip x) (option_res_flip y) <->
  option_le (res_le R) x y.
Proof.
  destruct x as [[|]|];
  destruct y as [[|]|];
  split; intro H;
  inversion H; subst;
  try (inversion H2; subst);
  repeat (constructor || assumption).
Qed.

Global Instance option_res_flip_le:
  Monotonic
    (@option_res_flip)
    (forallr R, option_le (res_le R) ++> res_le (option_le R)).
Proof.
  intros A1 A2 RA x y Hxy.
  apply option_res_le_flip.
  assumption.
Qed.

Lemma res_option_flip_inv {A} (x: res (option A)):
  option_res_flip (res_option_flip x) = x.
Proof.
  destruct x as [[x|] | msg]; reflexivity.
Qed.

Lemma option_res_flip_inv {A} (x: option (res A)):
  res_option_flip (option_res_flip x) = x.
Proof.
  destruct x as [[x|msg] | ]; reflexivity.
Qed.

Lemma res_option_le_flip {A B} (R: rel A B) x y:
  option_le (res_le R) (res_option_flip x) (res_option_flip y) <->
  res_le (option_le R) x y.
Proof.
  rewrite <- option_res_le_flip.
  repeat rewrite res_option_flip_inv.
  tauto.
Qed.

(** * [PseudoJoin] structure for [res (option -)] *)

Require Import PseudoJoin.

Section RES_OPTION_PSEUDO_JOIN.
  Global Instance res_option_oplus_op (A: Type): Oplus (res (option A)) | 10 :=
    { oplus rox roy :=
    ox <- rox;
    oy <- roy;
    match ox, oy with
      | None, None => ret None
      | Some x, None => ret (Some x)
      | None, Some y => ret (Some y)
      | Some x, Some y => Error nil
    end }.

  Global Instance res_option_oplus_monotonic {A} (R: relation A):
    Monotonic
      (⊕)
      (res_le (option_le R) ++> res_le (option_le R) ++> res_le (option_le R)).
  Proof.
    simpl.
    unfold Errors.bind.
    repeat rstep.
    destruct H3 as [[y1|] | x1 y1 H1];
    destruct H4 as [[y2|] | x2 y2 H2];
    repeat rstep.
  Qed.

  Existing Instance res_le_op.
  Existing Instance option_le_op.

  Local Hint Extern 4 => reflexivity.

  Global Instance res_option_oplus_prf (A: Type) `{Ale: Le A}:
    @PreOrder A (≤) ->
    PseudoJoin (res (option A)) (OK None).
  Proof with simpl; monad_norm; repeat constructor; reflexivity.
    intros Hpre.
    split; try typeclasses eauto.
    * simpl (≤).
      split; typeclasses eauto.
    * red; rauto.
    * intros [[y|]|err]...
    * intros [[x|]|xerr] [[y|]|yerr] [[z|]|zerr]...
    * intros [[x|]|xerr] [[y|]|yerr]...
    * intros [[x|]|xerr] [[y|]|yerr]...
  Qed.

  (** In addition, we have stronger versions of those. *)

  Global Instance res_option_oplus_id_left A:
    @LeftIdentity (res (option A)) eq (⊕) (OK None).
  Proof.
    intros [[|]|]; reflexivity.
  Qed.

  Global Instance res_option_oplus_comm A:
    @RightIdentity (res (option A)) eq (⊕) (OK None).
  Proof.
    intros [[|]|]; reflexivity.
  Qed.
End RES_OPTION_PSEUDO_JOIN.

Section OPTION_RES_PSEUDO_JOIN.
  Global Instance option_res_oplus_op (A: Type): Oplus (option (res A)) | 10 :=
    {
      oplus orx ory :=
        match orx, ory with
          | None, None => None
          | Some x, None => Some x
          | None, Some y => Some y
          | Some (Error e), Some y => Some (Error e)
          | Some (OK x), Some (Error e) => Some (Error e)
          | Some (OK x), Some (OK y) => Some (Error nil)
        end
    }.

  Existing Instance option_le_op.
  Existing Instance res_le_op.

  Global Instance option_res_oplus_prf (A: Type) `{Ale: Le A} `{Hle: PreOrder A (≤)}:
    PseudoJoin (option (res A)) None.
  Proof with simpl; eauto with liblayers; intros; try solve_monotonic.
    split; try typeclasses eauto.
    * simpl (≤); split; typeclasses eauto.
    * intros x1 x2 Hx y1 y2 Hy; simpl.
      destruct Hx as [ [[x2|xerr]|] | _ _ [x1 x2 Hx | xerr [x|xe]]];
      destruct Hy as [ [[y2|yerr]|] | _ _ [y1 y2 Hy | yerr [y|ye]]]...
    * intros [[?|?]|]...
    * intros [[?|?]|] [[?|?]|] [[?|?]|]...
    * intros [[?|?]|] [[?|?]|]...
    * intros [[?|?]|] [[?|?]|]...
  Qed.

  (** In addition, we have a top element. *)
  Global Instance option_res_top {A B} (R: rel A B) errmsg:
    UpperBound (option_le (res_le R)) (Some (Error errmsg)).
  Proof.
    intro x.
    destruct x as [|]; repeat constructor.
  Qed.
End OPTION_RES_PSEUDO_JOIN.

(* Decidable equality *)

Global Instance decide_res_eq `{EqDec}:
  EqDec (res A).
Proof.
  repeat red.
  repeat decide equality.
  apply (decide _).
Defined.


(* *********************************************************************)
(*                                                                     *)
(*              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. *)

(* This file comes from commit fe51a04 in CompCert *)
(* Getting rid of globalenvs for the JIT/IR/Mixed programs *)

Require Import Relations.
Require Import Wellfounded.
Require Import Coqlib.
Require Import Events.
(* Require Import Globalenvs. *)
Require Import Integers.

(* redefining match_traces *)
Inductive match_traces: trace -> trace -> Prop :=
| match_traces_E0:
    match_traces nil nil
| match_traces_same:
    forall e,
      match_traces (e::nil) (e::nil).

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: genv -> state -> trace -> state -> Prop.

(** No transitions: stuck state *)

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

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

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

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

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

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

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

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

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

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

Lemma star_E0_ind:
  forall ge (P: state -> state -> Prop),
  (forall s, P s s) ->
  (forall s1 s2 s3, step ge s1 E0 s2 -> P s2 s3 -> P s1 s3) ->
  forall s1 s2, star ge s1 E0 s2 -> P s1 s2.
Proof.
  intros ge P BASE REC.
  assert (forall s1 t s2, star ge 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 (ge: genv): state -> trace -> state -> Prop :=
  | plus_left: forall s1 t1 s2 t2 s3 t,
      step ge s1 t1 s2 -> star ge s2 t2 s3 -> t = t1 ** t2 ->
      plus ge s1 t s3.

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

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

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

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

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

Lemma plus_right:
  forall ge s1 t1 s2 t2 s3 t,
  star ge s1 t1 s2 -> step ge s2 t2 s3 -> t = t1 ** t2 ->
  plus ge 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 ge s1 t1 s2 t2 s3 t,
  step ge s1 t1 s2 -> plus ge s2 t2 s3 -> t = t1 ** t2 ->
  plus ge s1 t s3.
Proof.
  intros. eapply plus_left; eauto. apply plus_star; auto.
Qed.

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

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

Lemma star_plus_trans:
  forall ge s1 t1 s2 t2 s3 t,
  star ge s1 t1 s2 -> plus ge s2 t2 s3 -> t = t1 ** t2 -> plus ge 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 ge s1 t1 s2 t2 s3 t,
  plus ge s1 t1 s2 -> plus ge s2 t2 s3 -> t = t1 ** t2 -> plus ge s1 t s3.
Proof.
  intros. eapply plus_star_trans. eauto. apply plus_star. eauto. auto.
Qed.

Lemma plus_inv:
  forall ge s1 t s2,
  plus ge s1 t s2 ->
  step ge s1 t s2 \/ exists s', exists t1, exists t2, step ge s1 t1 s' /\ plus ge 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 ge s1 t s2,
  star ge s1 t s2 ->
  (s2 = s1 /\ t = E0) \/ plus ge s1 t s2.
Proof.
  intros. inv H. left; auto. right; econstructor; eauto.
Qed.

Lemma plus_ind2:
  forall ge (P: state -> trace -> state -> Prop),
  (forall s1 t s2, step ge s1 t s2 -> P s1 t s2) ->
  (forall s1 t1 s2 t2 s3 t,
   step ge s1 t1 s2 -> plus ge s2 t2 s3 -> P s2 t2 s3 -> t = t1 ** t2 ->
   P s1 t s3) ->
  forall s1 t s2, plus ge s1 t s2 -> P s1 t s2.
Proof.
  intros ge P BASE IND.
  assert (forall s1 t s2, star ge s1 t s2 ->
         forall s0 t0, step ge 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 ge (P: state -> state -> Prop),
  (forall s1 s2 s3, step ge s1 E0 s2 -> star ge s2 E0 s3 -> P s1 s3) ->
  forall s1 s2, plus ge 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 (ge: genv): nat -> state -> trace -> state -> Prop :=
  | starN_refl: forall s,
      starN ge O s E0 s
  | starN_step: forall n s t t1 s' t2 s'',
      step ge s t1 s' -> starN ge n s' t2 s'' -> t = t1 ** t2 ->
      starN ge (S n) s t s''.

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

Remark star_starN:
  forall ge s t s', star ge s t s' -> exists n, starN ge 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 (ge: genv): state -> traceinf -> Prop :=
  | forever_intro: forall s1 t s2 T,
      step ge s1 t s2 -> forever ge s2 T ->
      forever ge s1 (t *** T).

Lemma star_forever:
  forall ge s1 t s2, star ge s1 t s2 ->
  forall T, forever ge s2 T ->
  forever ge 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 (ge: genv) : A -> state -> traceinf -> Prop :=
  | forever_N_star: forall s1 t s2 a1 a2 T1 T2,
      star ge s1 t s2 ->
      order a2 a1 ->
      forever_N ge a2 s2 T2 ->
      T1 = t *** T2 ->
      forever_N ge a1 s1 T1
  | forever_N_plus: forall s1 t s2 a1 a2 T1 T2,
      plus ge s1 t s2 ->
      forever_N ge a2 s2 T2 ->
      T1 = t *** T2 ->
      forever_N ge a1 s1 T1.

Hypothesis order_wf: well_founded order.

Lemma forever_N_inv:
  forall ge a s T,
  forever_N ge a s T ->
  exists t, exists s', exists a', exists T',
  step ge s t s' /\ forever_N ge a' s' T' /\ T = t *** T'.
Proof.
  intros ge 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 ge a s T, forever_N ge a s T -> forever ge 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 (ge: genv) : state -> traceinf -> Prop :=
  | forever_plus_intro: forall s1 t s2 T1 T2,
      plus ge s1 t s2 ->
      forever_plus ge s2 T2 ->
      T1 = t *** T2 ->
      forever_plus ge s1 T1.

Lemma forever_plus_inv:
  forall ge s T,
  forever_plus ge s T ->
  exists s', exists t, exists T',
  step ge s t s' /\ forever_plus ge 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 ge s T, forever_plus ge s T -> forever ge 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 (ge: genv): state -> Prop :=
  | forever_silent_intro: forall s1 s2,
      step ge s1 E0 s2 -> forever_silent ge s2 ->
      forever_silent ge s1.

(** An alternate definition. *)

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

Lemma forever_silent_N_inv:
  forall ge a s,
  forever_silent_N ge a s ->
  exists s', exists a',
  step ge s E0 s' /\ forever_silent_N ge a' s'.
Proof.
  intros ge 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 ge a s, forever_silent_N ge a s -> forever_silent ge 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 (ge: genv): state -> traceinf -> Prop :=
  | forever_reactive_intro: forall s1 s2 t T,
      star ge s1 t s2 -> t <> E0 -> forever_reactive ge s2 T ->
      forever_reactive ge s1 (t *** T).

Lemma star_forever_reactive:
  forall ge s1 t s2 T,
  star ge s1 t s2 -> forever_reactive ge s2 T ->
  forever_reactive ge 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 semantics : Type := Semantics_gen {
  state: Type;
  genvtype: Type;
  step : genvtype -> state -> trace -> state -> Prop;
  initial_state: state -> Prop;
  final_state: state -> int -> Prop;
  globalenv: genvtype;
  (* symbolenv: Senv.t *)
}.

(** The form used in earlier CompCert versions, for backward compatibility. *)

(* Definition Semantics {state funtype vartype: Type} *)
(*                      (step: Genv.t funtype vartype -> state -> trace -> state -> Prop) *)
(*                      (initial_state: state -> Prop) *)
(*                      (final_state: state -> int -> Prop) *)
(*                      (globalenv: Genv.t funtype vartype) := *)
(*   {| state := state; *)
(*      genvtype := Genv.t funtype vartype; *)
(*      step := step; *)
(*      initial_state := initial_state; *)
(*      final_state := final_state; *)
(*      globalenv := globalenv; *)
(*      symbolenv := Genv.to_senv globalenv |}. *)

(** Handy notations. *)
Declare Scope smallstep_scope.
Notation " 'Step' L " := (step L (globalenv L)) (at level 1) : smallstep_scope.
Notation " 'Star' L " := (star (step L) (globalenv L)) (at level 1) : smallstep_scope.
Notation " 'SPlus' L " := (plus (step L) (globalenv L)) (at level 1) : smallstep_scope.
Notation " 'Forever_silent' L " := (forever_silent (step L) (globalenv L)) (at level 1) : smallstep_scope.
Notation " 'Forever_reactive' L " := (forever_reactive (step L) (globalenv L)) (at level 1) : smallstep_scope.
Notation " 'Nostep' L " := (nostep (step L) (globalenv L)) (at level 1) : smallstep_scope.

Open Scope smallstep_scope.

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

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

Record forward_simulation (L1 L2: semantics) : Type :=
  Forward_simulation {
    fsim_index: Type;
    fsim_order: fsim_index -> fsim_index -> Prop;
    fsim_order_wf: well_founded fsim_order;
    fsim_match_states :> fsim_index -> state L1 -> state L2 -> Prop;
    fsim_match_initial_states:
      forall s1, initial_state L1 s1 ->
      exists i, exists s2, initial_state L2 s2 /\ fsim_match_states i s1 s2;
    fsim_match_final_states:
      forall i s1 s2 r,
      fsim_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, fsim_match_states i s1 s2 ->
      exists i', exists s2',
         (SPlus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ fsim_order i' i))
      /\ fsim_match_states i' s1' s2';
    (* fsim_public_preserved: *)
    (*   forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id *)
  }.

(* Implicit Arguments forward_simulation []. *)
Arguments forward_simulation: clear implicits.

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

Lemma fsim_simulation':
  forall L1 L2 (S: forward_simulation L1 L2),
  forall i s1 t s1', Step L1 s1 t s1' ->
  forall s2, S i s1 s2 ->
  (exists i', exists s2', SPlus L2 s2 t s2' /\ S i' s1' s2')
  \/ (exists i', fsim_order S i' i /\ t = E0 /\ S i' s1' s2).
Proof.
  intros. exploit fsim_simulation; eauto.
  intros [i' [s2' [A B]]]. intuition.
  left; exists i'; exists s2'; auto.
  inv H2.
  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_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',
  (SPlus 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
    (fsim_order := order)
    (fsim_match_states := fun idx s1 s2 => idx = s1 /\ match_states s1 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.
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', SPlus 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.

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', SPlus 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.

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.

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.

End SIMULATION_OPT.

End FORWARD_SIMU_DIAGRAMS.

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

Section SIMULATION_SEQUENCES.

Variable L1: semantics.
Variable L2: semantics.
Variable S: forward_simulation L1 L2.

Lemma simulation_star:
  forall s1 t s1', Star L1 s1 t s1' ->
  forall i s2, S i s1 s2 ->
  exists i', exists s2', Star L2 s2 t s2' /\ S 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. apply plus_star; auto.
Qed.

Lemma simulation_plus:
  forall s1 t s1', SPlus L1 s1 t s1' ->
  forall i s2, S i s1 s2 ->
  (exists i', exists s2', SPlus L2 s2 t s2' /\ S i' s1' s2')
  \/ (exists i', clos_trans _ (fsim_order S) i' i /\ t = E0 /\ S 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.
  eapply t_trans; eauto. eapply t_step; eauto.
Qed.

Lemma simulation_forever_silent:
  forall i s1 s2,
  Forever_silent L1 s1 -> S i s1 s2 ->
  Forever_silent L2 s2.
Proof.
  assert (forall i s1 s2,
          Forever_silent L1 s1 -> S i s1 s2 ->
          forever_silent_N (step L2) (fsim_order S) (globalenv L2) 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. apply fsim_order_wf.
Qed.

Lemma simulation_forever_reactive:
  forall i s1 s2 T,
  Forever_reactive L1 s1 T -> S i s1 s2 ->
  Forever_reactive L2 s2 T.
Proof.
  cofix COINDHYP; intros.
  inv H.
  destruct (simulation_star H1 i _ H0) as [i' [st2' [A B]]].
  econstructor; eauto.
Qed.

End SIMULATION_SEQUENCES.

(** ** Composing two forward simulations *)

Section COMPOSE_SIMULATIONS.

Variable L1: semantics.
Variable L2: semantics.
Variable L3: semantics.
Variable S12: forward_simulation L1 L2.
Variable S23: forward_simulation L2 L3.

Let ff_index : Type := (fsim_index S23 * fsim_index S12)%type.

Let ff_order : ff_index -> ff_index -> Prop :=
  lex_ord (clos_trans _ (fsim_order S23)) (fsim_order S12).

Let ff_match_states (i: ff_index) (s1: state L1) (s3: state L3) : Prop :=
  exists s2, S12 (snd i) s1 s2 /\ S23 (fst i) s2 s3.

Lemma compose_forward_simulation: forward_simulation L1 L3.
Proof.
  apply Forward_simulation with (fsim_order := ff_order) (fsim_match_states := ff_match_states).
(* well founded *)
  unfold ff_order. apply wf_lex_ord. apply wf_clos_trans. apply fsim_order_wf. apply fsim_order_wf.
(* initial states *)
  intros. exploit (fsim_match_initial_states S12); eauto. intros [i [s2 [A B]]].
  exploit (fsim_match_initial_states S23); eauto. intros [i' [s3 [C D]]].
  exists (i', i); exists s3; split; auto. exists s2; auto.
(* final states *)
  intros. destruct H as [s3 [A B]].
  eapply (fsim_match_final_states S23); eauto.
  eapply (fsim_match_final_states S12); eauto.
(* simulation *)
  intros. destruct H0 as [s3 [A B]]. destruct i as [i2 i1]; simpl in *.
  exploit (fsim_simulation' S12); 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); apply fsim_public_preserved; auto. *)
Qed.

End COMPOSE_SIMULATIONS.

(** * 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,
      initial_state L s1 -> initial_state L s2 -> 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
  }.

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.

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

Record receptive_at (L: semantics) (s:L.(state)) : Prop :=
  Receptive_at {
    sr_receptive_at: forall t1 s1 t2,
      Step L s t1 s1 -> match_traces (* (symbolenv L) *) t1 t2 -> exists s2, Step L s t2 s2;
    sr_traces_at:
      single_events_at L s
  }.

Record determinate_at (L: semantics) (s:L.(state)) : Prop :=
  Determinate_at {
    sd_determ_at: forall 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_at:
      single_events_at L s
  }.

Lemma no_event_receptive L s
      (DETERM: forall t1 s1, Step L s t1 s1 -> t1 = E0):
  receptive_at L s.
Proof.
  econstructor; intros.
  - exploit DETERM; eauto. intro. subst.
    inv H0. exists s1. auto.
  - repeat intro. exploit DETERM; eauto.
    intro. subst. auto.
Qed.

Notation " 'DeterminateStep' L " := (fun s1 t s2 => determinate_at L s1 /\ step L (globalenv L) s1 t s2) (at level 1) : smallstep_scope.
Notation " 'DeterminateStar' L " := (star (fun ge s1 t s2 => determinate_at L s1 /\ step L ge s1 t s2) (globalenv L)) (at level 1) : smallstep_scope.
Notation " 'DeterminateStarN' L " := (starN (fun ge s1 t s2 => determinate_at L s1 /\ step L ge s1 t s2) (globalenv L)) (at level 1) : smallstep_scope.
Notation " 'DeterminateSPlus' L " := (plus (fun ge s1 t s2 => determinate_at L s1 /\ step L ge s1 t s2) (globalenv L)) (at level 1) : smallstep_scope.

Lemma determinate_step_step:
  forall (L: semantics) s t s',
  DeterminateStep L s t s' -> Step L s t s'.
Proof.
  intros. inv H. auto.
Qed.

Lemma determinate_star_star:
  forall (L: semantics) s t s',
  DeterminateStar L s t s' -> Star L s t s'.
Proof.
  intros L s t s' H. induction H; econstructor; eauto.
  destruct H. auto.
Qed.

Lemma determinate_plus_plus:
  forall (L: semantics) s t s',
  DeterminateSPlus L s t s' -> SPlus L s t s'.
Proof.
  intros. inv H. destruct H0. econstructor; eauto.
  apply determinate_star_star. auto.
Qed.

(** * 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 backward_simulation (L1 L2: semantics) : Type :=
  Backward_simulation {
    bsim_index: Type;
    bsim_order: bsim_index -> bsim_index -> Prop;
    bsim_order_wf: well_founded bsim_order;
    bsim_match_states :> bsim_index -> state L1 -> state L2 -> Prop;
    bsim_initial_states_exist:
      forall s1, initial_state L1 s1 -> exists s2, initial_state L2 s2;
    bsim_match_initial_states:
      forall s1 s2, initial_state L1 s1 -> initial_state L2 s2 ->
      exists i, exists s1', initial_state L1 s1' /\ bsim_match_states i s1' s2;
    bsim_match_final_states:
      forall i s1 s2 r,
      bsim_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,
      bsim_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, bsim_match_states i s1 s2 -> safe L1 s1 ->
      exists i', exists s1',
         (SPlus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ bsim_order i' i))
      /\ bsim_match_states i' s1' s2';
    (* bsim_public_preserved: *)
    (*   forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id *)
  }.

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

Lemma bsim_simulation':
  forall L1 L2 (S: backward_simulation L1 L2),
  forall i s2 t s2', Step L2 s2 t s2' ->
  forall s1, S i s1 s2 -> safe L1 s1 ->
  (exists i', exists s1', SPlus L1 s1 t s1' /\ S i' s1' s2')
  \/ (exists i', bsim_order S i' i /\ t = E0 /\ S i' s1 s2').
Proof.
  intros. exploit bsim_simulation; eauto.
  intros [i' [s1' [A B]]]. intuition.
  left; exists i'; exists s1'; auto.
  inv H3.
  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 initial_states_exist:
  forall s1, initial_state L1 s1 -> exists s2, initial_state L2 s2.

Hypothesis match_initial_states:
  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', SPlus L1 s1 t s1' /\ match_states s1' s2'.

Lemma backward_simulation_plus: backward_simulation L1 L2.
Proof.
  apply Backward_simulation with
    (bsim_order := fun (x y: unit) => False)
    (bsim_match_states := fun (i: unit) s1 s2 => match_states s1 s2);
  auto.
  red; intros; constructor; intros. contradiction.
  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.

Variable L1: semantics.
Variable L2: semantics.
Variable S: backward_simulation L1 L2.

Lemma bsim_E0_star:
  forall s2 s2', Star L2 s2 E0 s2' ->
  forall i s1, S i s1 s2 -> safe L1 s1 ->
  exists i', exists s1', Star L1 s1 E0 s1' /\ S 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,
  S 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', SPlus L2 s2 t s2' -> t = E0 ->
  forall i s1, S i s1 s2 -> safe L1 s1 ->
     (exists i', exists s1', SPlus L1 s1 E0 s1' /\ S i' s1' s2')
  \/ (exists i', clos_trans _ (bsim_order S) i' i /\ S 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.
Variable S12: backward_simulation L1 L2.
Variable S23: backward_simulation L2 L3.

Let bb_index : Type := (bsim_index S12 * bsim_index S23)%type.

Let bb_order : bb_index -> bb_index -> Prop :=
  lex_ord (clos_trans _ (bsim_order S12)) (bsim_order S23).

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

Lemma bb_match_at: forall i1 i2 s1 s3 s2,
  S12 i1 s1 s2 -> S23 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, S12 i1 s1 s2 -> S23 i2 s2 s3 -> safe L1 s1 ->
  exists i', exists s1',
    (SPlus 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; 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. eexact P. eauto. auto. intros [i1' [s1x [X Y]]].
  exploit bsim_simulation'. 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',
    (SPlus 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; 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.

Lemma compose_backward_simulation: backward_simulation L1 L3.
Proof.
  apply Backward_simulation with (bsim_order := bb_order) (bsim_match_states := bb_match_states).
(* well founded *)
  unfold bb_order. apply wf_lex_ord. apply wf_clos_trans. apply bsim_order_wf. apply bsim_order_wf.
(* initial states exist *)
  intros. exploit (bsim_initial_states_exist S12); eauto. intros [s2 A].
  eapply (bsim_initial_states_exist S23); eauto.
(* match initial states *)
  intros s1 s3 INIT1 INIT3.
  exploit (bsim_initial_states_exist S12); eauto. intros [s2 INIT2].
  exploit (bsim_match_initial_states S23); eauto. intros [i2 [s2' [INIT2' M2]]].
  exploit (bsim_match_initial_states S12); eauto. intros [i1 [s1' [INIT1' M1]]].
  exists (i1, i2); exists s1'; intuition. eapply bb_match_at; eauto.
(* match final states *)
  intros i s1 s3 r MS SAFE FIN. inv MS.
  exploit (bsim_match_final_states S23); eauto.
    eapply star_safe; eauto. eapply bsim_safe; eauto.
  intros [s2' [A B]].
  exploit bsim_E0_star. eapply star_trans. eexact H0. eexact A. auto. eauto. auto.
  intros [i1' [s1' [C D]]].
  exploit (bsim_match_final_states S12); 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 S23). eauto. eapply star_safe; eauto. eapply bsim_safe; eauto.
(* simulation *)
  exact bb_simulation.
(* symbols *)
  (* intros. transitivity (Senv.public_symbol (symbolenv L2) id); apply bsim_public_preserved; auto. *)
Qed.

End COMPOSE_BACKWARD_SIMULATIONS.

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

Section FORWARD_TO_BACKWARD.

Variable L1: semantics.
Variable L2: semantics.
Variable FS: forward_simulation L1 L2.
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'' ->
      SPlus L2 s2 t s2' ->
      FS i' s1' s2 ->
      FS i'' s1'' s2' ->
      f2b_transitions s1 s2.

Lemma f2b_progress:
  forall i s1 s2, FS i s1 s2 -> safe L1 s1 -> f2b_transitions s1 s2.
Proof.
  intros i0; pattern i0. apply well_founded_ind with (R := fsim_order FS).
  apply fsim_order_wf.
  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: SPlus L2 s2 t s2' \/ (s2' = s2 /\ t = E0 /\ fsim_order FS i' i)).
    intuition.
    destruct (star_inv H0); intuition.
  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, FS i s1 s2 ->
  exists i', exists s2', SPlus L2 s2 t s2' /\ FS 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,
      FS 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) (globalenv L2) n s2 t s2a ->
      FS i s1 s2b ->
      f2b_match_states (F2BI_before n) s1 s2
  | f2b_match_after: forall n s2 s2a s1 i,
      starN (step L2) (globalenv L2) (S n) s2 E0 s2a ->
      FS 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) (globalenv L2) n s2 E0 s2a ->
  FS 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',
    (SPlus 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.

(** The backward simulation *)

Lemma forward_to_backward_simulation: backward_simulation L1 L2.
Proof.
  apply Backward_simulation with (bsim_order := f2b_order) (bsim_match_states := f2b_match_states).
  apply wf_f2b_order.
(* initial states exist *)
  intros. exploit (fsim_match_initial_states FS); eauto. intros [i [s2 [A B]]].
  exists s2; auto.
(* initial states *)
  intros. exploit (fsim_match_initial_states FS); eauto. intros [i [s2' [A B]]].
  assert (s2 = s2') by (eapply sd_initial_determ; eauto). subst s2'.
  exists (F2BI_after O); exists s1; 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 *)
  exact f2b_simulation_step.
(* symbols preserved *)
  (* exact (fsim_public_preserved FS). *)
Qed.

End FORWARD_TO_BACKWARD.

(** * 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 (ge: genvtype L): (trace * state L) -> trace -> (trace * state L) -> Prop :=
  | atomic_step_silent: forall s s',
      Step L s E0 s' ->
      atomic_step ge (E0, s) E0 (E0, s')
  | atomic_step_start: forall s ev t s',
      Step L s (ev :: t) s' ->
      atomic_step ge (E0, s) (ev :: nil) (t, s')
  | atomic_step_continue: forall ev t s,
      output_trace (ev :: t) ->
      atomic_step ge (ev :: t, s) (ev :: nil) (t, s).

Definition atomic : semantics := {|
  state := (trace * state L)%type;
  genvtype := genvtype L;
  step := atomic_step;
  initial_state := fun s => initial_state L (snd s) /\ fst s = E0;
  final_state := fun s r => final_state L (snd s) r /\ fst s = E0;
  globalenv := globalenv L;
  (* symbolenv := symbolenv 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.
Variable sim: forward_simulation L1 L2.
Hypothesis L2single: single_events L2.

Inductive ffs_match: fsim_index sim -> (trace * state L1) -> state L2 -> Prop :=
  | ffs_match_at: forall i s1 s2,
      sim 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' -> sim 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, SPlus 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',
     (SPlus L2 s2 t s2' \/ (Star L2 s2 t s2') /\ fsim_order sim 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.

Theorem factor_forward_simulation:
  forward_simulation (atomic L1) L2.
Proof.
  apply Forward_simulation with (fsim_match_states := ffs_match) (fsim_order := fsim_order sim).
(* wf *)
  apply fsim_order_wf.
(* initial states *)
  intros. destruct s1 as [t1 s1]. simpl in H. destruct H. subst.
  exploit (fsim_match_initial_states sim); 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 *)
  exact ffs_simulation.
(* symbols preserved *)
  (* simpl. exact (fsim_public_preserved sim). *)
Qed.

End FACTOR_FORWARD_SIMULATION.

(** 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.
Variable sim: backward_simulation L1 L2.
Hypothesis L1single: single_events L1.
Hypothesis L2wb: well_behaved_traces L2.

Inductive fbs_match: bsim_index sim -> state L1 -> (trace * state L2) -> Prop :=
  | fbs_match_intro: forall i s1 t s2 s1',
      Star L1 s1 t s1' -> sim 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',
     (SPlus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ bsim_order sim 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.

Theorem factor_backward_simulation:
  backward_simulation L1 (atomic L2).
Proof.
  apply Backward_simulation with (bsim_match_states := fbs_match) (bsim_order := bsim_order sim).
(* wf *)
  apply bsim_order_wf.
(* initial states exist *)
  intros. exploit (bsim_initial_states_exist sim); eauto. intros [s2 A].
  exists (E0, s2). simpl; auto.
(* initial states match *)
  intros. destruct s2 as [t s2]; simpl in H0; destruct H0; subst.
  exploit (bsim_match_initial_states sim); eauto. intros [i [s1' [A B]]].
  exists i; exists s1'; 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 *)
  exact fbs_progress.
(* simulation *)
  exact fbs_simulation.
(* symbols *)
  (* simpl. exact (bsim_public_preserved sim). *)
Qed.

End FACTOR_BACKWARD_SIMULATION.

(** 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) (globalenv L) s1 T
}.


Require Import Coq.Classes.Morphisms.
Require Import Fiat.Computation.Core.

Global Instance ret_Proper_eq {A}
  : Proper (eq ==> eq) (ret (A:=A)).
Proof. repeat intro; subst; reflexivity. Qed.
Global Instance refine_Proper_eq_iff {A}
  : Proper (eq ==> eq ==> iff) (@refine A).
Proof. repeat intro; subst; reflexivity. Qed.
Global Instance refine_Proper_eq_impl {A}
  : Proper (eq ==> eq ==> Basics.impl) (@refine A) | 1.
Proof. repeat (assumption || subst || intro). Qed.
Global Instance refine_Proper_eq_flip_impl {A}
  : Proper (eq ==> eq ==> Basics.flip Basics.impl) (@refine A) | 1.
Proof. repeat (assumption || subst || intro). Qed.


Require Import Coq.ZArith.BinInt.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Import ListNotations.

Require Import Util.

(*TODO: where do we need this? See. Also should we use Interval package?*)
Record int_range := mk_intrng { ir_lower : Z; ir_upper: Z}.

(* TODO: should really be machine-length integers *)
Record float_format := mk_floatfmt {
    fp_exponent_digits : Z;
    fp_significand_digits : Z
}.

(*TODO: do we need attributes or tag?*)
(* Need tag for comparison (use as key in map) *)
Record ident : Type := mk_ident {
    id_string : string;
    id_tag : Z (*We just use the concrete type, not hashtable tag*)
}.

Definition ident_eq_dec: forall (i1 i2: ident), {i1 = i2} + {i1 <> i2}.
Proof.
    solve_eq_dec.
Defined.

(*In the real implementation, there is a mutable counter for the tags of
    each ident that is registered (in id_register in ident.ml). Instead,
    we assume the existence of an injective string -> Z function (which
    does exist and we may write it later), and just use the fact that the
    string names are unique.*)
Section MakeTag.

Axiom string_to_Z : string -> Z.
Axiom string_to_Z_inj: forall s1 s2, string_to_Z s1 = string_to_Z s2 -> s1 = s2.

End MakeTag.

Definition mk_id (s: string) : ident := mk_ident s (string_to_Z s).

(*Types*)

Record tvsymbol : Type :=
    mk_tvsym { tv_name : ident }.

Definition tvsymbol_eq_dec: forall (t1 t2: tvsymbol), {t1 = t2} + {t1 <> t2}.
Proof.
    solve_eq_dec.
Defined.

(*Simplified version of types with no mutual recursion.
  We do not include Range/Float because they are not used
  in the frama-C translation.
  Frama-C does ues Alias, which we represent with an option type.*)

Inductive ty : Type :=
    | Tyvar : (ident * list tvsymbol * option ty) -> ty
    | Tyapp : (ident * list tvsymbol * option ty) -> list ty -> ty
    | Alias : ty -> ty.

Notation tysymbol := (ident * list tvsymbol * option ty)%type.

(*A more faithful (but annoying to use) version would be:

Inductive type_def (A: Type) : Type :=
    | NoDef : type_def A
    | Alias : A -> type_def A
    | Range : int_range -> type_def A
    | Float : float_format -> type_def A.

Inductive tysymbol : Type :=
    | mk_tysym : ident -> list tvsymbol -> type_def ty -> tysymbol
(*simplified version - ignore tags, combine ty and ty_node into 1*)
with ty : Type := (*ignoring tag*)
    | mk_ty : ty_node -> ty
with ty_node : Type :=
    | Tyvar : tvsymbol -> ty_node
    | Tyapp : tysymbol -> list ty -> ty_node.
*)

(*The default induction principle is useless, we need a better one:*)

Definition p_opt {A: Type} (P: A -> Prop) (o: option A) : Prop :=
    match o with
    | None => True
    | Some x => P x
    end.

Section TyInd.

Variable P: ty -> Prop.
Variable Hvar: forall (i: ident) (l: list tvsymbol) (o: option ty),
    p_opt P o -> P (Tyvar (i, l, o)).
Variable Happ: forall (i: ident) (l: list tvsymbol) (o: option ty) (lty: list ty),
    p_opt P o -> Forall P lty ->P (Tyapp (i, l, o) lty).
Variable Halias: forall (t: ty), P t -> P (Alias t).

Fixpoint ty_ind' (t: ty): P t :=
let f := (fix list_ty_ind (ls: list ty) : Forall P ls :=
    match ls with
    | nil => (@Forall_nil ty P)
    | (x :: tl) => @Forall_cons ty P _ _ (ty_ind' x) (list_ty_ind tl)
    end) in
match t with
| Tyvar (i, l, (Some t)) => Hvar i l (Some t) (ty_ind' t)
| Tyvar (i, l, None) => Hvar i l None I
| Tyapp (i, l, Some t) lty => Happ i l (Some t) lty (ty_ind' t) (f lty)
| Tyapp (i, l, None) lty => Happ i l None lty I (f lty)
| Alias t' => Halias t' (ty_ind' t')
end.

End TyInd.

(* Decidable Equality on Types *)

(*Writing functions over this type is quite annoying, due to the nested
  options/lists*)
Fixpoint ty_eqb (t1 t2: ty) : bool :=
    match t1, t2 with
    | Tyvar (i1, l1, o1), Tyvar (i2, l2, o2) =>
        (ident_eq_dec i1 i2) &&
        (list_eq_dec tvsymbol_eq_dec l1 l2) &&
        match o1, o2 with
        | Some t1', Some t2' => ty_eqb t1' t2'
        | None, None => true
        | _, _ => false
        end
    | Tyapp (i1, l1, o1) tyl1, Tyapp (i2, l2, o2) tyl2 =>
        (ident_eq_dec i1 i2) &&
        (list_eq_dec tvsymbol_eq_dec l1 l2) &&
        match o1, o2 with
        | Some t1', Some t2' => ty_eqb t1' t2'
        | None, None => true
        | _, _ => false
        end &&
        ((fix eqb_ty_list (l1: list ty) (l2: list ty) : bool :=
            match l1, l2 with
            | nil, nil => true
            | t1 :: tl1, t2 :: tl2 => (ty_eqb t1 t2) && (eqb_ty_list tl1 tl2)
            | _, _ => false
            end) tyl1 tyl2)
    | Alias t1', Alias t2' => ty_eqb t1' t2'
    | _, _ => false
    end.

Ltac contra :=
    let C := fresh in
    intro C; inversion C; subst; contradiction.

Ltac destruct_eq x :=
    destruct x; simpl; [|contra].

Lemma eqb_ty_list_simpl: forall l l',
(fix eqb_ty_list (l1 l2 : list ty) {struct l1} : bool :=
match l1 with
| [] => match l2 with
        | [] => true
        | _ :: _ => false
        end
| t1 :: tl1 =>
    match l2 with
    | [] => false
    | t2 :: tl2 => ty_eqb t1 t2 && eqb_ty_list tl1 tl2
    end
end) l l' = (Nat.eqb (length l) (length l')) && forallb id (map2 l l' (fun x y => ty_eqb x y)).
Proof.
    intros l. induction l as [|h t IH]; intros l'; simpl.
    - destruct l'; reflexivity.
    - destruct l' as [|h1 t1]; simpl; auto.
      rewrite IH; simpl. rewrite andb_comm, andb_assoc.
      unfold id at 2. rewrite <- andb_assoc.
      rewrite (andb_comm _ (ty_eqb _ _)), andb_assoc.
      reflexivity.
Qed.

Lemma ty_eqb_eq: forall (t1 t2: ty),
    ty_eqb t1 t2 = true ->
    t1 = t2.
Proof.
    intros t1. induction t1 using ty_ind'.
    - intros t2. destruct t2; simpl; try contra.
      destruct p as [[i2 l2] o2]; simpl.
      destruct_eq (ident_eq_dec i i2).
      destruct_eq (list_eq_dec tvsymbol_eq_dec l l2).
      subst.
      destruct o as [t1|]; destruct o2 as [t2|]; try contra;[|reflexivity].
      simpl in H. intro Heq. subst. rewrite (H t2); auto.
    - intros t2. destruct t2; simpl; try contra.
      destruct p as [[i2 l2] o2]; simpl.
      destruct_eq (ident_eq_dec i i2).
      destruct_eq (list_eq_dec tvsymbol_eq_dec l l2).
      subst. intros Heq; apply andb_prop in Heq; destruct Heq.
      assert (lty = l0). {
          rewrite eqb_ty_list_simpl in H2.
          apply andb_prop in H2; destruct H2.
          apply EqNat.beq_nat_true in H2.
          rewrite map2_combine, forallb_forall in H3.
          apply list_combine_eq; auto.
          intros x y Hinxy. assert(Hmap:=Hinxy).
          eapply in_map in Hmap. apply H3 in Hmap.
          simpl in Hmap. unfold id in Hmap.
          apply in_combine_l in Hinxy.
          rewrite Forall_forall in H0. apply H0; assumption.
      } subst; clear H2.
      destruct o as [t1|]; destruct o2 as [t2|]; try solve[inversion H1].
      rewrite (H t2) by assumption. all: reflexivity.
    - simpl. intros t2; destruct t2; try contra; intros Heq.
      rewrite (IHt1 t2); auto.
Qed.

Lemma ty_eqb_refl: forall (t: ty),
    ty_eqb t t = true.
Proof.
    intros t; induction t using ty_ind'; simpl.
    - destruct (ident_eq_dec i i); auto.
      destruct (list_eq_dec tvsymbol_eq_dec l l); auto.
      simpl. destruct o; simpl in *; auto.
    - destruct (ident_eq_dec i i); auto.
      destruct (list_eq_dec tvsymbol_eq_dec l l); auto.
      simpl.
      (*Need nested lemma for fixpoint here:*)
      assert (
      (fix eqb_ty_list (l1 l2 : list ty) {struct l1} : bool :=
      match l1 with
      | [] => match l2 with
              | [] => true
              | _ :: _ => false
              end
      | t1 :: tl1 =>
          match l2 with
          | [] => false
          | t2 :: tl2 => ty_eqb t1 t2 && eqb_ty_list tl1 tl2
          end
      end) lty lty = true). {
        rewrite eqb_ty_list_simpl. apply andb_true_intro.
        split.
        - apply PeanoNat.Nat.eqb_refl.
        - rewrite map2_combine; apply forallb_forall. intros x Hin.
          rewrite in_map_iff in Hin. destruct Hin as [[t1 t2] [Heq Hin]].
          simpl in *; subst. assert (Heq:=Hin).
          apply in_combine_same in Heq; subst. apply in_combine_l in Hin.
          rewrite Forall_forall in H0. apply H0. assumption.
      }
      rewrite H1; clear H1.
      destruct o; simpl in *; auto.
      rewrite H. reflexivity.
    - assumption.
Qed.

Lemma ty_eqb_eq_iff: forall (t1 t2: ty),
  Bool.reflect (t1 = t2) (ty_eqb t1 t2).
Proof.
    intros t1 t2. destruct (ty_eqb t1 t2) eqn : Heq.
    - apply ReflectT. apply ty_eqb_eq. assumption.
    - apply ReflectF. intro C; subst.
      rewrite ty_eqb_refl in Heq. inversion Heq.
Qed.

Definition ty_eq_dec: forall (t1 t2: ty), {t1 = t2} + {t1 <> t2} :=
    fun t1 t2 => reflect_dec _ _ (ty_eqb_eq_iff t1 t2).

Definition tysymbol_eq_dec: forall (t1 t2: tysymbol), {t1 = t2} + {t1 <> t2}.
Proof.
    intros t1 t2. decide equality.
    - apply option_eq_dec. intros a1 a2. apply ty_eq_dec.
    - solve_eq_dec.
Qed.

(* Type constructors *)
Definition mk_ts (name: string) (args: list tvsymbol) (def: option ty) : tysymbol :=
    ((mk_id name), args, def).

(* Built in type symbols *)
Definition ts_int : tysymbol :=
    mk_ts "int" nil None.

Definition ts_real : tysymbol :=
    mk_ts "real" nil None.

Definition ts_bool : tysymbol :=
    mk_ts "bool" nil None.

Definition ts_str : tysymbol :=
    mk_ts "string" nil None.

(*Their implementation uses mutable hashtables and lots of exceptions.
    This is a simpler version for the types we need*)
Definition ty_app (s: tysymbol) (tl : list ty) : ty :=
    (*TODO: ignoring alias for now, may need*)
    Tyapp s tl.

Definition ty_int : ty := ty_app ts_int nil.
Definition ty_real : ty := ty_app ts_real nil.
Definition ty_bool : ty := ty_app ts_bool nil.
Definition ty_str : ty := ty_app ts_str nil.

Definition ts_func : tysymbol :=
    let tv_a := mk_tvsym (mk_id "a") in
    let tv_b := mk_tvsym (mk_id "b") in
    mk_ts "->" [tv_a; tv_b] None.

Definition ty_func (ty_a ty_b : ty) : ty :=
    ty_app ts_func [ty_a; ty_b].

(*a -> bool function*)
Definition ty_pred (ty_a : ty) : ty :=
    ty_app ts_func [ty_a; ty_bool].

(*Tuples*)

Definition nat_to_string (n: nat) : string :=
    (String (Ascii.ascii_of_nat n) EmptyString).

(*In the OCaml impl, each element gets a different id. We model
  that by giving each a different name (technically, this means that
  tuples cannot have more than 256 elements)
  Do these have to be globally unique?*)
Definition ts_tuple (n: nat) : tysymbol :=
    let vl := fold_left (fun acc m => mk_tvsym (mk_id (nat_to_string m)) :: acc)
        (seq 0 n) nil in
    mk_ts ("tuple" ++ nat_to_string n) vl None.

Definition ty_tuple (tyl: list ty) : ty :=
    ty_app (ts_tuple (length tyl)) tyl.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.VSU.
Require Import apile.
Require Import spec_stdlib.
Require Import spec_pile.
Require Import spec_pile_private.
Require Import spec_apile.

#[export] Instance APileCompSpecs : compspecs. make_compspecs prog. Defined.

Section Apile_VSU.
Variable M: MallocFreeAPD.
Variable PILEPRIV: PilePrivateAPD M. (*apile is parametric in a PRIVATE pile predicate structure*)

Definition apile (sigma: list Z) (gv: globals): mpred :=
  !!(headptr (gv _a_pile)) && pilerep PILEPRIV sigma (gv _a_pile).
(*We define apile in terms of pilerep and then,
  in the proof of make_apile below, use the axiom
  spec_pile_private.pile_rep_exposed
  to exploit the representation exposure*)

Lemma make_apile: forall gv,
  globals_ok gv ->
  data_at Ews size_t nullval (gv apile._a_pile) |-- apile nil gv.
Proof.
intros. unfold apile. rewrite pile_rep_exposed. (*HERE*)
unfold prep.
assert_PROP (headptr (gv _a_pile)) by entailer!.
Exists nullval.
unfold listrep. entailer!.
unfold_data_at (data_at _ spec_pile.tpile _ _).
rewrite field_at_data_at. simpl.
rewrite field_compatible_field_address
   by auto with field_compatible.
simpl. normalize.
rewrite <- data_at_nullptr.
cancel.
Qed.

Lemma apile_Init: VSU_initializer prog (apile nil).
  Proof.
    InitGPred_tac.  rewrite sepcon_emp.
    apply make_apile; auto.
Qed.

Definition APILE: APileAPD := Build_APileAPD apile (*APileCompSpecs make_apile*) (*_ apile_Init*).

  Definition Apile_ASI: funspecs := ApileASI M APILE.

  Definition apile_imported_specs:funspecs :=
     [ Pile_add_spec M PILEPRIV; Pile_count_spec PILEPRIV].

  Definition apile_internal_specs: funspecs := Apile_ASI.

  Definition ApileVprog: varspecs. mk_varspecs prog. Defined.
  Definition ApileGprog: funspecs := apile_imported_specs ++ apile_internal_specs.

Lemma body_Apile_add: semax_body ApileVprog ApileGprog f_Apile_add (Apile_add_spec M APILE).
Proof.
start_function.
simpl spec_apile.apile. unfold apile; Intros.
forward_call (gv _a_pile, n,sigma,gv).
entailer!. simpl. unfold apile. entailer!.
Qed.

Lemma body_Apile_count: semax_body ApileVprog ApileGprog f_Apile_count (Apile_count_spec M APILE).
Proof.
start_function.
simpl spec_apile.apile. unfold apile in *; Intros.
forward_call (gv _a_pile, sigma).
forward.
entailer!. simpl. unfold apile. entailer!.
Qed.

Definition ApileVSU: @VSU NullExtension.Espec
      nil apile_imported_specs ltac:(QPprog prog) Apile_ASI (apile nil).
Proof.
 mkVSU prog apile_internal_specs.
    + solve_SF_internal body_Apile_add.
    + solve_SF_internal body_Apile_count.
    + apply apile_Init.
  Qed.

End Apile_VSU.