(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)
Set Implicit Arguments.
(** ** BSM recues to MM *)
Tactic Notation "rew" "length" := autorewrite with length_db.
Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).
Local Notation "I '/BSM/' s -1> t" := (bsm_sss I s t) (at level 70, no associativity).
Local Notation "P '/BSM/' s -+> t" := (sss_progress (@bsm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/BSM/' s ->> t" := (sss_compute (@bsm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/BSM/' s ~~> t" := (sss_output (@bsm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/BSM/' s ↓" := (sss_terminates (@bsm_sss _) P s)(at level 70, no associativity).
Local Notation "P '/MM/' s -+> t" := (sss_progress (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/MM/' s ->> t" := (sss_compute (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/MM/' s '~~>' t" := (sss_output (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P '/MM/' s ↓" := (sss_terminates (@mm_sss _) P s)(at level 70, no associativity).
Section simulator.
Ltac dest x y := destruct (pos_eq_dec x y) as [ | ]; [ subst x | ]; rew vec.
Variables (m : nat).
(** each stack of the BSM corresponds to a (unique) register in the MM and there are extra registers: tmp1, tmp2 which must have value 0 at start they might change value during a simulated BSM instruction but when the instruction is finished, their values are back to 0  This is expressed in the below bsm_state_enc invariant *)
Let n := 2+m.
Let tmp1 : pos n := pos0.
Let tmp2 : pos n := pos1.
Let reg p: pos n := pos_nxt (pos_nxt p).
Let Hv12 : tmp1 <> tmp2.             Proof. discriminate. Qed.
Let Hvr1 : forall p, reg p <> tmp1.  Proof. discriminate. Qed.
Let Hvr2 : forall p, reg p <> tmp2.  Proof. discriminate. Qed.
Let Hreg : forall p q, reg p = reg q -> p = q.
Hint Resolve bsm_instr_compile_sound.
Section bsm_sim.
Variable (iP : nat) (cP : list (bsm_instr m)).
Let lnk_Q_pair := @gen_compiler_correction _ _ _ _ bsm_instr_compile_length_eq _ _ _ _  (@bsm_sss_total' _)
(@mm_sss_fun _) _ bsm_instr_compile_sound (iP,cP) 1.
Let lnk := projT1 lnk_Q_pair.
Let Q := proj1_sig (projT2 lnk_Q_pair).
Let Hlnk : fst Q = 1 /\ lnk iP = 1 /\ forall i, out_code i (iP,cP) -> lnk i = code_end Q.
Infix "⋈" := bsm_state_enc (at level 70, no associativity).
Let HQ1 : forall i1 v1 w1 i2 v2, v1 ⋈ w1 /\ (iP,cP) /BSM/ (i1,v1) ~~> (i2,v2)
-> exists w2,    v2 ⋈ w2 /\ Q /MM/ (lnk i1,w1) ~~> (lnk i2,w2).
(** (iQ,cQ) simulates termination of (iP,cP) while ensuring tmp1 and tmp2 stay void when it terminates *)
Let Q_spec1 : (iP,cP) /BSM/ (iP,v) ↓ -> exists w', Q /MM/ (1,w) ~~> (code_end Q, w') /\ w'#>tmp1 = 0 /\ w'#>tmp2 = 0.
Let Q_spec2 : Q /MM/ (1,w) ↓ -> (iP,cP) /BSM/ (iP,v) ↓.
Definition bsm_mm_sim := snd Q.

(* Specifications: *)
Theorem bsm_mm_sim_spec : (iP,cP) /BSM/ (iP,v) ↓ <-> (1,bsm_mm_sim) /MM/ (1,w) ↓.
Let iE := code_end Q.