(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Ensembles.
Require Export Constructive_sets.
Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Partial_Order.
Require Export Cpo.
Require Export Powerset.

Section Sets_as_an_algebra.
  Variable U : Type.

  Theorem Empty_set_zero : forall X:Ensemble U, Union U (Empty_set U) X = X.
  Proof.
    auto 6 with sets.
  Qed.

  Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x.
  Proof.
    unfold Add at 1 in |- *; auto using Empty_set_zero with sets.
  Qed.

  Lemma less_than_empty :
    forall X:Ensemble U, Included U X (Empty_set U) -> X = Empty_set U.
  Proof.
    auto with sets.
  Qed.

  Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A.
  Proof.
    auto with sets.
  Qed.

  Theorem Union_associative :
    forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C).
  Proof.
    auto 9 with sets.
  Qed.

  Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A.
  Proof.
    auto 7 with sets.
  Qed.

  Lemma Union_absorbs :
    forall A B:Ensemble U, Included U B A -> Union U A B = A.
  Proof.
    auto 7 with sets.
  Qed.

  Theorem Couple_as_union :
    forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y.
  Proof.
    intros x y; apply Extensionality_Ensembles; split; red in |- *.
    intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets).
    intros x0 H'; elim H'; auto with sets.
  Qed.

  Theorem Triple_as_union :
    forall x y z:U,
      Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) =
      Triple U x y z.
  Proof.
    intros x y z; apply Extensionality_Ensembles; split; red in |- *.
    intros x0 H'; elim H'.
    intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets).
    intros x1 H'0; elim H'0; auto with sets.
    intros x0 H'; elim H'; auto with sets.
  Qed.

  Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y.
  Proof.
    intros x y.
    rewrite <- (Couple_as_union x y).
    rewrite <- (Union_idempotent (Singleton U x)).
    apply Triple_as_union.
  Qed.

  Theorem Triple_as_Couple_Singleton :
    forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z).
  Proof.
    intros x y z.
    rewrite <- (Triple_as_union x y z).
    rewrite <- (Couple_as_union x y); auto with sets.
  Qed.

  Theorem Intersection_commutative :
    forall A B:Ensemble U, Intersection U A B = Intersection U B A.
  Proof.
    intros A B.
    apply Extensionality_Ensembles.
    split; red in |- *; intros x H'; elim H'; auto with sets.
  Qed.

  Theorem Distributivity :
    forall A B C:Ensemble U,
      Intersection U A (Union U B C) =
      Union U (Intersection U A B) (Intersection U A C).
  Proof.
    intros A B C.
    apply Extensionality_Ensembles.
    split; red in |- *; intros x H'.
    elim H'.
    intros x0 H'0 H'1; generalize H'0.
    elim H'1; auto with sets.
    elim H'; intros x0 H'0; elim H'0; auto with sets.
  Qed.

  Theorem Distributivity' :
    forall A B C:Ensemble U,
      Union U A (Intersection U B C) =
      Intersection U (Union U A B) (Union U A C).
  Proof.
    intros A B C.
    apply Extensionality_Ensembles.
    split; red in |- *; intros x H'.
    elim H'; auto with sets.
    intros x0 H'0; elim H'0; auto with sets.
    elim H'.
    intros x0 H'0; elim H'0; auto with sets.
    intros x1 H'1 H'2; try exact H'2.
    generalize H'1.
    elim H'2; auto with sets.
  Qed.

  Theorem Union_add :
    forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x).
  Proof.
    unfold Add in |- *; auto using Union_associative with sets.
  Qed.

  Theorem Non_disjoint_union :
    forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X.
  Proof.
    intros X x H'; unfold Add in |- *.
    apply Extensionality_Ensembles; red in |- *.
    split; red in |- *; auto with sets.
    intros x0 H'0; elim H'0; auto with sets.
    intros t H'1; elim H'1; auto with sets.
  Qed.

  Theorem Non_disjoint_union' :
    forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X.
  Proof.
    intros X x H'; unfold Subtract in |- *.
    apply Extensionality_Ensembles.
    split; red in |- *; auto with sets.
    intros x0 H'0; elim H'0; auto with sets.
    intros x0 H'0; apply Setminus_intro; auto with sets.
    red in |- *; intro H'1; elim H'1.
    lapply (Singleton_inv U x x0); auto with sets.
    intro H'4; apply H'; rewrite H'4; auto with sets.
  Qed.

  Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y.
  Proof.
    intro x; rewrite (Empty_set_zero' x); auto with sets.
  Qed.

  Lemma incl_add :
    forall (A B:Ensemble U) (x:U),
      Included U A B -> Included U (Add U A x) (Add U B x).
  Proof.
    intros A B x H'; red in |- *; auto with sets.
    intros x0 H'0.
    lapply (Add_inv U A x x0); auto with sets.
    intro H'1; elim H'1;
      [ intro H'2; clear H'1 | intro H'2; rewrite <- H'2; clear H'1 ];
      auto with sets.
  Qed.

  Lemma incl_add_x :
    forall (A B:Ensemble U) (x:U),
      ~ In U A x -> Included U (Add U A x) (Add U B x) -> Included U A B.
  Proof.
    unfold Included in |- *.
    intros A B x H' H'0 x0 H'1.
    lapply (H'0 x0); auto with sets.
    intro H'2; lapply (Add_inv U B x x0); auto with sets.
    intro H'3; elim H'3;
      [ intro H'4; try exact H'4; clear H'3 | intro H'4; clear H'3 ].
    absurd (In U A x0); auto with sets.
    rewrite <- H'4; auto with sets.
  Qed.

  Lemma Add_commutative :
    forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x.
  Proof.
    intros A x y.
    unfold Add in |- *.
    rewrite (Union_associative A (Singleton U x) (Singleton U y)).
    rewrite (Union_commutative (Singleton U x) (Singleton U y)).
    rewrite <- (Union_associative A (Singleton U y) (Singleton U x));
      auto with sets.
  Qed.

  Lemma Add_commutative' :
    forall (A:Ensemble U) (x y z:U),
      Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y.
  Proof.
    intros A x y z.
    rewrite (Add_commutative (Add U A x) y z).
    rewrite (Add_commutative A x z); auto with sets.
  Qed.

  Lemma Add_distributes :
    forall (A B:Ensemble U) (x y:U),
      Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y).
  Proof.
    intros A B x y H'; try assumption.
    rewrite <- (Union_add (Add U A x) B y).
    unfold Add at 4 in |- *.
    rewrite (Union_commutative A (Singleton U x)).
    rewrite Union_associative.
    rewrite (Union_absorbs A B H').
    rewrite (Union_commutative (Singleton U x) A).
    auto with sets.
  Qed.

  Lemma setcover_intro :
    forall (U:Type) (A x y:Ensemble U),
      Strict_Included U x y ->
      ~ (exists z : _, Strict_Included U x z /\ Strict_Included U z y) ->
      covers (Ensemble U) (Power_set_PO U A) y x.
  Proof.
    intros; apply Definition_of_covers; auto with sets.
  Qed.

End Sets_as_an_algebra.

Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add
  singlx incl_add: sets v62.


(** Relational and functional specifications of conditional weakest
    pre-expectation semantics. *)

Set Implicit Arguments.
Require Import Coq.Program.Basics.
Require Import List.
Require Import Nat.
Require Import Coq.QArith.QArith.
Require Import Coq.micromega.Lqa.
Require Import Coq.micromega.Lia.
Local Open Scope program_scope.
Import ListNotations.

Require Import cpGCL.
Require Import geometric.
Require Import order.
Require Import Q.
Open Scope cpGCL_scope.
Open Scope Q_scope.
Open Scope order_scope.

(** Note on the relational versions of wp and wlp: we make them
  explicitly "proper" wrt extensional equivalence of arguments. This
  is necessary (or at least useful) because equivalence of standard
  library rational numbers doesn't coincide with Coq's definitional
  equality in general, so rational equivalence lifted pointwise to
  functions must be handled explicitly (can't use functional
  extensionality axiom). *)

(** Relational specification of weakest pre-expectation semantics *)
Inductive wp : cpGCL -> (St -> Q) -> (St -> Q) -> Prop :=
| wp_skip : forall f g, f ==f g -> wp CSkip f g
| wp_abort : forall f g, g ==f const 0 -> wp CAbort f g
| wp_assign : forall x e f f',
    f' ==f (fun st => f (upd x (e st) st)) ->
    wp (CAssign x e) f f'
| wp_seq : forall c1 c2 f f' g g',
    wp c2 f g ->
    wp c1 g g' ->
    f' ==f g' ->
    wp (CSeq c1 c2) f f'
| wp_ite : forall e c1 c2 f f' g h,
    wp c1 f g ->
    wp c2 f h ->
    f' ==f (fun st => if e st : bool then g st else h st) ->
    wp (CIte e c1 c2) f f'
| wp_choice : forall p c1 c2 f f' g h,
    wp c1 f g ->
    wp c2 f h ->
    f' ==f (fun st => p * g st + (1-p) * h st) ->
    wp (CChoice p c1 c2) f f'
| wp_while : forall e body f f' ch,
    ch O ==f (fun st => if e st : bool then const 0 st else f st) ->
    (forall n, exists g, wp body (ch n) g /\
               ch (S n) ==f fun st => if e st : bool then g st else f st) ->
    supremum f' ch ->
    wp (CWhile e body) f f'
| wp_observe : forall e f f',
    f' ==f (fun st => if e st : bool then f st else 0) ->
    wp (CObserve e) f f'.

(** Relational specification of weakest liberal pre-expectation
    semantics. *)
Inductive wlp : cpGCL -> (St -> Q) -> (St -> Q) -> Prop :=
| wlp_skip : forall f g, f ==f g -> wlp CSkip f g
| wlp_abort : forall f g, g ==f const 1 -> wlp CAbort f g
| wlp_assign : forall x e f f',
    f' ==f (fun st => f (upd x (e st) st)) ->
    wlp (CAssign x e) f f'
| wlp_seq : forall c1 c2 f f' g g',
    wlp c2 f g ->
    wlp c1 g g' ->
    f' ==f g' ->
    wlp (CSeq c1 c2) f f'
| wlp_ite : forall e c1 c2 f f' g h,
    wlp c1 f g ->
    wlp c2 f h ->
    f' ==f (fun st => if e st : bool then g st else h st) ->
    wlp (CIte e c1 c2) f f'
| wlp_choice : forall p c1 c2 f f' g h,
    wlp c1 f g ->
    wlp c2 f h ->
    f' ==f (fun st => p * g st + (1-p) * h st) ->
    wlp (CChoice p c1 c2) f f'
| wlp_while : forall e body f f' ch,
    ch O ==f (fun st => if e st : bool then const 1 st else f st) ->
    (forall n, exists g, wlp body (ch n) g /\
               ch (S n) ==f fun st => if e st : bool then g st else f st) ->
    infimum f' ch ->
    wlp (CWhile e body) f f'
| wlp_observe : forall e f f',
    f' ==f (fun st => if e st : bool then f st else 0) ->
    wlp (CObserve e) f f'.

(** cwp_ is decomposed into wp and wlp *)
Definition cwp_ (c : cpGCL) (f f' g g' : St -> Q) :=
  wp c f f' /\ wlp c g g'.

(** cwp is the ratio of the pair given by cwp_ *)
Definition cwp (c : cpGCL) (f f'' : St -> Q) :=
  exists f' g', cwp_ c f f' (const 1) g' /\ f'' ==f fun st => f' st / g' st.

(** As observed by Olmedo et al. in Lemma 7.4 (page 39), wp and wlp
  for loops can be computed directly as a ratio whenever the loops are
  iid. This leads to the following functional specifications of wp and
  wlp. *)

(** Functional specification of weakest pre-expectation semantics
    (only valid for iid programs). *)
Fixpoint wpf (c : cpGCL) (f : St -> Q) : St -> Q :=
  match c with
  | CSkip => f
  | CAbort => const 0
  | CAssign x e => fun st => f (upd x (e st) st)
  | CSeq c1 c2 => (wpf c1 ∘ wpf c2) f
  | CIte e c1 c2 => fun st => if e st then wpf c1 f st else wpf c2 f st
  | CChoice p c1 c2 => fun st => p * wpf c1 f st + (1-p) * wpf c2 f st
  | CWhile e body =>
    fun st =>
      if e st then
        wpf body (fun st' => if e st' then 0 else f st') st /
            (1 - wpf body (fun st' => if e st' then 1 else 0) st)
      else f st
  | CObserve e => fun st => if e st then f st else 0
  end.

(** Functional specification of weakest liberal pre-expectation
    semantics (only valid for iid programs). *)
Fixpoint wlpf (c : cpGCL) (f : St -> Q) : St -> Q :=
  match c with
  | CSkip => f
  | CAbort => const 1
  | CAssign x e => fun st => f (upd x (e st) st)
  | CSeq c1 c2 => (wlpf c1 ∘ wlpf c2) f
  | CIte e c1 c2 => fun st => if e st then wlpf c1 f st else wlpf c2 f st
  | CChoice p c1 c2 => fun st => p * wlpf c1 f st + (1-p) * wlpf c2 f st
  | CWhile e body =>
    fun st =>
      if e st then
        let a := wlpf body (fun st' => if e st' then 0 else f st') st in
        let r := wpf body (fun st' => if e st' then 1 else 0) st in
        if Qeq_bool r 1 then 1 else a / (1 - r)
      else f st
  | CObserve e => fun st => if e st then f st else 0
  end.

Definition cwpf_ (c : cpGCL) (f : St  -> Q) : St -> Q*Q :=
  fun st => (wpf c f st, wlpf c (const 1) st).

(** Functional specification of conditional weakest pre-expectation
    semantics (only valid for iid programs). *)
Definition cwpf (c : cpGCL) (f : St  -> Q) : St -> Q :=
  fun st => let (a, b) := cwpf_ c f st in a / b.

Definition indicator (e : exp) (st : St) : Q :=
  if e st then 1 else 0.

Definition neg_indicator (e : exp) (st : St) : Q :=
  if e st then 0 else 1.

(** [unroll e c i] is the ith finite unrolling of the loop with guard
  condition [e] and body [c]. *)
Fixpoint unroll (e : exp) (c : cpGCL) (i : nat) : cpGCL :=
  match i with
  | O => CIte e CAbort CSkip
  | S i' => CIte e (CSeq c (unroll e c i')) CSkip
  end.

(** iid condition for functional wp *)
Definition iid_wpf (e : exp) (c : cpGCL) :=
  forall f st n,
    e st = true ->
    wpf (unroll e c (S n)) f st ==
    wpf c (indicator e) st * wpf (unroll e c n) f st +
    wpf c (fun x => if e x then 0 else f x) st.

(** iid condition for functional wlp *)
Definition iid_wlpf (e : exp) (c : cpGCL) :=
  forall f st n,
    e st = true ->
    wlpf (unroll e c (S n)) f st ==
    wpf c (indicator e) st * wlpf (unroll e c n) f st +
    wlpf c (fun x => if e x then 0 else f x) st.

(** The loop with guard expression e and body c is iid wrt both wpf
    and wlpf. *)
Definition iid (e : exp) (c : cpGCL) :=
  iid_wpf e c /\ iid_wlpf e c.

(** Predicate asserting that all loops in a program are iid. *)
Inductive iid_cpGCL : cpGCL -> Prop :=
| iid_skip : iid_cpGCL CSkip
| iid_abort : iid_cpGCL CAbort
| iid_assign : forall x e, iid_cpGCL (CAssign x e)
| iid_seq : forall c1 c2,
    iid_cpGCL c1 -> iid_cpGCL c2 ->
    iid_cpGCL (CSeq c1 c2)
| iid_ite : forall e c1 c2,
    iid_cpGCL c1 -> iid_cpGCL c2 ->
    iid_cpGCL (CIte e c1 c2)
| iid_choice : forall p c1 c2,
    iid_cpGCL c1 -> iid_cpGCL c2 ->
    iid_cpGCL (CChoice p c1 c2)
| iid_while : forall e c,
    iid_cpGCL c ->
    iid e c ->
    iid_cpGCL (CWhile e c)
| iid_observe : forall e,
    iid_cpGCL (CObserve e).

(** A couple tactics that are useful for reasoning about example
    programs with wp and wlp. *)

Ltac rewrite_equiv :=
  match goal with
  | [ H : forall _ : St, _ == _ |- _ ] => rewrite H; simpl
  | [ H : _ ==f _ |- _ ] => unfold f_Qeq in H; rewrite H; simpl
  end.

Ltac wp_inversion :=
  match goal with
  | [ H : wp ?c ?f ?f' |- _ ] => inversion H; subst; clear H
  end;
  repeat rewrite_equiv.

Ltac wlp_inversion :=
  match goal with
  | [ H : wlp ?c ?f ?f' |- _ ] => inversion H; subst; clear H
  end;
  repeat rewrite_equiv.

(** wp is proper wrt extensional equivalence of its function
    arguments. *)
Instance Proper_wp : Proper (eq ==> f_Qeq ==> f_Qeq ==> iff) wp.
Proof.
  unfold f_Qeq; intros ? c ? f g Heq f' g' Heq'; subst; split; intro Hwp.
  - revert f g Heq f' g' Heq' Hwp.
    induction c; intros f g Heq f' g' Heq' Hwp; inversion Hwp; subst.
    + constructor; intro x; rewrite <- Heq, H; apply Heq'.
    + constructor; intro x; rewrite <- H, Heq'; reflexivity.
    + constructor; intro x. rewrite <- Heq, <- H3, Heq'; reflexivity.
    + econstructor; eauto.
      eapply IHc2; eauto; reflexivity. intro x; rewrite <- Heq'; apply H5.
    + assert (Hwp0: wp c1 g g0).
      { eapply IHc1; eauto; reflexivity. }
      assert (Hwp1: wp c2 g h).
      { eapply IHc2; eauto; reflexivity. }
      econstructor; eauto.
      intro x; rewrite <- Heq'; auto.
    + econstructor.
      * eapply IHc1. auto. apply (f_Qeq_refl g0). auto.
      * eapply IHc2. auto. apply (f_Qeq_refl h). auto.
      * intro x; rewrite <- Heq', H6; reflexivity.
    + econstructor; eauto.
      * intro x. rewrite H1. destruct (e x); auto; lra.
      * intro n. specialize (H2 n). destruct H2 as [g0 [Hg0 Hg0']].
        exists g0. split; auto.
        intro x. rewrite Hg0'.
        destruct (e x); auto; reflexivity.
      * eapply equ_supremum; eauto.
        apply f_Qeq_equ; auto.
    + constructor; intro x; rewrite <- Heq', H0.
      destruct (e x); auto; reflexivity.
  - revert f g Heq f' g' Heq' Hwp.
    induction c; intros f g Heq f' g' Heq' Hwp; inversion Hwp; subst.
    + constructor; intro x; rewrite Heq, Heq'; auto.
    + constructor; intro x; rewrite <- H, Heq'; reflexivity.
    + constructor; intro x. rewrite Heq, Heq'; auto.
    + econstructor; eauto.
      eapply IHc2; eauto; reflexivity. intro x; rewrite Heq'; apply H5.
    + assert (Hwp0: wp c1 f g0).
      { eapply IHc1; eauto; reflexivity. }
      assert (Hwp1: wp c2 f h).
      { eapply IHc2; eauto; reflexivity. }
      econstructor; eauto.
      intro x; rewrite Heq'; auto.
    + econstructor.
      * eapply IHc1. auto. apply (f_Qeq_refl g0). auto.
      * eapply IHc2. auto. apply (f_Qeq_refl h). auto.
      * intro x; rewrite Heq', H6; reflexivity.
    + econstructor; eauto.
      * intro x; rewrite H1; destruct (e x); try rewrite Heq; reflexivity.
      * intro n. specialize (H2 n). destruct H2 as [g0 [Hg0 Hg0']].
        exists g0. split; auto.
        intro x. rewrite Hg0'.
        destruct (e x); auto. reflexivity. rewrite Heq; reflexivity.
      * eapply equ_supremum; eauto.
        apply f_Qeq_equ; intro x; symmetry; apply Heq'.
    + constructor; intro x; rewrite  Heq', H0.
      destruct (e x); symmetry; auto; reflexivity.
Qed.

(** wlp is proper wrt extensional equivalence of its function
    arguments. *)
Instance Proper_wlp : Proper (eq ==> f_Qeq ==> f_Qeq ==> iff) wlp.
Proof.
  unfold f_Qeq; intros ? c ? f g Heq f' g' Heq'; subst; split; intro Hwlp.
  - revert f g Heq f' g' Heq' Hwlp.
    induction c; intros f g Heq f' g' Heq' Hwlp; inversion Hwlp; subst.
    + constructor; intro x; rewrite <- Heq, H; apply Heq'.
    + constructor; intro x; rewrite <- H, Heq'; reflexivity.
    + constructor; intro x. rewrite <- Heq, <- H3, Heq'; reflexivity.
    + econstructor; eauto.
      eapply IHc2; eauto; reflexivity. intro x; rewrite <- Heq'; apply H5.
    + assert (Hwp0: wlp c1 g g0).
      { eapply IHc1; eauto; reflexivity. }
      assert (Hwp1: wlp c2 g h).
      { eapply IHc2; eauto; reflexivity. }
      econstructor; eauto.
      intro x; rewrite <- Heq'; auto.
    + econstructor.
      * eapply IHc1. auto. apply (f_Qeq_refl g0). auto.
      * eapply IHc2. auto. apply (f_Qeq_refl h). auto.
      * intro x; rewrite <- Heq', H6; reflexivity.
    + econstructor; eauto.
      * intro x; rewrite H1; destruct (e x); auto; reflexivity.
      * intro n. specialize (H2 n). destruct H2 as [g0 [Hg0 Hg0']].
        exists g0. split; auto.
        intro x. rewrite Hg0'.
        destruct (e x); auto; reflexivity.
      * eapply equ_infimum; eauto.
        apply f_Qeq_equ; auto.
    + constructor; intro x; rewrite <- Heq', H0.
      destruct (e x); auto; reflexivity.
  - revert f g Heq f' g' Heq' Hwlp.
    induction c; intros f g Heq f' g' Heq' Hwp; inversion Hwp; subst.
    + constructor; intro x; rewrite Heq, Heq'; auto.
    + constructor; intro x; rewrite <- H, Heq'; reflexivity.
    + constructor; intro x. rewrite Heq, Heq'; auto.
    + econstructor; eauto.
      eapply IHc2; eauto; reflexivity. intro x; rewrite Heq'; apply H5.
    + assert (Hwp0: wlp c1 f g0).
      { eapply IHc1; eauto; reflexivity. }
      assert (Hwp1: wlp c2 f h).
      { eapply IHc2; eauto; reflexivity. }
      econstructor; eauto.
      intro x; rewrite Heq'; auto.
    + econstructor.
      * eapply IHc1. auto. apply (f_Qeq_refl g0). auto.
      * eapply IHc2. auto. apply (f_Qeq_refl h). auto.
      * intro x; rewrite Heq', H6; reflexivity.
    + econstructor; eauto.
      * intro x; rewrite H1; destruct (e x); try rewrite Heq; reflexivity.
      * intro n. specialize (H2 n). destruct H2 as [g0 [Hg0 Hg0']].
        exists g0. split; auto.
        intro x. rewrite Hg0'.
        destruct (e x); auto. reflexivity. rewrite Heq; reflexivity.
      * eapply equ_infimum; eauto.
        apply f_Qeq_equ; intro x; symmetry; apply Heq'.
    + constructor; intro x; rewrite  Heq', H0.
      destruct (e x); symmetry; auto; reflexivity.
Qed.

(** cwp is proper wrt extensional equivalence of its function
    arguments. *)
Instance Proper_cwp : Proper (eq ==> f_Qeq ==> f_Qeq ==> iff) cwp.
Proof.
  unfold f_Qeq; intros ? c ? f g Heq f' g' Heq'; subst.
  unfold cwp, cwp_.
  split; intros (f'' & g'' & [Hwp Hwlp] & Hrat).
  - exists f'', g''; split.
    + split.
      * eapply Proper_wp; unfold f_Qeq.
        reflexivity. symmetry. eauto. reflexivity. auto.
      * apply Hwlp.
    + intro x; rewrite <- Heq'; auto.
  - exists f'', g''; split.
    + split.
      * eapply Proper_wp; unfold f_Qeq.
        reflexivity. eauto. reflexivity. auto.
      * apply Hwlp.
    + intro x; rewrite Heq'; auto.
Qed.

(** wpf is proper wrt extensional equivalence of its function
    arguments. *)
Instance Proper_wpf : Proper (eq ==> f_Qeq ==> f_Qeq) wpf.
Proof.
  intros c1 c2 Heq; subst.
  induction c2; intros f g Hqeq st; simpl.
  - apply Hqeq.
  - reflexivity.
  - apply Hqeq.
  - unfold compose, respectful, f_Qeq in *.
    rewrite IHc2_1. reflexivity. apply IHc2_2; auto.
  - destruct (e st).
    + apply IHc2_1; auto.
    + apply IHc2_2; auto.
  - unfold respectful, f_Qeq in *.
    rewrite IHc2_1, IHc2_2; auto; reflexivity.
  - unfold respectful, f_Qeq in *.
    destruct (e st); auto.
    rewrite IHc2. reflexivity.
    intros; simpl; destruct (e x); auto; reflexivity.
  - destruct (e st); auto; reflexivity.
Qed.

(** wlpf is proper wrt extensional equivalence of its function
    arguments. *)
Instance Proper_wlpf : Proper (eq ==> f_Qeq ==> f_Qeq) wlpf.
Proof.
  intros c1 c2 Heq; subst.
  induction c2; intros f g Hqeq st; simpl.
  - apply Hqeq.
  - reflexivity.
  - apply Hqeq.
  - unfold compose, respectful, f_Qeq in *.
    rewrite IHc2_1. reflexivity. apply IHc2_2; auto.
  - destruct (e st).
    + apply IHc2_1; auto.
    + apply IHc2_2; auto.
  - unfold respectful, f_Qeq in *.
    rewrite IHc2_1, IHc2_2; auto; reflexivity.
  - unfold respectful, f_Qeq in *.
    destruct (e st); auto.
    set (a := wlpf c2 (fun st' : St => if e st' then 0 else f st') st).
    set (r := wpf c2 (fun st' : St => if e st' then 1 else 0) st).
    destruct (Qeq_dec r 1).
    + rewrite Qeq_eq_bool; lra.
    + rewrite Qeq_bool_false; auto.
      rewrite IHc2. reflexivity.
    intros; simpl; destruct (e x). reflexivity.
    rewrite Hqeq; reflexivity.
  - destruct (e st); auto; reflexivity.
Qed.

(** wp preserves const 0. *)
Lemma wp_strict c :
  wp c (const 0) (const 0).
Proof.
  induction c; try (constructor; reflexivity).
  - econstructor; eauto; reflexivity.
  - econstructor; eauto; intro x; destruct (e x); reflexivity.
  - econstructor; eauto; unfold const; intro; lra.
  - apply wp_while with (ch := const (const 0)).
    + intro x; destruct (e x); reflexivity.
    + intro i; exists (const 0).
      unfold const; split; auto.
      intro x; destruct (e x); reflexivity.
    + apply const_supremum; reflexivity.
  - constructor; intro x; destruct (e x); reflexivity.
Qed.

(** wlp preserves const 1. *)
Lemma wlp_strict c :
  no_obs c ->
  wlp c (const 1) (const 1).
Proof.
  induction c; intros Hno_obs;
    try (constructor; reflexivity); inversion Hno_obs; subst.
  - econstructor; eauto; reflexivity.
  - econstructor; eauto; intro x; destruct (e x); reflexivity.
  - econstructor; eauto; unfold const; intro; lra.
  - apply wlp_while with (ch := const (const 1)).
    + intro x; destruct (e x); reflexivity.
    + intro i; exists (const 1).
      unfold const; split; auto.
      intro x; destruct (e x); reflexivity.
    + apply const_infimum; reflexivity.
Qed.

(** wp is deterministic up to extensional equivalence. *)
Lemma wp_deterministic c f g g' :
  wp c f g ->
  wp c f g' ->
  g ==f g'.
Proof.
  revert f g g'.
  induction c; simpl; intros f g g' Hwlp1 Hwlp2;
    inversion Hwlp1; inversion Hwlp2; subst.
  - intros; rewrite <- H; auto.
  - intros; rewrite H, H0; reflexivity.
  - intros; rewrite H3, H8; reflexivity.
  - assert (g0 ==f g1).
    { eapply IHc2; eauto. }
    intros; rewrite H5, H12. eapply IHc1; eauto.
    eapply Proper_wp. reflexivity.
    intro y. apply H. reflexivity.
    auto.
  - intros; rewrite H6, H14.
    destruct (e x).
    + eapply IHc1; eauto.
    + eapply IHc2; eauto.
  - intros; rewrite H6, H14.
    assert (Hg: g0 ==f g1).
    { eapply IHc1; eauto. }
    assert (Hh: h ==f h0).
    { eapply IHc2; eauto. }
    rewrite Hg, Hh; reflexivity.
  - apply f_Qeq_equ.
    eapply supremum_unique; eauto.
    assert (equ ch ch0).
    { apply chain_equ.
      intro i. apply f_Qeq_equ.
      induction i; intro x.
      - rewrite H1, H8; reflexivity.
      - destruct (H2 i) as [h [Hwlp1' Hch1]].
        destruct (H9 i) as [h' [Hwlp2' Hch2]].
        rewrite Hch1, Hch2.
        destruct (e x); try reflexivity.
        eapply IHc; eauto.
        eapply Proper_wp. reflexivity.
        intro y. apply IHi. reflexivity.
        auto. }
    eapply Proper_supremum. reflexivity. eauto. auto.
  - intros x; rewrite H0, H4; destruct (e x); reflexivity.
Qed.

(** wlp is deterministic up to extensional equivalence. *)
Lemma wlp_deterministic c f g g' :
  wlp c f g ->
  wlp c f g' ->
  g ==f g'.
Proof.
  revert f g g'.
  induction c; simpl; intros f g g' Hwlp1 Hwlp2;
    inversion Hwlp1; inversion Hwlp2; subst.
  - intros; rewrite <- H; auto.
  - intros; rewrite H, H0; reflexivity.
  - intros; rewrite H3, H8; reflexivity.
  - assert (g0 ==f g1).
    { eapply IHc2; eauto. }
    intros; rewrite H5, H12. eapply IHc1; eauto.
    eapply Proper_wlp. reflexivity.
    intro y. apply H. reflexivity.
    auto.
  - intros; rewrite H6, H14.
    destruct (e x).
    + eapply IHc1; eauto.
    + eapply IHc2; eauto.
  - intros; rewrite H6, H14.
    assert (Hg: g0 ==f g1).
    { eapply IHc1; eauto. }
    assert (Hh: h ==f h0).
    { eapply IHc2; eauto. }
    rewrite Hg, Hh; reflexivity.
  - apply f_Qeq_equ.
    eapply infimum_unique; eauto.
    assert (equ ch ch0).
    { apply chain_equ.
      intro i. apply f_Qeq_equ.
      induction i; intro x.
      - rewrite H1, H8; reflexivity.
      - destruct (H2 i) as [h [Hwlp1' Hch1]].
        destruct (H9 i) as [h' [Hwlp2' Hch2]].
        rewrite Hch1, Hch2.
        destruct (e x); try reflexivity.
        eapply IHc; eauto.
        eapply Proper_wlp. reflexivity.
        intro y. apply IHi. reflexivity.
        auto. }
    eapply Proper_infimum. reflexivity. eauto. auto.
  - intros x; rewrite H0, H4; destruct (e x); reflexivity.
Qed.

(** cwp is deterministic up to extensional equivalence. *)
Lemma cwp_deterministic c f g g' :
  cwp c f g ->
  cwp c f g' ->
  g ==f g'.
Proof.
  unfold cwp.
  intros (n & m & [Hwp Hwlp] & Hg) (n' & m' & [Hwp' Hwlp'] & Hg') x.
  rewrite Hg, Hg'.
  rewrite wp_deterministic; eauto.
  cut (m x == m' x).
  { intros; rewrite H; reflexivity. }
  eapply wlp_deterministic; eauto.
Qed.

(* Lemma wp_expectation (c : cpGCL) (f f' : St -> Q) : *)
(*   wf_cpGCL c -> *)
(*   expectation f -> *)
(*   wp c f f' -> *)
(*   expectation f'. *)
(* Proof. *)
(* Admitted. *)

(* (** The relational version of wp is monotone (the corresponding proof *)
(*     for wpf is in cwp_cwpf.v. *) *)
(* Lemma wp_monotone (c : cpGCL) : *)
(*   wf_cpGCL c -> *)
(*   forall f f' g g' : St -> Q, *)
(*     expectation f -> expectation g -> *)
(*     wp c f f' -> wp c g g' -> *)
(*     leq f g -> leq f' g'. *)
(* Proof. *)
(*   induction c; simpl; intros Hwf f f' g g' Hf Hg Hwpf Hwpg Hleq; *)
(*     inversion Hwpf; inversion Hwpg; subst; intro x. *)
(*   - rewrite <- H, <- H0; auto. *)
(*   - rewrite H, H0; lra. *)
(*   - rewrite H3, H8; apply Hleq. *)
(*   - inversion Hwf; subst; rewrite H5, H12. *)
(*     eapply IHc1 with (f:=g0) (g:=g1); eauto. *)
(*     + eapply wp_expectation with (f:=f); eauto. *)
(*     + eapply wp_expectation with (f:=g); eauto. *)
(*   - inversion Hwf; subst; rewrite H6, H14; destruct (e x). *)
(*     + eapply IHc1 with (f:=f); eauto. *)
(*     + eapply IHc2 with (f:=f); eauto. *)
(*   - inversion Hwf; subst; rewrite H6, H14. *)
(*     cut (g0 x <= g1 x). *)
(*     { intro Hle; cut (h x <= h0 x). *)
(*       { nra. } *)
(*       eapply IHc2 with (f:=f); eauto. } *)
(*     eapply IHc1 with (f:=f); eauto. *)
(*   - admit. *)
(*   - rewrite H0, H4; destruct (e x); auto; lra. *)
(* Admitted. *)

Lemma unroll_le (e : exp) (c : cpGCL) (i : nat) :
  unroll e c i ⊑ unroll e c (S i).
Proof.
  induction i.
  - repeat constructor.
  - constructor; constructor; apply IHi.
Qed.

(* (** wp is ω-continuous. *) *)
(* Lemma wp_continuous (c : cpGCL) : *)
(*   wf_cpGCL c -> *)
(*   forall ch ch' : nat -> St -> Q, forall sup sup' : St -> Q, *)
(*       chain ch -> *)
(*       (forall i, expectation (ch i)) -> *)
(*       supremum sup ch -> *)
(*       wp c sup sup' -> *)
(*       (forall i, wp c (ch i) (ch' i)) -> *)
(*       supremum sup' ch'. *)
(* Proof. *)
(*   induction c; intros Hwf ch ch' sup sup' Hchain Hexp Hsup Hwpsup Hwpchain. *)
(*   - inversion Hwpsup; subst. *)
(*     rewrite f_Qeq_equ in H. rewrite <- H. *)
(*     assert (H0: equ ch ch'). *)
(*     { split; intro i; specialize (Hwpchain i); inversion Hwpchain; subst; *)
(*         apply f_Qeq_equ in H0; apply H0. } *)
(*     rewrite <- H0; auto. *)
(*   - inversion Hwpsup; subst. *)
(*     rewrite f_Qeq_equ in H. rewrite H. *)
(*     assert (H0: equ ch' (const (const 0))). *)
(*     { split; intro i; specialize (Hwpchain i); inversion Hwpchain; subst; *)
(*         apply f_Qeq_equ in H0; apply H0. } *)
(*     rewrite H0. *)
(*     apply const_supremum; intro i; apply f_Qeq_equ; intro j; reflexivity. *)
(*   - inversion Hwpsup; subst. *)
(*     apply f_Qeq_equ in H3; rewrite H3; clear H3. *)
(*     split. *)
(*     + intros i x. specialize (Hwpchain i). *)
(*       inversion Hwpchain; subst. *)
(*       rewrite H3. apply Hsup. *)
(*     + intros ub Hub. *)
(*     admit. *)
(*   - inversion Hwpsup; subst. *)
(*     apply f_Qeq_equ in H5. *)
(*     rewrite H5. *)
(*     inversion Hwf; subst. *)
(*     assert (Htemp: forall i, exists f, wp c1 f (ch' i) /\ wp c2 (ch i) f). *)
(*     { intro i. specialize (Hwpchain i). inversion Hwpchain; subst. *)
(*       exists g0; auto; split; eapply Proper_wp; eauto; reflexivity. } *)
(*     (* Need choice function to turn Htemp into Hch'' *) *)
(*     assert (Hch'': exists ch'', (forall i, wp c1 (ch'' i) (ch' i) /\ wp c2 (ch i) (ch'' i))). *)
(*     { admit. } *)
(*     destruct Hch'' as [ch'' Hch'']. *)
(*     eapply IHc2 with (ch' := ch'') in H1; eauto. *)
(*     2: { apply Hch''. } *)
(*     eapply IHc1 with (ch := ch'') (ch' := ch') in H2; eauto. *)
(*     + intro i; eapply wp_monotone; eauto; apply Hch''. *)
(*     + intro i; eapply wp_expectation; eauto; apply Hch''. *)
(*     + apply Hch''. *)
(*   - admit. *)
(*   - admit. *)
(*   - admit. *)
(*   - inversion Hwpsup; subst. *)
(*     apply f_Qeq_equ in H0; rewrite H0; clear H0. *)
(*     admit. *)
(* Admitted. *)


(* -*- mode: coq; mode: visual-line -*-  *)
(** * Impredicative truncations. *)

Require Import HoTT.Basics HoTT.Types.
Require Import PropResizing.PropResizing.
Local Open Scope path_scope.

(* Be careful about [Import]ing this file!  It defines truncations
with the same name as those constructed with HITs.  Probably you want
to use those instead, if you are using HITs. *)

Section AssumePropResizing.
  Context `{PropResizing}.

  Definition merely@{i j} (A : Type@{i}) : Type@{i}
    := forall P:Type@{j}, IsHProp P -> (A -> P) -> P.   (* requires j < i *)

  Definition trm {A} : A -> merely A
    := fun a P HP f => f a.

  Global Instance ishprop_merely `{Funext} (A : Type) : IsHProp (merely A).
  Proof.
    exact _.
  Defined.

  Definition merely_rec {A : Type@{i}} {P : Type@{j}} `{IsHProp P} (f : A -> P)
    : merely A -> P
    := fun ma => (equiv_resize_hprop P)^-1
                 (ma (resize_hprop P) _ (equiv_resize_hprop P o f)).

  Definition functor_merely `{Funext} {A B : Type} (f : A -> B)
    : merely A -> merely B.
  Proof.
    srefine (merely_rec (trm o f)).
  Defined.

(* show what is gained by propositional resizing, without mentioning universe levels *)
  Local Definition typeofid (A : Type) := A -> A.

  Local Definition functor_merely_sameargs `{Funext} {A : Type} (f : typeofid A)
    : typeofid (merely A) := functor_merely f.

(* a more informative version using universe levels *)
  Local Definition functor_merely_sameuniv `{Funext} {A B: Type@{i}} (f : A -> B)
    : merely@{j k} A -> merely@{j k} B:= functor_merely f.    (* requires i <= j & k < j *)

End AssumePropResizing.

(* Here, we show what goes wrong without propositional resizing. *)

(* the naive definition *)
Local Definition merely_rec_naive {A : Type@{i}} {P : Type@{j}} {p:IsHProp@{j} P} (f : A -> P)
  : merely@{i j} A -> P
  := fun ma => ma P p f.

(* the too weak definition *)
Local Definition functor_merely_weak `{Funext} {A B : Type@{k}} (f : A -> B)
  : merely@{j k} A -> merely@{k l} B. (* evidently, this requires k<j and l<k *)
Proof.
  srefine (merely_rec_naive (trm o f)).
Defined.

(* impossible due to universe inconsistency: *)
Fail Local Definition functor_merely_weak_sameargs `{Funext} {A : Type} (f : typeofid A)
  : typeofid(merely A) := functor_merely_weak f.

(* The following much weaker definition is possible: *)
Local Definition functor_merely_weak_sameargs_weak `{Funext} {A : Type} (f : typeofid A)
  : merely A -> merely A := functor_merely_weak f.

(* a more general (but still weak) and more informative version using universe levels *)
Local Definition functor_merely_weak_sameuniv_weak `{Funext} {A B: Type@{i}} (f : A -> B)
  : merely@{j k} A -> merely@{k l} B:= functor_merely_weak f.
(* requires i <= j & l < k < j *)


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Deterministic
        Type_Safety
        Typing.

Require Import List. Import ListNotations.
Require Import Arith Omega.
Require Import Strings.String.

Lemma tpre_refl: forall A,
  tpre A A.
Proof.
   inductions A; eauto.
Qed.

Lemma sim_refl: forall A,
 sim A A.
Proof.
  introv.
  inductions A; eauto.
Qed.

Lemma epre_lc: forall e1 e2,
 epre e1 e2 ->
 lc_exp e1 ->
 lc_exp e2.
Proof.
  introv ep lc. gen e2.
  inductions lc; intros; eauto;
  try solve [inverts ep; eauto].
Qed.

Lemma epre_lc2: forall e1 e2,
 epre e1 e2 ->
 lc_exp e2 ->
 lc_exp e1.
Proof.
  introv ep lc. gen e1.
  inductions lc; intros; eauto;
  try solve [inverts ep; eauto].
Qed.

Lemma epre_open: forall e1 e2 u1 u2 x,
 epre e1 e2 ->
 epre u1 u2 ->
 lc_exp u1 ->
 lc_exp u2 ->
 epre [x~> u1]e1 [x~>u2]e2 .
Proof.
  introv ep1 ep2 lc1 lc2. gen u1 u2 x.
  inductions ep1; intros;
  simpl; eauto.
  - inductions H; simpl; eauto.
    + destruct (x == x0); eauto.
    +
      apply ep_abs with (L := (singleton x)); intros; auto.
      forwards*: H0 x0 ep2 x.
      rewrite subst_exp_open_exp_wrt_exp_var; eauto.
      rewrite subst_exp_open_exp_wrt_exp_var; eauto.
      apply tpre_refl. apply tpre_refl.
    + apply ep_anno; eauto.
      apply tpre_refl.
    + apply ep_save; eauto.
      apply tpre_refl.
  -
    apply ep_abs with (L := (union L (singleton x))); intros; auto.
    forwards*: H0 x0 ep2 x.
    rewrite subst_exp_open_exp_wrt_exp_var; eauto.
      rewrite subst_exp_open_exp_wrt_exp_var; eauto.
Qed.

Lemma Typing_c_rename : forall (x y : atom) E e T1 T2,
  x `notin` fv_exp e -> y `notin` (dom E `union` fv_exp e) ->
  Typing ((x , T1) :: E) (open_exp_wrt_exp e (e_var_f x)) Inf T2 ->
  Typing ((y , T1) :: E) (open_exp_wrt_exp e (e_var_f y)) Inf T2.
Proof.
  intros x y E e T1 T2 Fr1 Fr2 H.
  destruct (x == y).
  Case "x = y".
    subst; eauto.
  Case "x <> y".
    assert (J : uniq (((x , T1) :: E))).
      eapply Typing_regular_2; eauto.
    assert (J' : uniq E).
      inversion J; eauto.
    rewrite (@subst_exp_intro x); eauto.
    rewrite_env (nil ++ ((y , T1) :: E)).
    apply Typing_subst_1 with (S := T1).
    simpl_env.
    SCase "(open x s) is well-typed".
      apply Typing_weaken. eauto. auto.
    SCase "y is well-typed". eauto.
Qed.

Theorem precise_type: forall e e' T T',
   epre e e' ->
   Typing nil e Inf T ->
   Typing nil e' Inf T'->
   tpre T T'.
Proof.
    introv ep Typ1 Typ2.
    gen T T'.
    inductions ep; intros;
    try solve[inverts* Typ1; inverts* Typ2].
    - forwards*: inference_unique Typ1 Typ2. subst.
      apply tpre_refl.
    - inverts* Typ1.
      inverts* Typ2.
      forwards*: IHep1 H2 H4.
      inverts* H.
Qed.

Lemma vval_pre: forall e1 e2,
  epre e1 e2 ->
  vvalue e1 ->
  vvalue e2.
Proof.
  introv ep vval1. gen e2.
  inductions vval1; intros; eauto.
  - inverts ep. eauto. inverts H3. eauto.
  - inverts ep. eauto. inverts* H4.
    assert (epre (e_abs A e B) (e_abs A2 e2 B2)).
    eauto.
    forwards*: epre_lc H0.
Qed.

Lemma val_pre: forall e1 e2,
  epre e1 e2 ->
  value e2 ->
  value e1.
Proof.
  introv ep vval1. gen e1.
  inductions vval1; intros; eauto.
  - inverts ep. eauto. inverts H3. eauto.
  - inverts ep. eauto. inverts* H4.
    pick fresh x.
    forwards*: H6.
    assert(epre ((e_abs A1 e1 B1)) ((e_abs A e B))). eauto.
    forwards*: epre_lc2 H1.
  - inverts ep. inverts* H. inverts H; inverts* H4.
    assert(epre ((e_abs A2 e2 B1)) ((e_abs A1 e1 B))). eauto.
    forwards*: epre_lc2 H.
Qed.

Lemma val_prel: forall e1 e2,
  epre e1 e2 ->
  value e1 ->
  value e2.
Proof.
  introv ep vval1. gen e2.
  inductions vval1; intros; eauto.
  - inverts ep. eauto. inverts H3. eauto.
  - inverts ep. eauto. inverts* H4.
    assert(epre ((e_abs A e B)) ((e_abs A2 e2 B2))). eauto.
    forwards*: epre_lc H0.
  - inverts ep. inverts* H. inverts* H. inverts* H4.
     assert(epre ((e_abs A0 e1 B0)) ((e_abs A2 e3 B2))). eauto.
    forwards*: epre_lc H.
    inverts* H4.
Qed.

Lemma epre_sim : forall A1 B1 A2 B2,
  sim A1 B1 ->
  tpre A1 A2 ->
  tpre B1 B2 ->
  sim A2 B2.
Proof.
  introv s1 tp1 tp2. gen A2 B2.
  inductions s1; intros; eauto.
  - inverts tp1. inverts* tp2. inverts* tp2.
  - inverts* tp1.
    inverts* tp2.
  - inverts* tp1.
  - inverts* tp2.
Qed.

Lemma tdynamic_guarantee: forall e1 e2 e1' A B,
 epre e1 e2 ->
 tpre A B ->
 value e1 ->
 Typing nil e1 Chk A ->
 Typing nil e2 Chk B ->
 cTypedReduce e1 A (Expr e1') ->
 exists e2', cTypedReduce e2 B (Expr e2') /\ epre e1' e2'.
Proof.
  introv ep tp val typ1 typ2 red. gen e2 B .
  inductions red; intros; eauto.
  - forwards*: val_prel ep.
    inverts val.
    + destruct B.
      * inverts tp. inverts ep. inverts typ2. inverts H3.
        inverts H7. inverts H3. inverts H4.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto. inverts H6.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto. inverts ep.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto. inverts H6.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
      * inverts* H0.
      * inverts tp. inverts typ2.
        inverts ep.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto. inverts H8.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
    + destruct B.
      * inverts tp. inverts ep. inverts typ2. inverts H4.
        inverts H8. inverts H4. inverts H6. inverts H5.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
        inverts H7.  inverts typ2. inverts H4.
        inverts H9. inverts H4. inverts H7. inverts H6. inverts H0.
        inverts H0. inverts H0.
      * inverts tp. inverts ep.  inverts typ2. inverts H4.
         exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
        forwards*: value_lc H1. inverts H2.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
        inverts ep.
        simpl in H0.
        assert(tpre (t_arrow A0 B1) (t_arrow A0 B1)). apply tpre_refl.
        assert (tpre (t_arrow B2 B3) (t_arrow C D)). eauto.
        forwards*: epre_sim H0 H4 H6.
        exists. split.
        apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
        inverts H9.
        simpl in H0.
        assert(tpre (t_arrow A0 B1) (t_arrow A0 B1)). apply tpre_refl.
        assert (tpre (t_arrow B2 B3) (t_arrow C D)). eauto.
        forwards*: epre_sim H0 H4 H8.
        exists. split.
        apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
        simpl in H0.
        assert(tpre (t_arrow A0 B1) (t_arrow A2 B4)). eauto.
        assert (tpre (t_arrow B2 B3) (t_arrow C D)). eauto.
        forwards*: epre_sim H0 H2 H4.
        exists. split.
        assert (epre (e_abs A0 e0 B1) (e_abs A2 e2 B4)).
        eauto. forwards*: epre_lc H9.
        apply ep_anno; eauto.
      * inverts tp. inverts typ2.
        inverts ep.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
        forwards*: value_lc H1. inverts H5.
        exists. split. apply cTReduce_sim; eauto.
        apply ep_anno; eauto.
  - inverts* ep. inverts typ2. inverts H1.
    + destruct B.
      * inverts tp.
       exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto. inverts* H0.
        exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto. inverts* H0.
      * inverts tp.
         exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto. inverts* H0.
        inverts H6.
        simpl in H.
        assert(tpre (t_arrow A B) (t_arrow A B)). apply tpre_refl.
        assert (tpre (t_arrow B2 B3) (t_arrow C D)). eauto.
        forwards*: epre_sim H H3 H6.
        exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto.  inverts H.
      * inverts tp.
        exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto. inverts* H0.
    + destruct B.
      * inverts val. inverts tp. inverts H1. inverts H.
        inverts H4.  exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto.  inverts H1. inverts H.
        exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto.
      * inverts tp.
         exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto. inverts val. inverts H1.
        inverts H4.
        simpl in H.
        assert(tpre (t_arrow A0 B) (t_arrow A0 B)). apply tpre_refl.
        assert (tpre (t_arrow B2 B3) (t_arrow C D)). eauto.
        forwards*: epre_sim H H4 H5.
        exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto.
        assert(tpre (t_arrow A0 B) (t_arrow A2 B4)). eauto.
        assert (tpre (t_arrow B2 B3) (t_arrow C D)). eauto.
        forwards*: epre_sim H H1 H4.
        assert (epre (e_abs A0 e1 B) (e_abs A2 e3 B4)).
        eauto. forwards*: epre_lc H7.
        inverts H.
      * inverts tp.
        exists. split. apply cTReduce_savep; eauto.
        apply ep_anno; eauto.
Qed.

Lemma dynamic_guarantee_dir: forall e1 e2 e1' dir T1 T2,
 epre e1 e2 ->
 Typing nil e1 dir T1 ->
 Typing nil e2 dir T2 ->
 cstep e1 (Expr e1') ->
 exists e2', cstep e2 (Expr e2') /\ epre e1' e2'.
Proof.
  introv ep typ1 typ2 red. gen e1' dir T1 T2.
  inductions ep; intros; eauto.
  - exists. split. apply red. apply ep_refl.
    forwards*: cpreservation typ1.
    forwards*: Typing_regular_1 H0.
  - inverts red. exists. split. assert (epre (e_abs A1 e1 B1) (e_abs A2 e2 B2)).
    eauto. forwards*: epre_lc H3. apply ep_anno; eauto.
    destruct E; unfold simpl_fill in H3; inverts* H3.
  - inverts red.
    + destruct E; unfold simpl_fill in H; inverts* H.
      inverts typ1. inverts typ2.
      forwards*: IHep1 H2. inverts H. inverts H0.
      exists. rewrite sfill_appl. split. apply cdo_step; eauto.
      unfold simpl_fill. eauto.
      inverts typ2. inverts H. inverts H3.
      forwards*: IHep1 H2. inverts H. inverts H3.
      exists. rewrite sfill_appl. split. apply cdo_step; eauto.
      unfold simpl_fill. eauto.
      inverts typ1.  inverts typ2.
      forwards*: IHep2 H2. inverts H. inverts H0.
      rewrite sfill_appr. exists. inverts H1.  split.
      apply cdo_step; eauto. forwards*: vval_pre ep1. unfold simpl_fill. eauto.
      inverts typ2.  inverts H. inverts H3.
      forwards*: IHep2 H2. inverts H. inverts H3.
      rewrite sfill_appr. exists. inverts H1.  split.
      apply cdo_step; eauto. forwards*: vval_pre ep1. unfold simpl_fill. eauto.
    + inverts* ep1.
      forwards*: vval_pre ep2.
      exists. split. apply cStep_beta; eauto.
      apply ep_anno; eauto. apply tpre_refl.
      apply ep_anno; eauto. apply tpre_refl.
      forwards*: vval_val H3.
      forwards*: vval_val H0.

      assert (epre (e_anno (e_anno e2 A2) A1) (e_anno (e_anno e2' A2) A1)).
      apply ep_anno; eauto. apply tpre_refl.
      apply ep_anno; eauto. apply tpre_refl.
      pick fresh x.
      assert((e ^^ e_anno (e_anno e2' A2) A1) = [x ~> e_anno (e_anno e2' A2) A1] (e ^ x)).
      rewrite (subst_exp_intro x); eauto.
      rewrite (subst_exp_intro x); eauto.
      rewrite H6.
      forwards*: vval_val H3. forwards*: vval_val H0.
      forwards*: value_lc H7. forwards*: value_lc H8.
      assert(lc_exp (e_anno (e_anno e2 A2) A1)); eauto.
      assert(lc_exp (e_anno (e_anno e2' A2) A1)); eauto.
      inverts H2. forwards*: H14 x.
      assert(epre (e^x) (e^x)); eauto.
      forwards*: epre_open H13 H5 H11 H12.

      inverts* H5. inverts* H1.
      inverts typ2. inverts H5.
      inverts H0. inverts H7.
      forwards*: vval_pre ep2.
      exists. split. apply cStep_beta; eauto.
      apply ep_anno; eauto.
      apply ep_anno; eauto. apply tpre_refl.
      assert (epre (e_anno (e_anno e2 A2) A1) (e_anno (e_anno e2' C) A1)).
      apply ep_anno; eauto. apply tpre_refl.
      pick fresh x.
      assert((e ^^ e_anno (e_anno e2' C) A1) = [x ~>e_anno (e_anno e2' C) A1] (e ^ x)).
      rewrite (subst_exp_intro x); eauto.
      rewrite (subst_exp_intro x); eauto.
      rewrite H4.
      forwards*: vval_val H3. forwards*: vval_val H0.
      forwards*: value_lc H6. forwards*: value_lc H8.
      assert(lc_exp (e_anno (e_anno e2 A2) A1)); eauto.
      assert(lc_exp (e_anno (e_anno e2' C) A1)); eauto.
      inverts H2. forwards*: H14 x.
      assert(epre (e^x) (e^x)); eauto.
      forwards*: epre_open H13 H1 H11 H12.

      inverts typ2. inverts H5.
      forwards*: vval_pre ep2.
      exists. split. apply cStep_beta; eauto.
      assert(epre (e_abs A1 e B1) (e_abs A3 e3 B3)).
      eauto. forwards*: epre_lc H0.
      apply ep_anno; eauto. inverts H1. auto.
      apply ep_anno; eauto. inverts H4.
      assert(epre (e_abs A1 e B1) (e_abs A3 e3 B3)).
      eauto.
      forwards*: epre_lc H4.
      pick fresh x.
      forwards*: H6.
      assert(x `notin` (fv_exp e)). eauto.
      assert(x `notin` (fv_exp e3)). eauto.
      assert((e3 ^^ e_anno (e_anno e2' A) A3) = [x ~> e_anno (e_anno e2' A) A3] (e3 ^ x)).
      rewrite (subst_exp_intro x). eauto. auto.
      rewrite (subst_exp_intro x); eauto.
      forwards*:vval_val H3.
      forwards*:vval_val H.
      inverts typ1. inverts H20. inverts H23. inverts H17. inverts H18.
      inverts H0. inverts H5.
      assert (Typing nil (e_anno (e_anno e2 A4) A1) Inf A1).
      apply Typ_anno; eauto. eapply Typ_sim; eauto.
      apply BA_AB. auto.
      forwards*: value_no_fv H0.
      assert (Typing nil (e_anno (e_anno e2' A) A3) Inf A3).
      apply Typ_anno; eauto. eapply Typ_sim; eauto.
      apply BA_AB. auto.
      forwards*: value_no_fv H17.
      forwards*: value_lc H15. forwards*: value_lc H16.
      assert (lc_exp (e_anno (e_anno e2 A4) A1)). eauto.
      assert (lc_exp (e_anno (e_anno e2' A) A3)). eauto. inverts H1.
      assert (epre (e_anno (e_anno e2 A4) A1) (e_anno (e_anno e2' A) A3)).
      apply ep_anno; eauto.
      rewrite H14.
      forwards*: epre_open H10 H1.

      inverts* H1. inverts* H.
      inverts H7. inverts H. inverts H10.
      inverts H13. inverts H.
      forwards*: vval_pre ep2.
      exists. split. apply cStep_beta; eauto.
      assert(epre (e_abs A1 e B1) (e_abs A3 e3 B3)).
      eauto.
      forwards*: epre_lc H4.
      pick fresh x.
      forwards*: H6.
      assert(x `notin` (fv_exp e)). eauto.
      assert(x `notin` (fv_exp e3)). eauto.
      assert((e3 ^^ e_anno (e_anno e2' A0) A3) = [x ~> e_anno (e_anno e2' A0) A3] (e3 ^ x)).
      rewrite (subst_exp_intro x). eauto. auto.
      rewrite (subst_exp_intro x); eauto.
      rewrite H13.
      forwards*: vval_val H3. forwards*: vval_val H.
      forwards*: value_lc H14. forwards*: value_lc H16.
      assert(lc_exp (e_anno (e_anno e2 A2) A1)); eauto.
      assert(lc_exp (e_anno (e_anno e2' A0) A3)); eauto.
      (* forwards*: H14 x. *)
      assert(epre (e^x) (e3^x)); eauto.
      apply ep_anno; eauto.
      apply ep_anno; eauto.
      forwards*: epre_open H21 H19 H20.
  - inverts red.
    + destruct E; unfold simpl_fill in H; inverts* H.
      inverts typ1. inverts typ2. inverts H4. inverts H5. inverts H6. inverts H7.
      forwards*: IHep1 H2. inverts H7. inverts H10.
      exists. rewrite sfill_addl. split. apply cdo_step; eauto.
      unfold simpl_fill. eauto.
      inverts typ2. inverts H3. inverts H.
      forwards*: IHep1 H2. inverts H. inverts H3.
      exists. rewrite sfill_addl. split. apply cdo_step; eauto.
      unfold simpl_fill. eauto.
      inverts typ1. inverts typ2.
      forwards*: IHep2 H2. inverts H. inverts H0.
      exists. rewrite sfill_addr. split. apply cdo_step; eauto.
      inverts H1. forwards*: vval_pre ep1.
      unfold simpl_fill. eauto.
      inverts typ2. inverts H.  inverts H3. inverts H1.
      forwards*: IHep2 H2. inverts H . inverts H1.
      rewrite sfill_addr. exists.   split.
      apply cdo_step; eauto. forwards*: vval_pre ep1. unfold simpl_fill. eauto.
    + inverts typ2. inverts ep1. inverts ep2.
      exists. split. apply cStep_addb; eauto. eauto.
      inverts H6. exists. split. apply cStep_addb; eauto. eauto.
      inverts H4. inverts ep2.
      exists. split. apply cStep_addb; eauto. eauto.
      inverts H7. exists. split. apply cStep_addb; eauto. eauto.
      inverts H. inverts ep1. inverts ep2.
      exists. split. apply cStep_addb; eauto. eauto.
      inverts H7. exists. split. apply cStep_addb; eauto. eauto.
      inverts H6. inverts ep2.
      exists. split. apply cStep_addb; eauto. eauto.
      inverts H8. exists. split. apply cStep_addb; eauto. eauto.
  - inverts red.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    assert (not (value (e_anno e2 A))).
    unfold not; intros. assert (epre (e_anno e1 A) (e_anno e2 A)).
    apply ep_anno; eauto. apply tpre_refl.
    apply H4. forwards*: val_pre H1.
    inverts typ1.  inverts typ2.
    forwards*: IHep H3. inverts H1. inverts H2.
    exists. split. apply cStep_anno; eauto.
    unfold not; intro. inverts H2.
    apply H0. eauto. apply H0. eauto.
    apply ep_anno; eauto.
    inverts typ2. inverts H1.  inverts H5.
    forwards*: IHep H3. inverts H1. inverts H5.
    exists. split. apply cStep_anno; eauto.
    unfold not; intro. inverts H5.
    apply H0. eauto. apply H0. eauto.
    apply ep_anno; eauto.
    inverts typ1. inverts typ2.
    forwards*: tdynamic_guarantee H7 H3 H4. inverts H0.
    inverts H1. exists. split. apply cStep_annov; eauto.
    forwards*: val_prel ep.  auto.
    inverts typ2. inverts H0.  inverts H3.
    forwards*: tdynamic_guarantee H8 H7 H4. inverts H0.
    inverts H3. exists. split. apply cStep_annov; eauto.
    forwards*: val_prel ep.  auto.
  - forwards*: cstep_not_value red. inverts typ1.
    eauto.
    forwards*: cstep_not_value red. inverts H0.
    eauto.
Qed.

Lemma dynamic_guarantee: forall e1 e2 e1' T1 T2,
 epre e1 e2 ->
 Typing nil e1 Inf T1 ->
 Typing nil e2 Inf T2 ->
 cstep e1 (Expr e1') ->
 exists e2', cstep e2 (Expr e2') /\ epre e1' e2'.
Proof.
  introv ep typ1 typ2 red. gen e1' T1 T2.
  inductions ep; intros; eauto.
  - exists. split. apply red. apply ep_refl.
    forwards*: cpreservation typ1.
    forwards*: Typing_regular_1 H0.
  - inverts red. exists. split. assert (epre (e_abs A1 e1 B1) (e_abs A2 e2 B2)).
    eauto. forwards*: epre_lc H3. apply ep_anno; eauto.
    destruct E; unfold simpl_fill in H3; inverts* H3.
  - inverts red.
    + destruct E; unfold simpl_fill in H; inverts* H.
      inverts typ1. inverts typ2.
      forwards*: IHep1 H2. inverts H. inverts H0.
      exists. rewrite sfill_appl. split. apply cdo_step; eauto.
      unfold simpl_fill. eauto.
      inverts typ1. inverts H5. inverts typ2. inverts H8.
      forwards*: IHep2 H2. inverts H6.
      rewrite sfill_appr. exists. inverts H1. inverts H8. split.
      apply cdo_step; eauto. forwards*: vval_pre ep1. unfold simpl_fill. eauto.
    + inverts* ep1.
      forwards*: vval_pre ep2.
      exists. split. apply cStep_beta; eauto.
      apply ep_anno; eauto. apply tpre_refl.
      apply ep_anno; eauto. apply tpre_refl.
      forwards*: vval_val H3.
      forwards*: vval_val H0.

      assert (epre (e_anno (e_anno e2 A2) A1) (e_anno (e_anno e2' A2) A1)).
      apply ep_anno; eauto. apply tpre_refl.
      apply ep_anno; eauto. apply tpre_refl.
      pick fresh x.
      assert((e ^^ e_anno (e_anno e2' A2) A1) = [x ~> e_anno (e_anno e2' A2) A1] (e ^ x)).
      rewrite (subst_exp_intro x); eauto.
      rewrite (subst_exp_intro x); eauto.
      rewrite H6.
      forwards*: vval_val H3. forwards*: vval_val H0.
      forwards*: value_lc H7. forwards*: value_lc H8.
      assert(lc_exp (e_anno (e_anno e2 A2) A1)); eauto.
      assert(lc_exp (e_anno (e_anno e2' A2) A1)); eauto.
      inverts H2. forwards*: H14 x.
      assert(epre (e^x) (e^x)); eauto.
      forwards*: epre_open H13 H5 H11 H12.

      inverts* H5. inverts* H1.
      inverts typ2. inverts H5.
      forwards*: vval_pre ep2.
      exists. split. apply cStep_beta; eauto.
      apply ep_anno; eauto.
      apply ep_anno; eauto. apply tpre_refl.
      assert (epre (e_anno (e_anno e2 A2) A1) (e_anno (e_anno e2' C) A1)).
      apply ep_anno; eauto. apply tpre_refl.
      pick fresh x.
      assert((e ^^ e_anno (e_anno e2' C) A1) = [x ~>e_anno (e_anno e2' C) A1] (e ^ x)).
      rewrite (subst_exp_intro x); eauto.
      rewrite (subst_exp_intro x); eauto.
      rewrite H4.
      forwards*: vval_val H3. forwards*: vval_val H0.
      forwards*: value_lc H6. forwards*: value_lc H8.
      assert(lc_exp (e_anno (e_anno e2 A2) A1)); eauto.
      assert(lc_exp (e_anno (e_anno e2' C) A1)); eauto.
      inverts H2. forwards*: H14 x.
      assert(epre (e^x) (e^x)); eauto.
      forwards*: epre_open H13 H1 H11 H12.

      inverts typ2. inverts H5.
      forwards*: vval_pre ep2.
      exists. split. apply cStep_beta; eauto.
      assert(epre (e_abs A1 e B1) (e_abs A3 e3 B3)).
      eauto. forwards*: epre_lc H0.
      apply ep_anno; eauto. inverts H1. auto.
      apply ep_anno; eauto. inverts H4.
      assert(epre (e_abs A1 e B1) (e_abs A3 e3 B3)).
      eauto.
      forwards*: epre_lc H4. inverts H10. inverts H2.
      pick fresh x.
      forwards*: H6.
      assert(x `notin` (fv_exp e)). eauto.
      assert(x `notin` (fv_exp e3)). eauto.
      assert((e3 ^^ e_anno (e_anno e2' A) A3) = [x ~> e_anno (e_anno e2' A) A3] (e3 ^ x)).
      rewrite (subst_exp_intro x). eauto. auto.
      rewrite (subst_exp_intro x); eauto.
      forwards*:vval_val H3.
      forwards*:vval_val H.
      inverts typ1. inverts H20. inverts H23. inverts H17. inverts H18.
      inverts H0. inverts H5.
      assert (Typing nil (e_anno (e_anno e2 A4) A1) Inf A1).
      apply Typ_anno; eauto. eapply Typ_sim; eauto.
      apply BA_AB. auto.
      forwards*: value_no_fv H0.
      assert (Typing nil (e_anno (e_anno e2' A) A3) Inf A3).
      apply Typ_anno; eauto. eapply Typ_sim; eauto.
      apply BA_AB. auto.
      forwards*: value_no_fv H17.
      forwards*: value_lc H15. forwards*: value_lc H16.
      assert (lc_exp (e_anno (e_anno e2 A4) A1)). eauto.
      assert (lc_exp (e_anno (e_anno e2' A) A3)). eauto. inverts H1.
      assert (epre (e_anno (e_anno e2 A4) A1) (e_anno (e_anno e2' A) A3)).
      apply ep_anno; eauto.
      rewrite H14.
      forwards*: epre_open H2 H1 H28 H29.
  - inverts red.
    + destruct E; unfold simpl_fill in H; inverts* H.
      inverts typ1. inverts typ2. inverts H4. inverts H5. inverts H6. inverts H7.
      forwards*: IHep1 H2. inverts H7. inverts H10.
      exists. rewrite sfill_addl. split. apply cdo_step; eauto.
      unfold simpl_fill. eauto.
      inverts typ1. inverts H5.  inverts typ2. inverts H8.
      forwards*: IHep2 H2. inverts H6. inverts H8.
      rewrite sfill_addr. exists. inverts H1.  split.
      apply cdo_step; eauto. forwards*: vval_pre ep1. unfold simpl_fill. eauto.
    + inverts typ2. inverts ep1. inverts ep2.
      exists. split. apply cStep_addb; eauto. eauto.
      inverts H6. exists. split. apply cStep_addb; eauto. eauto.
      inverts H5. inverts ep2.
      exists. split. apply cStep_addb; eauto. eauto.
      inverts H7. exists. split. apply cStep_addb; eauto. eauto.
  - inverts red.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    assert (not (value (e_anno e2 A))).
    unfold not; intros. assert (epre (e_anno e1 A) (e_anno e2 A)).
    apply ep_anno; eauto. apply tpre_refl.
    apply H4. forwards*: val_pre H1.
    inverts typ1. inverts H5. inverts typ2. inverts H7.
    forwards*: IHep H3. inverts H7. inverts H8.
    exists. split. apply cStep_anno; eauto.
    unfold not; intro. inverts H8.
    apply H0. eauto. apply H0. eauto.
    apply ep_anno; eauto. inverts typ1. inverts typ2.
    forwards*: tdynamic_guarantee H3 H5 H4. inverts H0.
    inverts H1. exists. split. apply cStep_annov; eauto.
    forwards*: val_prel ep.  auto.
  - forwards*: cstep_not_value red. inverts typ1.
    eauto.
Qed.

Lemma dynamic_guarantees: forall e1 e2 m1 T1 T2,
 epre e1 e2 ->
 Typing nil e1 Inf T1 ->
 Typing nil e2 Inf T2 ->
 vvalue m1 ->
 e1 ->* (Expr m1) ->
 exists m2, vvalue m2 /\ e2 ->* (Expr m2) /\ epre m1 m2.
Proof.
  introv ep typ1 typ2 val red. gen e2 T1 T2 .
  inductions red; intros.
  - forwards*: vval_pre ep.
  - forwards*: dynamic_guarantee ep typ1 typ2 H.
    inverts H0. inverts H1.
    forwards*: cpreservation H.
    forwards*: cpreservation H0.
    forwards*: IHred val H2 H1 H3.
    inverts H4. inverts H5. inverts H6.
    exists. split. apply H4. split.
    apply star_trans with (b := x).
    apply star_one. apply H0.
    apply H5. auto.
Qed.

Lemma dynamic_guarantees2: forall e1 e2 dir m1 T1 T2,
 epre e1 e2 ->
 Typing nil e1 dir T1 ->
 Typing nil e2 dir T2 ->
 vvalue m1 ->
 e1 ->* (Expr m1) ->
 exists m2, vvalue m2 /\ e2 ->* (Expr m2) /\ epre m1 m2.
Proof.
  introv ep typ1 typ2 val red. gen e2 T1 dir T2 .
  inductions red; intros.
  - forwards*: vval_pre ep.
  - forwards*: dynamic_guarantee_dir ep typ1 typ2 H.
    inverts H0. inverts H1.
    forwards*: cpreservation H.
    forwards*: cpreservation H0.
    forwards*: IHred val H2 H1 H3.
    inverts H4. inverts H5. inverts H6.
    exists. split. apply H4. split.
    apply star_trans with (b := x).
    apply star_one. apply H0.
    apply H5. auto.
Qed.