(** * Reasoning principles for interpretable layered monads *)

(* When we layer the [interp] combinator, we also intend certain structural
  properties to hold at each layer of interpretation. Most importantly,
  it should respect monadic operators such as [ret] and [bind] and interact
  well with iteration.

  Given an interpretable monad equipped with an appropriate instance of [eqmR],
  we can state laws for the [trigger], [over], and [interp] functions that are
  expected.

  Thanks to the fact that iterative monad transformers form higher order functors
  which are monad morphisms (as shown in [HFunctor.v]), we only need to prove
  this structural property once and for all for each monad transformer. *)

(* begin hide *)
From Coq Require Import
     Program
     Setoid
     Morphisms
     RelationClasses.

From Paco Require Import paco.

From ITree.Basics Require Import
     Basics Category CategoryKleisli CategoryKleisliFacts
     HeterogeneousRelations
     Tacs MonadFail.

From ITree.Core Require Import
     ITreeDefinition KTree KTreeFacts Subevent.

From ITree.Eq Require Import
     Eq UpToTaus Paco2.

From ITree.Indexed Require Import
     Sum Function Relation.

From ITree.Interp Require Import
     Interp HFunctor Handler TranslateFacts.

From ITree.EqmR Require Import
     EqmRMonad EqmRMonadT
     Monads.ITree_weak
     Monads.StateT Monads.ErrorT.

From ExtLib Require Import
     Structures.Functor
     Structures.Monad.

Set Primitive Projections.

Import RelNotations.
Import ITreeNotations.
Import MonadNotation.
Import CatNotations.
Local Open Scope relationH_scope.
Local Open Scope cat_scope.
Local Open Scope monad_scope.
(* end hide *)

(** *Structural laws for interpretation. *)
Section interp_laws.

  Context (T : (Type -> Type) -> Type -> Type)
          (M : Type -> Type)
          {T_HFunctor : HFunctor T}
          {T_MonadT:MonadT T}
          {T_MonadIter:(forall m : Type -> Type, Monad m -> MonadIter m -> MonadIter (T m))}
          {M_Monad : Monad M}
          {M_EqmR : EqmR M}
          {M_MonadIter : MonadIter M}
          {TM_Interp : Interp (T := T) itree M}.

  Class InterpRet : Prop :=
    interp_ret :
      forall {E R} {f : E ~> M} (x: R),
        eqmR eq (interp f (ret x)) (ret x : T M R).

  Class InterpTrigger : Prop :=
    interp_trigger :
      forall {E R} (f : E ~> M) (e : E R),
        eqmR eq (interp f (trigger e)) (morph (MT := T M) (f _ e) : T M R).

  Class InterpOverTrigger : Prop :=
      interp_over_trigger :
      forall {E F G R} {S : F +? E -< G} {S_wf : Subevent_wf S}
        {Tr : Trigger E M} (f : F ~> M) (e : F R),
          eqmR eq
              (interp (@over F G E M S _ f) (trigger e : T (itree G) R))
              (morph (f _ e)).

  Class InterpOverIgnoreTrigger : Prop :=
    interp_over_ignore_trigger :
      forall (A B C BC ABC : Type -> Type) {S : B +? C -< BC} {S' : A +? BC -< ABC}
        {S_wf : Subevent_wf S} {S'_wf : Subevent_wf S'}
        R (h : A ~> M) (e : B R) {Tr : Trigger BC M},
      eqmR eq (m := T M)
      (interp (IM := itree) (T := T) (I := ABC) (M := M) (over h) (trigger (E := B) e))
      (morph (MT := T M) (trigger (E := BC) (inj1 e))).

  Class InterpBind : Prop :=
    interp_bind :
      forall {E R S} (f : E ~> M) (k : R -> T (itree E) S) t,
        eqmR eq (interp f (bind t k)) (bind (interp f t) (fun r => interp f (k r))).

  Class InterpIter : Prop :=
    interp_iter :
      forall {E I R} (f : E ~> M) (t : I -> T (itree E) (I + R)) (t' : I -> T M (I + R)) (i:I),
        (forall i, eqmR eq (interp f (t i)) (t' i))  ->
          interp f (Basics.iter t i) ≈{ eq } Basics.iter t' i.

  Class InterpProper : Prop :=
    interp_proper :
      forall {E} (h : E ~> M) R1 R2 (RR : R1 -> R2 -> Prop),
      ProperH (eqmR (m := T (itree E)) RR ~~> eqmR (B := R2) RR)
            (interp h (T0 := R1)) (interp h (T0 := R2)).

  Class InterpLaws : Prop :=
    { InterpLaws_InterpRet :> InterpRet;
      InterpLaws_InterpTrigger :> InterpTrigger;
      InterpLaws_InterpOverIgnoreTrigger :> InterpOverIgnoreTrigger;
      InterpLaws_InterpBind :> InterpBind;
      InterpLaws_InterpIter :> InterpIter;
      InterpLaws_InterpProper :> InterpProper }.

End interp_laws.

Arguments InterpLaws _ _ {_ _ _ _ _ _}.
Arguments interp_ret {_ _ _ _ _ _ _} [_ _].
Arguments interp_trigger {_ _ _ _ _ _ _} [_ _].
Arguments interp_over_trigger {_ _ _ _ _ _ _ _ _ _} [_ _] {_ _}.
Arguments interp_over_ignore_trigger {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _} [_].
Arguments interp_bind {_ _ _ _ _ _ _} [_ _ _].
Arguments interp_iter {_ _ _ _ _ _ _} [_ _ _].
Arguments interp_proper {_ _ _ _ _ _ _} [_].

#[global]
Existing Instance itree_interp.

(** *Nesting interpretation *)
(* We can stack interpretation, in the sense that given a higher-order functor [T]
   and iterative monad [M] (which is the semantic domain for interpreting an itree)
   the interpretable monad instance can be derived for the interpretation from
   [T (itree)] to [T M].

   In order to define this function, we use the higher-order fmap [hfmap] and lift
   the [itree_interp] function over the [T (itree)]. *)
#[global] Instance stack_interp
       {T : (Type -> Type) -> Type -> Type}
       {M : Type -> Type}
       {T_HFunctor : HFunctor T}
       {M_Monad : IterativeMonad M}
        : Interp itree M  | 10 :=
  fun E h R t => hfmap (f := T) (itree_interp h) t.

#[global] Instance Proper_eq_itree_interp_body (E M:Type->Type) `{WF_IterativeMonad M} (A:Type) (RR:A->A->Prop) (f:E~>M):
  Proper (eq_itree RR ==> eqmR (sum_rel (eq_itree RR) RR)) (interp_body (E := E) (M := M) f A).
Proof.
  repeat intro. unfold interp_body.
  punfold H0. red in H0. remember (observe x); remember (observe y).
  revert x y Heqi Heqi0.
  induction H0; pclearbot; intros; subst; try inv CHECK.
  - eapply eqmR_ret; eauto; typeclasses eauto.
  - eapply eqmR_ret; eauto; try typeclasses eauto.
  - eapply eqmR_bind_ProperH; try typeclasses eauto; [ reflexivity | ..]; intros; subst;
      eapply eqmR_ret; eauto; typeclasses eauto.
Qed.

Section InterpITree.

  (** Unfolding of [interp]. *)
  Definition _interp {E F R} (f : E ~> itree F) (ot : itreeF E R _)
    : itree F R :=
    match ot with
    | RetF r => Ret r
    | TauF t => Tau (interp f t)
    | VisF e k => f _ e >>= (fun x => Tau (interp f (k x)))
    end.

  (** Unfold lemma. *)
  Lemma unfold_interp {E F R} {f : E ~> itree F} (t : itree E R) :
    interp f t ≅ (_interp f (observe t)).
  Proof.
    unfold interp, Basics.iter, MonadIter_itree. setoid_rewrite unfold_iter.
    unfold interp_body.
    destruct (observe t); cbn; try rewrite ?Eq.bind_bind;
      rewrite ?Eq.bind_ret_l, ?bind_map.
    all: try solve [tau_steps; reflexivity].
    setoid_rewrite Eq.bind_ret_l. reflexivity.
  Qed.

  #[global]
  Instance eq_itree_interp' {E F R} (f : E ~> itree F)
    : Proper (eq_itree eq ==> eq_itree eq) (interp f (T0 := R)).
  Proof.
    repeat red.
    ginit. pcofix CIH.
    intros l r0 Hlr.
    rewrite 2 unfold_interp.
    punfold Hlr; red in Hlr.
    destruct Hlr; cbn; subst; try discriminate; pclearbot; try (gstep; constructor; eauto with paco; fail).
    guclo eqit_clo_bind. econstructor; eauto.
    eapply reflexivity.
    intros; subst.
    gstep; econstructor; eauto with paco.
  Qed.

  #[global]
  Instance eutt_interp {E F R} (f : E ~> itree F)
    : Proper (eutt eq ==> eutt eq) (interp f (T0 := R)).
  Proof.
    repeat red.
    ginit. pcofix CIH. intros.

    rewrite !unfold_interp. punfold H0. red in H0.
    induction H0; intros; subst; pclearbot; simpl.
    - gstep. constructor. eauto.
    - gstep. constructor. eauto with paco.
    - guclo eqit_clo_bind; econstructor; eauto. eapply reflexivity.
      intros; subst.
      gstep; constructor; eauto with paco.
    - rewrite tau_euttge, unfold_interp. auto.
    - rewrite tau_euttge, unfold_interp. auto.
  Qed.

  #[global]
  Definition eutt_interp' {E F : Type -> Type} {R1 R2 : Type} (RR: R1 -> R2 -> Prop) (f : E ~> itree F) :
    ProperH (eutt RR ~~> eutt RR) (interp f (T0 := R1)) (interp f (T0 := R2)).
  Proof.
    repeat red.
    einit.
    ecofix CIH. intros.
    rewrite !unfold_interp.
    punfold H0.
    induction H0; intros; subst; pclearbot; simpl.
    - estep.
    - estep.
    - ebind; econstructor.
      + reflexivity.
      + intros; subst. estep. ebase.
    - rewrite tau_euttge, unfold_interp. eauto.
    - rewrite tau_euttge, unfold_interp. eauto.
  Qed.

  #[global]
  Instance itree_morph_ret:
    forall (E F : Type -> Type) (f : E ~> itree F),
      MorphRet (itree E) (itree F) (itree_interp f).
  Proof. repeat intro. setoid_rewrite unfold_interp. cbn.
        apply eqit_Ret; eauto. Qed.

  Lemma itree_interp_tau {E F R} {f : E ~> itree F} (t: itree E R):
    eq_itree eq (interp f (Tau t)) (Tau (interp f t)).
  Proof. rewrite unfold_interp. reflexivity. Qed.

  Lemma itree_interp_vis {E F R} {f : E ~> itree F} U (e: E U) (k: U -> itree E R) :
    eq_itree eq (interp f (Vis e k)) (ITree.bind (f _ e) (fun x => Tau (interp f (k x)))).
  Proof. rewrite unfold_interp. reflexivity. Qed.

  Lemma itree_interp_bind {E F R S}
        (f : E ~> itree F) (t : itree E R) (k : R -> itree E S) :
      interp f (ITree.bind t k)
    ≅ ITree.bind (interp f t) (fun r => interp f (k r)).
  Proof.
    revert R t k. ginit. pcofix CIH; intros.
    rewrite unfold_bind, (unfold_interp t).
    destruct (observe t); cbn.
    - rewrite Eq.bind_ret_l. apply reflexivity.
    - rewrite bind_tau, !itree_interp_tau.
      gstep. econstructor. eauto with paco.
    - rewrite itree_interp_vis, Eq.bind_bind.
      guclo eqit_clo_bind; econstructor; try reflexivity.
      intros; subst.
      rewrite bind_tau. gstep; constructor; eauto with paco.
  Qed.

  #[global]
  Instance itree_morph_bind:
    forall (E F : Type -> Type) (f : E ~> itree F),
      MorphBind (itree E) (itree F) (itree_interp f).
  Proof.
    repeat intro. setoid_rewrite itree_interp_bind.
    eapply eutt_clo_bind. eapply eutt_interp'; eauto.
    intros. eapply eutt_interp'; eauto. eapply H0; eauto.
  Qed.

  #[global] Instance itree_MonadMorphism :
    forall (E F : Type -> Type) (f : E ~> itree F),
      MonadMorphism _ _ (itree_interp f).
  Proof.
    constructor; [constructor; try typeclasses eauto |..]; try typeclasses eauto.
    repeat intro; eapply eutt_interp'; repeat intro; eauto.
  Qed.

  Lemma itree_interp_iter' {E F} (f : E ~> itree F) {I A}
        (t  : I -> itree E (I + A))
        (t' : I -> itree F (I + A))
        (EQ_t : forall i, eq_itree eq (interp f (t i)) (t' i))
    : forall i,
      interp f (ITree.iter t i)
    ≅ ITree.iter t' i.
  Proof.
    ginit. pcofix CIH; intros i.
    rewrite 2 unfold_iter.
    rewrite itree_interp_bind.
    guclo eqit_clo_bind; econstructor; eauto.
    { apply EQ_t. }
    intros [] _ []; cbn.
    - rewrite itree_interp_tau; gstep; constructor; auto with paco.
    - setoid_rewrite unfold_interp. cbn. gstep; constructor; auto with paco.
  Qed.

  Lemma itree_interp_iter_eutt' {E F} (f : E ~> itree F) {I A}
        (t  : I -> itree E (I + A))
        (t' : I -> itree F (I + A))
        (EQ_t : forall i, eutt eq (interp f (t i)) (t' i))
    : forall i,
      interp f (ITree.iter t i)
    ≈ ITree.iter t' i.
  Proof.
    ginit. pcofix CIH; intros i.
    rewrite 2 unfold_iter.
    rewrite itree_interp_bind.
    guclo eqit_clo_bind; econstructor; eauto.
    { apply EQ_t. }
    intros [] _ []; cbn.
    - rewrite itree_interp_tau; gstep; constructor; auto with paco.
    - setoid_rewrite unfold_interp. cbn. gstep; constructor; auto with paco.
  Qed.

  Lemma itree_interp_iter {E F} (f : E ~> itree F) {A B}
        (t : A -> itree E (A + B)) a0
    : interp f (iter (C := ktree E) t a0) ≅ iter (C := ktree F) (fun a => interp f (t a)) a0.
  Proof.
    unfold iter, Iter_Kleisli, Basics.iter, MonadIter_itree.
    apply itree_interp_iter'.
    reflexivity.
  Qed.

  #[global] Instance itree_IterMorphism:
    forall (E F : Type -> Type) (f : E ~> itree F),
      IterMorphism (itree_interp f).
  Proof.
    unfold IterMorphism. cbn.
    ginit. gcofix CIH; intros. cbn.
    setoid_rewrite unfold_iter at 2.
    setoid_rewrite unfold_iter at 2. cbn.
    pose proof @itree_interp_bind. setoid_rewrite H. clear H.
    guclo eqit_clo_bind; econstructor; eauto.
    - apply H0; eauto.
    - intros [|] [ |] H; cbn; subst; inv H.
      + setoid_rewrite itree_interp_tau.
        gstep; constructor. gfinal. left. eapply CIH; eauto.
      + pose proof @itree_morph_ret. cbn in H. unfold MorphRet in H.
        unfold morph in H.
        specialize (H E F f R _ eq r1 _ eq_refl).
        gfinal. right. cbn in H.
        eapply paco2_mon; eauto; intros; contradiction.
  Qed.

  #[global] Instance interp_laws_itree_interp {F}:
    InterpLaws (fun x => x) (itree F) (TM_Interp := @itree_interp _ _ _).
  Proof.
    constructor; repeat intro.
    - apply itree_morph_ret; auto.
    - setoid_rewrite itree_interp_vis.
      cbn. setoid_rewrite tau_eutt.
      etransitivity.
      eapply eutt_clo_bind. reflexivity.
      intros; subst; apply itree_morph_ret; auto.
      rewrite Eq.bind_ret_r; reflexivity.
    - setoid_rewrite itree_interp_vis.
      cbn. setoid_rewrite tau_eutt.
      etransitivity.
      eapply eutt_clo_bind. reflexivity.
      intros; subst; apply itree_morph_ret; auto.
      unfold over, cat, Cat_IFun, merge_E, case, split_E.
      destruct S', S.
      destruct S'_wf. red in iso_epi.
      unfold over, cat, Cat_IFun in iso_epi.
      unfold Subevent.merge_E, Subevent.split_E in iso_epi.
      rewrite iso_epi. cbn.
      rewrite Eq.bind_ret_r; reflexivity.
    - setoid_rewrite itree_interp_bind; reflexivity.
    - apply itree_interp_iter_eutt'; auto.
    - eapply eutt_interp'; auto.
  Qed.

End InterpITree.

(* Facts about [interp] *)
Section Facts.

  Context {T : (Type -> Type) -> Type -> Type} {M : Type -> Type}
          {T_MonadT:MonadT T}
          {T_HFunctor:HFunctor T}
          {T_MonadIter:(forall m : Type -> Type, Monad m -> MonadIter m -> MonadIter (T m))}
          {WF_IMT : WF_IterativeMonadT T  _ _}
          {T_wf : @WF_HFunctor T _ _ _ _}
          {M_Monad : Monad M}
          {M_EqmR : EqmR M}
          {M_MonadIter : MonadIter M}
          {M_wf : WF_IterativeMonad M _ _ _}
          {itree_monad_morphism : forall (E : Type -> Type) (f : E ~> M),
              MonadMorphism _ _ (itree_interp (I := E) f)}
          {itree_iter_morphism : forall (E : Type -> Type) (f : E ~> M),
              IterMorphism (itree_interp (I := E) f)}.

  #[local] Instance M_IM: IterativeMonad M. constructor; eauto. Defined.

  (** * [interp] and constructors *)
  (** These are specializations of [unfold_interp], which can be added as
      rewrite hints. *)
  Lemma _interp_ret {E R} (f : E ~> M) (x: R):
    eqmR (m := T M) eq (interp f (ret x)) (ret x).
  Proof.
    unfold interp. unfold stack_interp.
    pose proof (@hfmap_nat T _ _ _ _ _ _ _ _ _ _ _ _ _ (itree_interp (I := E) f) _).
    destruct H.
    eapply morph_ret; eauto.
  Qed.

  Ltac unfold_cat := unfold cat, Cat_Kleisli.

  Lemma _interp_bind {E R S} (f : E ~> M) (k : R -> _ S) t:
    eqmR (m := T M) eq (interp f (bind t k))
        (bind (interp f t) (fun r => interp f (k r))).
  Proof.
    eapply MM_morph_bind; eauto; try typeclasses eauto.

    Unshelve. 3 : exact eq.
    all : intros; subst; eapply reflexivity.
  Qed.

  Lemma _interp_trigger {R E} (f : E ~> M) (e : E R) :
    eqmR (m := T M) eq (interp f (trigger e)) (morph (f _ e)).
  Proof.
    { pose proof @hfmap_lift as Hlift.
      specialize (Hlift T _ _ _).

      specialize (Hlift _ _ R (itree E) M).
      specialize (Hlift _ _).
      specialize (Hlift _ _ _ _ _ _ (itree_interp f)).
      etransitivity.
      eapply Hlift; typeclasses eauto.

      eapply morph_proper; try typeclasses eauto.

      unfold ITree.trigger. unfold interp.
      unfold Basics.iter, MonadIter_itree, Kleisli_MonadIter.
      pose proof (iter_unfold (C := Kleisli M)) as Hunfold.
      specialize (Hunfold _ _ (interp_body f R)).
      specialize (Hunfold (trigger e)).
      unfold_cat; cbn. unfold iter, Iter_Kleisli in Hunfold. rewrite Hunfold.
      unfold_cat. unfold case_, Case_Kleisli, Function.case_sum.

      eapply Proper_eqmR_eq_impl; try typeclasses eauto.
      2 : symmetry; eapply (bind_ret_r (f R e)).
      2 : reflexivity.
      unfold id_.

      eapply Proper_bind.
      { unfold interp_body; cbn. setoid_rewrite <- bind_ret_r at 5.
        eapply Proper_bind. unfold id_. reflexivity.
        all : intros; subst. Unshelve.
        2 : exact(fun x y => match x with
                          | inl a => a = Ret y
                          | _ => False end).
        all : eapply eqmR_ret; try typeclasses eauto; try reflexivity. }
      all : intros; cbn; destruct a1; inv H.
      { unfold Basics.iter, MonadIter_itree. clear Hunfold.
        pose proof (iter_unfold (C := Kleisli M)) as Hunfold.
        specialize (Hunfold _ _ (interp_body f R) (ret a2)).
        unfold iter, Iter_Kleisli, Basics.iter, MonadIter_itree in Hunfold.
        rewrite Hunfold.
        unfold_cat; cbn. rewrite bind_ret_l. cbn.
        apply eqmR_ret; eauto.
        typeclasses eauto. } }
  Qed.

  Lemma _interp_over_trigger:
    forall (E F : Type -> Type) (R : Type) (G : Type -> Type) (S : E +? G -< F)
      (S_wf : Subevent_wf S)
      (M_Trigger : Trigger G M)
      (f : E ~> M) (e : E R),
      interp (over f) (trigger e : T (itree F) R) ≋ morph (f _ e).
  Proof.
    intros E F R G S ? M_Trigger f e.
    { pose proof @hfmap_lift as Hlift.
      unfold interp, stack_interp.
      specialize (Hlift T _ _ _).
      specialize (Hlift _ _  R _ _ _ _ _ _ _ _ _ _ (itree_interp (over f)) _).
      etransitivity.

      eapply Hlift; typeclasses eauto.

      eapply morph_proper; try typeclasses eauto.

      unfold ITree.trigger. unfold interp.
      unfold Basics.iter, MonadIter_itree, Kleisli_MonadIter.
      pose proof (iter_unfold (C := Kleisli M)) as Hunfold.
      specialize (Hunfold _ _ (interp_body (over f) R)).
      specialize (Hunfold (trigger e)).
      unfold_cat; cbn. unfold iter, Iter_Kleisli in Hunfold. rewrite Hunfold.
      unfold_cat. unfold case_, Case_Kleisli, Function.case_sum.

      eapply Proper_eqmR_eq_impl; try typeclasses eauto.
      3 : reflexivity.
      unfold id_.

      eapply Proper_bind.
      { unfold interp_body; cbn. setoid_rewrite <- bind_ret_r.
        rewrite bind_bind. setoid_rewrite bind_ret_r.
        eapply Proper_bind. unfold id_. reflexivity.
        all : intros; subst. Unshelve.
        3 : exact (fun x => ret (inl (Ret x))).
        reflexivity. shelve. }
      all: intros; subst.
      Unshelve.
      3 : exact (fun a2 =>
          match a2 with
          | inl a => Basics.iter (interp_body (over f) R) a
          | inr b => Id_Kleisli R b
          end).
      reflexivity.
      rewrite bind_bind. setoid_rewrite bind_ret_l.
      setoid_rewrite <- bind_ret_r at 1.
      eapply eqmR_bind_ProperH_simple; [typeclasses eauto | ..]; intros; subst.
      { unfold over. unfold inj1, inl_, Inl_sum1, case.
        unfold_cat; unfold Cat_IFun.
        clear Hunfold.
        pose proof (iter_unfold (C := Kleisli M)) as Hunfold.
        specialize (Hunfold _ _ (interp_body (over f) R)).
        unfold iter, Iter_Kleisli in Hunfold. repeat red in Hunfold.
        pose proof @sub_iso as Hiso.
        specialize (Hiso _ _ _ S _). destruct Hiso.
        repeat red in iso_epi.
        unfold cat, Cat_IFun in iso_epi.
        rewrite iso_epi. cbn.
        reflexivity. }
      { unfold Basics.iter, MonadIter_itree. clear Hunfold.
        pose proof (iter_unfold (C := Kleisli M)) as Hunfold.
        specialize (Hunfold _ _ (interp_body (over f) R) (ret a2)).
        unfold iter, Iter_Kleisli, Basics.iter, MonadIter_itree in Hunfold.
        rewrite Hunfold.
        unfold_cat; cbn. rewrite bind_ret_l. cbn.
        apply eqmR_ret; eauto.
        typeclasses eauto. } }
  Qed.

  Lemma _interp_over_ignore_trigger:
    forall (A B C BC ABC : Type -> Type) (S : B +? C -< BC) (S' : A +? BC -< ABC)
      (S_wf : Subevent_wf S) (S'_wf : Subevent_wf S')
      (R : Type) (h : forall T0 : Type, A T0 -> M T0)
            (e : B R) (Tr : Trigger BC M),
      eqmR eq
           (interp (IM := itree) (T := T) (I := ABC) (M := M) (over h)
                   (trigger (E := B) e))
           (morph (MT := T M) (trigger (E := BC) (inj1 e))).
   Proof.
     intros A B C BC ABC S S' ? ? R h e Tr.
     pose proof @hfmap_lift as Hlift.
     specialize (Hlift T _ _ _ _ _ R (itree ABC) M _ _ _ _ _ _ _ _ (itree_interp (over h)) _).
     etransitivity.
     eapply Hlift. clear Hlift.

     eapply morph_proper.

    unfold ITree.trigger. unfold interp.
    unfold Basics.iter, MonadIter_itree, Kleisli_MonadIter.
    pose proof (iter_unfold (C := Kleisli M)) as Hunfold.
    specialize (Hunfold _ _ (interp_body (over h) R)).
    specialize (Hunfold (trigger e)).
    unfold_cat; cbn. unfold iter, Iter_Kleisli in Hunfold. rewrite Hunfold.
    unfold_cat. unfold case_, Case_Kleisli, Function.case_sum.

    eapply Proper_eqmR_eq_impl; try typeclasses eauto.
    3 : reflexivity.
    2 : symmetry; eapply (bind_ret_r (trigger (inj1 e))).
    unfold id_, Id_Kleisli.

    eapply eqmR_bind_ProperH_simple; [ typeclasses eauto | ..].
    { unfold interp_body; cbn. setoid_rewrite <- bind_ret_r at 5.
      eapply eqmR_bind_ProperH_simple; [ typeclasses eauto | ..].
      unfold_cat. unfold Cat_IFun, over.
      unfold case.
      pose proof @sub_iso as Hiso.
      specialize (Hiso _ _ _ S' _). destruct Hiso.
      repeat red in iso_epi.
      unfold cat, Cat_IFun in iso_epi.
      rewrite iso_epi. cbn.

      repeat red in iso_mono.
      unfold cat, Cat_IFun in iso_mono.
      unfold inj1. unfold_cat. unfold Cat_IFun. reflexivity.
      intros; subst; apply eqmR_ret; try typeclasses eauto.
      Unshelve.
      2 : exact(fun x y => match x with
                        | inl a => a = Ret y
                        | _ => False end). cbn. reflexivity. }
    all : intros; cbn; destruct a1; inv H.
    { unfold Basics.iter, MonadIter_itree. clear Hunfold.
      pose proof (iter_unfold (C := Kleisli M)) as Hunfold.
      specialize (Hunfold _ _ (interp_body (over h) R) (ret a2)).
      unfold iter, Iter_Kleisli, Basics.iter, MonadIter_itree in Hunfold.
      rewrite Hunfold.
      unfold_cat; cbn. rewrite bind_ret_l. cbn.
      apply eqmR_ret; eauto.
      typeclasses eauto. }
   Qed.

  Lemma _interp_iter {I E R} (f : E ~> M) t t' (i:I):
    (forall i, eqmR eq (interp f (t i)) (t' i)) ->
      interp f
        (@Basics.iter (T (itree E)) _ R I t i)
      ≈{ @eq R
      } @Basics.iter (T M) _ R I t' i.
  Proof.
    cbn. intros.

    pose proof (@hfmap_iter T _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ (itree_interp f) _ _).
    eapply H0; eauto.
  Qed.

  Lemma _interp_proper {E} :
    forall (h : forall T0 : Type, E T0 -> M T0) (R1 R2 : Type) (RR : R1 -> R2 -> Prop),
      ProperH (eqmR (m := T (itree E)) RR ~~> eqmR (B := R2) RR)
            (fun t => interp h t) (fun t => interp h t).
  Proof.
    cbn. repeat intro.
    pose proof (@hfmap_nat T _ _ _ _ _ _ _ _ _ _ _ _ _ (itree_interp h) _).
    destruct H0.
    eapply morph_proper; eauto.
  Qed.

  Global Instance InterpLaws_: InterpLaws T M.
  constructor; repeat intro.
  apply _interp_ret.
  apply _interp_trigger.
  apply _interp_over_ignore_trigger; eauto.
  apply _interp_bind.
  apply _interp_iter; auto.
  apply _interp_proper; auto.
  Qed.

End Facts.

#[global] Program Instance WF_IterativeMonad_Trans T M `{T_WF_IterativeMonadT : WF_IterativeMonadT T}
 `{M_WF_IterativeMonad : WF_IterativeMonad M} : WF_IterativeMonad (T M) _ _ _.

#[global] Instance IterativeMonad_itree E : IterativeMonad (itree E).
Proof.
  constructor; repeat intro; try constructor; intros; eauto.
  exact (ret X).
  exact (bind X X0).
  exact (eqmR R).
  exact (observe (ITree.iter X X0)).
Defined.

(* Facts about [interp] when the *base monad* is an ITree. *)
Section Facts.

  Context {T : (Type -> Type) -> Type -> Type} {F : Type -> Type}
          {T_MonadT:IterativeMonadT T}
          {T_HFunctor:HFunctor T}
          {T_WF_IterativeMonadT : WF_IterativeMonadT T _ _}
          {T_wf : @WF_HFunctor T _ _ _ _}
          {itree_monad_morphism : forall (E : Type -> Type) (f : E ~> T (itree F)),
              MonadMorphism _ _ (itree_interp (I := E) f)}
          {itree_iter_morphism : forall (E : Type -> Type) (f : E ~> T (itree F)),
              IterMorphism (itree_interp (I := E) f)}.

  #[global] Instance IM_TF : IterativeMonad (T (itree F)).
  constructor; try typeclasses eauto.
  Defined.

  #[global] Instance InterpLaws_itree_base :
    InterpLaws (fun x => x) (T (itree F)) (TM_Interp := stack_interp).
  eapply InterpLaws_.
  Defined.

End Facts.


From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising2 Require Import Memory View Time Cell TView.
From imm Require Import AuxRel2.

Definition memory_close tview memory :=
  ⟪ CLOSED_CUR :
    Memory.closed_timemap (View.rlx (TView.cur tview)) memory ⟫ /\
  ⟪ CLOSED_ACQ :
    Memory.closed_timemap (View.rlx (TView.acq tview)) memory ⟫ /\
  ⟪ CLOSED_REL :
    forall loc,
      Memory.closed_timemap (View.rlx (TView.rel tview loc)) memory ⟫.

Lemma memory_closed_timemap_le view memory memory'
      (MEM_LE : Memory.le memory memory')
      (MEM_CLOS : Memory.closed_timemap view memory) :
  Memory.closed_timemap view memory'.
Proof using.
  red; ins. specialize (MEM_CLOS loc). desf.
  apply MEM_LE in MEM_CLOS.
  eauto.
Qed.

Lemma memory_close_le tview memory memory'
      (MEM_LE : Memory.le memory memory')
      (MEM_CLOS : memory_close tview memory) :
  memory_close tview memory'.
Proof using.
  cdes MEM_CLOS.
  red; splits; ins.
  all: eapply memory_closed_timemap_le; eauto.
Qed.

Lemma loc_ts_eq_dec_eq {A} {a b : A} l ts :
  (if loc_ts_eq_dec (l, ts) (l, ts) then a else b) = a.
Proof using. edestruct loc_ts_eq_dec; desf. Qed.

Lemma loc_ts_eq_dec_neq {A} {a b : A} {l ts l' ts'}
      (NEQ: l <> l' \/ ts <> ts'):
  (if loc_ts_eq_dec (l, ts) (l', ts') then a else b) = b.
Proof using. edestruct loc_ts_eq_dec; desf. Qed.

Lemma memory_add_le memory memory' loc from to msg
      (ADD : Memory.add memory loc from to msg memory'):
  Memory.le memory memory'.
Proof using.
  red. ins. erewrite Memory.add_o; eauto.
  destruct (loc_ts_eq_dec (loc0, to0) (loc, to)); [simpls; desf|done].
  exfalso. eapply Memory.add_get0 in ADD. desf.
  rewrite ADD in LHS. inv LHS.
Qed.

Lemma memory_remove_le memory memory' loc from to msg
      (ADD : Memory.remove memory loc from to msg memory'):
  Memory.le memory' memory.
Proof using.
  red. ins. erewrite Memory.remove_o in LHS; eauto.
    by destruct (loc_ts_eq_dec (loc0, to0) (loc, to)) in LHS; [desf|].
Qed.

Set Implicit Arguments.
Remove Hints plus_n_O.

Lemma memory_init_o loc to from msg
      (GET : Memory.get loc to Memory.init = Some (from, msg)) :
  to = Time.bot /\ from = Time.bot /\ msg = Message.elt.
Proof using.
  unfold Memory.init, Cell.init, Cell.Raw.init in *.
  unfold Memory.get, Cell.get in *; simpls.
  apply IdentMap.singleton_find_inv in GET.
  desf.
Qed.

Lemma inhabited_init : Memory.inhabited Memory.init.
Proof using. red. ins. Qed.

Lemma inhabited_future memory memory'
      (INHAB : Memory.inhabited memory)
      (FUTURE : Memory.future memory memory') :
  Memory.inhabited memory'.
Proof using.
  destruct FUTURE; auto.
  apply clos_rt1n_rt in FUTURE.
  apply clos_rt_rtn1 in FUTURE.
  induction FUTURE; auto.
  { destruct H.
    eapply Memory.op_inhabited; eauto. }
  destruct H0.
  eapply Memory.op_inhabited; eauto.
Qed.

Lemma inhabited_future_init memory (FUTURE : Memory.future Memory.init memory) :
  Memory.inhabited memory.
Proof using. eapply inhabited_future; eauto. apply inhabited_init. Qed.

Lemma inhabited_le memory memory' (LE : Memory.le memory memory')
      (INHAB : Memory.inhabited memory) :
  Memory.inhabited memory'.
Proof using. red. ins. apply LE. apply INHAB. Qed.

Definition ts_lt_or_bot memory :=
  forall loc to from msg (GET : Memory.get loc to memory = Some (from, msg)),
    (to = Time.bot /\ from = Time.bot) \/
    ⟪ FTLT : Time.lt from to ⟫.

Lemma ts_lt_or_bot_init : ts_lt_or_bot Memory.init.
Proof using. red. ins. apply memory_init_o in GET. left. desf. Qed.

Lemma ts_lt_or_bot_add loc from to msg memory memory_add
      (TLOB : ts_lt_or_bot memory)
      (ADD : Memory.add memory loc from to msg memory_add) :
  ts_lt_or_bot memory_add.
Proof using.
  red. ins.
  erewrite Memory.add_o in GET; eauto.
  desf; simpls; desf.
  { right. inv ADD. inv ADD0. }
  all: by eapply TLOB; eauto.
Qed.

Lemma ts_lt_or_bot_lower loc from to msg released' memory memory_lower
      (TLOB : ts_lt_or_bot memory)
      (LOWER : Memory.lower memory loc from to msg released' memory_lower) :
  ts_lt_or_bot memory_lower.
Proof using.
  red. ins.
  erewrite Memory.lower_o in GET; eauto.
  desf; simpls; desf.
  { right. inv LOWER. inv LOWER0. }
  all: by eapply TLOB; eauto.
Qed.

Lemma ts_lt_or_bot_split loc from to to' msg msg' memory memory_split
      (TLOB : ts_lt_or_bot memory)
      (SPLIT : Memory.split memory loc from to to' msg msg' memory_split) :
  ts_lt_or_bot memory_split.
Proof using.
  red. ins.
  erewrite Memory.split_o in GET; eauto.
  desf; simpls; desf.
  1,2: by right; inv SPLIT; inv SPLIT0.
  all: eapply TLOB; eauto.
Qed.

Lemma ts_lt_or_bot_remove loc from to msg memory memory'
      (REMOVE : Memory.remove memory loc from to msg memory')
      (TLOB : ts_lt_or_bot memory) :
  ts_lt_or_bot memory'.
Proof using.
  red. ins.
  erewrite Memory.remove_o in GET; eauto.
  desf; simpls; desf.
  all: eapply TLOB; eauto.
Qed.

Lemma ts_lt_or_bot_op loc from to msg kind memory memory'
      (TLOB : ts_lt_or_bot memory)
      (OP : Memory.op memory loc from to msg memory' kind) :
  ts_lt_or_bot memory'.
Proof using.
  destruct OP.
  { eapply ts_lt_or_bot_add; eauto. }
  { eapply ts_lt_or_bot_split; eauto. }
  { eapply ts_lt_or_bot_lower; eauto. }
  eapply ts_lt_or_bot_remove; eauto.
Qed.

Lemma ts_lt_or_bot_future memory memory'
      (TLOB : ts_lt_or_bot memory)
      (FUTURE : Memory.future memory memory') :
  ts_lt_or_bot memory'.
Proof using.
  apply clos_rt1n_rt in FUTURE.
  apply clos_rt_rtn1 in FUTURE.
  induction FUTURE; auto.
  destruct H.
  eapply ts_lt_or_bot_op; eauto.
Qed.

Lemma ts_lt_or_bot_future_init memory
      (FUTURE : Memory.future Memory.init memory) :
  ts_lt_or_bot memory.
Proof using. eapply ts_lt_or_bot_future; eauto. apply ts_lt_or_bot_init. Qed.

Lemma time_le_rect a b c d (AB : Time.le a b) (CD : Time.le c d) :
  Time.le (Time.join a c) (Time.join b d).
Proof using.
  unfold Time.join.
  desf.
  { apply Time.le_lteq. left.
    eapply TimeFacts.le_lt_lt; eauto. }
  etransitivity; eauto.
Qed.

Lemma timemap_le_rect a b c d (AB : TimeMap.le a b) (CD : TimeMap.le c d) :
  TimeMap.le (TimeMap.join a c) (TimeMap.join b d).
Proof using.
  unfold TimeMap.join. intros x.
  all: by apply time_le_rect.
Qed.

Lemma view_le_rect a b c d (AB : View.le a b) (CD : View.le c d) :
  View.le (View.join a c) (View.join b d).
Proof using.
  unfold View.join in *.
  destruct AB. destruct CD.
  constructor; simpls; intros x.
  all: by apply timemap_le_rect.
Qed.

Lemma memory_split_get_old memory memory_split
      loc from to ts msg msg'
      (SP : Memory.split memory loc from to ts msg msg' memory_split) :
  Memory.get loc ts memory = Some (from, msg').
Proof using. inv SP. inv SPLIT. Qed.

Lemma interval_le_not_disjoint la ra lb rb
      (LTA : Time.lt la ra)
      (LTB : Time.lt lb rb)
      (NEQ : ra <> rb)
      (ILE : Interval.le (la, ra) (lb, rb)) :
  ~ Interval.disjoint (la, ra) (lb, rb).
Proof using.
  inv ILE. simpls.
  intros HH. eapply HH; constructor; simpls; eauto.
  { reflexivity. }
  eapply TimeFacts.le_lt_lt; eauto.
Qed.

Lemma closed_view_le view memory memory'
      (LE : Memory.le memory memory')
      (CLOS : Memory.closed_view view memory) :
  Memory.closed_view view memory'.
Proof using.
  destruct CLOS.
  constructor; red; [clear RLX; rename PLN into RLX|]; ins.
  all: specialize (RLX loc); desc.
  all: apply LE in RLX; eauto.
Qed.

Lemma memory_le_add2 mem1 mem1' mem2 mem2' loc from to msg
      (LE : Memory.le mem1 mem2)
      (ADD1 : Memory.add mem1 loc from to msg mem1')
      (ADD2 : Memory.add mem2 loc from to msg mem2') :
  Memory.le mem1' mem2'.
Proof using.
  red. ins.
  erewrite Memory.add_o in LHS; eauto.
  erewrite Memory.add_o; [|by apply ADD2].
  desf. by apply LE.
Qed.

Lemma memory_le_split2 mem1 mem1' mem2 mem2' loc from to to' msg msg'
      (LE : Memory.le mem1 mem2)
      (SPLIT1 : Memory.split mem1 loc from to to' msg msg' mem1')
      (SPLIT2 : Memory.split mem2 loc from to to' msg msg' mem2') :
  Memory.le mem1' mem2'.
Proof using.
  red. ins.
  erewrite Memory.split_o in LHS; eauto.
  erewrite Memory.split_o; [|by apply SPLIT2].
  desf. by apply LE.
Qed.

Lemma memory_le_remove2 mem1 mem1' mem2 mem2' loc from to msg
      (LE : Memory.le mem1 mem2)
      (REMOVE1 : Memory.remove mem1 loc from to msg mem1')
      (REMOVE2 : Memory.remove mem2 loc from to msg mem2') :
  Memory.le mem1' mem2'.
Proof using.
  red. ins.
  erewrite Memory.remove_o in LHS; eauto.
  erewrite Memory.remove_o; [|by apply REMOVE2].
  desf. by apply LE.
Qed.

Lemma interval_disjoint_imm_le a b c d (LE : Time.le b c):
  Interval.disjoint (a, b) (c, d).
Proof using.
  red; ins.
  destruct LHS as [LFROM LTO].
  destruct RHS as [RFROM RTO]; simpls.
  eapply Time.lt_strorder.
  eapply TimeFacts.le_lt_lt.
  2: by apply RFROM.
  etransitivity; [by apply LTO|].
  done.
Qed.

Lemma message_max_ts_disjoint loc to from msg memory
      (GET : Memory.get loc to memory = Some (from, msg)) :
  Interval.disjoint (Memory.max_ts loc memory, Time.incr (Memory.max_ts loc memory))
                    (from, to).
Proof using.
  symmetry.
  apply interval_disjoint_imm_le.
  eapply Memory.max_ts_spec; eauto.
Qed.

Lemma nonsynch_loc_le loc mem1 mem2 (LE : Memory.le mem1 mem2)
      (NSL : Memory.nonsynch_loc loc mem2) :
  Memory.nonsynch_loc loc mem1.
Proof using. red. ins. apply LE in GET. by apply NSL in GET. Qed.

Definition msg_preserved memory memory' :=
  forall loc ts from v rel
         (INMEM : Memory.get loc ts memory = Some (from, Message.full v rel)),
    exists from', Memory.get loc ts memory' = Some (from', Message.full v rel).

Definition msg_preserved_refl memory : msg_preserved memory memory.
Proof using. red. ins. eauto. Qed.

Definition msg_preserved_add memory memory' loc from to msg
           (ADD : Memory.add memory loc from to msg memory') :
  msg_preserved memory memory'.
Proof using. red. ins. exists from0. eapply memory_add_le; eauto. Qed.

Definition msg_preserved_split memory memory'
           loc ts1 ts2 ts3 msg1 msg2
           (SPLIT : Memory.split memory loc ts1 ts2 ts3 msg1 msg2 memory'):
  msg_preserved memory memory'.
Proof using.
  red. ins.
  erewrite Memory.split_o; eauto.
  edestruct Memory.split_get0 as [HH BB]; eauto.
  destruct (loc_ts_eq_dec (loc0, ts) (loc, ts2)) as [EQ|NEQ].
  { simpls. desf. rewrite HH in INMEM. desf. }
  simpls.
  destruct (loc_ts_eq_dec (loc0, ts) (loc, ts3)) as [EQ|NNEQ].
  { simpls. desf. rewrite BB in INMEM. inv INMEM. eauto. }
  eauto.
Qed.

Definition msg_preserved_cancel memory memory' loc from to
           (CANCEL : Memory.remove memory loc from to Message.reserve memory') :
  msg_preserved memory memory'.
Proof using.
  red. ins. exists from0.
  erewrite Memory.remove_o; eauto.
  destruct (loc_ts_eq_dec (loc0, ts) (loc, to)) as [EQ|NEQ].
  2: simpls.
  simpls. desf.
  edestruct Memory.remove_get0 as [HH]; eauto.
  rewrite HH in INMEM. inv INMEM.
Qed.

Definition msg_preserved_trans memory memory' memory''
           (PRES  : msg_preserved memory  memory')
           (PRES' : msg_preserved memory' memory'') :
  msg_preserved memory memory''.
Proof.
  red. ins.
  apply PRES  in INMEM. desf.
  apply PRES' in INMEM. desf.
Qed.

(*********************************************)
(* TODO: explanation. Maybe a separate file. *)
(*********************************************)
Lemma opt_wf_unwrap (view : option View.t) (H: View.wf (View.unwrap view)) :
  View.opt_wf view.
Proof using. by destruct view; simpls; constructor. Qed.

Lemma view_join_bot_r (lhs : View.t): View.join lhs View.bot = lhs.
Proof using. rewrite View.join_comm. apply View.join_bot_l. Qed.

Lemma view_join_id l : View.join l l = l.
Proof using. rewrite View.le_join_l; reflexivity. Qed.

Lemma time_join_le_r lhs rhs (LE : Time.le lhs rhs): Time.join lhs rhs = rhs.
Proof using.
  unfold Time.join. desf.
  exfalso. eapply DenseOrder.lt_strorder. eapply TimeFacts.lt_le_lt; eauto.
Qed.

Lemma time_join_le_l lhs rhs (LE : Time.le rhs lhs): Time.join lhs rhs = lhs.
Proof using. unfold Time.join. desf. by apply TimeFacts.antisym. Qed.

Lemma time_join_bot_r lhs: Time.join lhs Time.bot = lhs.
Proof using. apply time_join_le_l. apply Time.bot_spec. Qed.

Lemma time_join_bot_l rhs: Time.join Time.bot rhs = rhs.
Proof using. apply time_join_le_r. apply Time.bot_spec. Qed.

Lemma time_lt_join_l lhs rlhs rrhs (LT : Time.lt lhs rlhs) :
  Time.lt lhs (Time.join rlhs rrhs).
Proof using. unfold Time.join. desf. eapply TimeFacts.lt_le_lt; eauto. Qed.

Lemma time_lt_join_r lhs rlhs rrhs (LT : Time.lt lhs rrhs) :
  Time.lt lhs (Time.join rlhs rrhs).
Proof using. unfold Time.join. desf. etransitivity; eauto. Qed.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs64.shift.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition shift {X} (l : list X) k :=
  sublist k (Zlength l) l ++ sublist 0 k l.

Definition shift_spec :=
 DECLARE _shift
  WITH sh : share, a : val, s : list Z, n : Z, k : Z
  PRE [ _a OF (tptr tint) , _n OF (tint), _k OF (tint)]
     PROP(writable_share sh)
     LOCAL (temp _a a; temp _n (Vint (Int.repr n)); temp _k (Vint (Int.repr k)))
     SEP (data_at sh (tarray tint n) (map Vint (map Int.repr s)) a)
  POST [ tvoid ]
     PROP()
     LOCAL()
     SEP ((data_at sh (tarray tint n) (map Vint (map Int.repr (shift s k))) a)).

Definition Gprog : funspecs :=
        ltac:(with_library prog [shift_spec]).

Lemma shift_body : semax_body Vprog Gprog f_shift shift_spec.
Proof.
  start_function.
  forward_call.


Require Import Omega.
Require Import Bool.
Require Import RelationClasses.

Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import DenseOrder.
Require Import Language.
Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Pred.
Require Import Trace.

Require Import MemoryMerge.
Require Import ReorderCancel.
Require Import MemoryProps.
Require Import OrderedTimes.
Require Import Cover.
Require Import Mapping.

Set Implicit Arguments.

Lemma promise_not_cancel_covered_increase prom0 prom1 mem0 mem1
      loc from to msg kind
      (PROMISE: Memory.promise prom0 mem0 loc from to msg prom1 mem1 kind)
      (NOTCANCEL: kind <> Memory.op_kind_cancel)
      loc0 ts0
      (COVERED: covered loc0 ts0 mem0)
  :
    covered loc0 ts0 mem1.
Proof.
  inv PROMISE.
  { erewrite (@add_covered mem1 mem0); eauto. }
  { erewrite (@split_covered mem1 mem0); eauto. }
  { erewrite (@lower_covered mem1 mem0); eauto. }
  { ss. }
Qed.

Lemma step_not_cancel_covered_increase lang (th0 th1: Thread.t lang) pf e
      (STEP: Thread.step pf e th0 th1)
      (NOTCANCEL: ~ ThreadEvent.is_cancel e)
      loc0 ts0
      (COVERED: covered loc0 ts0 (Thread.memory th0))
  :
    covered loc0 ts0 (Thread.memory th1).
Proof.
  inv STEP.
  { inv STEP0. inv LOCAL. ss.
    eapply promise_not_cancel_covered_increase; eauto. destruct kind; ss.
    des_ifs. inv PROMISE; ss.
  }
  { inv STEP0. inv LOCAL; auto.
    { inv LOCAL0. inv WRITE. eapply promise_not_cancel_covered_increase; eauto.
      destruct kind; ss. inv PROMISE; ss. }
    { inv LOCAL2. inv WRITE. eapply promise_not_cancel_covered_increase; eauto.
      destruct kind; ss. inv PROMISE; ss. }
  }
Qed.

Lemma traced_steps_not_cancel_covered_increase lang (th0 th1: Thread.t lang) tr
      (STEPS: Trace.steps tr th0 th1)
      (EVENTS: List.Forall (fun em => <<SAT: (fun e => ~ ThreadEvent.is_cancel e) (snd em)>>) tr)
      loc0 ts0
      (COVERED: covered loc0 ts0 (Thread.memory th0))
  :
    covered loc0 ts0 (Thread.memory th1).
Proof.
  ginduction STEPS; auto. i. clarify. inv EVENTS.
  eapply step_not_cancel_covered_increase in STEP; eauto.
Qed.

Section UNATTACHABLE.

  Inductive unattachable (mem: Memory.t) (loc: Loc.t) (ts: Time.t): Prop :=
  | unattachable_intro
      from to msg
      (MSG: Memory.get loc to mem = Some (from, msg))
      (FROM: Time.le from ts)
      (TO: Time.lt ts to)
  .

  Lemma lower_unattachable mem1 mem0 loc from to msg1 msg2
        (LOWER: Memory.lower mem0 loc from to msg1 msg2 mem1)
    :
      unattachable mem1 = unattachable mem0.
  Proof.
    extensionality loc0. extensionality ts0.
    exploit Memory.lower_get0; eauto. i. des.
    apply Coq.Logic.PropExtensionality.propositional_extensionality. split; i.
    { inv H. erewrite Memory.lower_o in MSG; eauto. des_ifs.
      { ss. des; clarify. econs; eauto. }
      { econs; eauto. }
    }
    { inv H. eapply Memory.lower_get1 in MSG; eauto. des. econs; eauto. }
  Qed.

  Lemma split_unattachable mem1 mem0 loc ts1 ts2 ts3 msg2 msg3
        (SPLIT: Memory.split mem0 loc ts1 ts2 ts3 msg2 msg3 mem1)
    :
      unattachable mem1 = unattachable mem0.
  Proof.
  Admitted.
    (* extensionality loc0. extensionality ts0.
    exploit split_succeed_wf; eauto. i. des.
    exploit Memory.split_get0; eauto. i. des.
    apply Coq.Logic.PropExtensionality.propositional_extensionality. split; i.
    { inv H. erewrite Memory.split_o in MSG; eauto. des_ifs.
      { ss. des; clarify. econs; eauto. }
      { ss. des; clarify. econs; eauto. etrans; eauto. left. auto. }
      { econs; eauto. }
    }
    { inv H. generalize (Memory.split_o loc0 to SPLIT). intros MSG0. des_ifs.
      { ss. des; clarify. }
      { ss. des; clarify.
        destruct (Time.le_lt_dec ts2 ts0).
        { econs; try apply MSG0; eauto. }
        { econs; try apply GET1; eauto. }
      }
      { erewrite MSG in *. clarify. econs; eauto. }
    }
  Qed. *)

  Lemma add_unattachable mem1 mem0 loc from to msg
        (ADD: Memory.add mem0 loc from to msg mem1)
    :
      unattachable mem1 =
      (fun loc0 ts0 =>
         unattachable mem0 loc0 ts0 \/ (loc0 = loc /\ Time.le from ts0 /\ Time.lt ts0 to)).
  Proof.
    extensionality loc0. extensionality ts0.
    exploit add_succeed_wf; eauto. i.  des.
    exploit Memory.add_get0; eauto. i. des.
    apply Coq.Logic.PropExtensionality.propositional_extensionality. split; i.
    { inv H. erewrite Memory.add_o in MSG; eauto. des_ifs.
      { ss. des; clarify. right. splits; auto. }
      { left. econs; eauto. }
    }
    { des; subst.
      { inv H. econs; eauto. eapply Memory.add_get1; eauto. }
      { econs; eauto. }
    }
  Qed.

End UNATTACHABLE.

Section LIFT.

  Lemma memory_remove_le_preserve mem0 mem0' mem1 mem1' loc from to msg
        (REMOVE0: Memory.remove mem0 loc from to msg mem0')
        (REMOVE1: Memory.remove mem1 loc from to msg mem1')
        (MLE: Memory.le mem0 mem1)
  :
    Memory.le mem0' mem1'.
  Proof.
    ii. erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o mem0' mem0) in LHS; eauto. des_ifs.
    eapply MLE; eauto.
  Qed.

  Lemma memory_add_le_preserve mem0 mem0' mem1 mem1' loc from to msg
        (ADD0: Memory.add mem0 loc from to msg mem0')
        (ADD1: Memory.add mem1 loc from to msg mem1')
        (MLE: Memory.le mem0 mem1)
    :
      Memory.le mem0' mem1'.
  Proof.
    ii. erewrite Memory.add_o; eauto.
    erewrite (@Memory.add_o mem0' mem0) in LHS; eauto. des_ifs.
    eapply MLE; eauto.
  Qed.

  Lemma memory_split_le_preserve mem0 mem0' mem1 mem1' loc ts1 ts2 ts3 msg2 msg3
        (SPLIT0: Memory.split mem0 loc ts1 ts2 ts3 msg2 msg3 mem0')
        (SPLIT1: Memory.split mem1 loc ts1 ts2 ts3 msg2 msg3 mem1')
        (MLE: Memory.le mem0 mem1)
    :
      Memory.le mem0' mem1'.
  Proof.
    ii. erewrite Memory.split_o; eauto.
    erewrite (@Memory.split_o mem0' mem0) in LHS; eauto. des_ifs.
    eapply MLE; eauto.
  Qed.

  Lemma memory_lower_le_preserve mem0 mem0' mem1 mem1' loc from to msg1 msg2
        (LOWER0: Memory.lower mem0 loc from to msg1 msg2 mem0')
        (LOWER1: Memory.lower mem1 loc from to msg1 msg2 mem1')
        (MLE: Memory.le mem0 mem1)
    :
      Memory.le mem0' mem1'.
  Proof.
    ii. erewrite Memory.lower_o; eauto.
    erewrite (@Memory.lower_o mem0' mem0) in LHS; eauto. des_ifs.
    eapply MLE; eauto.
  Qed.

  Lemma step_lifting_promise prom0 prom1 mem0 mem1 cap0
        loc from to msg kind
        (spaces lefts: Loc.t -> Time.t -> Prop)
        (PROMISE: Memory.promise prom0 mem0 loc from to msg prom1 mem1 kind)
        (WRITENOTIN: forall ts (ITV: Interval.mem (from, to) ts), ~ spaces loc ts)
        (WRITENOTTO: ~ lefts loc to)
        (SOUND: Memory.le mem0 cap0)
        (SPACES:
           forall loc ts (COV: covered loc ts cap0),
             <<COV: covered loc ts mem0>> \/ <<SPACE: spaces loc ts>>)
        (LEFTS:
           forall loc ts (UNATTACHABLE: unattachable cap0 loc ts),
             <<COV: unattachable mem0 loc ts>> \/ <<LEFT: lefts loc ts>>)
        (MEM0: Memory.closed mem0)
        (PROM0: Memory.le prom0 mem0)
        (PROM1: Memory.le prom0 cap0)
        (NOTCANCEL: kind <> Memory.op_kind_cancel)
    :
      exists cap1,
        (<<STEP: Memory.promise prom0 cap0 loc from to msg prom1 cap1 kind>>) /\
        (<<SOUND: Memory.le mem1 cap1>>) /\
        (<<SPACES:
           forall loc ts (COV: covered loc ts cap1),
             <<COV: covered loc ts mem1>> \/ spaces loc ts>>) /\
        (<<LEFTS:
           forall loc ts (UNATTACHABLE: unattachable cap1 loc ts),
             <<COV: unattachable mem1 loc ts>> \/ lefts loc ts>>).
  Proof.
    inv PROMISE.
    { exploit add_succeed_wf; try apply MEM; eauto. i. des.
      exploit (@Memory.add_exists cap0 loc from to msg); eauto.
      { ii. exploit SPACES.
        { econs; eauto. }
        i. des.
        { inv COV. eapply DISJOINT; eauto. }
        { eapply WRITENOTIN; eauto. }
      }
      i. des. esplits.
      { econs; eauto. i. subst. exploit LEFTS.
        { econs; eauto.
          { refl. }
          { apply memory_get_ts_strong in GET. des; auto.
            subst. eapply TimeFacts.le_lt_lt; eauto. eapply Time.bot_spec. }
        }
        i. des; ss.
        { inv COV. destruct FROM.
          { eapply DISJOINT; eauto.
            { instantiate (1:=to). econs; ss. refl. }
            { econs; ss. left. eauto. }
          }
          { inv H. eapply ATTACH; eauto. }
        }
      }
      { eapply memory_add_le_preserve; eauto. }
      { i. erewrite add_covered in COV; eauto.
        erewrite (@add_covered mem1 mem0); eauto. des; eauto.
        eapply SPACES in COV. des; auto. }
      { i. erewrite add_unattachable in UNATTACHABLE; eauto.
        erewrite (@add_unattachable mem1 mem0); eauto. des; auto.
        eapply LEFTS in UNATTACHABLE. des; auto. }
    }
    { des. subst.
      exploit (@Memory.split_exists_le prom0 cap0); eauto. i. des. esplits.
      { econs; eauto. }
      { ii. erewrite Memory.split_o in LHS; eauto.
        erewrite (@Memory.split_o mem2 cap0); eauto. des_ifs.
        eapply SOUND; eauto. }
      { i. erewrite (@split_covered mem2 cap0) in COV; eauto.
        erewrite (@split_covered mem1 mem0); eauto. }
      { i. erewrite (@split_unattachable mem2 cap0) in UNATTACHABLE; eauto.
        erewrite (@split_unattachable mem1 mem0); eauto. }
    }
    { des. subst.
      exploit (@Memory.lower_exists_le prom0 cap0); eauto. i. des. esplits.
      { econs; eauto. }
      { ii. erewrite Memory.lower_o in LHS; eauto.
        erewrite (@Memory.lower_o mem2 cap0); eauto. des_ifs.
        eapply SOUND; eauto. }
      { i. erewrite (@lower_covered mem2 cap0) in COV; eauto.
        erewrite (@lower_covered mem1 mem0); eauto. }
      { i. erewrite (@lower_unattachable mem2 cap0) in UNATTACHABLE; eauto.
        erewrite (@lower_unattachable mem1 mem0); eauto. }
    }
    { ss. }
  Qed.

  Lemma step_lifting lang st0 st1 lc0 lc1 sc0 sc1 mem0 mem1 cap0 pf e
        (spaces lefts: Loc.t -> Time.t -> Prop)
        (STEP: Thread.step pf e (Thread.mk lang st0 lc0 sc0 mem0) (Thread.mk _ st1 lc1 sc1 mem1))
        (WRITENOTIN: write_not_in spaces e)
        (WRITENOTTO: write_not_to lefts e)
        (NOTCANCEL: ~ ThreadEvent.is_cancel e)
        (SOUND: Memory.le mem0 cap0)
        (SPACES:
           forall loc ts (COV: covered loc ts cap0),
             <<COV: covered loc ts mem0>> \/ <<SPACE: spaces loc ts>>)
        (LEFTS:
           forall loc ts (UNATACHABLE: unattachable cap0 loc ts),
             <<COV: unattachable mem0 loc ts>> \/ <<LEFT: lefts loc ts>>)
       (MEM0: Memory.closed mem0)
        (LOCAL0: Local.wf lc0 mem0)
        (SC0: Memory.closed_timemap sc0 mem0)
    :
      exists cap1,
        (<<STEP: Thread.step pf e (Thread.mk _ st0 lc0 sc0 cap0) (Thread.mk _ st1 lc1 sc1 cap1)>>) /\
        (<<SOUND: Memory.le mem1 cap1>>) /\
        (<<SPACES:
           forall loc ts (COV: covered loc ts cap1),
             <<COV: covered loc ts mem1>> \/ spaces loc ts>>) /\
        (<<UNATTACHABLE:
           forall loc ts (COV: unattachable cap1 loc ts),
             <<COV: unattachable mem1 loc ts>> \/ lefts loc ts>>).

  Proof.
    inv STEP.
    { inv STEP0. inv LOCAL. ss.
      destruct (Memory.op_kind_is_cancel kind) eqn:KIND; ss.
      { destruct kind; ss. des_ifs. inv PROMISE; ss. }
      exploit step_lifting_promise; eauto.
      { eapply LOCAL0. }
      { transitivity mem0; eauto. eapply LOCAL0. }
      { destruct kind; ss. }
      i. des. esplits; eauto. econs. econs.
      { econs; eauto. eapply memory_concrete_le_closed_msg; eauto. }
      { ss. destruct kind; ss. }
    }
    { inv STEP0. inv LOCAL.
      { esplits; eauto. }
      { inv LOCAL1. eapply SOUND in GET. esplits; eauto. }
      { inv LOCAL1. inv WRITE. exploit step_lifting_promise; eauto.
        { eapply LOCAL0. }
        { transitivity mem0; eauto. eapply LOCAL0. }
        { destruct kind; ss. inv PROMISE; ss. }
        i. des. esplits; eauto. econs 2; eauto.
      }
      { inv LOCAL1. eapply SOUND in GET. inv LOCAL2. inv WRITE.
        exploit step_lifting_promise; eauto.
        { eapply LOCAL0. }
        { transitivity mem0; eauto. eapply LOCAL0. }
        { destruct kind; ss. inv PROMISE; ss. }
        i. des. esplits; eauto. econs 2; eauto. econs; eauto. }
      { esplits; eauto. }
      { esplits; eauto. }
      { esplits; eauto. }
    }
  Qed.

  Lemma traced_step_lifting lang st0 st1 lc0 lc1 sc0 sc1 mem0 mem1 cap0 tr
        (spaces lefts: Loc.t -> Time.t -> Prop)
        (STEPS: Trace.steps tr (Thread.mk lang st0 lc0 sc0 mem0) (Thread.mk _ st1 lc1 sc1 mem1))
        (EVENTS: List.Forall (fun em => <<SAT: (write_not_in spaces /1\ write_not_to lefts /1\ (fun e => ~ ThreadEvent.is_cancel e)) (snd em)>>) tr)
        (SOUND: Memory.le mem0 cap0)
        (SPACES:
           forall loc ts (COV: covered loc ts cap0),
             <<COV: covered loc ts mem0>> \/ <<SPACE: spaces loc ts>>)
        (LEFTS:
           forall loc ts (UNATACHABLE: unattachable cap0 loc ts),
             <<COV: unattachable mem0 loc ts>> \/ <<LEFT: lefts loc ts>>)
        (MEM0: Memory.closed mem0)
        (LOCAL0: Local.wf lc0 mem0)
        (SC0: Memory.closed_timemap sc0 mem0)
    :
      exists cap1,
        (<<STEPS: Trace.steps tr (Thread.mk _ st0 lc0 sc0 cap0) (Thread.mk _ st1 lc1 sc1 cap1)>>) /\
        (<<SOUND: Memory.le mem1 cap1>>) /\
        (<<SPACES:
           forall loc ts (COV: covered loc ts cap1),
             <<COV: covered loc ts mem1>> \/ spaces loc ts>>) /\
        (<<LEFTS:
           forall loc ts (UNATACHABLE: unattachable cap1 loc ts),
             <<COV: unattachable mem1 loc ts>> \/ lefts loc ts>>).
  Proof.
    remember (Thread.mk lang st0 lc0 sc0 mem0).
    remember (Thread.mk lang st1 lc1 sc1 mem1). ginduction STEPS.
    { i. clarify. esplits; eauto. }
    { i. clarify. inv EVENTS. ss. des.
      exploit Thread.step_future; eauto. i. des.
      destruct th1. ss. exploit step_lifting; eauto. i. des.
      exploit IHSTEPS; eauto. i. des. exists cap2. splits; auto. econs; eauto.
    }
  Qed.

End LIFT.

Fixpoint intervals_sum (l: list (Loc.t * Interval.t)):
  Loc.t -> Time.t -> Prop :=
  match l with
  | [] => bot2
  | (loc, (from, to))::tl =>
    fun loc0 ts0 =>
      (loc0 = loc /\ Interval.mem (from, to) ts0) \/
      intervals_sum tl loc0 ts0
  end.

Fixpoint intervals_sum_left (l: list (Loc.t * Interval.t)):
  Loc.t -> Time.t -> Prop :=
  match l with
  | [] => bot2
  | (loc, (from, to))::tl =>
    fun loc0 ts0 =>
      (loc0 = loc /\ Time.le from ts0 /\ Time.lt ts0 to) \/
      intervals_sum_left tl loc0 ts0
  end.

Lemma intervals_sum_interval l
      loc ts
  :
    intervals_sum l loc ts <->
    exists from to,
      (<<IN: List.In (loc, (from, to)) l>>) /\ (<<ITV: Interval.mem (from, to) ts>>).
Proof.
  ginduction l; ss.
  { i; split; i; ss. des. ss. }
  { i; split; i; ss.
    { destruct a. destruct t0. des; clarify.
      { esplits; eauto. }
      { eapply IHl in H. des. esplits; eauto. }
    }
    { destruct a. destruct t0. des; clarify; eauto. right.
      eapply IHl. eauto. }
  }
Qed.

Lemma intervals_sum_left_interval l
      loc ts
  :
    intervals_sum_left l loc ts <->
    exists from to,
      (<<IN: List.In (loc, (from, to)) l>>) /\ (<<FROM: Time.le from ts>>) /\ (<<TO: Time.lt ts to>>).
Proof.
  ginduction l; ss.
  { i; split; i; ss. des. ss. }
  { i; split; i; ss.
    { destruct a. destruct t0. des; clarify.
      { esplits; eauto. }
      { eapply IHl in H. des. esplits; eauto. }
    }
    { destruct a. destruct t0. des; clarify; eauto. right.
      eapply IHl. eauto. }
  }
Qed.

Lemma promise_needed_spaces prom0 prom1 mem0 mem1
      loc from to msg kind
      (PROMISE: Memory.promise prom0 mem0 loc from to msg prom1 mem1 kind)
      (WF: kind <> Memory.op_kind_cancel)
  :
    ((<<ALREADY: forall ts (ITV: Interval.mem (from, to) ts), covered loc ts mem0>>) /\
     (<<COVERED: forall loc ts, covered loc ts mem1 <-> covered loc ts mem0>>))
    \/
    ((<<NEW: forall ts (ITV: Interval.mem (from, to) ts), ~ covered loc ts mem0>>) /\
     (<<COVERED: forall loc0 ts0,
         covered loc0 ts0 mem1 <-> covered loc0 ts0 mem0 \/ (loc0 = loc /\ Interval.mem (from, to) ts0)>>) /\
     (<<WF: Time.lt from to>>))
.
Proof.
  inv PROMISE.
  { right. exploit add_succeed_wf; try apply MEM. i. des. splits; auto.
    { ii. inv H. eapply DISJOINT; eauto. }
    { i. erewrite (@add_covered mem1); eauto. }
  }
  { left. exploit split_succeed_wf; try apply MEM. i. des. splits; auto.
    { ii. econs; eauto. eapply Interval.le_mem; eauto. econs; ss.
      { refl. }
      { left. auto. }
    }
    { i. eapply split_covered; eauto. }
  }
  { left. exploit lower_succeed_wf; try apply MEM. i. des. splits; auto.
    { ii. econs; eauto. }
    { i. eapply lower_covered; eauto. }
  }
  { ss. }
Qed.

Lemma step_needed_spaces lang (th0 th1: Thread.t lang) pf e
      (times: Loc.t -> Time.t -> Prop)
      (STEP: Thread.step pf e th0 th1)
      (NOTCANCEL: ~ ThreadEvent.is_cancel e)
      (WFTIME: wf_time_evt times e)
  :
    ((<<ALREADY: write_not_in (fun loc0 ts0 => ~ covered loc0 ts0 (Thread.memory th0)) e>>) /\
     (<<COVERED: forall loc ts, covered loc ts (Thread.memory th1) <-> covered loc ts (Thread.memory th0)>>))
    \/
    exists loc from to,
      (<<NEW: forall ts (ITV: Interval.mem (from, to) ts), ~ covered loc ts (Thread.memory th0)>>) /\
      (<<COVERED: forall loc0 ts0,
          covered loc0 ts0 (Thread.memory th1) <-> covered loc0 ts0 (Thread.memory th0) \/ (loc0 = loc /\ Interval.mem (from, to) ts0)>>) /\
      (<<WF: Time.lt from to>>) /\
      (<<TIMES: times loc from /\ times loc to>>) /\
      (<<EVENT: write_not_in (fun loc0 ts0 => ~ (loc0 = loc /\ Interval.mem (from, to) ts0)) e>>).
Proof.
  inv STEP.
  { inv STEP0. inv LOCAL. ss.
    destruct (Memory.op_kind_is_cancel kind) eqn:KIND.
    { destruct kind; ss. des_ifs. inv PROMISE; ss. }
    exploit promise_needed_spaces; eauto.
    { destruct kind; ss. }
    i. des.
    { left. splits; auto. }
    { right. esplits; eauto. }
  }
  { inv STEP0. inv LOCAL; try by (splits; eauto); ss.
    { ss. inv LOCAL0. inv WRITE.
      exploit promise_needed_spaces; eauto.
      { destruct kind; ss. inv PROMISE; ss. }
      i. des.
      { left. esplits; eauto. }
      { right. esplits; eauto. }
    }
    { ss. inv LOCAL2. inv WRITE.
      exploit promise_needed_spaces; eauto.
      { destruct kind; ss. inv PROMISE; ss. }
      i. des.
      { left. esplits; eauto. }
      { right. esplits; eauto. }
    }
  }
Qed.

Inductive reservations_added:
  forall (l: list (Loc.t * Interval.t)) (mem0 mem1: Memory.t), Prop :=
| reservations_added_base
    mem0
  :
    reservations_added [] mem0 mem0
| reservations_added_cons
    mem0 mem1 mem2 loc from to tl
    (ADD: Memory.add mem0 loc from to Message.reserve mem1)
    (TL: reservations_added tl mem1 mem2)
    (WF: Time.lt from to)
  :
    reservations_added ((loc, (from, to))::tl) mem0 mem2
.

Lemma reservations_added_trans l0 l1 mem0 mem1 mem2
      (ADDED0: reservations_added l0 mem0 mem1)
      (ADDED1: reservations_added l1 mem1 mem2)
  :
    reservations_added (l0 ++ l1) mem0 mem2.
Proof.
  ginduction l0; eauto.
  { i. inv ADDED0. ss. }
  { i. inv ADDED0. exploit IHl0; eauto. i. econs; eauto. }
Qed.

Lemma reservations_added_cancel
      loc from to mem0 mem1 mem2 tl
      (CANCEL: Memory.remove mem1 loc from to Message.reserve mem0)
      (TL: reservations_added tl mem1 mem2)
      (WF: Time.lt from to)
  :
    reservations_added ((loc, (from, to))::tl) mem0 mem2.
Proof.
  econs; eauto.
  exploit (@Memory.add_exists mem0 loc from to Message.reserve); eauto.
  { i. erewrite Memory.remove_o in GET2; eauto. des_ifs.
    exploit Memory.get_disjoint.
    { eapply GET2. }
    { eapply Memory.remove_get0; eauto. }
    i. ss. des; clarify. symmetry. auto.
  }
  { econs. }
  i. des. replace mem1 with mem3; auto. eapply Memory.ext.
  i. erewrite (@Memory.add_o mem3 mem0); eauto.
  erewrite (@Memory.remove_o mem0 mem1); eauto. des_ifs.
  ss. des; clarify. symmetry. eapply Memory.remove_get0; eauto.
Qed.

Inductive disjoint_intervals
  :
    forall (l: list (Loc.t * Interval.t)), Prop :=
| disjoint_base
  :
    disjoint_intervals []
| disjoint_intervals_cons
    loc from to tl
    (TL: disjoint_intervals tl)
    (NITV: forall ts (ITV: Interval.mem (from, to) ts),
        ~ intervals_sum tl loc ts)
    (TS: Time.lt from to)
  :
    disjoint_intervals ((loc, (from, to)) :: tl)
.
Hint Constructors disjoint_intervals.

Lemma traced_steps_needed_spaces lang (th0 th1: Thread.t lang) tr
      (times: Loc.t -> Time.t -> Prop)
      (STEP: Trace.steps tr th0 th1)
      (EVENTS: List.Forall (fun em => <<SAT: ((fun e => ~ ThreadEvent.is_cancel e) /1\ wf_time_evt times) (snd em)>>) tr)
  :
    exists l,
      (<<WRITENOTIN:
         List.Forall (fun em => <<SAT: write_not_in (fun loc ts => ~ (covered loc ts (Thread.memory th0) \/ intervals_sum l loc ts)) (snd em)>>) tr>>) /\
      (<<DISJOINT: disjoint_intervals l>>) /\
      (<<NITV: forall loc ts (ITV: intervals_sum l loc ts), ~ covered loc ts (Thread.memory th0)>>) /\
      (<<COVERED: forall loc ts,
          covered loc ts (Thread.memory th1) <-> covered loc ts (Thread.memory th0) \/ intervals_sum l loc ts>>) /\
      (<<TIMES: List.Forall (fun locitv =>
                               times (fst locitv) (fst (snd locitv)) /\
                               times (fst locitv) (snd (snd locitv))) l>>)
.
Proof.
  ginduction STEP; i.
  { exists []. splits; auto. i. ss. split; auto. i. des; ss. }
  { subst. inv EVENTS. des. exploit IHSTEP; eauto. i. des.
    exploit step_needed_spaces; eauto. i. des.
    { exists l. splits; auto.
      { econs; eauto.
        { eapply write_not_in_mon; eauto. i. ss.
          eapply not_or_and in PR. des. auto. }
        { eapply List.Forall_impl; eauto. i. ss.
          eapply write_not_in_mon; eauto. i. ss.
          erewrite COVERED0; eauto. }
      }
      { i. erewrite <- COVERED0; eauto. }
      { i. erewrite <- COVERED0. eauto. }
    }
    { exists ((loc, (from, to)) :: l). splits.
      { econs.
        { eapply write_not_in_mon; eauto. ss. i.
          ii. des. eapply PR. eauto. }
        { eapply List.Forall_impl; try apply WRITENOTIN; eauto. i. ss.
          eapply write_not_in_mon; eauto. i. ss.
          ii. eapply PR. des; auto. eapply COVERED0 in H3. des; auto. }
      }
      { econs; eauto. ii. eapply NITV; eauto. eapply COVERED0. auto. }
      { i. ss. des; clarify; eauto.
        eapply NITV in ITV. ii. eapply ITV. eapply COVERED0. auto. }
      { ii. erewrite COVERED. erewrite COVERED0. ss. split; i; des; auto. }
      { econs; ss. }
    }
  }
Qed.

Lemma reserve_empty_intervals times lang (th: Thread.t lang) l
      (DISJOINT: disjoint_intervals l)
      (NITV: forall loc ts (ITV: intervals_sum l loc ts),
          ~ covered loc ts (Thread.memory th))
      (MLE: Memory.le (Local.promises (Thread.local th)) (Thread.memory th))
      (TIMES: List.Forall (fun locitv =>
                             times (fst locitv) (fst (snd locitv)) /\
                             times (fst locitv) (snd (snd locitv))) l)
  :
    exists tr prom' mem',
      (<<STEPS: Trace.steps tr th (Thread.mk _ (Thread.state th) (Local.mk (Local.tview (Thread.local th)) prom') (Thread.sc th) mem')>>) /\
      (<<RESERVETRACE: List.Forall (fun em => <<SAT: (ThreadEvent.is_reserve /1\ wf_time_evt times) (snd em)>>) tr>>) /\
      (<<ADDEDPROM: reservations_added l (Local.promises (Thread.local th)) prom'>>) /\
      (<<ADDEDMEM: reservations_added l (Thread.memory th) mem'>>)
.
Proof.
  ginduction l; i.
  { destruct th. destruct local. ss. exists []. esplits; eauto.
    { econs. }
    { econs. }
  }
  { inv DISJOINT. inv TIMES. ss.
    exploit (@Memory.add_exists (Thread.memory th) loc from to Message.reserve); eauto.
    { ii. eapply NITV.
      { left. eauto. }
      { econs; eauto. }
    }
    { econs. }
    intros [mem MEM].
    exploit (@Memory.add_exists_le (Local.promises (Thread.local th)) (Thread.memory th)); eauto.
    intros [prom PROM].
    assert (STEP: Thread.step false (ThreadEvent.promise loc from to Message.reserve Memory.op_kind_add) th (Thread.mk _ (Thread.state th) (Local.mk (Local.tview (Thread.local th)) prom) (Thread.sc th) mem)).
    { destruct th. ss. econs. econs; ss. econs; ss. econs; ss. }
    exploit (@IHl times lang (Thread.mk _ (Thread.state th) (Local.mk (Local.tview (Thread.local th)) prom) (Thread.sc th) mem)); eauto; ss.
    { i. erewrite add_covered; eauto. ii. des; subst.
      { eapply NITV; eauto. }
      { eapply NITV0; eauto. }
    }
    { hexploit step_promises_le; eauto.
      { econs; eauto. }
      i. ss.
    }
    i. des. esplits.
    { econs; eauto. }
    { econs; ss. }
    { econs; eauto. }
    { econs; eauto. }
  }
Qed.

Lemma reservations_added_get_same mem1 mem0 l
      (ADDED: reservations_added l mem0 mem1)
      loc ts
      (NIN: forall from, ~ List.In (loc, (from, ts)) l)
  :
    Memory.get loc ts mem1 = Memory.get loc ts mem0.
Proof.
  ginduction ADDED; auto. i.
  erewrite IHADDED; eauto.
  { erewrite (@Memory.add_o mem1 mem0); eauto. des_ifs. ss. des; clarify.
    exfalso. eapply NIN; eauto. }
  { ii. ss. eapply NIN; eauto. }
Qed.

Lemma reservations_added_get_none mem1 mem0 l
      (ADDED: reservations_added l mem0 mem1)
      loc from ts
      (IN: List.In (loc, (from, ts)) l)
  :
    Memory.get loc ts mem0 = None.
Proof.
  ginduction ADDED; ss. i. des; clarify.
  { eapply Memory.add_get0; eauto. }
  { eapply IHADDED in IN. erewrite Memory.add_o in IN; eauto. des_ifs. }
Qed.

Lemma reservations_added_le_le l mem0 mem1 cap1 cap0
      (ADDED0: reservations_added l mem0 mem1)
      (MLE: Memory.le mem1 cap1)
      (ADDED1: reservations_added l cap0 cap1)
  :
    Memory.le mem0 cap0.
Proof.
  ii. destruct (classic (forall from, ~ List.In (loc, (from, to)) l)).
  { erewrite <- (@reservations_added_get_same cap1 cap0); eauto.
    erewrite <- (@reservations_added_get_same mem1 mem0) in LHS; eauto. }
  { eapply not_all_not_ex in H. des.
    erewrite reservations_added_get_none in LHS; eauto. ss. }
Qed.

Lemma cancel_reservations_added times l prom lang lc
      (ADDEDPROM: reservations_added l prom (Local.promises lc))
      (TIMES: List.Forall (fun locitv =>
                             times (fst locitv) (fst (snd locitv)) /\
                             times (fst locitv) (snd (snd locitv))) l)
  :
    exists tr,
      (<<CANCELTRACE: List.Forall (fun em => <<SAT: (ThreadEvent.is_cancel /1\ wf_time_evt times) (snd em)>>) tr>>) /\
    forall
      (st: Language.state lang) sc mem
      (MLE: Memory.le (Local.promises lc) mem),
    exists mem',
      (<<STEPS: Trace.steps tr (Thread.mk _ st lc sc mem) (Thread.mk _ st (Local.mk (Local.tview lc) prom) sc mem')>>) /\
      (<<ADDEDMEM: reservations_added l mem' mem>>)
.
Proof.
  ginduction l; i.
  { exists []. splits; ss. i. destruct lc. ss. inv ADDEDPROM. esplits; eauto. econs. }
  { inv TIMES. inv ADDEDPROM.
    exploit IHl; eauto. i. des.
    eexists (tr++[(Local.mk (Local.tview lc) mem1, ThreadEvent.promise loc from to Message.reserve Memory.op_kind_cancel)]).
    splits.
    { eapply Forall_app; eauto. econs; ss. }
    i. exploit (x0 st sc mem); eauto. i. des.
    exploit (@Memory.remove_exists mem1 loc from to Message.reserve); eauto.
    { eapply Memory.add_get0; eauto. } i. des.
    exploit (@Memory.remove_exists_le mem1 mem'); eauto.
    { eapply trace_steps_promises_le in STEPS; eauto. } i. des.
    assert (mem2 = prom).
    { symmetry. eapply MemoryMerge.add_remove; eauto. } subst.
    esplits.
    { eapply Trace.steps_trans.
      { eapply STEPS. }
      { econs; eauto. econs 1; eauto. econs; eauto. }
    }
    { eapply reservations_added_cancel; eauto. }
  }
Qed.

Lemma step_finte_write_to (e: ThreadEvent.t)
      (times: Loc.t -> Time.t -> Prop)
      (EVENT: wf_time_evt times e)
  :
    exists (l: list (Loc.t * Time.t)),
      (<<EVENT: write_not_to (fun loc ts => ~ List.In (loc, ts) l) e>>) /\
      (<<TIMES: List.Forall (fun locts => times (fst locts) (snd locts)) l>>).
Proof.
  destruct e; try by (exists []; esplits; eauto); ss.
  { exists [(loc, to)]. esplits; ss.
    { des_ifs. ii. eapply H. auto. }
    { econs; ss. des. auto. }
  }
  { exists [(loc, to)]. esplits; ss.
    { ii. eapply H. auto. }
    { econs; ss. des. auto. }
  }
  { exists [(loc, tsw)]. esplits; ss.
    { ii. eapply H. auto. }
    { econs; ss. des. auto. }
  }
Qed.

Lemma write_not_to_mon P0 P1
      (LE: P0 <2= P1)
  :
    write_not_to P1 <1= write_not_to P0.
Proof.
  ii. unfold write_not_to in *. des_ifs; auto.
Qed.

Lemma traced_steps_finte_write_to (tr: Trace.t)
      (times: Loc.t -> Time.t -> Prop)
      (EVENTS: List.Forall (fun em => <<SAT: (wf_time_evt times) (snd em)>>) tr)
  :
    exists (l: list (Loc.t * Time.t)),
      (<<EVENTS: List.Forall (fun em => write_not_to (fun loc ts => ~ List.In (loc, ts) l) (snd em)) tr>>) /\
      (<<TIMES: List.Forall (fun locts => times (fst locts) (snd locts)) l>>).
Proof.
  ginduction tr.
  { i. inv EVENTS. exists []. esplits; eauto. }
  { i. inv EVENTS. exploit IHtr; eauto. i. des.
    exploit (@step_finte_write_to (snd a)); eauto. i. des.
    exists (l0 ++ l). esplits; eauto.
    { econs; eauto.
      { eapply write_not_to_mon; eauto. ii. eapply PR. eapply List.in_or_app; eauto. }
      { eapply List.Forall_impl; eauto. i. ss.
        eapply write_not_to_mon; eauto. ii. eapply PR. eapply List.in_or_app; eauto. }
    }
    { eapply Forall_app; eauto. }
  }
Qed.

Lemma reserve_write_to (times: Loc.t -> Time.t -> Prop)
      (DIVERGE: forall loc ts,
          exists ts',
            (<<TIMES: times loc ts'>>) /\
            (<<TS: Time.lt ts ts'>>))
      mem
      (MWF: memory_times_wf times mem)
      loc ts
      (TIMES: times loc ts)
  :
    (<<ALREADY: unattachable mem loc ts>>) \/
    (<<NEW: exists from mem',
        (<<TS: Time.lt ts from>>) /\
        (<<ADD: Memory.add mem loc ts from Message.reserve mem'>>) /\
        (<<TIMES: times loc from>>) /\
        (<<MWF: memory_times_wf times mem'>>)>>).
Proof.
  destruct (classic (unattachable mem loc ts)); auto. right.
  hexploit (@cell_elements_least
              (mem loc)
              (fun to => exists from msg,
                   (<<GET: Memory.get loc to mem = Some (from, msg)>>) /\
                   (<<TS: Time.lt ts from>>))).
  i. des.
  { hexploit (@Memory.add_exists mem loc ts from0 Message.reserve); ss.
    { ii. destruct (Time.le_lt_dec from2 ts).
      { eapply H. econs; eauto.
        inv LHS. inv RHS. ss. eapply TimeFacts.lt_le_lt; eauto. }
      { dup GET2. eapply LEAST in GET2.
        { exploit memory_get_to_mon.
          { eapply GET1. }
          { eapply GET0. }
          { inv LHS. inv RHS. ss. eapply TimeFacts.lt_le_lt; eauto. }
          i. timetac.
        }
        esplits; eauto.
      }
    }
    { econs. }
    i. des. esplits; eauto.
    { eapply MWF in GET0. des; auto. }
    { eapply MWF in GET0. des.
      ii. erewrite Memory.add_o in GET0; eauto. des_ifs.
      { ss. des; clarify. }
      { eapply MWF; eauto. }
    }
  }
  { hexploit (DIVERGE loc ts). i. des.
    hexploit (@Memory.add_exists mem loc ts ts' Message.reserve); ss.
    { ii. eapply EMPTY; eauto. esplits; eauto.
      destruct (Time.le_lt_dec from2 ts); auto. exfalso.
      eapply H. econs; eauto.
      inv LHS. inv RHS. ss. eapply TimeFacts.lt_le_lt; eauto. }
    { econs. }
    i. des. esplits; eauto.
    ii. erewrite Memory.add_o in GET; eauto. des_ifs.
    { ss. des; clarify. }
    { eapply MWF; eauto. }
  }
Qed.

Lemma reserve_write_tos times lang (th: Thread.t lang) tos
      (DIVERGE: forall loc ts,
          exists ts',
            (<<TIMES: times loc ts'>>) /\
            (<<TS: Time.lt ts ts'>>))
      (MWF: memory_times_wf times (Thread.memory th))
      (MLE: Memory.le (Local.promises (Thread.local th)) (Thread.memory th))
      (TIMES: List.Forall (fun locts => times (fst locts) (snd locts)) tos)
  :
    exists l tr prom' mem',
      (<<STEPS: Trace.steps tr th (Thread.mk _ (Thread.state th) (Local.mk (Local.tview (Thread.local th)) prom') (Thread.sc th) mem')>>) /\
      (<<RESERVETRACE: List.Forall (fun em => <<SAT: (ThreadEvent.is_reserve /1\ wf_time_evt times) (snd em)>>) tr>>) /\
      (<<ADDEDPROM: reservations_added l (Local.promises (Thread.local th)) prom'>>) /\
      (<<ADDEDMEM: reservations_added l (Thread.memory th) mem'>>) /\
      (<<WRITETO: forall loc ts (IN: List.In (loc, ts) tos),
          unattachable mem' loc ts>>) /\
      (<<TIMES: List.Forall (fun locitv =>
                               times (fst locitv) (fst (snd locitv)) /\
                               times (fst locitv) (snd (snd locitv))) l>>)
.
Proof.
  ginduction tos; i; ss.
  { exists [], []. destruct th. destruct local. ss. esplits; eauto; ss.
    { econs. }
    { econs. }
  }
  { inv TIMES. exploit IHtos; eauto. i. des.
    exploit reserve_write_to.
    { eauto. }
    { eapply memory_times_wf_traced in STEPS; eauto.
      eapply List.Forall_impl; eauto. i. ss. des; auto. }
    { eauto. }
    i. ss. des.
    { exists l, tr. esplits; eauto. i. des; auto. clarify. }
    { exploit (@Memory.add_exists_le prom' mem'); eauto.
      { eapply trace_steps_promises_le in STEPS; eauto. }
      i. des.
      assert (PROM: Memory.promise prom' mem' (fst a) (snd a) from Message.reserve promises2 mem'0 Memory.op_kind_add).
      { econs; eauto. ss. }
      destruct th. esplits.
      { eapply Trace.steps_trans.
        { eauto. }
        { econs 2.
          { econs 1. econs; eauto. }
          { econs 1. }
          { ss. }
        }
      }
      { eapply Forall_app; eauto. econs; ss. }
      { ss. eapply reservations_added_trans.
        { eauto. }
        { econs; eauto. econs. }
      }
      { ss. eapply reservations_added_trans.
        { eauto. }
        { econs; eauto. econs. }
      }
      { i. erewrite add_unattachable; eauto. des; clarify.
        { right. splits; ss. refl. }
        { eauto. }
      }
      { eapply Forall_app; eauto. }
    }
  }
Qed.

Lemma reservations_added_non_covered l mem0 mem1
      (ADDED: reservations_added l mem0 mem1)
      loc ts
      (COVERED: covered loc ts mem0)
  :
    ~ intervals_sum l loc ts.
Proof.
  ginduction l; eauto. i. inv ADDED. ss. ii.
  des; clarify.
  { inv COVERED. eapply add_succeed_wf in ADD. des.
    eapply DISJOINT; eauto. }
  { eapply IHl; eauto. erewrite add_covered; eauto. }
Qed.

Lemma add_unattachable_disjoint mem1 mem0 loc from to msg
      (ADD: Memory.add mem0 loc from to msg mem1)
      loc0 ts0
      (UNATTACHABLE: unattachable mem0 loc0 ts0)
  :
    ~ (loc0 = loc /\ Time.le from ts0 /\ Time.lt ts0 to).
Proof.
  ii. des; subst. inv UNATTACHABLE.
  exploit add_succeed_wf; eauto. i. des.
  hexploit DISJOINT; eauto. i. eapply disjoint_equivalent2 in H. des; ss.
  { eapply TS1. eapply TimeFacts.le_lt_lt; eauto. }
  { eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
    { eapply TS0. } eapply TimeFacts.le_lt_lt.
    { instantiate (1:=ts0). unfold Time.join. des_ifs. }
    { unfold Time.meet. des_ifs. }
  }
Qed.

Lemma reservations_added_non_unattachable l mem0 mem1
      (ADDED: reservations_added l mem0 mem1)
      loc ts
      (UNATTACHABLE: unattachable mem0 loc ts)
  :
    ~ intervals_sum_left l loc ts.
Proof.
  ginduction l; eauto. i. inv ADDED. ss. ii.
  des; clarify.
  { exploit add_unattachable_disjoint; eauto. }
  { eapply IHl; eauto. erewrite add_unattachable; eauto. }
Qed.

Lemma reservations_added_unattachable l mem0 mem1
      (ADDED: reservations_added l mem0 mem1)
      loc ts
      (UNATTACHABLE: unattachable mem1 loc ts)
  :
    unattachable mem0 loc ts \/ intervals_sum_left l loc ts.
Proof.
  ginduction l; eauto. i.
  { inv ADDED. auto. }
  { i. inv ADDED. eapply IHl in TL; eauto. ss.
    erewrite add_unattachable in TL; eauto. des; auto. }
Qed.

Definition eventable (mem prom: Memory.t) (spaces: Loc.t -> Time.t -> Prop)
           (loc: Loc.t) (ts: Time.t): Prop :=
  concrete_promised mem loc ts \/
  covered loc ts prom \/
  spaces loc ts.

Definition eventable_below (mem prom: Memory.t) (spaces: Loc.t -> Time.t -> Prop)
           (loc: Loc.t) (ts: Time.t): Prop :=
  exists to, <<TIME: eventable mem prom spaces loc to>> /\ <<TS: Time.le ts to>>.

Lemma eventable_le_below mem0 prom0 mem1 prom1 spaces
      (INCR: eventable mem1 prom1 spaces <2= eventable mem0 prom0 spaces)
  :
    eventable_below mem1 prom1 spaces <2= eventable_below mem0 prom0 spaces.
Proof.
  ii. unfold eventable_below in *. des. esplits; eauto.
Qed.

Lemma event_in_concrete_or_writes_promise (spaces: Loc.t -> Time.t -> Prop)
      prom0 mem0 loc from to msg prom1 mem1 kind
      (PROMISE: Memory.promise prom0 mem0 loc from to msg prom1 mem1 kind)
      (NOTIN: if Memory.op_kind_is_cancel kind
              then True
              else (forall ts (ITV: Interval.mem (from, to) ts),
                       spaces loc ts \/ covered loc ts mem0))
      (CLOSED: Memory.closed mem0)
  :
    (<<INCR: eventable mem1 prom1 spaces <2= eventable mem0 prom0 spaces>>) /\
    (<<FROM: eventable_below mem0 prom0 spaces loc from>>) /\
    (<<TO: eventable_below mem0 prom0 spaces loc to>>).
Proof.
Admitted.
  (* unfold eventable. inv PROMISE.
  { exploit add_succeed_wf; try apply MEM; eauto. i. des.
    splits.
    { ii. des; auto.
      { inv PR. erewrite Memory.add_o in GET; eauto. des_ifs.
        { ss. des; clarify. right. exploit NOTIN; eauto.
          { econs; eauto. refl. }
          i. des; auto. inv x. exfalso. eapply DISJOINT; eauto.
          econs; ss. refl.
        }
        { left. econs; eauto. }
      }
      { erewrite add_covered in PR; eauto. des; auto. subst.
        right. right. exploit NOTIN; eauto. i. des; auto.
        inv x. exfalso. eapply DISJOINT; eauto. }
    }
    { exists to. esplits; eauto.
      { right. right. exploit NOTIN; eauto.
        { econs; eauto. refl. }
        i. des; auto. inv x. exfalso. eapply DISJOINT; eauto.
        econs; ss. refl.
      }
      { left. auto. }
    }
    { exists to. esplits; eauto.
      { right. right. exploit NOTIN; eauto.
        { econs; eauto. refl. }
        i. des; auto. inv x. exfalso. eapply DISJOINT; eauto.
        econs; ss. refl.
      }
      { refl. }
    }
  }
  { exploit split_succeed_wf; try apply PROMISES; eauto. i. des.
    splits.
    { ii. des; auto.
      { inv PR. erewrite Memory.split_o in GET; eauto. des_ifs.
        { ss. des; clarify. right. left. econs; eauto.
          econs; eauto. ss. left. auto. }
        { ss. des; clarify. right. left. econs; eauto.
          econs; eauto. ss. refl. }
        { left. econs; eauto. }
      }
      { erewrite split_covered in PR; eauto. }
    }
    { exists ts3. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { left. etrans; eauto. }
    }
    { exists ts3. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { left. auto. }
    }
  }
  { exploit lower_succeed_wf; try apply PROMISES; eauto. i. des.
    splits.
    { ii. des; auto.
      { inv PR. erewrite Memory.lower_o in GET0; eauto. des_ifs.
        { ss. des; clarify. right. left. econs; eauto.
          econs; eauto. ss. refl. }
        { left. econs; eauto. }
      }
      { erewrite lower_covered in PR; eauto. }
    }
    { exists to. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { left. eauto. }
    }
    { exists to. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { refl. }
    }
  }
  { exploit Memory.remove_get0; try apply PROMISES; eauto. i. des.
    assert (TS: Time.lt from to).
    { exploit Memory.remove_get0; try apply MEM; eauto. i. des.
      inv CLOSED. apply memory_get_ts_strong in GET. des; auto.
      subst. erewrite INHABITED in GET1. ss. }
    splits.
    { ii. des; auto.
      { inv PR. erewrite Memory.remove_o in GET1; eauto. des_ifs.
        left. econs; eauto. }
      { erewrite remove_covered in PR; eauto. des; auto. }
    }
    { exists to. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { left. eauto. }
    }
    { exists to. esplits; eauto.
      { right. left. econs; eauto. econs; eauto. refl. }
      { refl. }
    }
  }
Qed. *)

Lemma event_in_concrete_or_writes_write (spaces: Loc.t -> Time.t -> Prop)
      prom0 mem0 loc from to prom1 mem1 val released kind
      (PROMISE: Memory.write prom0 mem0 loc from to val released prom1 mem1 kind)
      (NOTIN: if Memory.op_kind_is_cancel kind
              then True
              else (forall ts (ITV: Interval.mem (from, to) ts),
                       spaces loc ts \/ covered loc ts mem0))
      (CLOSED: Memory.closed mem0)
  :
    (<<INCR: eventable mem1 prom1 spaces <2= eventable mem0 prom0 spaces>>) /\
    (<<FROM: eventable_below mem0 prom0 spaces loc from>>) /\
    (<<TO: eventable_below mem0 prom0 spaces loc to>>).
Proof.
  inv PROMISE.
  exploit event_in_concrete_or_writes_promise; eauto. i. des. esplits; eauto.
  i. eapply INCR. unfold eventable in *. des; auto.
  erewrite remove_covered in PR; eauto. des; auto.
Qed.

Lemma step_eventable_time lang (th0 th1: Thread.t lang) pf e
      (spaces: Loc.t -> Time.t -> Prop)
      (STEP: Thread.step pf e th0 th1)
      (WRITENOTIN: write_not_in (fun loc ts => ~ (spaces loc ts \/ covered loc ts (Thread.memory th0))) e)
      (CLOSED: Memory.closed (Thread.memory th0))
  :
    (<<INCR: eventable (Thread.memory th1) (Local.promises (Thread.local th1)) spaces <2= eventable (Thread.memory th0) (Local.promises (Thread.local th0)) spaces>>) /\
    (<<TIMES: tevent_map_weak
                (fun loc ts fts => ts = fts /\
                                   eventable_below (Thread.memory th0) (Local.promises (Thread.local th0)) spaces loc ts) e e>>).
Proof.
  inv STEP.
  { inv STEP0; ss. inv LOCAL.
    eapply event_in_concrete_or_writes_promise in PROMISE; ss.
    { des. splits; eauto. econs; eauto. }
    { des_ifs. ii. apply NNPP. eapply WRITENOTIN; eauto. }
  }
  { inv STEP0; ss. inv LOCAL; ss; eauto.
    { splits; auto. econs. }
    { inv LOCAL0. ss. splits; auto. econs; eauto. split; auto.
      exists ts. splits; ss.
      { left. econs; eauto. }
      { refl. }
    }
    { inv LOCAL0. eapply event_in_concrete_or_writes_write in WRITE; eauto.
      { des. splits; eauto. econs; eauto. }
      { des_ifs. ii. eapply NNPP. eauto. }
    }
    { inv LOCAL1. inv LOCAL2. eapply event_in_concrete_or_writes_write in WRITE; eauto.
      { des. splits; eauto. econs; eauto. }
      { des_ifs. ii. eapply NNPP. eauto. }
    }
    { inv LOCAL0. ss. splits; auto. econs; eauto. }
    { inv LOCAL0. ss. splits; auto. econs; eauto. }
    { inv LOCAL0. ss. splits; auto. econs; eauto. }
 }
Qed.

Lemma tevent_map_weak_mon (f0 f1: Loc.t -> Time.t -> Time.t -> Prop)
      (LE: f0 <3= f1)
  :
    tevent_map_weak f0 <2= tevent_map_weak f1.
Proof.
  i. inv PR; econs; eauto.
Qed.

Lemma traced_steps_eventable_time_normal lang (th0 th1: Thread.t lang) tr
      (spaces: Loc.t -> Time.t -> Prop)
      (STEPS: Trace.steps tr th0 th1)
      (WRITENOTIN: List.Forall (fun em => (write_not_in (fun loc ts => ~ (spaces loc ts \/ covered loc ts (Thread.memory th0))) /1\ (fun e => ~ ThreadEvent.is_cancel e)) (snd em)) tr)
      (MEM: Memory.closed (Thread.memory th0))
      (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
      (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
  :
    (<<INCR: eventable (Thread.memory th1) (Local.promises (Thread.local th1)) spaces <2= eventable (Thread.memory th0) (Local.promises (Thread.local th0)) spaces>>) /\
    (<<TIMES: List.Forall2
                (fun em fem =>
                   tevent_map_weak (fun loc ts fts => ts = fts /\ eventable_below (Thread.memory th0) (Local.promises (Thread.local th0)) spaces loc ts)
                                   (snd fem) (snd em)) tr tr>>).
Proof.
  ginduction STEPS.
  { i. splits; ss. }
  { i. subst. inv WRITENOTIN.
    exploit Thread.step_future; eauto. i. des.
    exploit IHSTEPS; eauto.
    { eapply List.Forall_impl; eauto.
      i. ss. des. splits; auto. eapply write_not_in_mon; eauto. i. ss.
      ii. eapply PR. des; eauto. right.
      eapply step_not_cancel_covered_increase; eauto. }
    i. des.
    hexploit step_eventable_time; eauto.
    i. des. esplits; eauto. econs; ss; eauto.
    eapply list_Forall2_impl; eauto.
    i. ss. eapply tevent_map_weak_mon; eauto.
    i. ss. des. subst. splits; auto.
    eapply eventable_le_below; eauto.
  }
Qed.

Lemma traced_steps_eventable_time_cancel lang (th0 th1: Thread.t lang) tr
      (spaces: Loc.t -> Time.t -> Prop)
      (STEPS: Trace.steps tr th0 th1)
      (WRITENOTIN: List.Forall (fun em => ThreadEvent.is_cancel (snd em)) tr)
      (MEM: Memory.closed (Thread.memory th0))
      (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
      (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
  :
    (<<INCR: eventable (Thread.memory th1) (Local.promises (Thread.local th1)) spaces <2= eventable (Thread.memory th0) (Local.promises (Thread.local th0)) spaces>>) /\
    (<<TIMES: List.Forall2
                (fun em fem =>
                   tevent_map_weak (fun loc ts fts => ts = fts /\ eventable_below (Thread.memory th0) (Local.promises (Thread.local th0)) spaces loc ts)
                                   (snd fem) (snd em)) tr tr>>).
Proof.
  ginduction STEPS.
  { i. splits; ss. }
  { i. subst. inv WRITENOTIN.
    exploit Thread.step_future; eauto. i. des.
    hexploit step_eventable_time; eauto.
    { instantiate (1:=spaces). destruct e; ss. des_ifs. }
    exploit IHSTEPS; eauto. i. des.
    splits; eauto. econs; eauto.
    eapply list_Forall2_impl; eauto.
    i. ss. eapply tevent_map_weak_mon; eauto.
    i. ss. des. subst. splits; auto.
    eapply eventable_le_below; eauto.
  }
Qed.

Lemma reservations_added_covered mem0 mem1 l
      (ADDED: reservations_added l mem0 mem1)
      loc ts
  :
    covered loc ts mem1 <-> (covered loc ts mem0 \/ intervals_sum l loc ts).
Proof.
  ginduction l; ss.
  { i. inv ADDED. split; i; des; ss; auto. }
  { i. inv ADDED. rewrite IHl; eauto.
    rewrite (@add_covered mem3 mem0); eauto. split; i; des; auto. }
Qed.

Lemma reservations_added_covered_rev mem0 mem1 l
      (ADDED: reservations_added l mem0 mem1)
      loc ts
  :
    covered loc ts mem0 <-> (covered loc ts mem1 /\ ~ intervals_sum l loc ts).
Proof.
  split; i.
  { split.
    { eapply reservations_added_covered; eauto. }
    { eapply reservations_added_non_covered; eauto. }
  }
  { des. eapply reservations_added_covered in H; eauto. des; ss. }
Qed.

Lemma can_reserve_all_needed times
      (DIVERGE: forall loc ts,
          exists ts',
            (<<TIMES: times loc ts'>>) /\
            (<<TS: Time.lt ts ts'>>))
      lang
      st0 st1 lc0 lc1 sc0 sc1 mem0 mem1 tr
      (MWF: memory_times_wf times mem0)
      (STEPS: Trace.steps tr (Thread.mk lang st0 lc0 sc0 mem0) (Thread.mk lang st1 lc1 sc1 mem1))
      (EVENTS: List.Forall (fun em => <<SAT: ((fun e => ~ ThreadEvent.is_cancel e) /1\ wf_time_evt times) (snd em)>>) tr)
      (MEM: Memory.closed mem0)
      (LOCAL: Local.wf lc0 mem0)
      (SC: Memory.closed_timemap sc0 mem0)
  :
    exists lc0' mem0' tr_reserve tr_cancel reserves,
      (<<RESERVESTEPS:
         Trace.steps tr_reserve (Thread.mk lang st0 lc0 sc0 mem0) (Thread.mk lang st0 lc0' sc0 mem0')>>) /\
      (<<RESERVETRACE:
         List.Forall (fun em => <<SAT: (ThreadEvent.is_reserve /1\ wf_time_evt times) (snd em)>>) tr_reserve>>) /\
      (<<CANCELTRACE: List.Forall (fun em => <<SAT: (ThreadEvent.is_cancel /1\ wf_time_evt times) (snd em)>>) tr_cancel>>) /\
      (<<RESERVEMEM: reservations_added reserves mem0 mem0'>>) /\
      (<<CAP:
         forall cap0'
                (MLE: Memory.le mem0' cap0'),
         exists cap0 cap1 ,
           (<<CANCELSTEPS:
              Trace.steps tr_cancel (Thread.mk lang st0 lc0' sc0 cap0') (Thread.mk lang st0 lc0 sc0 cap0)>>) /\
           (<<STEPS:
              Trace.steps tr (Thread.mk lang st0 lc0 sc0 cap0) (Thread.mk lang st1 lc1 sc1 cap1)>>) /\
           (<<RESERVEMEM: reservations_added reserves cap0 cap0'>>)>>) /\
      (<<TIMES: forall max
                       (MAX: concrete_promise_max_timemap mem0' (Local.promises lc0') max),
          List.Forall2
            (fun em fem =>
               tevent_map_weak (fun loc ts fts => ts = fts /\ Time.le ts (max loc))
                               (snd fem) (snd em)) (tr_cancel ++ tr) (tr_cancel ++ tr)>>)
.
Proof.
  exploit (@traced_steps_finte_write_to tr); eauto.
  { eapply List.Forall_impl; eauto. i. ss. des. eauto. }
  intros [tos ?]. des.
  exploit traced_steps_needed_spaces; eauto.
  i. des.
  exploit reserve_empty_intervals; eauto.
  { eapply LOCAL. }
  i. des. ss.
  assert (MLE: Memory.le prom' mem').
  { eapply trace_steps_promises_le in STEPS0; eauto. eapply LOCAL. }
  exploit reserve_write_tos.
  { eauto. }
  { eapply memory_times_wf_traced in STEPS0; eauto.
    eapply List.Forall_impl; eauto. i. ss. des. eauto.
  }
  { ss. }
  { eauto. }
  i. des. ss.
  assert (ADDEDPROMALL: reservations_added (l ++ l0) (Local.promises lc0) prom'0).
  { eapply reservations_added_trans; eauto. }
  assert (ADDEDMEMALL: reservations_added (l ++ l0) mem0 mem'0).
  { eapply reservations_added_trans; eauto. }
  hexploit cancel_reservations_added.
  { instantiate (1:=Local.mk (Local.tview lc0) prom'0). eapply ADDEDPROMALL. }
  { eapply Forall_app; eauto. }
  i. des.
  assert (CAP: forall cap0'
                      (MLE: Memory.le mem'0 cap0'),
             exists cap0 cap1,
               Trace.steps
                 tr2
                 (Thread.mk _ st0 {| Local.tview := Local.tview lc0; Local.promises := prom'0 |} sc0 cap0')
                 (Thread.mk _ st0 lc0 sc0 cap0) /\
               Trace.steps
                 tr
                 (Thread.mk _ st0 lc0 sc0 cap0)
                 (Thread.mk _ st1 lc1 sc1 cap1) /\
               (<<ADDED: reservations_added (l ++ l0) cap0 cap0'>>))
  .
  { i. ss. exploit (H0 st0 sc0 cap0').
    { etrans; eauto. eapply trace_steps_promises_le in STEPS1; eauto. }
    i. des.
    assert (MLE1: Memory.le mem0 mem'1).
    { eapply reservations_added_le_le.
      { eapply ADDEDMEMALL. }
      { eapply MLE0. }
      { eauto. }
    }
    hexploit traced_step_lifting.
    { eapply STEPS. }
    { eapply list_Forall_sum.
      { eapply list_Forall_sum.
        { eapply EVENTS. }
        { eapply EVENTS0. }
        { instantiate (1:=fun em => <<SAT: ((fun e => ~ ThreadEvent.is_cancel e) /1\ write_not_to (fun loc ts => ~ List.In (loc, ts) tos)) (snd em)>>).
          i. ss. des. splits; auto. }
      }
      { eapply WRITENOTIN. }
      i. ss. des. splits; eauto.
    }
    { eapply MLE1. }
    { i. destruct (classic (covered loc ts mem0)); auto. right.
      ii. des; ss. eapply reservations_added_non_covered in ADDEDMEM1; eauto.
      eapply ADDEDMEM1. erewrite intervals_sum_interval.
      erewrite intervals_sum_interval in H1. des. esplits; eauto.
      eapply List.in_or_app; eauto. }
    { i. destruct (classic (unattachable mem0 loc ts)); auto. right.
      ii. des; ss. eapply reservations_added_non_unattachable in ADDEDMEM1; eauto.
      eapply ADDEDMEM1. erewrite intervals_sum_left_interval.
      eapply WRITETO in H1. eapply reservations_added_unattachable in H1; eauto.
      des; ss. }
    { eauto. }
    { eauto. }
    { eauto. }
    i. des. exists mem'1, cap1.
    splits; eauto. destruct lc0. ss.
  }
  esplits.
  { eapply Trace.steps_trans.
    { eapply STEPS0. }
    { eapply STEPS1. }
  }
  { eapply Forall_app; eauto. }
  { eapply CANCELTRACE. }
  { eauto. }
  { i. exploit CAP; eauto. }
  { i. exploit (CAP mem'0).
    { refl. }
    i. des. ss.
    exploit Trace.steps_future; try apply STEPS0; eauto. i. des. ss.
    exploit Trace.steps_future; try apply STEPS1; eauto. i. des. ss.
    exploit Trace.steps_future; try apply x0; eauto. i. des. ss.
    exploit traced_steps_eventable_time_cancel; try apply x0; eauto; ss.
    { eapply List.Forall_impl; eauto. i. ss. des. splits; auto. }
    instantiate (1:=intervals_sum l). i. ss. des.
    assert (EVENTTIMES: forall loc ts
                               (EVENTABLE: eventable_below mem'0 prom'0 (intervals_sum l) loc ts),
               Time.le ts (max loc)).
    { i. unfold eventable_below in EVENTABLE. des. etrans; eauto.
      unfold eventable in TIME. des.
      { inv TIME. eapply MAX in GET. auto. }
      { inv TIME. eapply MAX in GET. inv ITV. ss. etrans; eauto. }
      { eapply reservations_added_covered in ADDEDPROM; eauto. des.
        exploit ADDEDPROM1.
        { right. eauto. }
        i. eapply reservations_added_covered in ADDEDPROM0; eauto. des.
        exploit ADDEDPROM2.
        { left. eauto. }
        i. inv x2. eapply MAX in GET. inv ITV. ss. etrans; eauto.
      }
    }
    eapply List.Forall2_app.
    { eapply list_Forall2_impl; eauto. i. ss.
      eapply tevent_map_weak_mon; eauto. i. ss. des. subst. splits; auto. }
    { exploit traced_steps_eventable_time_normal; try apply x1; eauto; ss.
      { instantiate (1:=intervals_sum l).
        eapply list_Forall_sum.
        { eapply EVENTS. }
        { eapply WRITENOTIN. }
        i. ss. des. splits; auto.
        eapply write_not_in_mon; eauto. i. ss. ii. eapply PR.
        apply or_comm in H. apply or_strengthen in H. des; auto. right.
        erewrite reservations_added_covered_rev; try apply ADDED; eauto.
        erewrite reservations_added_covered_rev in SAT; try apply ADDEDMEMALL; eauto.
      }
      { i. des. eapply list_Forall2_impl; eauto. i. ss.
        eapply tevent_map_weak_mon; eauto. i. ss. des. subst. splits; auto.
        eapply eventable_le_below in PR0; eauto. }
    }
  }
Qed.