From iris.algebra Require Import auth gmap frac agree.
From iris.base_logic.lib Require Export own.
From iris.base_logic.lib Require Import fractional.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.

Definition gen_heapUR (L V : Type) `{Countable L} : ucmraT :=
  gmapUR L (prodR fracR (agreeR (leibnizC V))).
Definition to_gen_heap {L V} `{Countable L} : gmap L V → gen_heapUR L V :=
  fmap (λ v, (1%Qp, to_agree (v : leibnizC V))).

(** The CMRA we need. *)
Class gen_heapG (L V : Type) (Σ : gFunctors) `{Countable L} := GenHeapG {
  gen_heap_inG :> inG Σ (authR (gen_heapUR L V));
  gen_heap_name : gname
}.
Arguments gen_heap_name {_ _ _ _ _} _ : assert.

Class gen_heapPreG (L V : Type) (Σ : gFunctors) `{Countable L} :=
  { gen_heap_preG_inG :> inG Σ (authR (gen_heapUR L V)) }.

Definition gen_heapΣ (L V : Type) `{Countable L} : gFunctors :=
  #[GFunctor (authR (gen_heapUR L V))].

Instance subG_gen_heapPreG {Σ L V} `{Countable L} :
  subG (gen_heapΣ L V) Σ → gen_heapPreG L V Σ.
Proof. solve_inG. Qed.

Section definitions.
  Context `{hG : gen_heapG L V Σ}.

  Definition gen_heap_ctx (σ : gmap L V) : iProp Σ :=
    own (gen_heap_name hG) (● (to_gen_heap σ)).

  Definition mapsto_def (l : L) (q : Qp) (v: V) : iProp Σ :=
    own (gen_heap_name hG) (◯ {[ l := (q, to_agree (v : leibnizC V)) ]}).
  Definition mapsto_aux : seal (@mapsto_def). by eexists. Qed.
  Definition mapsto := unseal mapsto_aux.
  Definition mapsto_eq : @mapsto = @mapsto_def := seal_eq mapsto_aux.
End definitions.

Local Notation "l ↦{ q } v" := (mapsto l q v)
  (at level 20, q at level 50, format "l  ↦{ q }  v") : uPred_scope.
Local Notation "l ↦ v" := (mapsto l 1 v) (at level 20) : uPred_scope.

Local Notation "l ↦{ q } -" := (∃ v, l ↦{q} v)%I
  (at level 20, q at level 50, format "l  ↦{ q }  -") : uPred_scope.
Local Notation "l ↦ -" := (l ↦{1} -)%I (at level 20) : uPred_scope.

Section to_gen_heap.
  Context (L V : Type) `{Countable L}.
  Implicit Types σ : gmap L V.

  (** Conversion to heaps and back *)
  Lemma to_gen_heap_valid σ : ✓ to_gen_heap σ.
  Proof. intros l. rewrite lookup_fmap. by case (σ !! l). Qed.
  Lemma lookup_to_gen_heap_None σ l : σ !! l = None → to_gen_heap σ !! l = None.
  Proof. by rewrite /to_gen_heap lookup_fmap=> ->. Qed.
  Lemma gen_heap_singleton_included σ l q v :
    {[l := (q, to_agree v)]} ≼ to_gen_heap σ → σ !! l = Some v.
  Proof.
    rewrite singleton_included=> -[[q' av] []].
    rewrite /to_gen_heap lookup_fmap fmap_Some_equiv => -[v' [Hl [/= -> ->]]].
    move=> /Some_pair_included_total_2 [_] /to_agree_included /leibniz_equiv_iff -> //.
  Qed.
  Lemma to_gen_heap_insert l v σ :
    to_gen_heap (<[l:=v]> σ) = <[l:=(1%Qp, to_agree (v:leibnizC V))]> (to_gen_heap σ).
  Proof. by rewrite /to_gen_heap fmap_insert. Qed.
  Lemma to_gen_heap_delete l σ :
    to_gen_heap (delete l σ) = delete l (to_gen_heap σ).
  Proof. by rewrite /to_gen_heap fmap_delete. Qed.
End to_gen_heap.

Lemma gen_heap_init `{gen_heapPreG L V Σ} σ :
  (|==> ∃ _ : gen_heapG L V Σ, gen_heap_ctx σ)%I.
Proof.
  iMod (own_alloc (● to_gen_heap σ)) as (γ) "Hh".
  { apply: auth_auth_valid. exact: to_gen_heap_valid. }
  iModIntro. by iExists (GenHeapG L V Σ _ _ _ γ).
Qed.

Section gen_heap.
  Context `{gen_heapG L V Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : V → iProp Σ.
  Implicit Types σ : gmap L V.
  Implicit Types h g : gen_heapUR L V.
  Implicit Types l : L.
  Implicit Types v : V.

  (** General properties of mapsto *)
  Global Instance mapsto_timeless l q v : Timeless (l ↦{q} v).
  Proof. rewrite mapsto_eq /mapsto_def. apply _. Qed.
  Global Instance mapsto_fractional l v : Fractional (λ q, l ↦{q} v)%I.
  Proof.
    intros p q. by rewrite mapsto_eq -own_op -auth_frag_op
      op_singleton pair_op agree_idemp.
  Qed.
  Global Instance mapsto_as_fractional l q v :
    AsFractional (l ↦{q} v) (λ q, l ↦{q} v)%I q.
  Proof. split. done. apply _. Qed.

  Lemma mapsto_agree l q1 q2 v1 v2 : l ↦{q1} v1 -∗ l ↦{q2} v2 -∗ ⌜v1 = v2⌝.
  Proof.
    apply wand_intro_r.
    rewrite mapsto_eq -own_op -auth_frag_op own_valid discrete_valid.
    f_equiv=> /auth_own_valid /=. rewrite op_singleton singleton_valid pair_op.
    by intros [_ ?%agree_op_invL'].
  Qed.

  Global Instance ex_mapsto_fractional l : Fractional (λ q, l ↦{q} -)%I.
  Proof.
    intros p q. iSplit.
    - iDestruct 1 as (v) "[H1 H2]". iSplitL "H1"; eauto.
    - iIntros "[H1 H2]". iDestruct "H1" as (v1) "H1". iDestruct "H2" as (v2) "H2".
      iDestruct (mapsto_agree with "H1 H2") as %->. iExists v2. by iFrame.
  Qed.
  Global Instance ex_mapsto_as_fractional l q :
    AsFractional (l ↦{q} -) (λ q, l ↦{q} -)%I q.
  Proof. split. done. apply _. Qed.

  Lemma mapsto_valid l q v : l ↦{q} v -∗ ✓ q.
  Proof.
    rewrite mapsto_eq /mapsto_def own_valid !discrete_valid.
    by apply pure_mono=> /auth_own_valid /singleton_valid [??].
  Qed.
  Lemma mapsto_valid_2 l q1 q2 v1 v2 : l ↦{q1} v1 -∗ l ↦{q2} v2 -∗ ✓ (q1 + q2)%Qp.
  Proof.
    iIntros "H1 H2". iDestruct (mapsto_agree with "H1 H2") as %->.
    iApply (mapsto_valid l _ v2). by iFrame.
  Qed.

  Lemma gen_heap_alloc σ l v :
    σ !! l = None → gen_heap_ctx σ ==∗ gen_heap_ctx (<[l:=v]>σ) ∗ l ↦ v.
  Proof.
    iIntros (?) "Hσ". rewrite /gen_heap_ctx mapsto_eq /mapsto_def.
    iMod (own_update with "Hσ") as "[Hσ Hl]".
    { eapply auth_update_alloc,
        (alloc_singleton_local_update _ _ (1%Qp, to_agree (v:leibnizC _)))=> //.
      by apply lookup_to_gen_heap_None. }
    iModIntro. rewrite to_gen_heap_insert. iFrame.
  Qed.

  Lemma gen_heap_dealloc σ l v :
    gen_heap_ctx σ -∗ l ↦ v ==∗ gen_heap_ctx (delete l σ).
  Proof.
    iIntros "Hσ Hl". rewrite /gen_heap_ctx mapsto_eq /mapsto_def.
    rewrite to_gen_heap_delete. iApply (own_update_2 with "Hσ Hl").
    eapply auth_update_dealloc, (delete_singleton_local_update _ _ _).
  Qed.

  Lemma gen_heap_valid σ l q v : gen_heap_ctx σ -∗ l ↦{q} v -∗ ⌜σ !! l = Some v⌝.
  Proof.
    iIntros "Hσ Hl". rewrite /gen_heap_ctx mapsto_eq /mapsto_def.
    iDestruct (own_valid_2 with "Hσ Hl")
      as %[Hl%gen_heap_singleton_included _]%auth_valid_discrete_2; auto.
  Qed.

  Lemma gen_heap_update σ l v1 v2 :
    gen_heap_ctx σ -∗ l ↦ v1 ==∗ gen_heap_ctx (<[l:=v2]>σ) ∗ l ↦ v2.
  Proof.
    iIntros "Hσ Hl". rewrite /gen_heap_ctx mapsto_eq /mapsto_def.
    iDestruct (own_valid_2 with "Hσ Hl")
      as %[Hl%gen_heap_singleton_included _]%auth_valid_discrete_2.
    iMod (own_update_2 with "Hσ Hl") as "[Hσ Hl]".
    { eapply auth_update, singleton_local_update,
        (exclusive_local_update _ (1%Qp, to_agree (v2:leibnizC _)))=> //.
      by rewrite /to_gen_heap lookup_fmap Hl. }
    iModIntro. rewrite to_gen_heap_insert. iFrame.
  Qed.
End gen_heap.


From MetaCoq.Template Require Import All.
From MetaCoq.Utils Require Import utils.
Import MCMonadNotation.

Module Type A.
  Parameter x : nat.
End A.

Module B (X : A) (Y : A).

  MetaCoq Test Quote Y.x.
  MetaCoq Unquote Definition uuu :=
          (tConst (MPbound ["modules_sections"; "TestSuite"; "MetaCoq"] "Y" 1, "x") []).

  MetaCoq Run (bc <- tmQuote X.x ;;
               tmPrint bc ;;
               bc <- tmUnquote bc ;;
               tmPrint bc).

End B.

Module Type C (X : A) (Y : A).
  MetaCoq Run (bc <- tmQuote X.x ;;
               tmPrint bc ;;
               bc <- tmUnquote bc ;;
               tmPrint bc).
End C.

Section S.

  Definition b := forall X, X.
  Definition c := Set.
  (* Set Printing All. Set Printing Universes. *)
  MetaCoq Run (bc <- tmQuote b ;;
                    tmPrint bc ;;
                    tmMkDefinition "bb" bc ;;
                    tmPrint "lol").
  Check bb.

  Variable x : nat.
  MetaCoq Run (bc <- tmQuote x ;;
                    tmPrint bc ;;
                    tmMkDefinition "bx" bc ;;
                    tmPrint "lol").

  Check bx.

End S.

MetaCoq Run (bc <- tmQuote b ;;
                tmPrint bc ;;
                bc <- tmUnquote bc ;;
                tmPrint bc).

Require Import MetaCoq.Template.Pretty.
Check (eq_refl : print_term (empty_ext empty_global_env) [] true
                      (tConst (MPfile ["test"; "Examples"; "MetaCoq"], "b") [])
                 = "MetaCoq.Examples.test.b").

Module S.

  Definition b := forall X, X.
  MetaCoq Run (bc <- tmQuote b ;;
               tmPrint bc ;;
               bc <- tmUnquote bc ;;
               tmPrint bc).
End S.

MetaCoq Run (bc <- tmQuote S.b ;;
             tmPrint bc ;;
             bc <- tmUnquote bc ;;
             tmPrint bc).

MetaCoq Test Quote my_projT2.
MetaCoq Test Unquote
     (Ast.tConstruct (mkInd (MPfile ["Datatypes"; "Init"; "Coq"], "nat") 0) 0 []).
MetaCoq Unquote Definition zero_from_syntax
  := (Ast.tConstruct (mkInd (MPfile ["Datatypes"; "Init"; "Coq"], "nat") 0) 0 []).

Existing Class nat.

Module Type X.
  Definition t : nat := 0.
  Parameter t' : nat.
  Parameter t'' : nat.
  Print Instances nat.
  MetaCoq Run (tmLocate1 "t" >>= tmExistingInstance global).
  MetaCoq Run (tmLocate1 "t'" >>= tmExistingInstance global).
  Print Instances nat.
End X.

Section XX.
  Variable u : nat.
  Fail MetaCoq Run (tmLocate1 "u" >>= tmExistingInstance global).
  Print Instances nat.
End XX.

Module Y (A : X).
  Print Instances nat.
  MetaCoq Run (tmLocate1 "t''" >>= tmExistingInstance global).
  Print Instances nat.
End Y.

MetaCoq Run (tmLocateModule1 "B" >>= tmPrint).
MetaCoq Run (tmLocateModule1 "S" >>= tmPrint).
MetaCoq Run (tmLocateModType1 "X" >>= tmPrint).
Fail MetaCoq Run (tmLocateModType1 "B" >>= tmPrint).
Fail MetaCoq Run (tmLocateModType1 "modules_sections.S" >>= tmPrint). (* finds (MPdot (MPfile ["FMapInterface"; "FSets"; "Coq"]) "S") if unqualified *)
Fail MetaCoq Run (tmLocateModule1 "X" >>= tmPrint).


(* TLC in Coq
 *
 * Module: tlc.utility.option
 * Purpose: Monad hierarchy typeclass instances for option.
 *)

Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrfun.
Require Import tlc.utility.monad.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Functor instance for option *)
#[refine]
Instance option_functor : Functor option := {
  map _ _ f x := if x is Some x' then Some (f x') else None;
}.
Proof.
  (* map_id *)
  {
    by move=> ?; case.
  }

  (* map_comp *)
  {
    by move=> ?????; case.
  }
Defined.

(* Applicative instance for option *)
#[refine]
Instance option_applicative : Applicative option := {
  pure := fun a x => Some x;
  apply _ _ f x :=
    match f, x with
    | Some f', Some x' => Some (f' x')
    | _, _ => None
    end;
}.
Proof.
  (* apply_left_id *)
  {
    by move=> ?; rewrite /left_id; case.
  }

  (* apply_homo *)
  {
    by [].
  }

  (* apply_inter *)
  {
    by [].
  }

  (* apply_comp *)
  {
    by move=> ???; case=> [? |] [? |] [? |].
  }
Defined.

(* Monad instance for option *)
#[refine]
Instance option_monad : Monad option := {
  bind _ _ x f := if x is Some x' then f x' else None;
}.
Proof.
  (* bind_left_id *)
  {
    by [].
  }

  (* bind_right_id *)
  {
    by move=> ?; case=> [? | ].
  }

  (* bind_assoc *)
  {
    by move=> ?????; case=> [? | ].
  }
Defined.


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