(* Correctness of the Assume Insertion with Delay pass *)
(* A pass of the dynamic optimizer *)
(* Inserts a new Assume after a Condition instruction, which is itself after a Framestate *)

Require Export assume_insertion_proof.
Require Export interpreter_proof.
Require Export specIR.
Require Export ir_properties.
Require Export internal_simulations.
Require Export inlining.
Require Export assume_insertion_delay.
Require Export def_regs.

(** * Matching the stack and properties  *)
(* Matching stackframes: a version may have been replaced with its optimized version *)
Inductive match_stackframe (v:version) (fid:fun_id) (guard:list expr) (fsl:label) (condl:label) (params:list reg): stackframe -> stackframe -> Prop :=
| frame_same:
    forall sf, (match_stackframe v fid guard fsl condl params) sf sf
| frame_opt:
    forall r lbl rm vins abs
      (AS_INSERT: insert_assume_version v fid guard fsl params = OK vins)
      (DEFREGS: defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs)
      (DEF: forall retval, defined (rm#r<-retval) (def_absstate_get lbl abs))
      (RET_COND: lbl <> condl),
      (match_stackframe v fid guard fsl condl params) (Stackframe r v lbl rm) (Stackframe r vins lbl rm).

(* Generalizing match_stackframe to the entire stack *)
Inductive match_stack (v:version) (fid:fun_id) (guard:list expr) (fsl:label) (condl:label) (params:list reg): stack -> stack -> Prop :=
| match_nil:
    (match_stack v fid guard fsl condl params) nil nil
| match_cons:
    forall s s' sf sf'
      (MS: (match_stack v fid guard fsl condl params) s s')
      (MSF: (match_stackframe v fid guard fsl condl params) sf sf'),
      (match_stack v fid guard fsl condl params) (sf::s) (sf'::s').

Lemma match_stack_same:
  forall s v fid guard fsl condl params,
    (match_stack v fid guard fsl condl params) s s.
Proof.
  intros s v fid guard fsl. induction s; constructor. auto. constructor.
Qed.

Lemma match_app:
  forall synth s s' v fid guard fsl condl params,
    (match_stack v fid guard fsl condl params) s s' ->
    (match_stack v fid guard fsl condl params) (synth++s) (synth++s').
Proof.
  intros. induction synth.
  - simpl. auto.
  - repeat rewrite <- app_comm_cons. apply match_cons. auto. constructor.
Qed.

Lemma app_match:
  forall synth synthopt s s' v fid guard fsl condl params,
    (match_stack v fid guard fsl condl params) s s' ->
    (match_stack v fid guard fsl condl params) synth synthopt ->
    (match_stack v fid guard fsl condl params) (synth++s) (synthopt++s').
Proof.
  intros. induction H0.
  - simpl. auto.
  - repeat rewrite <- app_comm_cons. apply match_cons; auto.
Qed.

(** * Index and order used in the simulation *)
(* There is one stuttering step for each inserted Framestate *)
Inductive as_index: Type :=
| Two : as_index
| One : as_index
| Zero: as_index.

Inductive as_order: as_index -> as_index -> Prop :=
| order10: as_order Zero One
| order21: as_order One Two
| order20: as_order Zero Two.

Lemma wfounded: well_founded as_order.
Proof.
  unfold well_founded. intros a. constructor. intros y H. inv H.
  - constructor. intros y H. inv H.
  - constructor. intros y H. inv H. constructor. intros y H. inv H.
  - constructor. intros y H. inv H.
Qed.

Lemma trans: Relation_Definitions.transitive _ as_order.
Proof.
  unfold Relation_Definitions.transitive. intros x y z H H0. inv H; inv H0. constructor.
Qed.

(** * The match_states relation  *)
(* This proof is a backward internal simulation.
   At the Framestate and the Condition, we take stuttering steps.
   During these stuttering steps, the invariant contains enough information
   for the source program to catch up the delay if we're not going to deoptimize
   (either because we don't take the true branch, or because the guard succeeds)

<<

       st1 --------------- st2
        |                   |
       t|(1, 2 or 3 steps)  |t
        |                   |
        v                   v
       st1'--------------- st2'

>>
*)

Inductive match_states (p:program) (v:version) (fid:fun_id) (guard: list expr) (fsl:label) (condl:label) (params:list reg): as_index -> specIR.state -> specIR.state -> Prop :=

  | assume_match:                     (* matching at the assume instruction *)
    forall vins s s' rm ms fa la vm sl synth newver newrm iftrue iffalse condexpr vcond abs
      (MATCHSTACK: (match_stack v fid guard fsl condl params) s s')
      (OPT: insert_assume_version v fid guard fsl params = OK vins)
      (COND: eval_expr condexpr rm (Vint vcond)) (* We only do this match if the condition holds *)
      (TRUE: vcond <> 0)

      (DEFREGS: defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs)
      (DEF: defined rm (def_absstate_get fsl abs))
      (VALIDATE: validator v fsl guard params = OK tt)

      (FS_SRC: (ver_code v) # fsl = Some (Framestate (fa,la) vm sl condl))
      (CO_SRC: (ver_code v) # condl = Some (Cond condexpr iftrue iffalse))
      (FS_OPT: (ver_code vins) # fsl = Some (Framestate (fa,la) vm sl condl))
      (CO_OPT: (ver_code vins) # condl = Some (Cond condexpr (fresh_label (Pos.succ condl) (ver_code v)) iffalse))
      (AS_OPT: (ver_code vins) # (fresh_label (Pos.succ condl) (ver_code v)) = Some (Assume guard (fa,la) vm sl iftrue))

      (SYNTH: synthesize_frame p rm sl synth)
      (FINDF: find_base_version fa p = Some newver)
      (UPDATE: update_regmap vm rm newrm),
      (match_states p v fid guard fsl condl params) Zero (State s v fsl rm ms) (State s' vins (fresh_label (Pos.succ condl) (ver_code v)) rm ms)

| cond_match_delay:
    forall vins s s' rm ms fa la vm sl synth newver newrm iftrue iffalse condexpr abs
      (MATCHSTACK: (match_stack v fid guard fsl condl params) s s')
      (OPT: insert_assume_version v fid guard fsl params = OK vins)

      (DEFREGS: defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs)
      (DEF: defined rm (def_absstate_get fsl abs))

      (FS_SRC: (ver_code v) # fsl = Some (Framestate (fa,la) vm sl condl))
      (CO_SRC: (ver_code v) # condl = Some (Cond condexpr iftrue iffalse))
      (FS_OPT: (ver_code vins) # fsl = Some (Framestate (fa,la) vm sl condl))
      (CO_OPT: (ver_code vins) # condl = Some (Cond condexpr (fresh_label (Pos.succ condl) (ver_code v)) iffalse))
      (AS_OPT: (ver_code vins) # (fresh_label (Pos.succ condl) (ver_code v)) = Some (Assume guard (fa,la) vm sl iftrue))

      (SYNTH: synthesize_frame p rm sl synth)
      (FINDF: find_base_version fa p = Some newver)
      (UPDATE: update_regmap vm rm newrm),
      (match_states p v fid guard fsl condl params) One (State s v fsl rm ms) (State s' vins condl rm ms)

| opt_match:           (* matching inside the optimized version *)
    forall vins s s' lbl rm ms abs
      (MATCHSTACK: (match_stack v fid guard fsl condl params) s s')
      (OPT: insert_assume_version v fid guard fsl params = OK vins)

      (DEFREGS: defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs)
      (DEF: defined rm (def_absstate_get lbl abs))

      (NOCOND: lbl <> condl),    (* the condition is matched with delay *)
      (match_states p v fid guard fsl condl params) Two (State s v lbl rm ms) (State s' vins lbl rm ms)

| refl_match:                   (* matching outside of the optimized version *)
    forall v' s s' pc rm ms
      (MATCHSTACK: (match_stack v fid guard fsl condl params) s s'),
      (match_states p v fid guard fsl condl params) Zero (State s v' pc rm ms) (State s' v' pc rm ms)

| final_match:                  (* matching final states *)
    forall retval ms,
      (match_states p v fid guard fsl condl params) Zero (Final retval ms) (Final retval ms).

(** * Code Preservation Properties  *)

Lemma code_preservation':
  forall vsrc vins fid guard fsl lbl tgt vm sl condl params,
    insert_assume_version vsrc fid guard fsl params = OK vins ->
    (ver_code vsrc) ! fsl = Some (Framestate tgt vm sl condl) ->
    lbl <> fsl ->
    lbl <> condl ->
    forall iopt isrc,
      (ver_code vins) # lbl = Some iopt ->
      (ver_code vsrc) # lbl = Some isrc ->
      iopt = isrc.
Proof.
  intros vsrc vins fid guard fsl lbl tgt vm sl condl params OPT CODEFS NOTFS NOTCOND iopt isrc CODEOPT CODESRC.
  unfold insert_assume_version in OPT. repeat do_ok. inv HDO.
  rewrite CODEFS in H1.
  destruct ((ver_code vsrc)!condl) eqn:CODECOND; inv H1. destruct i; inv H0.
  repeat do_ok. destruct u.
  simpl in CODEOPT. rewrite PTree.gso in CODEOPT; auto. rewrite PTree.gso in CODEOPT; auto.
  rewrite CODEOPT in CODESRC. inv CODESRC. auto.
  poseq_destr lbl (fresh_label (Pos.succ condl) (ver_code vsrc)); auto. erewrite fresh_label_correct in CODESRC; auto.
  inv CODESRC.
Qed.

Lemma code_preservation:        (* use at opt_match *)
  forall p p' s s' rm ms t news vsrc vins fid guard fsl lbl tgt vm sl condl params,
    insert_assume_version vsrc fid guard fsl params = OK vins ->
    (ver_code vsrc) ! fsl = Some (Framestate tgt vm sl condl) ->
    lbl <> fsl ->
    lbl <> condl ->
    safe (specir_sem p) (State s vsrc lbl rm ms) ->
    Step (specir_sem p') (State s' vins lbl rm ms) t news ->
    (ver_code vsrc) # lbl = (ver_code vins) # lbl.
Proof.
  intros p p' s s' rm ms t news vsrc vins fid guard fsl lbl tgt vm sl condl params H H0 H1 H2 H3 H4.
  apply safe_code in H3 as [isrc CODESRC]. apply step_code in H4 as [iopt CODEOPT].
  rewrite CODESRC. rewrite CODEOPT. f_equal. symmetry. eapply code_preservation'; eauto.
Qed.

(** * Validator Dominance Properties  *)
(* The Skipped Condition is not the entry of the version *)
Lemma no_entry:
  forall vsrc fsl guard params tgt vm_fs sl_fs condl condexpr iftrue iffalse,
    validator vsrc fsl guard params = OK tt ->
    (ver_code vsrc) ! fsl = Some (Framestate tgt vm_fs sl_fs condl) ->
    (ver_code vsrc) ! condl = Some (Cond condexpr iftrue iffalse) ->
    condl <> (ver_entry vsrc).
Proof.
  intros vsrc fsl guard params tgt vm_fs sl_fs condl condexpr iftrue iffalse VALID FS_CODE CO_CODE.
  unfold validator in VALID. rewrite FS_CODE in VALID. rewrite CO_CODE in VALID.
  destruct (only_pred (ver_code vsrc) condl fsl) eqn:ONLYPRED; inv VALID.
  poseq_destr condl (ver_entry vsrc); auto. inv H0.
Qed.

Lemma fold_and:
    forall X f (l:list X) start,
      fold_left (fun b x => andb b (f x)) l start = true ->
      start = true.
Proof.
  intros X f l start H. generalize dependent start. induction l; intros.
  - simpl in H. auto.
  - simpl in H. specialize (IHl (start && f a) H). unfold andb in IHl.
    destruct start; auto.
Qed.

Lemma in_fold_and:
  forall X f (l:list X) i,
    In i l ->
    fold_left (fun b x => andb b (f x)) l true = true ->
    f i = true.
Proof.
  intros X f l i H H0. induction l. inv H.
  simpl in H. destruct H as [AI|IND].
  - subst. simpl in H0. eapply fold_and; eauto.
  - specialize (IHl IND). apply IHl. simpl in H0. apply fold_and in H0 as FA. rewrite FA in H0. auto.
Qed.

Lemma only_pred_correct:
  forall c next pred,
    only_pred c next pred = true ->
    forall lbl i,
      lbl <> pred ->
      c ! lbl = Some i ->
      not_in_list (instr_succ i) next = true.
Proof.
  intros c next pred ONLYPRED lbl i NOTPRED CODE.
  apply PTree.elements_correct in CODE.
  unfold only_pred in ONLYPRED. rewrite PTree.fold_spec in ONLYPRED.
  eapply in_fold_and in ONLYPRED; eauto. simpl in ONLYPRED.
  poseq_destr lbl pred. contradiction. auto.
Qed.

(* If you're not at the Framestate, you can't get into the Condition *)
Lemma no_cond:
  forall vsrc fsl guard params tgt vm_fs sl_fs condl,
    validator vsrc fsl guard params = OK tt ->
    (ver_code vsrc) ! fsl = Some (Framestate tgt vm_fs sl_fs condl) ->
    forall lbl i,
      lbl <> fsl ->
      (ver_code vsrc) ! lbl = Some i ->
      not_in_list (instr_succ i) condl = true.
Proof.
  intros vsrc fsl guard params tgt vm_fs sl_fs condl VALID CODE_FS lbl i NOTFS CODE.
  unfold validator in VALID. rewrite CODE_FS in VALID.
  destruct ((ver_code vsrc)!condl) eqn:CODE_COND; inv VALID. destruct i0; inv H0.
  destruct (only_pred (ver_code vsrc) condl fsl) eqn:ONLY_PRED; inv H1.
  eapply only_pred_correct; eauto.
Qed.

Lemma preservation_code:
  forall vsrc vins fid guard fsl lbl params i tgt vm sl condl,
    insert_assume_version vsrc fid guard fsl params = OK vins ->
    (ver_code vsrc) # fsl = Some (Framestate tgt vm sl condl) ->
    lbl <> fsl -> lbl <> condl ->
    (ver_code vsrc) # lbl = Some i ->
    (ver_code vins) # lbl = Some i.
Proof.
  intros vsrc vins fid guard fsl lbl params i tgt vm sl condl H H0 H1 H2 H3.
  unfold insert_assume_version in H. repeat do_ok. inv HDO. rewrite H0 in H4.
  destruct ((ver_code vsrc)!condl) eqn:CONDCODE; inv H4. destruct i0; inv H5. repeat do_ok.
  simpl. rewrite PTree.gso; auto. rewrite PTree.gso; auto.
  poseq_destr lbl (fresh_label (Pos.succ condl) (ver_code vsrc)); auto.
  erewrite fresh_label_correct in H3; auto. inv H3.
Qed.

(** * Progress Preservation  *)
Lemma progress_preserved:
  forall f vsrc vins fid guard fsl condl params s1 s2 p i tgt vm sl,
    insert_assume_version vsrc fid guard fsl params = OK vins ->
    find_function fid p = Some f ->
    vsrc = current_version f ->
    match_states p vsrc fid guard fsl condl params i s1 s2 ->
    safe (specir_sem p) s1 ->
    (ver_code vsrc) ! fsl = Some (Framestate tgt vm sl condl) ->
    (exists r : value, final_state (set_version p fid vins) s2 r) \/
    (exists (t : trace) (s2' : Smallstep.state (specir_sem (set_version p fid vins))),
        Step (specir_sem (set_version p fid vins)) s2 t s2').
Proof.
  intros f vsrc vins fid guard fsl condl params s1 s2 p i tgt vm sl OPTV FINDOPT CURVER MATCH SAFE FS_CODE.
  inv MATCH.
  - unfold validator in VALIDATE. rewrite FS_SRC in VALIDATE. rewrite CO_SRC in VALIDATE.
    destruct (only_pred (ver_code (current_version f)) condl fsl) eqn:ONLY; inv VALIDATE.
    poseq_destr condl (ver_entry (current_version f)). inv H0. repeat do_ok.
    destruct (def_absstate_get condl d) eqn:ABSDR; inv H1.
    destruct (check_guard guard r) eqn:CHECK; inv H0.
    inv DEFREGS. assert (DEF': defined rm (def_absstate_get condl abs)).
    { def_ok. rewrite FS_SRC. auto. }
    rewrite ABSDR in DEF'. eapply evaluate_succeeds in CHECK as [v EVAL]; eauto.
    right. exists E0. rewrite OPT in OPTV. inv OPTV. destruct v.
    + exists (State s' vins iftrue rm ms). apply nd_exec_lowered. eapply exec_Assume_holds; eauto.
    + exists (State (synth++s') newver la newrm ms). eapply nd_exec_lowered. eapply exec_Assume_fails; eauto.
      simpl. rewrite <- base_version_unchanged. auto. simpl. apply synth_frame_unchanged. auto.

  - rewrite OPT in OPTV. inv OPTV. right. exists E0.
    assert (SAFE': safe (specir_sem p) (State s (current_version f) condl rm ms)).
    { eapply star_safe; eauto. apply plus_star. apply plus_one. eapply nd_exec_Framestate_go_on.
      econstructor; eauto. }
    assert (exists v, eval_expr condexpr rm v).
    { apply safe_step in SAFE'. destruct SAFE' as [s'' [t CONDSTEP]]. inv CONDSTEP.
      inv STEP; rewrite CODE in CO_SRC; inv CO_SRC. eauto.
      inv DEOPT_COND; rewrite CODE in CO_SRC; inv CO_SRC.
      inv DEOPT_COND; rewrite CODE in CO_SRC; inv CO_SRC. }
    destruct H as [v EVAL]. destruct v. destruct z.
    + exists (State s' vins iffalse rm ms). apply nd_exec_lowered. eapply exec_Cond; eauto.
    + exists (State s' vins (fresh_label (Pos.succ condl) (ver_code (current_version f))) rm ms). apply nd_exec_lowered.
      eapply exec_Cond; eauto.
    + exists (State s' vins (fresh_label (Pos.succ condl) (ver_code (current_version f))) rm ms). apply nd_exec_lowered.
      eapply exec_Cond; eauto.

  - poseq_destr lbl fsl.
    + rewrite OPT in OPTV. inv OPTV. unfold insert_assume_version in OPT. repeat do_ok.
      destruct (c!fsl) eqn:CODEFS; inv H1. destruct i; inv H0.
      destruct (c!l0) eqn:CODECOND; inv H1. destruct i; inv H0.
      right. exists E0. exists (State s' vins l0 rm ms).
      repeat do_ok. simpl. destruct d. apply safe_step in SAFE as STEP. destruct STEP as [s'' [t STEP]].
      inv HDO. inv STEP.
      * inv STEP0; rewrite CODEFS in CODE; inv CODE.
      * inv DEOPT_COND. rewrite CODEFS in CODE. inv CODE. destruct tgt.
        eapply nd_exec_Framestate_go_on. econstructor; eauto. simpl. rewrite PTree.gso; auto.
        rewrite PTree.gso; auto. eauto. rewrite CODEFS in FS_CODE. inv FS_CODE. auto.
        poseq_destr fsl (fresh_label (Pos.succ next) (ver_code (current_version f))); auto.
        erewrite fresh_label_correct in CODEFS; eauto. inv CODEFS. eauto.
        simpl. rewrite <- base_version_unchanged. eauto. apply synth_frame_unchanged. eauto.
      * inv DEOPT_COND. rewrite CODEFS in CODE. inv CODE. destruct tgt.
        eapply nd_exec_Framestate_go_on. econstructor; eauto. simpl. rewrite PTree.gso; auto.
        rewrite PTree.gso; auto. eauto. rewrite CODEFS in FS_CODE. inv FS_CODE. auto.
        poseq_destr fsl (fresh_label (Pos.succ next) (ver_code (current_version f))); auto.
        erewrite fresh_label_correct in CODEFS; eauto. inv CODEFS. auto.
        simpl. rewrite <- base_version_unchanged. eauto. apply synth_frame_unchanged. eauto.

    + apply safe_step in SAFE as STEP. destruct STEP as [s'' [t STEP]].
      right. rewrite OPT in OPTV. inv OPTV.
      apply safe_code in SAFE. destruct SAFE as [i CODESRC].
      eapply preservation_code in NOCOND as SAME_CODE; eauto.
      inv STEP.
      * exists t. { inv STEP0; rewrite CODE in CODESRC; inv CODESRC.
        + exists (State s' vins next rm ms). apply nd_exec_lowered. eapply exec_Nop. eauto.
        + exists (State s' vins next (rm#reg<-v) ms). apply nd_exec_lowered. eapply exec_Op; eauto.
        + exists (State s' vins next newrm ms). apply nd_exec_lowered. eapply exec_Move; eauto.
        + exists (State s' vins (pc_cond v iftrue iffalse) rm ms). apply nd_exec_lowered. eapply exec_Cond; eauto.
        + poseq_destr fid0 fid.
          * eapply find_function_same with (v:=vins) in FINDF.
            exists (State (Stackframe retreg vins next rm ::s') (current_version (set_version_function vins func)) (ver_entry (current_version (set_version_function vins func))) newrm ms).
            apply nd_exec_lowered. eapply exec_Call; eauto.
          * simpl in FINDF. eapply find_function_unchanged with (fid':=fid) (v:=vins) in HEQ0.
            rewrite HEQ0 in FINDF.
            exists (State (Stackframe retreg vins next rm ::s') (current_version (func)) (ver_entry (current_version (func))) newrm ms).
            apply nd_exec_lowered. eapply exec_Call; eauto.
        + inv MATCHSTACK. inv MSF.
          * exists (State s'0 fprev next (rmprev#retreg<-retval) ms).
            apply nd_exec_lowered. eapply exec_Return; eauto.
          * exists (State s'0 vins0 next (rmprev#retreg<-retval) ms). apply nd_exec_lowered.
            eapply exec_Return; eauto.
        + inv MATCHSTACK. exists (Final retval ms). apply nd_exec_lowered. eapply exec_Return_Final; eauto.
        + exists (State s' vins next rm ms). apply nd_exec_lowered. eapply exec_Printexpr; eauto.
        + exists (State s' vins next rm ms). apply nd_exec_lowered. eapply exec_Printstring. auto.
        + exists (State s' vins next rm newms). apply nd_exec_lowered. eapply exec_Store; eauto.
        + exists (State s' vins next (rm#reg<-val) ms). apply nd_exec_lowered. eapply exec_Load; eauto.
        + exists (State s' vins next rm ms). apply nd_exec_lowered. eapply exec_Assume_holds; eauto.
        + rewrite synth_frame_unchanged in SYNTH. erewrite base_version_unchanged in FINDF.
          exists (State (synth ++ s') newver la newrm ms). apply nd_exec_lowered. eapply exec_Assume_fails; eauto.
          simpl in FINDF. simpl. eauto. simpl in SYNTH. simpl. eauto. }
      * exists E0. exists (State s' vins next rm ms). inv DEOPT_COND. rewrite synth_frame_unchanged in SYNTH.
        rewrite CODE in CODESRC. inv CODESRC.  eapply nd_exec_Framestate_go_on.
        econstructor; eauto. simpl. rewrite <- base_version_unchanged. eauto. simpl in SYNTH. simpl. eauto.
      * exists E0. exists (State s' vins next rm ms). inv DEOPT_COND. rewrite synth_frame_unchanged in SYNTH.
        rewrite CODE in CODESRC. inv CODESRC. eapply nd_exec_Framestate_go_on.
        econstructor; eauto. simpl. rewrite <- base_version_unchanged. eauto. simpl in SYNTH. simpl. eauto.

  - apply safe_step in SAFE. destruct SAFE as [s'' [t STEP]].
    right. inv STEP.
    * exists t. { inv STEP0.
      + exists (State s' v' next rm ms). apply nd_exec_lowered. eapply exec_Nop. eauto.
      + exists (State s' v' next (rm#reg<-v) ms). apply nd_exec_lowered. eapply exec_Op; eauto.
      + exists (State s' v' next newrm ms). apply nd_exec_lowered. eapply exec_Move; eauto.
      + exists (State s' v' (pc_cond v iftrue iffalse) rm ms). apply nd_exec_lowered. eapply exec_Cond; eauto.
      + poseq_destr fid0 fid.
        * eapply find_function_same with (v:=vins) in FINDF.
          exists (State (Stackframe retreg v' next rm ::s') (current_version (set_version_function vins func)) (ver_entry (current_version (set_version_function vins func))) newrm ms).
          apply nd_exec_lowered. eapply exec_Call; eauto.
        * simpl in FINDF. eapply find_function_unchanged with (fid':=fid) (v:=vins) in HEQ.
          rewrite HEQ in FINDF.
          exists (State (Stackframe retreg v' next rm ::s') (current_version (func)) (ver_entry (current_version (func))) newrm ms).
          apply nd_exec_lowered. eapply exec_Call; eauto.
      + inv MATCHSTACK. inv MSF.
        * exists (State s'0 fprev next (rmprev#retreg<-retval) ms).
          apply nd_exec_lowered. eapply exec_Return; eauto.
        * exists (State s'0 vins0 next (rmprev#retreg<-retval) ms). apply nd_exec_lowered.
          eapply exec_Return; eauto.
      + inv MATCHSTACK. exists (Final retval ms). apply nd_exec_lowered. eapply exec_Return_Final; eauto.
      + exists (State s' v' next rm ms). apply nd_exec_lowered. eapply exec_Printexpr; eauto.
      + exists (State s' v' next rm ms). apply nd_exec_lowered. eapply exec_Printstring. auto.
      + exists (State s' v' next rm newms). apply nd_exec_lowered. eapply exec_Store; eauto.
      + exists (State s' v' next (rm#reg<-val) ms). apply nd_exec_lowered. eapply exec_Load; eauto.
      + exists (State s' v' next rm ms). apply nd_exec_lowered. eapply exec_Assume_holds; eauto.
      + rewrite synth_frame_unchanged in SYNTH. erewrite base_version_unchanged in FINDF.
        exists (State (synth ++ s') newver la newrm ms). apply nd_exec_lowered. eapply exec_Assume_fails; eauto.
        simpl in FINDF. simpl. eauto. simpl in SYNTH. simpl. eauto. }
    * exists E0. exists (State s' v' next rm ms). inv DEOPT_COND. rewrite synth_frame_unchanged in SYNTH.
      eapply nd_exec_Framestate_go_on.
      econstructor; eauto. simpl. rewrite <- base_version_unchanged. eauto. simpl in SYNTH. simpl. eauto.
    * exists E0. exists (State s' v' next rm ms). inv DEOPT_COND. rewrite synth_frame_unchanged in SYNTH.
      eapply nd_exec_Framestate_go_on.
      econstructor; eauto. simpl. rewrite <- base_version_unchanged. eauto. simpl in SYNTH. simpl. eauto.
  - left. exists retval. constructor.
Qed.

(** * Destructing the Condition  *)
Lemma pc_cond_disj:
  forall v ift iff,
    pc_cond v ift iff = ift \/ pc_cond v ift iff = iff.
Proof.
  intros. destruct v. destruct z; simpl.
  right. auto.
  left. auto.
  left. auto.
Qed.

Ltac def_ok :=
  match goal with
  | [CODE: (ver_code ?vsrc) ! ?lbl = Some ?i |- _] =>
    eapply def_analyze_correct; eauto; simpl; auto; unfold def_dr_transf; try rewrite CODE; auto
  end.

(** * The Internal Backward Simulation  *)
Theorem assume_delay_correct:
  forall p fid guard fs_lbl newp,
    insert_assume_delay fid guard fs_lbl p = OK newp ->
    backward_internal_simulation p newp.
Proof.
  intros p fid guard fs_lbl newp OPT. unfold insert_assume_delay in OPT. repeat do_ok.
  rename HDO1 into FINDOPTF. rename v into vins. set (vsrc:=current_version f).
  assert (OPTV: insert_assume_version vsrc fid guard fs_lbl (fn_params f)= OK vins) by auto.
  unfold insert_assume_version in HDO0. repeat do_ok. inv HDO. destruct u.
  set (c:=ver_code vsrc).  rename HDO0 into VALIDATE. fold vsrc in VALIDATE.
  fold vsrc in H1. fold c in H1. destruct (c!fs_lbl) eqn:SRC_FS; inv H1.
  destruct i; inv H0. destruct (c!l0) eqn:SRC_COND; inv H1. destruct i; inv H0. repeat do_ok.
  rename d into tgt. rename v into vm_fs. rename l into sl_fs. rename l0 into condl.
  rename e into condexpr. rename l1 into iftrue. rename l2 into iffalse. rename HDO0 into CODE_TRUE.
  set (vins:={|ver_code := (c # condl <- (Cond condexpr (fresh_label (Pos.succ condl) c) iffalse)) # (fresh_label (Pos.succ condl) c) <- (Assume guard tgt vm_fs sl_fs iftrue); ver_entry := ver_entry vsrc |}). fold vins in OPTV.
  apply Backward_internal_simulation with (bsim_order:=as_order) (bsim_match_states:=match_states p vsrc fid guard fs_lbl condl (fn_params f)).
  - apply wfounded.
  - apply trans.

  - unfold reflexive_forge. intros synchro stack r1 s1 ms FORGE.
    destruct synchro; simpl in FORGE; repeat do_ok; simpl.
    + poseq_destr f0 fid.  (* is the called function the optimized one? *)
      * unfold validator in VALIDATE. fold c in VALIDATE. rewrite SRC_FS in VALIDATE.
        rewrite SRC_COND in VALIDATE. destruct (only_pred c condl fs_lbl) eqn:ONLY; inv VALIDATE.
        poseq_destr condl (ver_entry vsrc); inv H0. repeat do_ok.
        erewrite find_function_same; eauto. simpl. rewrite HDO0. simpl.
        rewrite FINDOPTF in HDO1. inv HDO1. apply interpreter_proof.init_regs_correct in HDO0.
        repeat (esplit; eauto).
        eapply opt_match; auto. apply match_stack_same.
        fold vsrc. fold c. eauto. eapply def_analyze_init; eauto.
      * erewrite <- find_function_unchanged; eauto. rewrite HDO1. simpl. rewrite HDO0. simpl.
        repeat (esplit; eauto). constructor. apply match_stack_same.
    + destruct stack; try destruct s; inv FORGE.
      * repeat (esplit; eauto). constructor.
      * repeat (esplit; eauto). simpl. constructor. apply match_stack_same.
    + destruct d. repeat do_ok. simpl. rewrite <- base_version_unchanged. rewrite HDO0. simpl.
      repeat (esplit; eauto). simpl. constructor. apply match_stack_same.
    + inv FORGE. destruct r1; repeat (esplit; eauto).
      * simpl. apply refl_match. apply match_stack_same.
      * simpl. apply final_match.

  - intros. inv H1. inv H. exists (Final r ms). split. apply star_refl. constructor.

  - intros. eapply progress_preserved; eauto.

  - intros s2 t s2' STEP i0 s1 MATCH SAFE.
    eapply no_entry in VALIDATE as NO_ENTRY; eauto.
    assert (NO_LOOP: fs_lbl <> condl).
    { poseq_destr fs_lbl condl; auto. rewrite SRC_COND in SRC_FS. inv SRC_FS. }
    assert (NO_FRESH: fs_lbl <> fresh_label (Pos.succ condl) c).
    { poseq_destr fs_lbl (fresh_label (Pos.succ condl) c); auto. erewrite fresh_label_correct in SRC_FS; auto. inv SRC_FS. }
    assert (NO_FRESH_COND: condl <> fresh_label (Pos.succ condl) c).
    { poseq_destr condl (fresh_label (Pos.succ condl) c); auto. erewrite fresh_label_correct in SRC_COND; eauto. inv SRC_COND. }
    inv MATCH.

    + rewrite OPT in OPTV. inv OPTV. (* assume_match *)
      unfold c in SRC_FS. rewrite FS_SRC in SRC_FS. inv SRC_FS.
      unfold c in SRC_COND. rewrite CO_SRC in SRC_COND. inv SRC_COND.
      eapply no_cond in CO_SRC as NO_COND; eauto.
      inv STEP.
      { inv STEP0; rewrite CODE in AS_OPT; inv AS_OPT.
        - exists Two. exists (State s vsrc iftrue rm ms). split. (* Assume holds: we catch-up the delay *)
          + left. eapply plus_two with (s2:=(State s vsrc condl rm ms)).
            * eapply nd_exec_Framestate_go_on. econstructor; eauto.
            * apply nd_exec_lowered. eapply exec_Cond; eauto. simpl.
              destruct vcond; auto. contradiction.
            * auto.
          + eapply opt_match; eauto. poseq_destr iftrue condl. simpl in NO_COND.
            rewrite Pos.eqb_refl in NO_COND. inv NO_COND. auto.
            eapply def_analyze_correct. eauto. eapply CO_SRC. simpl. auto. unfold def_dr_transf.
            rewrite CO_SRC. eapply def_analyze_correct. eauto. apply FS_SRC. simpl; auto.
            unfold def_dr_transf. rewrite FS_SRC. auto. intro. subst. simpl in NO_COND.
            rewrite Pos.eqb_refl in NO_COND. inv NO_COND.
        - simpl in FINDF0. rewrite <- base_version_unchanged in FINDF0. rewrite FINDF0 in FINDF. inv FINDF.
          apply synth_frame_unchanged in SYNTH0. synth_determ; auto.
          exists Zero. exists (State (synth++s) newver la newrm0 ms). (* Assume fails: we deoptimize at the src FS *)
          split.
          + left. apply plus_one. eapply nd_exec_Framestate_deopt. econstructor; eauto.
          + eapply refl_match; eauto. apply app_match; auto. apply match_stack_same.
      }
      * inv DEOPT_COND. rewrite CODE in AS_OPT. inv AS_OPT.
      * inv DEOPT_COND. rewrite CODE in AS_OPT. inv AS_OPT.

    + rewrite OPT in OPTV. inv OPTV. (* cond_match_delay *)
      unfold c in SRC_FS. rewrite FS_SRC in SRC_FS. inv SRC_FS.
      unfold c in SRC_COND. rewrite CO_SRC in SRC_COND. inv SRC_COND.
      eapply no_cond in CO_SRC as NO_COND; eauto.
      inv STEP.
      { inv STEP0; rewrite CODE in CO_OPT; inv CO_OPT. destruct v as [v]. destruct v; simpl.
        - exists Two. exists (State s vsrc iffalse rm ms). split. (* We go to the branch without Assume *)
          + left. eapply plus_two with (s2:=(State s vsrc condl rm ms)).
            (* we take 2 steps to catch up the delay*)
            * eapply nd_exec_Framestate_go_on. econstructor; eauto.
            * eapply nd_exec_lowered. eapply exec_Cond; eauto.
            * auto.
          + poseq_destr iffalse condl. simpl in NO_COND. rewrite Pos.eqb_refl in NO_COND.
            poseq_destr iftrue condl; inv NO_COND. econstructor; eauto.
            eapply def_analyze_correct. eauto. apply CO_SRC. simpl; auto. unfold def_dr_transf. rewrite CO_SRC.
            eapply def_analyze_correct. eauto. apply FS_SRC. simpl; auto. unfold def_dr_transf. rewrite FS_SRC.
            auto.
        - exists Zero. exists (State s vsrc fs_lbl rm ms). split. (* We delay one more step *)
          + right. split. apply star_refl. constructor.
          + eapply assume_match; eauto. unfold not. intros. inv H.
        - exists Zero. exists (State s vsrc fs_lbl rm ms). split. (* We delay one more step *)
          + right. split. apply star_refl. constructor.
          + eapply assume_match; eauto. unfold not. intros. inv H. }
      * inv DEOPT_COND. rewrite CODE in CO_OPT. inv CO_OPT.
      * inv DEOPT_COND. rewrite CODE in CO_OPT. inv CO_OPT.

    + rewrite OPT in OPTV. inv OPTV. (* opt_match *)
      poseq_destr lbl fs_lbl.
      { inv STEP.               (* At the Framestate used for insertion *)
        - inv STEP0; unfold vins in CODE; simpl in CODE; rewrite PTree.gso in CODE; auto;
            rewrite PTree.gso in CODE; auto; rewrite CODE in SRC_FS; inv SRC_FS.
        - exists One. exists (State s vsrc fs_lbl rm ms). split. (* OPT_FS goes on: we delay match with cond *)
            * right. split. apply star_refl. constructor.
            * destruct tgt. inv DEOPT_COND. (* apply eval_expr_correct in EVAL. *)
              unfold vins in CODE. simpl in CODE. rewrite PTree.gso in CODE; auto.
              apply synth_frame_unchanged in SYNTH. simpl in FINDF. rewrite <- base_version_unchanged in FINDF.
              rewrite PTree.gso in CODE; auto. rewrite CODE in SRC_FS. inv SRC_FS.
              eapply cond_match_delay; fold c; eauto.
              unfold vins. simpl. rewrite PTree.gso; auto. rewrite PTree.gso; auto.
              unfold vins. simpl. rewrite PTree.gso; auto. rewrite PTree.gss; auto.
              unfold vins. simpl. rewrite PTree.gss; auto.
        - exists Zero. exists (State (synth++s) newver la newrm ms). split. (* OPT FS deopt: SRC FS also deopts *)
          + destruct tgt as [ftgt ltgt]. left. apply plus_one. eapply nd_exec_Framestate_deopt; eauto.
            inv DEOPT_COND. unfold vins in CODE. simpl in CODE. rewrite PTree.gso in CODE; auto.
            rewrite PTree.gso in CODE; auto. simpl in FINDF. rewrite <- base_version_unchanged in FINDF.
            apply synth_frame_unchanged in SYNTH. econstructor; fold c; eauto.
          + apply refl_match; auto. apply app_match; auto. apply match_stack_same. }

      { eapply code_preservation in OPT as SAME_CODE; eauto.
        assert (SOME_CODE: exists i, (ver_code vsrc)!lbl = Some i) by (eapply safe_code; eauto).
        destruct SOME_CODE as [isrc SOME_CODE].
        assert (NO_COND: not_in_list (instr_succ isrc) condl = true) by (eapply no_cond; eauto).
        inv STEP.               (* not at the Framestate used for insertion *)
        - inv STEP0; rewrite <- SAME_CODE in CODE; rewrite CODE in SOME_CODE; inv SOME_CODE; simpl in NO_COND.
          + exists Two. exists (State s vsrc next rm ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Nop; eauto.
            * econstructor; eauto. def_ok. poseq_destr next condl; auto. inv NO_COND.
          + exists Two. exists (State s vsrc next (rm#reg<-v) ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Op; eauto.
            * econstructor; eauto. def_ok. apply define_insert. auto.
              poseq_destr next condl; auto. inv NO_COND.
          + exists Two. exists (State s vsrc next newrm ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Move; eauto.
            * econstructor; eauto. def_ok. eapply define_insert_list; eauto.
              poseq_destr next condl; auto. inv NO_COND.
          + exists Two. exists (State s vsrc (pc_cond v iftrue0 iffalse0) rm ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Cond; eauto.
            * econstructor; eauto. def_ok. destruct v; destruct z; eauto.
              destruct pc_cond_disj with (v:=v) (ift:=iftrue0) (iff:=iffalse0); rewrite H.
              poseq_destr iftrue0 condl; auto. inv NO_COND. poseq_destr iffalse0 condl; auto.
              poseq_destr iftrue0 condl; auto; inv NO_COND.
          + poseq_destr fid fid0.
            * simpl in FINDF. erewrite find_function_same in FINDF; eauto. inv FINDF.
              rewrite current_version_same.
              exists Two. exists (State (Stackframe retreg vsrc next rm :: s) vsrc (ver_entry vsrc) newrm ms). split.
              left. apply plus_one. apply nd_exec_lowered. eapply exec_Call; eauto.
              econstructor; eauto. constructor; auto. econstructor; eauto.
              intro. def_ok. apply define_insert; auto.
              poseq_destr next condl; auto. inv NO_COND.
              unfold vins. simpl. eapply def_analyze_init; eauto.
            * simpl in FINDF. erewrite <- find_function_unchanged in FINDF; eauto.
              exists Zero. exists (State (Stackframe retreg vsrc next rm :: s) (current_version func) (ver_entry (current_version func)) newrm ms). split.
              left. apply plus_one. apply nd_exec_lowered. eapply exec_Call; eauto.
              constructor; auto. constructor; auto. econstructor; eauto.
              intro. def_ok. apply define_insert; auto.
              poseq_destr next condl; auto. inv NO_COND.
          + inv MATCHSTACK. inv MSF.
            * exists Zero. exists (State s1 fprev next (rmprev#retreg<-retval) ms). split.
              left. apply plus_one. apply nd_exec_lowered. eapply exec_Return; eauto.
              constructor; auto.
            * exists Two. exists (State s1 vsrc next (rmprev#retreg<-retval) ms). split.
              left. apply plus_one. apply nd_exec_lowered. eapply exec_Return; eauto.
              econstructor; eauto.
          + inv MATCHSTACK. exists Zero. exists (Final retval ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Return_Final; eauto.
            * constructor; auto.
          + exists Two. exists (State s vsrc next rm ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Printexpr; eauto.
            * econstructor; eauto. def_ok. poseq_destr next condl; auto. inv NO_COND.
          + exists Two. exists (State s vsrc next rm ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Printstring; eauto.
            * econstructor; eauto. def_ok. poseq_destr next condl; auto. inv NO_COND.
          + exists Two. exists (State s vsrc next rm newms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Store; eauto.
            * econstructor; eauto. def_ok. poseq_destr next condl; auto. inv NO_COND.
          + exists Two. exists (State s vsrc next (rm#reg<-val) ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Load; eauto.
            * econstructor; eauto. def_ok. apply define_insert; auto.
              poseq_destr next condl; auto. inv NO_COND.
          + exists Two. exists (State s vsrc next rm ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Assume_holds; eauto.
            * econstructor; eauto. def_ok. poseq_destr next condl; auto. inv NO_COND.
          + exists Zero. exists (State (synth++s) newver la newrm ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Assume_fails; eauto.
              simpl in FINDF. rewrite <- base_version_unchanged in FINDF. auto.
              apply synth_frame_unchanged in SYNTH. auto.
            * constructor; auto. apply app_match; auto. apply match_stack_same.
        - exists Two. destruct tgt. inv DEOPT_COND. simpl in FINDF. rewrite <- base_version_unchanged in FINDF.
          apply synth_frame_unchanged in SYNTH. exists (State s vsrc next rm ms). split.
          + left. apply plus_one. eapply nd_exec_Framestate_go_on. econstructor; eauto.
            rewrite CODE in SAME_CODE. eauto.
          + rewrite <- SAME_CODE in CODE. rewrite CODE in SOME_CODE. inv SOME_CODE.
            eapply opt_match; eauto. def_ok.
            simpl in NO_COND. poseq_destr next condl; auto. inv NO_COND.
        - exists Zero. destruct tgt. inv DEOPT_COND. simpl in FINDF. rewrite <- base_version_unchanged in FINDF.
          apply synth_frame_unchanged in SYNTH. exists (State (synth++s) newver la newrm ms). split.
          + left. apply plus_one. eapply nd_exec_Framestate_deopt. econstructor; eauto.
            rewrite CODE in SAME_CODE. eauto.
          + apply refl_match; auto. apply app_match; auto. apply match_stack_same. }

    + inv STEP.                 (* refl_match *)
      { inv STEP0.
        - exists Zero. exists (State s v' next rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Nop; eauto.
          + apply refl_match; auto.
        - exists Zero. exists (State s v' next (rm#reg<-v) ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Op; eauto.
          + apply refl_match; auto.
        - exists Zero. exists (State s v' next newrm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Move; eauto.
          + apply refl_match; auto.
        - exists Zero. exists (State s v' (pc_cond v iftrue0 iffalse0) rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Cond; eauto.
          + apply refl_match; auto.
        - poseq_destr fid fid0.
          + simpl in FINDF. erewrite find_function_same in FINDF; eauto. inv FINDF.
            rewrite current_version_same. destruct tgt.
            exists Two. exists (State (Stackframe retreg v' next rm :: s) vsrc (ver_entry vsrc) newrm ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Call; eauto.
            * unfold validator in VALIDATE. fold c in VALIDATE. rewrite SRC_FS in VALIDATE.
              rewrite SRC_COND in VALIDATE. destruct (only_pred c condl fs_lbl) eqn:ONLY; inv VALIDATE.
              poseq_destr condl (ver_entry vsrc); inv H0. repeat do_ok.
              eapply opt_match; fold c; eauto. constructor; auto. constructor; auto.
              unfold vins. simpl. eapply def_analyze_init; eauto.
          + simpl in FINDF. erewrite <- find_function_unchanged in FINDF; eauto.
            exists Zero. exists (State (Stackframe retreg v' next rm :: s) (current_version func) (ver_entry (current_version func)) newrm ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Call; eauto.
            * constructor; auto. constructor; auto. constructor; auto.
        - inv MATCHSTACK. inv MSF.
          + exists Zero. exists (State s1 fprev next (rmprev#retreg<-retval) ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Return; eauto.
            * apply refl_match; auto.
          + destruct tgt. exists Two. exists (State s1 vsrc next (rmprev#retreg<-retval) ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Return; eauto.
            * rewrite AS_INSERT in OPTV. inv OPTV. eapply opt_match; fold c; eauto.
        - inv MATCHSTACK. exists Zero. exists (Final retval ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Return_Final; eauto.
          + apply final_match; auto.
        - exists Zero. exists (State s v' next rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Printexpr; eauto.
          + apply refl_match; auto.
        - exists Zero. exists (State s v' next rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Printstring; eauto.
          + apply refl_match; auto.
        - exists Zero. exists (State s v' next rm newms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Store; eauto.
          + apply refl_match; auto.
        - exists Zero. exists (State s v' next (rm#reg<-val) ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Load; eauto.
          + apply refl_match; auto.
        - exists Zero. exists (State s v' next rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Assume_holds; eauto.
          + apply refl_match; auto.
        - exists Zero. exists (State (synth++s) newver la newrm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Assume_fails; eauto.
            erewrite base_version_unchanged; eauto. apply FINDF. apply synth_frame_unchanged in SYNTH. auto.
          + apply refl_match; auto. apply match_app; auto. }
      * exists Zero. exists (State s v' next rm ms). split.
        left. apply plus_one. eapply nd_exec_Framestate_go_on. inv DEOPT_COND.
        econstructor; eauto. simpl in FINDF. rewrite <- base_version_unchanged in FINDF. simpl. eauto.
        apply synth_frame_unchanged in SYNTH. eauto.
        apply refl_match. auto.
      * exists Zero. exists (State (synth ++ s) newver la newrm ms). split.
        left. apply plus_one. eapply nd_exec_Framestate_deopt. inv DEOPT_COND.
        econstructor; eauto. simpl in FINDF. rewrite <- base_version_unchanged in FINDF. simpl. auto.
        apply synth_frame_unchanged in SYNTH. eauto.
        apply refl_match. apply match_app; auto.

    + inv STEP. inv STEP0.
Qed.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.

Require Logic.PropositionalLogic.DeepEmbedded.Deep.

Local Open Scope list_scope.

Ltac length_cont ls k :=
  match ls with
  | nil => k O
  | _ :: ?ls' => length_cont ls' ltac:(fun n => k (S n))
  end.
Ltac length ls := length_cont ls ltac:(fun l => l).

Definition rev (l: list nat): list nat :=
  (fix rev (l: list nat) (cont: list nat -> list nat): list nat :=
    match l with
    | nil => cont nil
    | a :: l0 => rev l0 (fun l => a :: cont l)
    end) l (fun l => l).

Ltac reverse_cont l k :=
  match l with
  | @nil ?T => k (@nil T)
  | @cons _ ?h ?t =>
    let k' l :=
        let t' := k l in
        constr:(cons h t')
    in reverse_cont t k'
  end.
Ltac reverse l := reverse_cont l ltac:(fun l => l).

Ltac pred n :=
  match n with
  | O => O
  | S ?m => m
  end.

Ltac search_expr' n i l l0 :=
  match l with
  | nil => let len := length l0 in constr:((S len, n :: l0))
  | n :: ?t => constr:((i, l0))
  | _ :: ?t => let pi := pred i in search_expr' n pi t l0
  end.
Ltac search_expr n l := let len := length l in search_expr' n len l l.

Section Temp.
  Context {L : Language}
          {minL : MinimumLanguage L}
          {pL : PropositionalLanguage L}.

  Fixpoint reflect (tbl : list Base.expr) (e : Deep.expr) : Base.expr :=
    match e with
    | Deep.varp n => List.nth (pred n) tbl Syntax.falsep
    | Deep.andp e1 e2 => Syntax.andp (reflect tbl e1) (reflect tbl e2)
    | Deep.impp e1 e2 => Syntax.impp (reflect tbl e1) (reflect tbl e2)
    | Deep.orp e1 e2 => Syntax.orp (reflect tbl e1) (reflect tbl e2)
    | Deep.falsep => Syntax.falsep
    end.
End Temp.

Ltac shallowToDeep' se l0 :=
  match se with
  | Syntax.andp ?sp ?sq =>
    match shallowToDeep' sp l0 with
    | (?dp, ?l1) =>
      match shallowToDeep' sq l1 with
      | (?dq, ?l2) => constr:((Deep.andp dp dq, l2))
      end
    end
  | Syntax.impp ?sp ?sq =>
    match shallowToDeep' sp l0 with
    | (?dp, ?l1) =>
      match shallowToDeep' sq l1 with
      | (?dq, ?l2) => constr:((Deep.impp dp dq, l2))
      end
    end
  | ?sp => match search_expr sp l0 with
          | (?i, ?l1) => constr:((Deep.varp i, l1))
          end
  end.

Ltac shallowToDeep se :=
  match shallowToDeep' se constr:(@nil Base.expr) with
  | (?de, ?tbl) =>
    let tbl' := reverse tbl in
    assert (reflect tbl' de = se) by reflexivity
  end.

Section Temp.
  Context (L : Base.Language)
          (minL : Syntax.MinimumLanguage L)
          (pL : Syntax.PropositionalLanguage L).
  Context (P Q R : Base.expr).
  Goal False.
    let n := search_expr 1 (1 :: 2 :: 3 :: 4 :: nil) in pose n.
    let n := search_expr 5 (1 :: 2 :: 3 :: 4 :: nil) in pose n.
    shallowToDeep (Syntax.impp (Syntax.andp P Q) (Syntax.orp Q P)).
  Abort.
End Temp.

Section Temp.
  Context {L: Language}
          {minL: MinimumLanguage L}
          {pL: PropositionalLanguage L}
          {GammaP: Provable L}
          {minAX: MinimumAxiomatization L GammaP}
          {ipGamma: IntuitionisticPropositionalLogic L GammaP}.

  Theorem reify_sound :
    forall table (e : Deep.expr), Deep.provable e -> provable (reflect table e).
  Proof.
    induction 1.
    - apply (modus_ponens (reflect table x) (reflect table y)); assumption.
    - apply (axiom1 (reflect table x) (reflect table y)); assumption.
    - apply (axiom2 (reflect table x) (reflect table y)); assumption.
    - apply (andp_intros (reflect table x) (reflect table y)); assumption.
    - apply (andp_elim1 (reflect table x) (reflect table y)); assumption.
    - apply (andp_elim2 (reflect table x) (reflect table y)); assumption.
    - apply (orp_intros1 (reflect table x) (reflect table y)); assumption.
    - apply (orp_intros2 (reflect table x) (reflect table y)); assumption.
    - apply (orp_elim (reflect table x) (reflect table y)); assumption.
    - apply falsep_elim.
  Qed.
End Temp.

Module DSolver.
  Local Existing Instances Deep.L Deep.minL Deep.pL Deep.GP Deep.minAX Deep.ipG.

  Instance Adj : Adjointness _ _ andp impp.
  Proof.
    constructor. split; intros.
    - rewrite <- impp_uncurry. auto.
    - rewrite <- impp_curry. auto.
  Qed.

  Instance Comm : Commutativity _ _ andp.
  Proof.
    constructor. intros.
    rewrite andp_comm. apply provable_impp_refl.
  Qed.

  Instance Mono : Monotonicity _ _ andp.
  Proof.
    constructor. intros.
    apply solve_impp_andp.
    - rewrite andp_elim1. auto.
    - rewrite andp_elim2. auto.
  Qed.

  Instance Assoc : Associativity _ _ andp.
  Proof.
    constructor; intros; rewrite andp_assoc; apply provable_impp_refl.
  Qed.

  Instance LUnit : LeftUnit _ _ truep andp.
  Proof.
    constructor; intros; rewrite truep_andp; apply provable_impp_refl.
  Qed.

  Instance RUnit : RightUnit _ _ truep andp.
  Proof.
    constructor; intros; rewrite andp_truep; apply provable_impp_refl.
  Qed.

  Fixpoint flatten_imp (e : expr) : list expr * expr :=
    match e with
    | Deep.impp p q => let (cxt, fq) := flatten_imp q in (p :: cxt, fq)
    | _ => (nil, e)
    end.

  Definition flatten_imp_inv (p : list Deep.expr * Deep.expr) :=
    let (ctx, r) := p in multi_imp ctx r.

  Lemma flatten_imp_sound :
    forall e, e = flatten_imp_inv (flatten_imp e).
  Proof.
    intros. induction e; auto.
    simpl.
    destruct (flatten_imp e2) as [ctx fq].
    simpl. rewrite IHe2. auto.
  Qed.

  Fixpoint flatten_and (e : expr) : list expr :=
    match e with
    | Deep.andp p q => (flatten_and p ++ flatten_and q)
    | s => s :: nil
    end.

  Definition flatten_and_inv (es : list expr) := List.fold_left andp es truep.

  Lemma flatten_and_sound :
    forall e, provable (iffp e (flatten_and_inv (flatten_and e))).
  Proof.
    induction e;
      [ change (flatten_and_inv _) with (fold_left andp (flatten_and e1 ++ flatten_and e2) truep)
      | change (flatten_and_inv _) with (andp truep (orp e1 e2))
      | change (flatten_and_inv _) with (andp truep (impp e1 e2))
      | change (flatten_and_inv _) with (andp truep falsep)
      | change (flatten_and_inv _) with (andp truep (Deep.varp n))
      ].
    {
      unfold iffp in IHe1, IHe2.
      apply solve_andp_intros.
      {
        rewrite <- assoc_prodp_fold_left.
        rewrite andp_elim1 in IHe1.
        rewrite andp_elim1 in IHe2.
        apply prodp_mono; auto.
      }
      {
        rewrite assoc_fold_left_app.
        rewrite andp_elim2 in IHe1.
        rewrite andp_elim2 in IHe2.
        apply prodp_mono; auto.
      }
    }
    all: apply solve_andp_intros;
      [rewrite <- left_unit2 | rewrite left_unit1];
      apply provable_impp_refl.
  Qed.

  Definition flatten (e : expr) : list expr * list expr :=
    let (ctx, r) := flatten_imp e in
    (List.flat_map flatten_and ctx, flatten_and r).

  Definition AllInContext (es1 es2 : list expr) : Prop :=
    Forall (fun e => In e es1) es2.

  Lemma multi_imp_weaken :
    forall x y xs, provable (impp x y) -> provable (impp x (multi_imp xs y)).
  Proof.
    induction xs; intros.
    - auto.
    - change (multi_imp _ _) with (impp a (multi_imp xs y)).
      rewrite <- aux_minimun_theorem01. auto.
  Qed.

  Lemma flatten_imp_inv_In : forall es r, In r es -> provable (flatten_imp_inv (es,r)).
  Proof.
    intros. induction es.
    - contradiction.
    - inversion H; subst.
      + change (flatten_imp_inv _) with (impp r (multi_imp es r)).
        apply multi_imp_weaken. apply provable_impp_refl.
      + change (flatten_imp_inv _) with (impp a (multi_imp es r)).
        apply aux_minimun_rule00. auto.
  Qed.

  Lemma multi_imp_andp_intros :
    forall es x y, provable (multi_imp es x) ->
              provable (multi_imp es y) ->
              provable (multi_imp es (andp x y)).
  Proof.
    intros es x y Hx Hy.
    pose proof provable_multi_imp_weaken es x (impp y (andp x y)) (andp_intros x y).
    pose proof modus_ponens _ _ H Hx.
    pose proof provable_multi_imp_modus_ponens es y (andp x y).
    pose proof modus_ponens _ _ H1 Hy.
    pose proof modus_ponens _ _ H2 H0.
    exact H3.
  Qed.

  Lemma flatten_inv_left_In :
    forall es r, In r (List.flat_map flatten_and es) -> provable (flatten_imp_inv (es, r)).
  Proof.
    intros.
    induction es; [contradiction|].
    simpl in H.
    apply in_app_or in H.
    destruct H.
    + clear IHes.
      apply flatten_imp_inv_In in H.
      change (flatten_imp_inv _) with (multi_imp (flatten_and a) r) in H.
      rewrite <- multi_and_multi_imp in H.
      pose proof flatten_and_sound a.
      change (flatten_imp_inv _) with (impp a (multi_imp es r)).
      apply multi_imp_weaken.
      apply solve_andp_elim1 in H0.
      eapply aux_minimun_rule02; eauto.
    + apply aux_minimun_rule00, IHes, H.
  Qed.

  Lemma flatten_inv_All :
    forall es r, AllInContext (List.flat_map flatten_and es) (flatten_and r) ->
            provable (flatten_imp_inv (es, r)).
  Proof.
    intros.
    assert (Forall (fun e => provable (flatten_imp_inv (es, e)))
                   (flatten_and r)).
    { unfold AllInContext in H. rewrite Forall_forall in *. intros e ?.
      specialize (H e H0). clear H0.
      apply flatten_inv_left_In, H.
    } clear H. rename H0 into H.
    induction r; try apply (Forall_inv H).
    simpl in H; apply Coqlib.Forall_app_iff in H; destruct H as [H1 H2].
    apply IHr1 in H1. apply IHr2 in H2.
    apply multi_imp_andp_intros; auto.
  Qed.

  Lemma flatten_sound :
    forall es rs e, (es, rs) = flatten e -> AllInContext es rs -> provable e.
  Proof.
    unfold flatten. intros.
    pose proof flatten_imp_sound e.
    rewrite H1. destruct (flatten_imp e) as [es' r].
    inversion H. clear H. subst. apply flatten_inv_All, H0.
  Qed.

  Definition all_in_context e :=
    let (es, rs) := flatten e in forallb (fun r => existsb (Deep.beq r) es) rs.

  Lemma all_in_AllIn :
    forall es rs e, (es, rs) = flatten e -> all_in_context e = true -> AllInContext es rs.
  Proof.
    intros. unfold all_in_context in H0.
    rewrite <- H in H0. clear H. rename H0 into H.
    rewrite forallb_forall in H.
    unfold AllInContext. rewrite Forall_forall.
    intros. apply H in H0. clear H.
    apply existsb_exists in H0. destruct H0 as [y [H1 H2]].
    apply Deep.beq_eq in H2. subst y. exact H1.
  Qed.

  Lemma all_in_provable :
    forall e, all_in_context e = true -> provable e.
  Proof.
    intros. remember (flatten e) as fe.
    destruct fe as [es rs].
    pose proof all_in_AllIn _ _ _ Heqfe H.
    eapply flatten_sound; eauto.
  Qed.
End DSolver.

Module SolverSound.
  Ltac ipSolver' se :=
    match shallowToDeep' se constr:(@nil Base.expr) with
    | (?de, ?tbl) =>
      let tbl' := reverse tbl in
      let b := eval hnf in (DSolver.all_in_context de) in
      assert (DSolver.all_in_context de = b) by reflexivity;
      assert (reflect tbl' de = se) by reflexivity;
      apply (reify_sound tbl' de);
      apply DSolver.all_in_provable;
      match goal with
      | [H : DSolver.all_in_context _ = true |- _] => apply H
      end
    end.

  Ltac ipSolver :=
    match goal with
    | [|- Base.provable ?e] => ipSolver' e
    end.

  Section Temp.
    Context {L: Language}
            {minL: MinimumLanguage L}
            {pL: PropositionalLanguage L}
            {GammaP: Provable L}
            {minAX: MinimumAxiomatization L GammaP}
            {ipGamma: IntuitionisticPropositionalLogic L GammaP}.
    Parameter (P Q R : expr).
    Goal (provable (impp (andp P Q) (andp Q P))).
      ipSolver.
    Qed.
  End Temp.
End SolverSound.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2013-2018 Sylvie Boldo
#<br />#
Copyright (C) 2013-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** Translation from Flocq to Pff *)

From Coq Require Import Lia.
Require Import Pff Core.

Section RND_Closest_c.
(* extension of pff for rounding function with arbitrary tie *)
Variable b : Fbound.
Variable beta : radix.
Variable p : nat.

Coercion FtoRradix := FtoR beta.
Hypothesis pGreaterThanOne : 1 < p.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat beta p.

Variable choice: Z -> bool.

Definition RND_Closest (r : R) :=
   let ru := RND_Max b beta p r in
   let rd := RND_Min b beta p r in
  match Rle_dec (Rabs (ru - r)) (Rabs (rd - r)) with
  | left H =>
      match
        Rle_lt_or_eq_dec (Rabs (ru - r)) (Rabs (rd - r)) H
      with
      | left _ => ru
      | right _ =>
          match choice (Zfloor (scaled_mantissa beta (FLT_exp (- dExp b) p) r)) with
          | true => ru
          | false => rd
          end
      end
  | right _ => rd
  end.

Theorem RND_Closest_canonic :
 forall r : R, Fcanonic beta b (RND_Closest r).
Proof.
intros r; unfold RND_Closest in |- *.
case (Rle_dec _ _ ); intros H1.
case (Rle_lt_or_eq_dec _ _ H1); intros H2.
apply RND_Max_canonic; try easy; apply radix_gt_1.
case (choice _).
now apply RND_Max_canonic; try easy; apply radix_gt_1.
now apply RND_Min_canonic; try easy; apply radix_gt_1.
now apply RND_Min_canonic; try easy; apply radix_gt_1.
Qed.

Theorem RND_Closest_correct :
 forall r : R, Closest b beta r (RND_Closest r).
Proof.
intros r.
generalize (radix_gt_1 beta); intros M.
split.
apply FcanonicBound with beta; apply RND_Closest_canonic.
intros f H3; fold FtoRradix.
(* *)
cut (RND_Min b beta p r <= r)%R; [ intros V1 | idtac ].
2: apply (RND_Min_correct b beta p) with (r:=r); easy.
cut (r <= RND_Max b beta p r)%R; [ intros V2 | idtac ].
2: apply (RND_Max_correct b beta p) with (r:=r); easy.
cut (forall v w : R, (v <= w)%R -> (0 <= w - v)%R); [ intros V3 | idtac ].
2: intros v w H; apply Rplus_le_reg_l with v; ring_simplify; auto with real.
cut (forall v w : R, (v <= w)%R -> (v - w <= 0)%R); [ intros V4 | idtac ].
2: intros v w H; apply Rplus_le_reg_l with w; ring_simplify; auto with real.
(* *)
unfold RND_Closest; case (Rle_dec _ _); intros H1.
case (Rle_lt_or_eq_dec _ _ H1); intros H2.
(* . *)
rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ].
rewrite Rabs_left1 in H1; [ idtac | apply V4; auto with real ].
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
case (Rle_or_lt f r); intros H4.
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
apply Rle_trans with (1 := H1); apply Ropp_le_contravar;
 unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Min_correct b beta p) with (r:=r); easy.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Max_correct b beta p) with (r:=r); try easy.
now apply Rlt_le.
(* . *)
case (choice _).
rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ].
rewrite Rabs_left1 in H1; [ idtac | apply V4; auto with real ].
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
case (Rle_or_lt f r); intros H5.
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
apply Rle_trans with (1 := H1); apply Ropp_le_contravar;
 unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Min_correct b beta p) with (r:=r); easy.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Max_correct b beta p) with (r:=r); try easy.
now apply Rlt_le.
(* . *)
rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ].
rewrite Rabs_left1 in H1; [ idtac | apply V4; auto with real ].
rewrite <- H2.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
case (Rle_or_lt f r); intros H5.
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
apply Rle_trans with (1 := H1); apply Ropp_le_contravar;
 unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Min_correct b beta p) with (r:=r); easy.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
unfold Rminus in |- *; apply Rplus_le_compat_r.
apply (RND_Max_correct b beta p) with (r:=r); try easy.
now apply Rlt_le.
(* . *)
apply Rnot_le_lt in H1.
rewrite Rabs_left1 in H1; [ idtac | apply V4; auto with real ].
rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ].
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
case (Rle_or_lt f r); intros H4.
rewrite Rabs_left1; [ idtac | apply V4; auto with real ].
apply Ropp_le_contravar, Rplus_le_compat_r.
apply (RND_Min_correct b beta p) with (r:=r); easy.
rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ].
left; apply Rlt_le_trans with (1:=H1).
apply Rplus_le_compat_r.
apply (RND_Max_correct b beta p) with (r:=r); try easy.
now left.
Qed.

End RND_Closest_c.

Section Bounds.

Variable beta : radix.
Variable p E:Z.
Hypothesis precisionNotZero : (1 < p)%Z.

Definition make_bound := Bound
      (Z.to_pos (Zpower beta p))
      (Z.abs_N E).

Lemma make_bound_Emin: (E <= 0)%Z ->
        ((Z_of_N (dExp (make_bound)))=-E)%Z.
Proof.
simpl.
rewrite Zabs2N.id_abs.
now apply Z.abs_neq.
Qed.

Lemma make_bound_p:
        Zpos (vNum (make_bound))=(Zpower_nat beta (Z.abs_nat p)).
Proof.
unfold make_bound, vNum; simpl.
rewrite Z2Pos.id.
apply Zpower_nat_Zpower.
omega.
generalize (Zpower_gt_0 beta); simpl.
intros T; apply T.
omega.
Qed.

Lemma FtoR_F2R: forall (f:Pff.float) (g: float beta), Pff.Fnum f = Fnum g -> Pff.Fexp f = Fexp g ->
  FtoR beta f = F2R g.
Proof.
intros f g H1 H2; unfold FtoR, F2R.
rewrite H1, H2.
now rewrite bpow_powerRZ.
Qed.

End Bounds.
Section b_Bounds.

Definition bsingle := make_bound radix2 24 (-149)%Z.

Lemma psGivesBound: Zpos (vNum bsingle) = Zpower_nat 2 24.
Proof.
unfold bsingle; apply make_bound_p.
omega.
Qed.

Definition bdouble := make_bound radix2 53 1074.

Lemma pdGivesBound: Zpos (vNum bdouble) = Zpower_nat 2 53.
Proof.
unfold bdouble; apply make_bound_p.
omega.
Qed.

End b_Bounds.
Section Equiv.

Variable beta: radix.
Variable b : Fbound.
Variable p : Z.

Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat beta (Z.abs_nat p).
Hypothesis precisionNotZero : (1 < p)%Z.

Lemma pff_format_is_format: forall f, Fbounded b f ->
  (generic_format beta (FLT_exp (-dExp b) p) (FtoR beta f)).
Proof.
intros f Hf.
apply generic_format_FLT; auto with zarith.
exists (Float beta (Pff.Fnum f) (Pff.Fexp f)).
unfold F2R, FtoR; simpl.
rewrite bpow_powerRZ.
reflexivity.
destruct Hf.
apply Z.lt_le_trans with (1:=H).
rewrite pGivesBound.
rewrite Zpower_Zpower_nat; auto with zarith.
now destruct Hf.
Qed.

Lemma format_is_pff_format': forall r,
   (generic_format beta (FLT_exp (-dExp b) p) r) ->
    Fbounded b (Pff.Float (Ztrunc (scaled_mantissa beta (FLT_exp (-dExp b) p) r))
                            (cexp beta (FLT_exp (-dExp b) p) r)).
Proof.
intros x; unfold generic_format.
set (ex := cexp beta (FLT_exp (-dExp b) p) x).
set (mx := Ztrunc (scaled_mantissa beta (FLT_exp (-dExp b) p) x)).
intros Hx; repeat split ; simpl.
apply lt_IZR.
rewrite pGivesBound, IZR_Zpower_nat.
apply Rmult_lt_reg_r with (bpow beta ex).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite inj_abs; try omega.
change (F2R (Float beta (Z.abs mx) ex) < bpow beta (p + ex))%R.
rewrite F2R_Zabs.
rewrite <- Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
unfold cexp in ex.
destruct (mag beta x) as (ex', He).
simpl in ex.
specialize (He Hx0).
apply Rlt_le_trans with (1 := proj2 He).
apply bpow_le.
cut (ex' - p <= ex)%Z. omega.
unfold ex, FLT_exp.
apply Z.le_max_l.
apply Z.le_max_r.
Qed.

Lemma format_is_pff_format: forall r,
  (generic_format beta (FLT_exp (-dExp b) p) r)
  -> exists f, FtoR beta f = r /\ Fbounded b f.
Proof.
intros r Hr.
eexists; split.
2: apply (format_is_pff_format' _ Hr).
rewrite Hr at 3; unfold FtoR, F2R; simpl.
now rewrite bpow_powerRZ.
Qed.

Lemma format_is_pff_format_can: forall r,
  (generic_format beta (FLT_exp (-dExp b) p) r)
  -> exists f, FtoR beta f = r /\ Fcanonic beta b f.
Proof.
intros r Hr.
destruct (format_is_pff_format r Hr) as (f,(Hf1,Hf2)).
exists (Fnormalize beta b (Z.abs_nat p) f); split.
rewrite <- Hf1; apply FnormalizeCorrect.
apply radix_gt_1.
apply FnormalizeCanonic; try assumption.
apply radix_gt_1.
lia.
Qed.

Lemma equiv_RNDs_aux: forall z, Z.even z = true -> Even z.
Proof.
intros z; unfold Z.even, Even.
case z.
intros; exists 0%Z; auto with zarith.
intros p0; case p0.
intros p1 H; contradict H; auto.
intros p1 _.
exists (Zpos p1); auto with zarith.
intros H; contradict H; auto.
intros p0; case p0.
intros p1 H; contradict H; auto.
intros p1 _.
exists (Zneg p1); auto with zarith.
intros H; contradict H; auto.
Qed.

Lemma pff_canonic_is_canonic: forall f, Fcanonic beta b f -> FtoR beta f <> 0 ->
  canonical beta (FLT_exp (- dExp b) p)
    (Float beta (Pff.Fnum f) (Pff.Fexp f)).
Proof.
intros f Hf1 Hf2; unfold canonical; simpl.
assert (K:(F2R (Float beta (Pff.Fnum f) (Pff.Fexp f)) = FtoR beta f)).
  unfold FtoR, F2R; simpl.
  now rewrite bpow_powerRZ.
unfold cexp, FLT_exp.
rewrite K.
destruct (mag beta (FtoR beta f)) as (e, He).
simpl; destruct Hf1.
(* . *)
destruct H as (H1,H2).
cut (Pff.Fexp f = e-p)%Z.
intros V; rewrite V.
apply sym_eq; apply Zmax_left.
rewrite <- V; destruct H1; auto with zarith.
assert (e = Pff.Fexp f + p)%Z;[idtac|omega].
apply trans_eq with (mag beta (FtoR beta f)).
apply sym_eq; apply mag_unique.
apply He; assumption.
apply mag_unique.
rewrite <- K; unfold F2R; simpl.
rewrite Rabs_mult.
rewrite (Rabs_right (bpow beta (Pff.Fexp f))).
2: apply Rle_ge; apply bpow_ge_0.
split.
replace (Pff.Fexp f + p - 1)%Z with ((p-1)+Pff.Fexp f)%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
(* .. *)
apply Rmult_le_reg_l with (IZR beta).
apply IZR_lt.
apply radix_gt_0.
rewrite <- bpow_plus_1.
replace (p-1+1)%Z with (Z_of_nat (Z.abs_nat p)).
rewrite <- IZR_Zpower_nat.
simpl; rewrite <- pGivesBound.
rewrite Rabs_Zabs.
rewrite <- mult_IZR.
apply IZR_le.
rewrite <- (Z.abs_eq (beta)).
rewrite <- Zabs.Zabs_Zmult.
assumption.
apply Zlt_le_weak; apply radix_gt_0.
rewrite inj_abs; try ring.
omega.
(* .. *)
rewrite Zplus_comm, bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
rewrite <- (inj_abs p);[idtac|omega].
rewrite <- IZR_Zpower_nat.
simpl; rewrite <- pGivesBound.
rewrite Rabs_Zabs.
apply IZR_lt.
destruct H1; assumption.
(* . *)
destruct H as (H1,(H2,H3)).
rewrite H2.
apply sym_eq; apply Zmax_right.
assert ((e-1) < p-dExp b)%Z;[idtac|omega].
apply lt_bpow with beta.
apply Rle_lt_trans with (Rabs (FtoR beta f)).
apply He; auto.
apply Rlt_le_trans with (FtoR beta (firstNormalPos beta b (Z.abs_nat p))).
rewrite <- Fabs_correct.
2: apply radix_gt_0.
apply FsubnormalLtFirstNormalPos with (3 := pGivesBound).
apply radix_gt_1.
lia.
apply FsubnormFabs; auto with zarith.
apply radix_gt_1.
split; [idtac|split]; assumption.
rewrite Fabs_correct; auto with real zarith.
apply Rabs_pos.
apply radix_gt_0.
unfold firstNormalPos, FtoR, nNormMin.
simpl.
replace (IZR (Zpower_nat beta (Peano.pred (Z.abs_nat p)))) with (bpow beta (p-1)).
rewrite <- (bpow_powerRZ _).
rewrite <- bpow_plus.
apply bpow_le.
omega.
replace (p-1)%Z with (Z_of_nat (Peano.pred (Z.abs_nat p))).
rewrite <- IZR_Zpower_nat.
reflexivity.
rewrite inj_pred; lia.
Qed.

Lemma pff_round_NE_is_round: forall (r:R),
   (FtoR beta (RND_EvenClosest b beta (Z.abs_nat p) r)
     =  round beta (FLT_exp (-dExp b) p) rndNE r).
Proof.
intros.
assert (Rnd_NE_pt beta (FLT_exp (-dExp b) p) r
         (round beta (FLT_exp (-dExp b) p) rndNE r)).
apply round_NE_pt; auto with zarith.
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
apply exists_NE_FLT.
now right.
unfold Rnd_NE_pt, Rnd_NG_pt, Rnd_N_pt, NE_prop in H.
destruct H as ((H1,H2),H3).
destruct (format_is_pff_format _ H1) as (f,(Hf1,Hf2)).
rewrite <- Hf1.
apply sym_eq.
eapply (EvenClosestUniqueP b beta (Z.abs_nat p)).
apply radix_gt_1.
lia.
exact pGivesBound.
split.
(* *)
split; auto; intros g Hg.
rewrite Hf1.
apply H2.
apply pff_format_is_format; auto.
(* *)
case (Req_dec (FtoR beta (Fnormalize beta b (Z.abs_nat p) f))  0%R); intros L.
left.
unfold FNeven, Feven, Even.
exists 0%Z.
rewrite Zmult_0_r.
apply eq_IZR.
apply Rmult_eq_reg_l with (powerRZ beta (Pff.Fexp (Fnormalize beta b (Z.abs_nat p) f)))%R.
rewrite Rmult_0_r.
rewrite <- L; unfold FtoR; simpl; ring.
apply powerRZ_NOR; auto with zarith real.
apply Rgt_not_eq.
apply IZR_lt; apply radix_gt_0.
destruct H3.
(* . *)
destruct H as (g,(Hg1,(Hg2,Hg3))).
left.
unfold FNeven, Feven.
apply equiv_RNDs_aux.
replace (Pff.Fnum (Fnormalize beta b (Z.abs_nat p) f)) with (Fnum g); try assumption.
replace g with (Float beta (Pff.Fnum (Fnormalize beta b (Z.abs_nat p) f)) (Pff.Fexp (Fnormalize beta b (Z.abs_nat p) f))).
easy.
apply canonical_unique with (FLT_exp (- dExp b) p).
2: assumption.
apply pff_canonic_is_canonic.
apply FnormalizeCanonic. 2-3: lia. 2: auto with real.
apply radix_gt_1.
exact L.
rewrite <- Hg1, <- Hf1.
rewrite <- FnormalizeCorrect with beta b (Z.abs_nat p) f; auto with zarith.
unfold F2R, FtoR; simpl.
rewrite bpow_powerRZ.
reflexivity.
apply radix_gt_1.
(* . *)
right; intros q (Hq1,Hq2).
rewrite Hf1.
apply H.
split.
apply pff_format_is_format; auto.
intros g Hg.
destruct (format_is_pff_format _ Hg) as (v,(Hv1,Hv2)).
rewrite <- Hv1.
apply Hq2; auto.
apply RND_EvenClosest_correct with (3 := pGivesBound).
apply radix_gt_1.
lia.
Qed.

Lemma round_NE_is_pff_round: forall (r:R),
   exists f:Pff.float, (Fcanonic beta b f /\ (EvenClosest b beta (Z.abs_nat p) r f) /\
    FtoR beta f =  round beta (FLT_exp (-dExp b) p) rndNE r).
Proof.
intros r.
exists (RND_EvenClosest b beta (Z.abs_nat p) r).
split.
apply RND_EvenClosest_canonic with (3 := pGivesBound).
apply radix_gt_1.
lia.
split.
apply RND_EvenClosest_correct with (3 := pGivesBound).
apply radix_gt_1.
lia.
apply pff_round_NE_is_round.
Qed.

Lemma pff_round_UP_is_round: forall (r:R),
  FtoR beta (RND_Max b beta (Z.abs_nat p) r)
             = round beta (FLT_exp (- dExp b) p) Zceil r.
Proof with auto with typeclass_instances.
intros r.
generalize (radix_gt_1 beta); intros M.
assert (K:Valid_exp (FLT_exp (- dExp b) p)).
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
destruct (format_is_pff_format_can (round beta (FLT_exp (- dExp b) p) Zceil r)) as (fu,(Hfu1,Hfu2)).
apply generic_format_round...
rewrite <- Hfu1.
apply MaxUniqueP with b r.
apply RND_Max_correct; try assumption.
apply Nat2Z.inj_lt; rewrite inj_abs; simpl; omega.
split.
apply FcanonicBound with (1:=Hfu2).
assert (T:Rnd_UP_pt (generic_format beta (FLT_exp (- dExp b) p)) r
             (round beta (FLT_exp (- dExp b) p) Zceil r)).
apply round_UP_pt...
destruct T as (T1,(T2,T3)).
split.
rewrite Hfu1; apply T2.
intros g Hg1 Hg2.
rewrite Hfu1; apply T3; try assumption.
now apply pff_format_is_format.
Qed.

Lemma pff_round_DN_is_round: forall (r:R),
  FtoR beta (RND_Min b beta (Z.abs_nat p) r)
             = round beta (FLT_exp (- dExp b) p) Zfloor r.
Proof with auto with typeclass_instances.
intros r.
generalize (radix_gt_1 beta); intros M.
assert (K:Valid_exp (FLT_exp (- dExp b) p)).
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
destruct (format_is_pff_format_can (round beta (FLT_exp (- dExp b) p) Zfloor r)) as (fd,(Hfd1,Hfd2)).
apply generic_format_round...
rewrite <- Hfd1.
apply MinUniqueP with b r.
apply RND_Min_correct; try assumption.
apply Nat2Z.inj_lt; rewrite inj_abs; simpl; omega.
split.
apply FcanonicBound with (1:=Hfd2).
assert (T:Rnd_DN_pt (generic_format beta (FLT_exp (- dExp b) p)) r
             (round beta (FLT_exp (- dExp b) p) Zfloor r)).
apply round_DN_pt...
destruct T as (T1,(T2,T3)).
split.
rewrite Hfd1; apply T2.
intros g Hg1 Hg2.
rewrite Hfd1; apply T3; try assumption.
now apply pff_format_is_format.
Qed.

Lemma pff_round_N_is_round: forall choice, forall (r:R),
   (FtoR beta (RND_Closest b beta (Z.abs_nat p) choice r)
     =  round beta (FLT_exp (-dExp b) p) (Znearest choice) r).
Proof with auto with typeclass_instances.
generalize (radix_gt_1 beta); intros M.
intros choice r; apply sym_eq.
assert (K:Valid_exp (FLT_exp (- dExp b) p)).
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
unfold RND_Closest, FtoRradix.
rewrite pff_round_DN_is_round.
rewrite pff_round_UP_is_round.
case (Rle_dec _ _); intros H1.
case (Rle_lt_or_eq_dec _ _ H1); intros H2.
(* *)
rewrite pff_round_UP_is_round.
apply round_N_eq_UP...
rewrite Rabs_right in H2;[idtac| apply Rle_ge, Rle_0_minus, round_UP_pt; easy].
rewrite Rabs_left1 in H2;[idtac| apply Rle_minus, round_DN_pt; easy].
apply Rmult_lt_reg_r with 2%R; try apply Rlt_0_2.
unfold Rdiv; rewrite Rmult_assoc, Rinv_l.
2: apply Rgt_not_eq, Rlt_0_2.
apply Rplus_lt_reg_l with (-round beta (FLT_exp (- dExp b) p) Zfloor r - r)%R.
apply Rle_lt_trans with (round beta (FLT_exp (- dExp b) p) Zceil r - r)%R;[right;ring|idtac].
apply Rlt_le_trans with (1:=H2).
right; ring.
(* *)
rewrite round_N_middle.
rewrite inj_abs;[idtac|omega].
case (choice _).
apply sym_eq, pff_round_UP_is_round.
apply sym_eq, pff_round_DN_is_round.
rewrite Rabs_right in H2;[idtac| apply Rle_ge, Rle_0_minus, round_UP_pt; easy].
rewrite Rabs_left1 in H2;[idtac| apply Rle_minus, round_DN_pt; easy].
rewrite H2; ring.
(* *)
rewrite pff_round_DN_is_round.
apply round_N_eq_DN...
apply Rnot_le_lt in H1.
rewrite Rabs_left1 in H1;[idtac| apply Rle_minus, round_DN_pt; easy].
rewrite Rabs_right in H1;[idtac| apply Rle_ge, Rle_0_minus, round_UP_pt; easy].
apply Rmult_lt_reg_r with 2%R; try apply Rlt_0_2.
unfold Rdiv; rewrite Rmult_assoc, Rinv_l.
2: apply Rgt_not_eq, Rlt_0_2.
apply Rplus_lt_reg_l with (-round beta (FLT_exp (- dExp b) p) Zfloor r - r)%R.
apply Rle_lt_trans with (-(round beta (FLT_exp (- dExp b) p) Zfloor r - r))%R;[right;ring|idtac].
apply Rlt_le_trans with (1:=H1).
right; ring.
Qed.

Lemma round_N_is_pff_round: forall choice, forall (r:R),
   exists f:Pff.float, (Fcanonic beta b f /\ (Closest b beta r f) /\
    FtoR beta f =  round beta (FLT_exp (-dExp b) p) (Znearest choice) r).
Proof.
intros choice r.
assert (1 < Z.abs_nat p).
apply Nat2Z.inj_lt; simpl.
rewrite inj_abs; omega.
exists (RND_Closest b beta (Z.abs_nat p) choice r); split.
apply RND_Closest_canonic; easy.
split.
apply RND_Closest_correct; easy.
apply pff_round_N_is_round.
Qed.

Lemma pff_round_is_round_N: forall r f, Closest b beta r f ->
    exists (choice:Z->bool),
      FtoR beta f = round beta (FLT_exp (-dExp b) p) (Znearest choice) r.
Proof with auto with typeclass_instances.
intros r f Hf.
generalize (radix_gt_1 beta); intros M.
assert (M':1 < Z.abs_nat p).
apply Nat2Z.inj_lt; simpl.
rewrite inj_abs; omega.
pose (d := round beta (FLT_exp (-dExp b) p) Zfloor r).
pose (u := round beta (FLT_exp (-dExp b) p) Zceil r).
case (Rle_or_lt ((d+u)/2) r); intros L.
destruct L as [L|L].
(* rnd up *)
exists (fun _ => true).
rewrite <- pff_round_N_is_round.
apply trans_eq with (FtoR beta (RND_Max b beta (Z.abs_nat p) r)).
apply ClosestMaxEq with b r (RND_Min b beta (Z.abs_nat p) r); try assumption.
apply RND_Min_correct; assumption.
apply RND_Max_correct; assumption.
rewrite pff_round_DN_is_round; fold d.
rewrite pff_round_UP_is_round; fold u.
apply Rmult_lt_reg_r with (/2)%R.
apply pos_half_prf.
apply Rlt_le_trans with (1:=L).
right; simpl; field.
rewrite pff_round_N_is_round.
rewrite pff_round_UP_is_round; fold u.
apply sym_eq, round_N_eq_UP...
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
(* middle *)
case (ClosestMinOrMax b beta r f); try assumption; intros LL.
exists (fun _ => false).
rewrite round_N_middle.
rewrite <- pff_round_DN_is_round.
apply (MinUniqueP b beta r); try assumption.
apply RND_Min_correct; assumption.
fold d; fold u; rewrite <- L; field.
exists (fun _ => true).
rewrite round_N_middle.
rewrite <- pff_round_UP_is_round.
apply (MaxUniqueP b beta r); try assumption.
apply RND_Max_correct; assumption.
fold d; fold u; rewrite <- L; field.
(* rnd down *)
exists (fun _ => true).
rewrite <- pff_round_N_is_round.
apply trans_eq with (FtoR beta (RND_Min b beta (Z.abs_nat p) r)).
apply ClosestMinEq with b r (RND_Max b beta (Z.abs_nat p) r); try assumption.
apply RND_Min_correct; assumption.
apply RND_Max_correct; assumption.
rewrite pff_round_DN_is_round; fold d.
rewrite pff_round_UP_is_round; fold u.
apply Rmult_lt_reg_r with (/2)%R.
apply pos_half_prf.
apply Rle_lt_trans with (2:=L).
right; simpl; field.
rewrite pff_round_N_is_round.
rewrite pff_round_DN_is_round; fold d.
apply sym_eq, round_N_eq_DN...
apply FLT_exp_valid.
unfold Prec_gt_0; auto with zarith.
Qed.

Lemma FloatFexp_gt:  forall e f, Fbounded b f ->
  (bpow beta (e+p) <= Rabs (FtoR beta f))%R ->
       (e < Pff.Fexp f)%Z.
Proof.
intros e f Ff H1.
apply lt_bpow with beta.
apply Rmult_lt_reg_r with (bpow beta p).
apply bpow_gt_0.
rewrite <- bpow_plus.
apply Rle_lt_trans with (1:=H1).
rewrite <- Fabs_correct.
2: apply radix_gt_0.
unfold Fabs, FtoR; simpl; rewrite Rmult_comm.
rewrite bpow_powerRZ.
apply Rmult_lt_compat_l.
apply powerRZ_lt.
apply IZR_lt, radix_gt_0.
destruct Ff as (T1,T2).
rewrite bpow_powerRZ.
replace p with (Z.of_nat (Z.abs_nat p)).
rewrite <- Zpower_nat_Z_powerRZ.
apply IZR_lt.
now rewrite <- pGivesBound.
rewrite inj_abs; omega.
Qed.

Lemma CanonicGeNormal:  forall f, Fcanonic beta b f ->
  (bpow beta (-dExp b+p-1) <= Rabs (FtoR beta f))%R ->
       (Fnormal beta b f)%Z.
Proof.
intros f Cf H1.
case Cf; trivial.
intros (H2,(H3,H4)).
contradict H1; apply Rlt_not_le.
rewrite <- Fabs_correct.
2: apply radix_gt_0.
unfold FtoR, Fabs; simpl.
rewrite H3, <- bpow_powerRZ.
apply Rlt_le_trans with (bpow beta (p-1)*bpow beta (-dExp b))%R.
2: rewrite <- bpow_plus.
2: right; f_equal; ring.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply Rmult_lt_reg_l with (IZR beta).
apply IZR_lt, radix_gt_0.
rewrite <- mult_IZR.
apply Rlt_le_trans with (IZR (Z.pos (vNum b))).
apply IZR_lt.
rewrite <- (Z.abs_eq beta).
now rewrite <- Zabs_Zmult.
apply Zlt_le_weak, radix_gt_0.
rewrite pGivesBound.
rewrite IZR_Zpower_nat.
rewrite <- bpow_1.
rewrite <- bpow_plus.
apply bpow_le.
rewrite inj_abs; omega.
Qed.

Lemma Fulp_ulp_aux:  forall f, Fcanonic beta b f ->
   Fulp b beta (Z.abs_nat p) f
    = ulp beta (FLT_exp (-dExp b) p) (FtoR beta f).
Proof.
intros f H.
case (Req_dec (FtoR beta f) 0); intros Zf.
(* f = 0 *)
rewrite Zf, ulp_FLT_small.
2: unfold Prec_gt_0; omega.
2: rewrite Rabs_R0; apply bpow_gt_0.
rewrite Fulp_zero.
apply sym_eq, bpow_powerRZ.
apply is_Fzero_rep2 with beta; try assumption.
apply radix_gt_1.
(* f <> 0 *)
rewrite ulp_neq_0; try assumption.
replace (FtoR beta f) with (F2R (Float beta (Pff.Fnum f) (Pff.Fexp f))).
rewrite <- pff_canonic_is_canonic; try assumption.
simpl; rewrite CanonicFulp; try assumption.
unfold FtoR; simpl; rewrite bpow_powerRZ; ring.
apply radix_gt_1.
replace 1 with (Z.abs_nat 1) by easy.
apply Zabs_nat_lt; omega.
unfold F2R, FtoR; simpl.
rewrite bpow_powerRZ; easy.
Qed.

Lemma Fulp_ulp:  forall f, Fbounded b f ->
   Fulp b beta (Z.abs_nat p) f
    = ulp beta (FLT_exp (-dExp b) p) (FtoR beta f).
Proof.
intros f H.
assert (Y1: (1 < beta)%Z) by apply radix_gt_1.
assert (Y2:Z.abs_nat p <> 0).
apply sym_not_eq, Nat.lt_neq.
replace 0 with (Z.abs_nat 0) by easy.
apply Zabs_nat_lt; omega.
rewrite FulpComp with (q:=Fnormalize beta b (Z.abs_nat p) f); try assumption.
rewrite <- FnormalizeCorrect with beta b (Z.abs_nat p) f; try assumption.
apply Fulp_ulp_aux.
apply FnormalizeCanonic; try assumption.
replace 1 with (Z.abs_nat 1) by easy.
apply Zabs_nat_lt; omega.
apply FnormalizeBounded; try assumption.
apply sym_eq, FnormalizeCorrect; try assumption.
Qed.

End Equiv.

Section Equiv_instanc.

Lemma round_NE_is_pff_round_b32: forall (r:R),
   exists f:Pff.float, (Fcanonic 2 bsingle f /\ (EvenClosest bsingle 2 24 r f) /\
    FtoR 2 f =  round radix2 (FLT_exp (-149) 24) rndNE r).
Proof.
apply (round_NE_is_pff_round radix2 bsingle 24).
apply psGivesBound.
apply eq_refl.
Qed.

Lemma round_NE_is_pff_round_b64: forall (r:R),
   exists f:Pff.float, (Fcanonic 2 bdouble f /\ (EvenClosest bdouble 2 53 r f) /\
    FtoR 2 f =  round radix2 (FLT_exp (-1074) 53) rndNE r).
Proof.
apply (round_NE_is_pff_round radix2 bdouble 53).
apply pdGivesBound.
apply eq_refl.
Qed.

End Equiv_instanc.


Require Import Iron.Language.SimplePCF.Preservation.
Require Export Iron.Language.SimplePCF.SubstExpExp.
Require Export Iron.Language.SimplePCF.Step.
Require Export Iron.Language.SimplePCF.Ty.
Require Export Iron.Language.SimplePCF.Exp.

(* Big Step Evaluation.
   This is also called 'Natural Semantics'.
   It provides a relation between the expression to be reduced
   and its final value. *)
Inductive EVAL : exp -> exp -> Prop :=

 (* Values are already evaluated ******)
 | EvDone
   :  forall v2
   ,  wnfX v2
   -> EVAL v2 v2

 (* Function Applications *************)
 | EvLamApp
   :  forall x1 t11 x12 x2 v2 v3
   ,  EVAL x1 (XLam t11 x12) -> EVAL x2 v2 -> EVAL (substX 0 v2 x12) v3
   -> EVAL (XApp x1 x2) v3

 (* Fixpoint recursion ****************)
 | EvFix
   :  forall t11 x12 v3
   ,  EVAL (substX 0 (XFix t11 x12) x12) v3
   -> EVAL (XFix t11 x12) v3

 (* Naturals **************************)
 | EvSucc
   :  forall x1 n
   ,  EVAL x1 (XNat n)
   -> EVAL (XSucc x1) (XNat (S n))

 | EvPredZero
   :  forall x1
   ,  EVAL x1 (XNat O)
   -> EVAL (XPred x1) (XNat O)

 | EvPredSucc
   :  forall x1 n
   ,  EVAL x1 (XNat (S n))
   -> EVAL (XPred x1) (XNat n)

 (* Booleans **************************)
 | EvIsZeroTrue
   :  forall x1
   ,  EVAL x1 (XNat O)
   -> EVAL (XIsZero x1) XTrue

 | EvIsZeroFalse
   :  forall x1 n
   ,  EVAL x1 (XNat (S n))
   -> EVAL (XIsZero x1) XFalse

 (* Branching *************************)
 | EvIfThen
   :  forall x1 x2 x3 v2
   ,  EVAL x1 XTrue -> EVAL x2 v2
   -> EVAL (XIf x1 x2 x3) v2

 | EvIfElse
   :  forall x1 x2 x3 v3
   ,  EVAL x1 XFalse -> EVAL x3 v3
   -> EVAL (XIf x1 x2 x3) v3.

Hint Constructors EVAL.

(* A terminating big-step evaluation always produces a whnf.
   The fact that the evaluation terminated is implied by the fact
   that we have a finite proof of EVAL to pass to this lemma. *)
Lemma eval_produces_wnfX
 :  forall x1 v1
 ,  EVAL   x1 v1
 -> wnfX  v1.
Proof.
 intros. induction H; eauto.
Qed.
Hint Resolve eval_produces_wnfX.

(********************************************************************)
(* Big to Small steps.
   Convert a big-step evaluation into a list of individual
   machine steps. *)
Lemma steps_of_eval
 :  forall x1 t1 x2
 ,  TYPE nil x1 t1
 -> EVAL  x1 x2
 -> STEPS x1 x2.
Proof.
 intros x1 t1 v2 HT HE.
 gen t1.
 induction HE;
  intros;
  inverts keep HT; eauto;

  (* This gets simple expressions with a single context *)
  try (  eapply EsAppend ;
       [ eapply steps_context ; [ eauto | eapply IHHE ; eauto ]
       | eauto ]).

 Case "EvLamApp".
  lets E1: IHHE1 H2.
  lets E2: IHHE2 H4.
  lets T1: preservation_steps H2 E1. inverts keep T1.
  lets T2: preservation_steps H4 E2.
  lets T3: subst_exp_exp H1 T2.
  lets E3: IHHE3 T3.
  eapply EsAppend.
   lets D: steps_context XcApp1. eapply D. eauto.
  eapply EsAppend.
   eapply steps_context; eauto.
  eapply EsAppend.
   eapply EsStep.
     eapply EsLamApp. eauto. eauto.

 Case "EvFix".
  lets T1: subst_exp_exp H3 HT.
  lets E1: IHHE T1.
  eapply EsAppend.
   eapply EsStep.
    eapply EsFix. eauto.

 Case "EVIfTrue".
  lets S1: IHHE1 H3.
  lets S2: IHHE2 H5.
  eapply EsAppend.
   eapply (steps_context (fun xx => XIf xx x2 x3)); eauto.
   eauto.

 Case "EVIfFalse".
  lets S1: IHHE1 H3.
  lets S2: IHHE2 H6.
  eapply EsAppend.
   eapply (steps_context (fun xx => XIf xx x2 x3)); eauto.
   eauto.
Qed.

(********************************************************************)
(* Small to Big steps.
   Convert a list of individual machine steps to a big-step
   evaluation. The main part of this is the expansion lemma, which
   we use to build up the overall big-step evaluation one small-step
   at a time. The other lemmas are used to feed it small-steps.
 *)

(* Given an existing big-step evalution, we can produce a new one
   that does an extra step before returning the original value.
 *)
Lemma eval_expansion
 :  forall te x1 t1 x2 v3
 ,  TYPE te x1 t1
 -> STEP x1 x2 -> EVAL x2 v3
 -> EVAL x1 v3.
Proof.
 intros te x1 t1 x2 v3 HT HS. gen te t1 v3.
 induction HS; intros;
  try (solve [inverts H; eauto]); eauto.

 Case "Context".
  destruct H.
   eauto.
   inverts HT; inverts H0; try (inverts H); eauto.
   inverts HT; inverts H0; try (inverts H1); eauto.
   inverts HT; inverts H0; try (inverts H); eauto.
   inverts HT; inverts H0; try (inverts H); eauto.
   inverts HT; inverts H0; try (inverts H); eauto.
   inverts HT; inverts H0; try (inverts H); eauto.
Qed.

(* Convert a list of small steps to a big-step evaluation. *)
Lemma eval_of_stepsl
 :  forall x1 t1 v2
 ,  TYPE nil x1 t1
 -> STEPSL x1 v2 -> value v2
 -> EVAL   x1 v2.
Proof.
 intros x1 t1 v2 HT HS HV.
 induction HS; burn.

 Case "ESLCons".
  eapply eval_expansion;
   burn using preservation.
Qed.

(* Convert a multi-step evaluation to a big-step evaluation.
   We use stepsl_of_steps to flatten out the append constructors
   in the multi-step evaluation, leaving a list of individual
   small-steps. *)
Lemma eval_of_steps
 :  forall x1 t1 v2
 ,  TYPE nil x1 t1
 -> STEPS x1 v2 -> value v2
 -> EVAL  x1 v2.
Proof.
 intros.
 eapply eval_of_stepsl; burn.
  apply  stepsl_of_steps; burn.
Qed.