Require Import DataTypes Useful Channel Cache Compatible L1 Coq.Logic.Classical
Coq.Relations.Operators_Properties Coq.Relations.Relation_Operators List MsiState L1.
(*Require List.*)

Module Type LatestValueAxioms (dt: DataTypes) (ch: ChannelPerAddr dt).
  Import dt ch.

  Axiom toChild: forall {n a t p m}, defined n -> defined p ->
                   parent n p ->
                   mark mch p n a t m -> from m = MsiState.In -> dataM m = data p a t.
  Axiom fromParent: forall {n a t p m}, defined n -> defined p ->
                      parent n p ->
                      recv mch p n a t m -> from m = MsiState.In -> data n a (S t) = dataM m.
  Axiom toParent: forall {n a t c m}, defined n -> defined c ->
                     parent c n ->
                     mark mch c n a t m -> slt Sh (from m) -> dataM m = data c a t.
  Axiom fromChild: forall {n a t c m}, defined n -> defined c ->
                     parent c n ->
                     recv mch c n a t m -> slt Sh (from m) -> data n a (S t) = dataM m.

  Axiom initLatest: forall a, data hier a 0 = initData a /\ state hier a 0 = Mo.

  Axiom deqImpData: forall {n t i}, defined n -> deqR n i t ->
                                    desc (reqFn n i) = St ->
                                    data n (loc (reqFn n i)) (S t) = dataQ (reqFn n i).

  Axiom changeData:
    forall {n a t}, defined n ->
      data n a (S t) <> data n a t ->
      (exists m, (exists p, defined p /\ parent n p /\ recv mch p n a t m /\ from m = MsiState.In) \/
                 (exists c, defined c /\ parent c n /\ recv mch c n a t m /\
                            slt Sh (from m))) \/
      exists i, deqR n i t /\ loc (reqFn n i) = a /\ desc (reqFn n i) = St.

  Axiom deqImpNoSend: forall {c i t}, defined c -> deqR c i t ->
                                      forall {m p}, defined p ->
                                                    ~ mark mch c p (loc (reqFn c i)) t m.
End LatestValueAxioms.

Module LatestValueTheorems (dt: DataTypes) (ch: ChannelPerAddr dt) (c: BehaviorAxioms dt ch)
       (l1: L1Axioms dt) (comp: CompatBehavior dt ch) (lv: LatestValueAxioms dt ch): L1Theorems dt.
  Module mbt := mkBehaviorTheorems dt ch c.
  Module cbt := mkCompat dt ch comp c.
  Import dt ch c l1 comp lv mbt cbt.

  Theorem uniqM:
    forall {c a t}, defined c ->
      leaf c ->
      state c a t = Mo -> forall {co}, defined co -> leaf co -> c <> co -> state co a t = MsiState.In.
  Proof.
    intros c a t defC leaf_c cM co defCo leaf_co c_ne_co.
    pose proof (noLeafsDesc leaf_c leaf_co c_ne_co) as desc1.
    assert (co_ne_c: co <> c) by auto.
    pose proof (noLeafsDesc leaf_co leaf_c co_ne_c) as desc2.
    pose proof (@nonDescCompat c co defC defCo desc1 desc2 a t) as st.
    rewrite cM in st.
    unfold sle in *; destruct (state co a t); firstorder.
  Qed.

  Theorem parentLeafFalse: forall {c p}, leaf c -> parent p c -> False.
  Proof.
    intros c p leafC p_c.
    unfold leaf in *; unfold parent in *.
    destruct c.
    destruct l0.
    unfold List.In in *.
    assumption.
    assumption.
  Qed.

  Theorem leafGood: forall {p n a t}, defined p -> defined n -> parent n p ->
                                      slt MsiState.In (dir p n a t) -> slt (state n a t) Mo ->
                                      forall {c i},
                                        defined c ->
                                        deqR c i t -> desc (reqFn c i) = St ->
                                        loc (reqFn c i) = a -> False.
  Proof.
    unfold not; intros p n a t defP defN n_p pGtI nLtM c i defC deqSt isSt locA.
    pose proof (deqLeaf deqSt) as leafC.
    pose proof (processDeq deqSt) as st; simpl in st.
    destruct (classic (descendent c p)) as [c_p | c_ne_p].
    destruct (classic (descendent c n)) as [c_n | c_ne_n].
    pose proof (@descSle c n defC defN c_n a t) as low.
    rewrite isSt in st.
    rewrite locA in st.
    rewrite st in low.
    apply (slt_slei_false nLtM low).
    pose proof (clos_rt_rtn1 Tree parent c p c_p) as trans.
    destruct trans.
    apply (parentLeafFalse leafC n_p).
    pose proof (clos_rtn1_rt Tree parent c y trans) as c_y.
    pose proof (rt_step Tree parent y z H) as y_z.
    pose proof (rt_trans Tree parent y z hier y_z defP) as defY.
    clear trans y_z; fold descendent in *.
    assert (y_ne_n: n = y -> False).
    intros y_eq_n.
    rewrite y_eq_n in *.
    firstorder.
    pose proof (compatible defP a t defY H) as [_ good].
    specialize (good n defN y_ne_n n_p).
    pose proof (@descSle c y defC defY c_y a t) as low.
    rewrite isSt in st; rewrite locA in st.
    rewrite st in low.
    pose proof (conservative defP defY H a t) as stuff.
    unfold sle in *; destruct (dir z y a t); destruct (dir z n a t);
    destruct (state y a t); auto.
    assert (sec: ~ descendent p c).
    unfold not; intros p_c.
    pose proof (clos_rt_rtn1 Tree parent p c p_c) as trans.
    destruct trans.
    firstorder.
    apply (parentLeafFalse leafC H).
    pose proof (@nonDescCompat c p defC defP c_ne_p sec a t) as contra.
    rewrite isSt in st; rewrite locA in st.
    rewrite st in contra.
    pose proof (compatible defP a t defN n_p) as [good _].
    destruct (dir p n a t); destruct (state p a t); unfold slt in *; unfold sle in *;
    auto.
  Qed.

  Theorem leafGood2: forall {p n a t}, defined p -> defined n -> parent n p ->
                                       forall {m}, mark mch p n a t m ->
                                                   forall {c i},
                                                     defined c ->
                                                     deqR c i t -> desc (reqFn c i) = St ->
                                                     loc (reqFn c i) = a -> False.
  Proof.
    unfold not; intros p n a t defP defN n_p m markm c i defC deqSt isSt locA.
    pose proof (pSendUpgrade defP defN n_p markm) as dir_n_lt_M.
    pose proof (sendCCond defP defN n_p markm) as [st_hg othersCompat].
    pose proof (sendmChange (dt defP defN n_p) markm) as rew.
    rewrite <- rew in *; clear rew.
    pose proof (deqLeaf deqSt) as leafC.
    pose proof (processDeq deqSt) as st; simpl in st.
    destruct (classic (descendent c p)) as [c_p | c_ne_p].
    destruct (classic (descendent c n)) as [c_n | c_ne_n].
    pose proof (@descSle c n defC defN c_n a t) as low.
    pose proof (conservative defP defN n_p a t) as sth.
    rewrite isSt in st; rewrite locA in st.
    rewrite st in *.
    destruct (state n a t); destruct (dir p n a t); destruct (dir p n a (S t));
    unfold sle in *; unfold slt in *; auto.
    pose proof (clos_rt_rtn1 Tree parent c p c_p) as trans.
    destruct trans.
    apply (parentLeafFalse leafC n_p).
    pose proof (clos_rtn1_rt Tree parent c y trans) as c_y.
    pose proof (rt_step Tree parent y z H) as y_z.
    pose proof (rt_trans Tree parent y z hier y_z defP) as defY.
    clear trans y_z; fold descendent in *.
    assert (y_ne_n: y = n -> False).
    intros y_eq_n.
    rewrite y_eq_n in *.
    firstorder.
    specialize (othersCompat y defY y_ne_n H).
    pose proof (@descSle c y defC defY c_y a t) as low.
    pose proof (conservative defP defY H a t) as stuff.
    rewrite isSt in st; rewrite locA in st.
    rewrite st in *.
    unfold sle in *; unfold slt in *; destruct (dir z n a (S t)); destruct (dir z n a t);
    destruct (dir z y a t); destruct (state y a t); auto.
    assert (sec: ~ descendent p c).
    unfold not; intros p_c.
    pose proof (clos_rt_rtn1 Tree parent p c p_c) as trans.
    destruct trans.
    firstorder.
    apply (parentLeafFalse leafC H).
    pose proof (@nonDescCompat c p defC defP c_ne_p sec a t) as contra.
    rewrite isSt in st; rewrite locA in st.
    rewrite st in contra.
    unfold sle in *; unfold slt in *; destruct (dir p n a t); destruct (dir p n a (S t));
    destruct (state p a t); auto.
  Qed.

  Theorem leafGood3: forall {p n a t}, defined p -> defined n -> parent n p ->
                                       forall {m}, mark mch n p a t m ->
                                                   forall {c i},
                                                     defined c ->
                                                     deqR c i t -> desc (reqFn c i) = St ->
                                                     loc (reqFn c i) = a -> False.
  Proof.
    unfold not; intros p n a t defP defN n_p m markm c i defC deqSt isSt locA.
    destruct (classic (c = n)) as [eq|notEq].
    rewrite eq in *.
    rewrite <- locA in markm.
    apply (deqImpNoSend defN deqSt defP markm).
    destruct (classic (descendent c n)) as [c_n | c_no_n].
    pose proof (@sendPCond n a t p defN defP n_p m markm) as dirLower.
    pose proof (allDirLower defN dirLower notEq c_n) as condToM.
    pose proof (cSendDowngrade defP defN n_p markm) as dgd.
    pose proof (sendmChange (st defP defN n_p) markm) as stEq.
    rewrite stEq in dgd.
    pose proof (processDeq deqSt) as eqSth; simpl in *.
    rewrite isSt in eqSth; rewrite locA in eqSth.
    rewrite eqSth in *.
    destruct (state n a t); destruct (to m); unfold slt in *; unfold sle in *; auto.
    assert (n_no_c: ~ descendent n c).
    unfold not; intros n_c.
    pose proof (clos_rt_rtn1 Tree parent n c n_c) as trans.
    destruct trans.
    assert (n = n) by reflexivity; firstorder.
    pose proof (deqLeaf deqSt) as leaf_z.
    unfold parent in *; unfold leaf in *. destruct z. destruct l0.
    unfold List.In in H. assumption.
    assumption.
    pose proof (@nonDescCompat n c defN defC n_no_c c_no_n a t) as stNow.
    pose proof (cSendDowngrade defP defN n_p markm) as dgd.
    pose proof (processDeq deqSt) as eqSth; simpl in *;
    rewrite isSt in eqSth; rewrite locA in eqSth.
    rewrite eqSth in *.
    unfold sle in *; unfold slt in *; destruct (state n a t); destruct (state n a (S t));
    auto.
  Qed.

  Theorem allLatestValue:
    forall {a t n}, defined n ->
                    sle Sh (state n a t) ->
                    (forall {c}, defined c -> parent c n -> sle (dir n c a t) Sh) ->
                    (data n a t = initData a /\
                     forall {ti}, 0 <= ti < t ->
                                  forall {ci ii}, defined ci ->
                                                  ~ (deqR ci ii ti /\ loc (reqFn ci ii) = a /\
                                                     desc (reqFn ci ii) = St)) \/
    (exists cb ib tb, defined cb /\ tb < t /\ deqR cb ib tb /\ desc (reqFn cb ib) = St /\
                      loc (reqFn cb ib) = a /\
                      data n a t = dataQ (reqFn cb ib) /\
                      forall {ti}, tb < ti < t ->
                                   forall {ci ii},
                                     defined ci ->
                                     ~ (deqR ci ii ti /\ loc (reqFn ci ii) = a /\
                                        desc (reqFn ci ii) = St)
    ).
    Proof.
      intros a.
      pose (fun t => forall n,
              defined n ->
                    sle Sh (state n a t) ->
                    (forall {c}, defined c -> parent c n -> sle (dir n c a t) Sh) ->
                    (data n a t = initData a /\
                     forall {ti}, 0 <= ti < t ->
                                  forall {ci ii}, defined ci ->
                                                  ~ (deqR ci ii ti /\ loc (reqFn ci ii) = a /\
                                                     desc (reqFn ci ii) = St)) \/
    (exists cb ib tb, defined cb /\ tb < t /\ deqR cb ib tb /\ desc (reqFn cb ib) = St /\
                      loc (reqFn cb ib) = a /\
                      data n a t = dataQ (reqFn cb ib) /\
                      forall {ti}, tb < ti < t ->
                                   forall {ci ii},
                                     defined ci ->
                                     ~ (deqR ci ii ti /\ loc (reqFn ci ii) = a /\
                                        desc (reqFn ci ii) = St)
           )) as P.
      pose proof (initLatest a) as [hierInit hierM].
      apply (@ind P).
      unfold P in *; clear P.
      intros n defN stCond dirCond.
      destruct (classic (n = hier)) as [eq|notEq].
      rewrite eq.
      rewrite hierInit.
      constructor. constructor. reflexivity.
      intros ti [_ bad].
      assert (f: False) by omega.
      firstorder.
      pose proof (rt_refl Tree parent hier) as defHier.
      pose proof (@initCompat hier) as dir0.
      pose proof (clos_rt_rtn1 Tree parent n hier defN) as trans.
      pose proof @conservative as cons.
      pose proof @descSle as descSle.
      unfold defined in *.
      destruct trans.
      firstorder.
      pose proof (clos_rtn1_rt Tree parent n y trans) as n_y.
      pose proof (rt_step Tree parent y z H) as defY.
      clear dirCond trans; fold descendent in *.
      specialize (dir0 y defHier defY H a).
      pose proof (cons z y defHier defY H a 0) as sleUse.
      pose proof @descSle n y defN defY n_y a 0 as contra.
      rewrite dir0 in sleUse.
      unfold sle in *; destruct (state n a 0); destruct (state y a 0); firstorder.

      unfold P in *; clear P.
      intros t SIHt n defN condSt condDir.

      destruct (classic (sle Sh (state n a t) /\
                         forall c, defined c -> parent c n -> sle (dir n c a t) Sh))
               as [[condSt' condDir']|prevNotLatest].

      assert (triv: t <= t) by omega.
      specialize (SIHt t triv n defN condSt' condDir'); clear triv.

      assert (noneElse: forall co, defined co -> leaf co -> co <> n -> sle (state co a t) Sh).
      intros co defCo leafco co_ne_n.
      destruct (classic (descendent co n)) as [desc|noDesc].
      apply (allDirLower defN condDir' co_ne_n desc).

      assert (not_n_co: ~ descendent n co).
      unfold not; intros n_co.
      assert (no_co_parent: forall p, ~ parent p co) by
          (unfold not; intros p p_co; unfold leaf in *; unfold parent in *;
                                      unfold List.In in *; destruct co; destruct l0; auto).
      pose proof (clos_rt_rtn1 Tree parent n co n_co) as trans.
      destruct trans.
      assert (n = n) by reflexivity; firstorder.
      firstorder.

      pose proof (@nonDescCompat n co defN defCo not_n_co noDesc a t) as condState.
      destruct (state n a t); unfold sle in *; destruct (state co a t); auto.

      assert (noStore: forall co, defined co ->
                                  co <> n -> forall i,
                                               ~ (deqR co i t /\
                                                  loc (reqFn co i) = a /\
                                                  desc (reqFn co i) = St
             )).
      unfold not; intros co defCo co_ne_n i [deqSt [locA isSt]].
      pose proof (deqLeaf deqSt) as leafCo.
      specialize (noneElse co defCo leafCo co_ne_n).
      pose proof (processDeq deqSt) as use; simpl in use.
      rewrite locA in use; rewrite isSt in use.
      rewrite use in noneElse; unfold sle in *; auto.

      destruct (classic (exists i, deqR n i t /\ loc (reqFn n i) = a /\
               desc (reqFn n i) = St)) as [[i [deqSt [locA isSt]]] | noNStore].

      pose proof (deqImpData defN deqSt) as st.
      rewrite locA in st; rewrite isSt in st.
      rewrite st.
      assert (triv: t < S t) by omega.
      assert (triv2: forall ti, t < ti < S t -> False) by (intros ti cond; omega).
      right.
      exists n; exists i; exists t.
      generalize defN triv deqSt isSt locA st triv2; clear; firstorder.
      reflexivity.

      assert (good: forall c i, defined c ->
                                ~ (deqR c i t /\ loc (reqFn c i) = a /\
                                   desc (reqFn c i) = St)).
      unfold not. intros c i defC [deqc [locA isSt]].
      destruct (classic (c = n)) as [eq|notEq].
      rewrite eq in *; generalize noNStore deqc locA isSt; clear; firstorder.
      generalize noStore defC notEq deqc locA isSt; clear; firstorder.

      destruct (classic (data n a (S t) = data n a t)) as [dataEq| dataNeq].
      rewrite dataEq.

      destruct SIHt as [[initi condInit]|[resti condResti]].
      left.
      constructor. assumption.
      intros ti cond.
      assert (cases: 0 <= ti < t \/ ti = t) by omega.
      destruct cases as [ind|rew].
      specialize (condInit ti ind).
      assumption.
      rewrite rew.
      assumption.

      destruct condResti as [ib [tb [defCb [tb_lt_t [deqSt [isSt [locA [dEq rest]]]]]]]].
      right.
      exists resti; exists ib; exists tb.
      constructor. assumption.
      constructor.
      omega.
      constructor.
      assumption.
      constructor.
      assumption.
      constructor.
      assumption.
      constructor.
      assumption.
      intros ti cond.
      assert (cases: tb < ti < t \/ ti = t) by omega.
      destruct cases as [ind|rew].

      apply (rest ti ind).
      rewrite rew.
      assumption.

      pose proof (changeData defN dataNeq) as someChange.
      destruct someChange as [[m [[p [defP [n_p [recvm mIn]]]] |
                                  [c [defC [c_n [recvm mNotIn]]]]]] | bad].

      pose proof (cRecvmCond defP defN n_p recvm) as currSt.
      rewrite <- currSt in condSt'; rewrite mIn in condSt'.
      unfold sle in condSt'; firstorder.

      pose proof (recvmCond defN defC c_n recvm) as currSt.
      specialize (condDir' c defC c_n).
      rewrite currSt in mNotIn.
      pose proof (slt_slei_false mNotIn condDir') as f.
      firstorder.

      generalize noNStore bad; clear; firstorder.

      destruct (classic (state n a t = MsiState.In \/ exists c, defined c /\ parent c n /\
                                                       slt Sh (dir n c a t)))
               as [hard | easy].
      clear prevNotLatest.

      destruct hard as [stIn | [c [defC [c_n dirM]]]].

      assert (lt: slt (state n a t) (state n a (S t))) by
          (rewrite stIn; unfold sle in *; unfold slt in *; destruct (state n a (S t));
           auto).
      assert (chnge: state n a (S t) <> state n a t) by
          (destruct (state n a (S t)); destruct (state n a t); unfold slt in *;
                                                               unfold sle in *;
                                                               auto; discriminate).
      destruct (classic (exists p, defined p /\ parent n p)) as [[p [defP n_p]] | noP].
      pose proof (change (st defP defN n_p) chnge) as [[m markm] | [m recvm]].
      pose proof (cSendDowngrade defP defN n_p markm) as contra.
      pose proof (slt_slti_false lt contra) as f.
      firstorder.

      pose proof (recvImpMark recvm) as [ts [ts_le_t markm]].
      pose proof (@pSendNonI p n defP defN n_p m ts t a markm recvm) as pHigh.
      pose proof (@cRecvNonM p n defP defN n_p m ts t a markm recvm) as cLow.
      assert (cLow1: forall t0, ts < t0 <= t -> slt (state n a t0) Mo) by
          ( intros t0 cond; assert (H: ts <= t0 <= t) by omega; apply (cLow t0 H)).
      assert (cLow2: slt (state n a ts) Mo) by (assert (H: ts <= ts <= t) by omega;
                                                apply (cLow ts H)).

      assert (noDeq1: forall t0, ts < t0 <= t ->
                                 forall c i, defined c -> ~ (deqR c i t0
                                                            /\ loc (reqFn c i) = a /\
                                                            desc (reqFn c i) = St)).
      intros t0 cond.
      specialize (pHigh t0 cond).
      specialize (cLow1 t0 cond).
      pose proof (@leafGood p n a t0 defP defN n_p pHigh cLow1) as H.
      generalize H; clear; firstorder.

      pose proof (@leafGood2 p n a ts defP defN n_p m markm) as noDeq2.

      assert (goodT: forall t0, ts <= t0 <= t ->
                                forall c i, defined c -> ~ (deqR c i t0 /\
                                                            loc (reqFn c i) = a /\
                                                            desc (reqFn c i) = St)).
      intros t0 cond.
      assert (H: ts < t0 <= t \/ t0 = ts) by omega.
      destruct H as [c1|c2].
      apply (noDeq1 t0 c1).
      rewrite c2 in *.
      generalize noDeq2; clear; firstorder.

      pose proof (cRecvmCond defP defN n_p recvm) as stEq.
      rewrite <- stEq in stIn.
      pose proof (fromParent defN defP n_p recvm stIn) as dataEq.
      pose proof (toChild defN defP n_p markm stIn) as dataEq2.
      rewrite <- dataEq in dataEq2.
      rewrite dataEq2.

      pose proof (sendCCond defP defN n_p markm) as [one two].
      pose proof (pSendUpgrade defP defN n_p markm) as upg.
      pose proof (sendmChange (dt defP defN n_p) markm) as ch.
      rewrite ch in upg.
      assert (p1: sle Sh (state p a ts)) by
          ( unfold sle in *; unfold slt in *; destruct (to m); destruct (state p a ts);
            destruct (dir p n a ts); auto).
      assert (p2: forall c', defined c' -> parent c' p ->
                         sle (dir p c' a ts) Sh).
      intros c' defC' c'_p.

      destruct (classic (c' = n)) as [eq|not].
      pose proof (cRecvRespPrevState defP defN n_p recvm markm) as stDir.
      rewrite <- stEq in stDir.
      rewrite stIn in stDir.
      rewrite eq.
      rewrite <- stDir.
      unfold sle; auto.

      specialize (two c' defC' not c'_p).
      unfold sle in *; unfold slt in *; destruct (to m); destruct (dir p n a ts);
      destruct (dir p c' a ts); auto.

      specialize (SIHt ts ts_le_t p defP p1 p2).
      destruct (SIHt) as [[initi condInit] | [resti condRest]].
      left.
      constructor. assumption.

      intros ti cond; assert (H: 0 <= ti < ts \/ ts <= ti <= t ) by omega;
      destruct H as [ind|tough].

      apply (condInit ti ind).
      apply (goodT ti tough).

      right.
      destruct condRest as [ib [tb [defCb [tb_lt_ts [deqSt [isSt [locA [dtEq rest]]]]]]]].
      exists resti; exists ib; exists tb.
      constructor. assumption. constructor.
      assert (tb < S t) by omega. assumption.
      constructor. assumption.
      constructor. assumption.
      constructor. assumption.
      constructor. assumption.
      intros ti cond; assert (H: tb < ti < ts \/ ts <= ti <= t) by omega;
      destruct H as [ind|tough].
      apply (rest ti ind).
      apply (goodT ti tough).

      assert (contra: forall p, defined p -> ~ parent n p) by firstorder.
      specialize (@noParentSame n a t defN contra).
      firstorder.

      specialize (condDir c defC c_n).

      assert (gt: slt (dir n c a (S t)) (dir n c a t)) by
          (unfold slt in *; unfold sle in *; destruct (dir n c a (S t));
           destruct (dir n c a t); auto; discriminate).
      assert (chnge: dir n c a (S t) <> dir n c a t) by
          (destruct (dir n c a (S t)); destruct (dir n c a t); unfold slt in *;
                                                               unfold sle in *;
                                                               auto; discriminate).

      pose proof (change (dt defN defC c_n) chnge) as [[m markm] | [m recvm]].
      pose proof (pSendUpgrade defN defC c_n markm) as contra.
      pose proof (slt_slti_false gt contra) as f.
      firstorder.

      pose proof (recvImpMark recvm) as [ts [ts_le_t markm]].
      pose proof (@pRecvNonI n c defN defC c_n m ts t a markm recvm) as pHigh.
      pose proof (@cSendNonM n c defN defC c_n m ts t a markm recvm) as cLow.
      assert (pHigh1: forall t0, ts < t0 <= t -> slt MsiState.In (dir n c a t0)) by
          ( intros t0 cond; assert (H: ts <= t0 <= t) by omega; apply (pHigh t0 H)).
      assert (pHigh2: slt MsiState.In (dir n c a ts)) by (assert (H: ts <= ts <= t) by omega;
                                                apply (pHigh ts H)).

      assert (noDeq1: forall t0, ts < t0 <= t ->
                                 forall c i, defined c -> ~ (deqR c i t0 /\
                                                             loc (reqFn c i) = a /\
                                                             desc (reqFn c i) = St)).
      intros t0 cond.
      specialize (cLow t0 cond).
      specialize (pHigh1 t0 cond).
      pose proof (@leafGood n c a t0 defN defC c_n pHigh1 cLow) as H.
      generalize H; clear; firstorder.

      pose proof (@leafGood3 n c a ts defN defC c_n m markm) as noDeq2.

      assert (goodT: forall t0, ts <= t0 <= t ->
                                forall c i, defined c -> ~ (deqR c i t0 /\
                                                            loc (reqFn c i) = a /\
                                                            desc (reqFn c i) = St)).
      intros t0 cond.
      assert (H: ts < t0 <= t \/ t0 = ts) by omega.
      destruct H as [c1|c2].
      apply (noDeq1 t0 c1).
      rewrite c2 in *.
      generalize noDeq2; clear; firstorder.

      pose proof (recvmCond defN defC c_n recvm) as stEq.
      rewrite <- stEq in dirM.
      pose proof (fromChild defN defC c_n recvm dirM) as dataEq.
      pose proof (toParent defN defC c_n markm dirM) as dataEq2.
      rewrite <- dataEq in dataEq2.
      rewrite dataEq2.

      pose proof (@sendPCond c a ts n defC defN c_n m markm) as sth.
      pose proof (recvmChange (dt defN defC c_n) recvm) as ch.
      rewrite ch in condDir.
      pose proof (cSendDowngrade defN defC c_n markm) as dwn.

      assert (p2: forall c0, defined c0 -> parent c0 c -> sle (dir c c0 a ts) Sh).
      intros c0 defC0 c0_c; specialize (sth c0 defC0 c0_c);
      destruct (to m); destruct (dir c c0 a ts); unfold sle in *; unfold slt in *;
      auto.

      assert (p1: sle Sh (state c a ts)) by
          ( unfold sle in *; unfold slt in *; destruct (state c a (S ts));
            destruct (state c a ts); auto).

      specialize (SIHt ts ts_le_t c defC p1 p2).

      destruct SIHt as [[initi condInit] | [resti condRest]].
      left.
      constructor. assumption.
      intros ti cond; assert (H: 0 <= ti < ts \/ ts <= ti <= t ) by omega;
      destruct H as [ind|tough].

      apply (condInit ti ind).
      apply (goodT ti tough).

      right.
      destruct condRest as [ib [tb [defCb [tb_lt_ts [deqSt [isSt [locA [dtEq rest]]]]]]]].
      exists resti; exists ib; exists tb.
      constructor. assumption. constructor.
      assert (tb < S t) by omega. assumption.
      constructor. assumption.
      constructor. assumption.
      constructor. assumption.
      constructor. assumption.
      intros ti cond; assert (H: tb < ti < ts \/ ts <= ti <= t) by omega;
      destruct H as [ind|tough].
      apply (rest ti ind).
      apply (goodT ti tough).

      assert (ex: forall c, defined c -> parent c n -> ~ slt Sh (dir n c a t)) by
          firstorder.
      assert (ex': forall c, defined c -> parent c n -> sle (dir n c a t) Sh) by
          ( intros c defC c_n; unfold sle in *; specialize (ex c defC c_n);
            unfold slt in *; destruct (dir n c a t); auto).
      assert (ex2: state n a t <> MsiState.In) by firstorder.
      assert (ex2': sle Sh (state n a t)) by (destruct (state n a t); unfold sle in *;
                                                                      auto).
      firstorder.

    Qed.

  Theorem latestValue:
  forall {c a t},
    defined c ->
    leaf c ->
    sle Sh (state c a t) ->
    (data c a t = initData a /\
     forall {ti}, 0 <= ti < t -> forall {ci ii},
                                   defined ci ->
                                   ~ (deqR ci ii ti /\ loc (reqFn ci ii) = a /\
                                      desc (reqFn ci ii) = St)) \/
    (exists cb ib tb, defined cb /\ tb < t /\ deqR cb ib tb /\ desc (reqFn cb ib) = St /\
                      loc (reqFn cb ib) = a /\
                      data c a t = dataQ (reqFn cb ib) /\
                      forall {ti}, tb < ti < t ->
                                   forall {ci ii},
                                     defined ci ->
                                     ~ (deqR ci ii ti /\ loc (reqFn ci ii) = a /\
                                        desc (reqFn ci ii) = St)
    ).
  Proof.
    intros c a t cDef leafC more.
    assert (cond: forall {c'}, defined c' -> parent c' c -> sle (dir c c' a t) Sh).
    intros c' defC' c'_c; unfold leaf in *; unfold parent in *.
    destruct c.
    destruct l0.
    unfold List.In in *.
    firstorder.
    firstorder.
    pose proof (allLatestValue cDef more cond) as useful.
    assumption.
  Qed.

End LatestValueTheorems.


Require Import String.
Require Import Bool.
Require Import List.      (* sequence *)
Require Import Multiset.  (* bag *)
Require Import ListSet.   (* set *)
Require Import PeanoNat.
Require Import EqNat.
Require Import Coq.Logic.Eqdep_dec.

Require Import core.EqDec.
Require Import core.utils.Utils.
Require Import core.Metamodel.
Require Import core.modeling.ModelingMetamodel.
Require Import core.Model.
Require Import core.utils.CpdtTactics.
(* Base types *)

Inductive Class : Set :=
    BuildClass :
      (* id *) nat ->
      (* name *) string -> Class.

Inductive Attribute : Set :=
    BuildAttribute :
      (* id *) nat ->
      (* derived *) bool ->
      (* name *) string -> Attribute.

Inductive ClassAttributes : Set :=
    BuildClassAttributes:
      Class ->
      list Attribute -> ClassAttributes.

Inductive AttributeType : Set :=
    BuildAttributeType:
      Attribute ->
      Class -> AttributeType.

(* Accessors *)

Definition getClassId (c : Class) : nat :=
  match c with BuildClass id _ => id end.

Definition getClassName (c : Class) : string :=
  match c with BuildClass _ n => n end.

Definition getAttributeId (a : Attribute) : nat :=
  match a with BuildAttribute id _ _ => id end.

Definition getAttributeName (a : Attribute) : string :=
  match a with BuildAttribute _ _ n => n end.

Definition getAttributeDerived (a : Attribute) : bool :=
  match a with BuildAttribute _ n _ => n end.

Definition beq_Class (c1 : Class) (c2 : Class) : bool :=
  beq_nat (getClassId c1) (getClassId c2) && beq_string (getClassName c1) (getClassName c2).

Definition beq_Attribute (a1 : Attribute) (a2 : Attribute) : bool :=
  beq_nat (getAttributeId a1) (getAttributeId a2) && eqb (getAttributeDerived a1) (getAttributeDerived a2) && beq_string (getAttributeName a1) (getAttributeName a2).

Lemma lem_beq_Class_id:
 forall (a1 a2: Class),
   beq_Class a1 a2 = true -> a1 = a2.
Proof.
intros.
unfold beq_Class in H.
unfold "&&" in H.
destruct (getClassId a1 =? getClassId a2) eqn: ca1.
- apply (lem_beq_string_eq2) in H.
  apply (beq_nat_true) in ca1.
  destruct a1,a2.
  simpl in ca1, H.
  rewrite ca1,H.
  auto.
- congruence.
Qed.

Lemma lem_beq_Attribute_id:
 forall (a1 a2: Attribute),
   beq_Attribute a1 a2 = true -> a1 = a2.
Proof.
intros.
unfold beq_Attribute in H.
unfold "&&" in H.
destruct (getAttributeId a1 =? getAttributeId a2) eqn: ca1.
- destruct (eqb (getAttributeDerived a1) (getAttributeDerived a2)) eqn: ca2.
  + apply (lem_beq_string_eq2) in H.
    apply (beq_nat_true) in ca1.
    apply (eqb_prop) in ca2.
    destruct a1,a2.
    simpl in ca1,ca2, H.
    rewrite ca1,ca2,H.
    auto.
  + congruence.
- congruence.
Qed.

(* Meta-types *)

Inductive ClassMetamodel_Class : Set :=
  ClassClass | AttributeClass.

Definition ClassMetamodel_getTypeByClass (type : ClassMetamodel_Class) : Set :=
  match type with
  | ClassClass => Class
  | AttributeClass => Attribute
  end.

Definition ClassMetamodel_getEAttributeTypesByClass (c: ClassMetamodel_Class): Set :=
  match c with
  | ClassClass => (nat * string)
  | AttributeClass => (nat * bool * string)
  end.

Inductive ClassMetamodel_Reference : Set :=
  ClassAttributesReference | AttributeTypeReference.

Definition ClassMetamodel_getTypeByReference (type : ClassMetamodel_Reference) : Set :=
  match type with
  | ClassAttributesReference => ClassAttributes
  | AttributeTypeReference => AttributeType
  end.

Definition ClassMetamodel_getERoleTypesByReference (c: ClassMetamodel_Reference): Set :=
  match c with
  | ClassAttributesReference => (Class * list Attribute)
  | AttributeTypeReference => (Attribute * Class)
  end.

(* Generic types *)

Inductive ClassMetamodel_Object : Set :=
| ClassMetamodel_BuildObject : forall (c:ClassMetamodel_Class), (ClassMetamodel_getTypeByClass c) -> ClassMetamodel_Object.

Definition beq_ClassMetamodel_Object (c1 : ClassMetamodel_Object) (c2 : ClassMetamodel_Object) : bool :=
  match c1, c2 with
  | ClassMetamodel_BuildObject ClassClass o1, ClassMetamodel_BuildObject ClassClass o2 => beq_Class o1 o2
  | ClassMetamodel_BuildObject AttributeClass o1, ClassMetamodel_BuildObject AttributeClass o2 => beq_Attribute o1 o2
  | _, _ => false
  end.

Inductive ClassMetamodel_Link : Set :=
| ClassMetamodel_BuildLink : forall (c:ClassMetamodel_Reference), (ClassMetamodel_getTypeByReference c) -> ClassMetamodel_Link.

(* Reflective functions *)

Lemma ClassMetamodel_eqClass_dec : forall (c1:ClassMetamodel_Class) (c2:ClassMetamodel_Class), { c1 = c2 } + { c1 <> c2 }.
Proof. repeat decide equality. Defined.

Lemma ClassMetamodel_eqReference_dec : forall (c1:ClassMetamodel_Reference) (c2:ClassMetamodel_Reference), { c1 = c2 } + { c1 <> c2 }.
Proof. repeat decide equality. Defined.

Definition ClassMetamodel_getClass (c : ClassMetamodel_Object) : ClassMetamodel_Class :=
   match c with
  | (ClassMetamodel_BuildObject c _) => c
   end.

Definition ClassMetamodel_getReference (c : ClassMetamodel_Link) : ClassMetamodel_Reference :=
   match c with
  | (ClassMetamodel_BuildLink c _) => c
   end.

Definition ClassMetamodel_instanceOfClass (cmc: ClassMetamodel_Class) (c : ClassMetamodel_Object): bool :=
  if ClassMetamodel_eqClass_dec (ClassMetamodel_getClass c) cmc then true else false.

Definition ClassMetamodel_instanceOfReference (cmr: ClassMetamodel_Reference) (c : ClassMetamodel_Link): bool :=
  if ClassMetamodel_eqReference_dec (ClassMetamodel_getReference c) cmr then true else false.

Definition ClassMetamodel_getObjectFromEAttributeValues (t : ClassMetamodel_Class) : (ClassMetamodel_getEAttributeTypesByClass t) -> ClassMetamodel_Object :=
  match t with
  | ClassClass => (fun (p: nat * string) => (ClassMetamodel_BuildObject ClassClass (BuildClass (fst p) (snd p))))
  | AttributeClass => (fun (p: nat * bool * string) => (ClassMetamodel_BuildObject AttributeClass (BuildAttribute (fst (fst p)) (snd (fst p)) (snd p))))
  end.

Definition ClassMetamodel_getLinkFromERoleValues (t : ClassMetamodel_Reference) : (ClassMetamodel_getERoleTypesByReference t) -> ClassMetamodel_Link :=
  match t with
  | ClassAttributesReference => (fun (p: Class * list Attribute) => (ClassMetamodel_BuildLink ClassAttributesReference (BuildClassAttributes (fst p) (snd p))))
  | AttributeTypeReference => (fun (p: Attribute * Class) => (ClassMetamodel_BuildLink AttributeTypeReference (BuildAttributeType (fst p) (snd p))))
  end.

Definition ClassMetamodel_toClass (t : ClassMetamodel_Class) (c : ClassMetamodel_Object) : option (ClassMetamodel_getTypeByClass t).
Proof.
  destruct c.
  destruct (ClassMetamodel_eqClass_dec c t).
  - rewrite e in c0.
    exact (Some c0).
  - exact None.
Defined.

(*
match c with
| ClassMetamodel_BuildObject c0 d =>
    let s := ClassMetamodel_eqClass_dec c0 t in
    match s with
    | left e => match e with
                     eq_refl => Some d
               end
    | right _ => None
    end
  end.

*)

Definition ClassMetamodel_toReference (t : ClassMetamodel_Reference) (c : ClassMetamodel_Link) : option (ClassMetamodel_getTypeByReference t).
Proof.
  destruct c.
  destruct (ClassMetamodel_eqReference_dec t c).
  - rewrite <- e in c0.
    exact (Some c0).
  - exact None.
Defined.

(* Generic functions *)

Definition ClassMetamodel_toObjectFromClass (c :Class) : ClassMetamodel_Object :=
  (ClassMetamodel_BuildObject ClassClass c).

Definition ClassMetamodel_toObjectFromAttribute (a :Attribute) : ClassMetamodel_Object :=
  (ClassMetamodel_BuildObject AttributeClass a).

Definition ClassMetamodel_toObject (t: ClassMetamodel_Class) (e: ClassMetamodel_getTypeByClass t) : ClassMetamodel_Object :=
  (ClassMetamodel_BuildObject t e).

Definition ClassMetamodel_toLink (t: ClassMetamodel_Reference) (e: ClassMetamodel_getTypeByReference t) : ClassMetamodel_Link :=
  (ClassMetamodel_BuildLink t e).

Definition ClassMetamodel_getId (c : ClassMetamodel_Object) : nat :=
  match c with
  | (ClassMetamodel_BuildObject ClassClass c) => getClassId c
  | (ClassMetamodel_BuildObject AttributeClass a) => getAttributeId a
  end.

Definition ClassMetamodel_getName (c : ClassMetamodel_Object) : string :=
  match c with
  | (ClassMetamodel_BuildObject ClassClass c) => getClassName c
  | (ClassMetamodel_BuildObject AttributeClass a) => getAttributeName a
  end.

(*Definition allClasses (m : ClassModel) : list Class :=
  match m with BuildClassModel l _ => optionList2List (map (ClassMetamodel_toClass ClassClass) l) end.*)

(*Theorem allClassesInModel :
  forall (c : Class) (cm: ClassModel), (In c (allClasses cm)) -> (In (ClassMetamodel_BuildObject ClassClass c) (allClassModelElements cm)).
Proof.
  intros.
  destruct cm.
  unfold allClassModelElements.
  unfold allClasses in H.
  apply all_optionList2List_in_list in H.
  induction l.
  - inversion H.
  - simpl in H. simpl.
    destruct H.
    + unfold ClassMetamodel_toClass in H.
      left.
      destruct (ClassMetamodel_eqClass_dec (ClassMetamodel_getClass a) ClassClass).
      * destruct a.
        -- inversion H. reflexivity.
        -- inversion H.
      * inversion H.
    + right.
      apply IHl.
      apply H.
Qed.*)

(*Definition allAttributes (m : ClassModel) : list Attribute :=
  match m with BuildClassModel l _ => optionList2List (map (ClassMetamodel_toClass AttributeClass) l) end.*)

Fixpoint ClassMetamodel_getClassAttributesOnLinks (c : Class) (l : list ClassMetamodel_Link) : option (list Attribute) :=
  match l with
  | (ClassMetamodel_BuildLink ClassAttributesReference (BuildClassAttributes cl a)) :: l1 => if beq_Class cl c then Some a else ClassMetamodel_getClassAttributesOnLinks c l1
  | _ :: l1 => ClassMetamodel_getClassAttributesOnLinks c l1
  | nil => None
  end.

Definition getClassAttributes (c : Class) (m : Model ClassMetamodel_Object ClassMetamodel_Link) : option (list Attribute) :=
  ClassMetamodel_getClassAttributesOnLinks c (@allModelLinks _ _ m).

Definition getClassAttributesObjects (c : Class) (m : Model ClassMetamodel_Object ClassMetamodel_Link) : option (list ClassMetamodel_Object) :=
  match getClassAttributes c m with
  | Some l => Some (map ClassMetamodel_toObjectFromAttribute l)
  | _ => None
  end.

Fixpoint ClassMetamodel_getAttributeTypeOnLinks (a : Attribute) (l : list ClassMetamodel_Link) : option Class :=
  match l with
  | (ClassMetamodel_BuildLink AttributeTypeReference (BuildAttributeType att c)) :: l1 => if beq_Attribute att a then Some c else ClassMetamodel_getAttributeTypeOnLinks a l1
  | _ :: l1 => ClassMetamodel_getAttributeTypeOnLinks a l1
  | nil => None
  end.

Definition getAttributeType (a : Attribute) (m : Model ClassMetamodel_Object ClassMetamodel_Link) : option Class :=
  match m with
    (Build_Model cs ls) => ClassMetamodel_getAttributeTypeOnLinks a ls
  end.

Definition getAttributeTypeObject (a : Attribute) (m : Model ClassMetamodel_Object ClassMetamodel_Link) : option ClassMetamodel_Object :=
  match getAttributeType a m with
  | Some c => Some (ClassMetamodel_toObject ClassClass c)
  | None => None
  end.

Definition ClassMetamodel_defaultInstanceOfClass (c: ClassMetamodel_Class) : (ClassMetamodel_getTypeByClass c) :=
  match c with
  | ClassClass => (BuildClass 0 "")
  | AttributeClass => (BuildAttribute 0 false "")
  end.

(* Typeclass Instance *)

#[export]
Instance ClassElementSum : Sum ClassMetamodel_Object ClassMetamodel_Class :=
{
  denoteSubType := ClassMetamodel_getTypeByClass;
  toSubType := ClassMetamodel_toClass;
  toSumType := ClassMetamodel_toObject;
}.

(* TODO *)
Definition beq_ClassMetamodel_Link (c1 : ClassMetamodel_Link) (c2 : ClassMetamodel_Link) : bool := true.

#[export]
Instance ClassLinkSum : Sum ClassMetamodel_Link ClassMetamodel_Reference :=
{
  denoteSubType := ClassMetamodel_getTypeByReference;
  toSubType := ClassMetamodel_toReference;
  toSumType := ClassMetamodel_toLink;
}.

#[export]
Instance ClassMetamodel_EqDec : EqDec ClassMetamodel_Object := {
    eq_b := beq_ClassMetamodel_Object;
}.

#[export]
Instance ClassM : Metamodel :=
{
  ModelElement := ClassMetamodel_Object;
  ModelLink := ClassMetamodel_Link;
}.

#[export]
Instance ClassMetamodel : ModelingMetamodel ClassM :=
{
    elements := ClassElementSum;
    links := ClassLinkSum;
}.

Definition ClassModel := Model ClassMetamodel_Object ClassMetamodel_Link.

(* Useful lemmas *)
Lemma Class_invert :
  forall (clec_arg: ClassMetamodel_Class) (t1 t2: ClassMetamodel_getTypeByClass clec_arg), ClassMetamodel_BuildObject clec_arg t1 = ClassMetamodel_BuildObject clec_arg t2 -> t1 = t2.
Proof.
  intros.
  inversion H.
  apply inj_pair2_eq_dec in H1.
  exact H1.
  apply ClassMetamodel_eqClass_dec.
Qed.

Lemma Object_dec:
  forall (a: ClassMetamodel_Object),
    (ClassMetamodel_instanceOfClass ClassClass a) = true
 \/ (ClassMetamodel_instanceOfClass AttributeClass a) = true.
Proof.
  intros.
  destruct a.
  destruct c.
  + left. crush.
  + right. crush.
Qed.

Lemma Class_Object_cast:
  forall a c,
    ClassMetamodel_toClass ClassClass a = return c ->
      ClassMetamodel_toObject ClassClass c = a.
Proof.
  intros.
  unfold ClassMetamodel_toClass in H.
  destruct a.
  unfold ClassMetamodel_instanceOfClass in H.
  simpl in H.
  destruct (ClassMetamodel_eqClass_dec c0 ClassClass); crush.
Qed.

Lemma Attribute_Object_cast:
  forall a c,
    ClassMetamodel_toClass AttributeClass a = return c ->
      ClassMetamodel_toObject AttributeClass c = a.
Proof.
  intros.
  unfold ClassMetamodel_toClass in H.
  destruct a.
  unfold ClassMetamodel_instanceOfClass in H.
  simpl in H.
  destruct (ClassMetamodel_eqClass_dec c0 AttributeClass); crush.
Qed.

Lemma Class_dec :
  forall x y : Class, {x = y} + {x <> y}.
Proof.
  decide equality.
  - apply String.string_dec.
  - apply Nat.eq_dec.
Qed.

Lemma Attribute_dec :
  forall x y : Attribute, {x = y} + {x <> y}.
Proof.
  decide equality.
  - apply String.string_dec.
  - apply Bool.bool_dec.
  - apply Nat.eq_dec.
Qed.

Lemma eq_dec : forall (x y : ClassMetamodel_Object), {x = y} + {x <> y}.
  intros.
  destruct x as [[] x], y as [[] y]; try (right; discriminate).
  - destruct (Class_dec x y) as [H | H].
    + left. congruence.
    + right. contradict H.
      inversion H.
      apply Eqdep.EqdepTheory.inj_pair2 in H1.
      assumption.
  - destruct (Attribute_dec x y) as [H | H].
    + left. congruence.
    + right. contradict H.
      inversion H.
      apply Eqdep.EqdepTheory.inj_pair2 in H1.
      assumption.
Qed.


From iris.base_logic.lib Require Import ghost_map.
From iris Require Import program_logic.weakestpre.
From iris.proofmode Require Import tactics.
From st.STLCmuVS Require Import lang wkpre generic.lift contexts scopedness.
From st.STLCmu Require Import types.
From st.prelude Require Import big_op_three.
From st Require Import resources.

Canonical Structure typeO := leibnizO type.

Section definition.

  Context `{Σ : !gFunctors} `{semΣ_inst : !semΣ Σ}.

  (* We define a stuckness-sensistive and insensitive one *)
  Context (s : stuckness).

  Fixpoint valrel_typed_gen_pre (Ψ : typeO -n> valO -n> valO -n> iPropO Σ) (τ : typeO) : valO -n> valO -n> iPropO Σ := λne v v',
    (match τ with
     | TUnit => ⌜ v = (()%Vₙₒ : valO) ⌝ ∧ ⌜ v' = (()%Vₙₒ : valO) ⌝
     | TBool => ∃ b : bool, ⌜ v = b ⌝ ∧ ⌜ v' = b ⌝
     | TInt => ∃ z : Z, ⌜ v = z ⌝ ∧ ⌜ v' = z ⌝
     | TProd τ1 τ2 => ∃ v1 v2 v1' v2', ⌜ v = (v1, v2)%Vₙₒ ⌝ ∧ ⌜ v' = (v1' , v2')%Vₙₒ ⌝ ∗ valrel_typed_gen_pre Ψ τ1 v1 v1' ∗ valrel_typed_gen_pre Ψ τ2 v2 v2'
     | TSum τ1 τ2 => ∃ vi vi', (⌜ v = InjLV vi ⌝ ∧ ⌜ v' = InjLV vi' ⌝ ∧ valrel_typed_gen_pre Ψ τ1 vi vi') ∨
                              (⌜ v = InjRV vi ⌝ ∧ ⌜ v' = InjRV vi' ⌝ ∧ valrel_typed_gen_pre Ψ τ2 vi vi')
     | TArrow τ1 τ2 => □ (∀ w w', valrel_typed_gen_pre Ψ τ1 w w' -∗ lift s (valrel_typed_gen_pre Ψ τ2) (v w) (v' w'))
     | TRec τ => ∃ w w', ⌜ v = FoldV w ⌝ ∧ ⌜ v' = FoldV w' ⌝ ∧ ▷ (Ψ τ.[TRec τ/] w w')
     | TVar X => False
     end)%I.

  Definition valrel_typed_gen (Ψ : typeO -n> valO -n> valO -n> iPropO Σ) : typeO -n> valO -n> valO -n> iPropO Σ := λne τ v v', valrel_typed_gen_pre Ψ τ v v'.

  Instance valrel_typed_gen_contractive : Contractive valrel_typed_gen.
  Proof.
    intros n P1 P2 dl. rewrite /valrel_typed_gen. intro τ. simpl.
    induction τ; try by solve_contractive.
    - intros v v'. simpl. do 6 f_equiv. specialize (IHτ1 a a0). simpl in IHτ1. by rewrite IHτ1.
      rewrite /lift. do 5 f_equiv. specialize (IHτ2 a1 a2). simpl in IHτ2. by rewrite IHτ2.
  Qed.

  Definition valrel_typed := fixpoint valrel_typed_gen.

  Lemma valrel_typed_unfold τ v1 v2 : valrel_typed τ v1 v2 ≡ valrel_typed_gen (fixpoint valrel_typed_gen) τ v1 v2.
  Proof. do 3 f_equiv. by rewrite -fixpoint_unfold. Qed.
  Lemma valrel_typed_unfold' τ : valrel_typed τ ≡ valrel_typed_gen (fixpoint valrel_typed_gen) τ.
  Proof. intros x x'. by rewrite valrel_typed_unfold. Qed.
  Lemma valrel_typed_unfold'' : valrel_typed ≡ valrel_typed_gen (fixpoint valrel_typed_gen).
  Proof. intros x. by rewrite valrel_typed_unfold'. Qed.
  Lemma valrel_typed_gen_pre_gen Ψ τ v v' : valrel_typed_gen_pre Ψ τ v v' ≡ valrel_typed_gen Ψ τ v v'.
  Proof. auto. Qed.
  Lemma valrel_typed_gen_pre_gen' Ψ τ : valrel_typed_gen_pre Ψ τ ≡ valrel_typed_gen Ψ τ.
  Proof. intro. intro. auto. Qed.

  Lemma valrel_typed_TUnit_unfold v v' : valrel_typed TUnit v v' ≡ (⌜ v = (()%Vₙₒ : valO) ⌝ ∧ ⌜ v' = (()%Vₙₒ : valO) ⌝)%I.
  Proof. by rewrite valrel_typed_unfold. Qed.
  Lemma valrel_typed_TBool_unfold v v' : valrel_typed TBool v v' ≡ (∃ b : bool, ⌜ v = b ⌝ ∧ ⌜ v' = b ⌝)%I.
  Proof. by rewrite valrel_typed_unfold. Qed.
  Lemma valrel_typed_TInt_unfold v v' : valrel_typed TInt v v' ≡ (∃ z : Z, ⌜ v = z ⌝ ∧ ⌜ v' = z ⌝)%I.
  Proof. by rewrite valrel_typed_unfold. Qed.
  Lemma valrel_typed_TArrow_unfold τ1 τ2 v v' : valrel_typed (TArrow τ1 τ2) v v' ≡ (□ (∀ w w', valrel_typed τ1 w w' -∗ lift s (valrel_typed τ2) (v w) (v' w')))%I.
  Proof.
    rewrite valrel_typed_unfold. rewrite /valrel_typed_gen. simpl.
    f_equiv. f_equiv. intros w. f_equiv. intro w'. f_equiv.
    - rewrite valrel_typed_gen_pre_gen. unfold valrel_typed. rewrite -valrel_typed_unfold. auto.
    - rewrite /lift. f_equiv. simpl. f_equiv. f_equiv. f_equiv. f_equiv.
      by rewrite valrel_typed_unfold.
  Qed.
  Lemma valrel_typed_TSum_unfold τ1 τ2 v v' : valrel_typed (TSum τ1 τ2) v v' ≡ (∃ vi vi', (⌜ v = InjLV vi ⌝ ∧ ⌜ v' = InjLV vi' ⌝ ∧ valrel_typed τ1 vi vi') ∨ (⌜ v = InjRV vi ⌝ ∧ ⌜ v' = InjRV vi' ⌝ ∧ valrel_typed τ2 vi vi'))%I.
  Proof. rewrite valrel_typed_unfold. simpl. repeat f_equiv; rewrite valrel_typed_gen_pre_gen'; rewrite -valrel_typed_unfold'; auto. Qed.
  Lemma valrel_typed_TProd_unfold τ1 τ2 v v' : valrel_typed (TProd τ1 τ2) v v' ≡ (∃ v1 v2 v1' v2', ⌜ v = (v1, v2)%Vₙₒ ⌝ ∧ ⌜ v' = (v1' , v2')%Vₙₒ ⌝ ∗ valrel_typed τ1 v1 v1' ∗ valrel_typed τ2 v2 v2')%I.
  Proof. rewrite valrel_typed_unfold. simpl. repeat f_equiv; rewrite valrel_typed_gen_pre_gen'; rewrite -valrel_typed_unfold'; auto. Qed.
  Lemma valrel_typed_TRec_unfold τ v v' : valrel_typed (TRec τ) v v' ≡ (∃ w w', ⌜ v = FoldV w ⌝ ∧ ⌜ v' = FoldV w' ⌝ ∧ ▷ (valrel_typed τ.[TRec τ/] w w'))%I.
  Proof. rewrite valrel_typed_unfold. simpl. repeat f_equiv. auto. Qed.
  Lemma valrel_typed_TVar_unfold X v v' : valrel_typed (TVar X) v v' ≡ False%I.
  Proof. rewrite valrel_typed_unfold. by simpl. Qed.

  Ltac simpl_valrel_typed := fold (valrel_typed_gen_pre); repeat rewrite valrel_typed_gen_pre_gen -valrel_typed_unfold; fold (valrel_typed).

  Global Instance valrel_typed_persistent τ v v' : Persistent (valrel_typed τ v v').
  Proof.
    rewrite /Persistent. revert τ v v'. iLöb as "IHlob". iIntros (τ).
    iInduction τ as [ | | | τ1 τ2 | τ1 τ2 | τ1 τ2 | τ1 τ2 | τ ] "IH";
      iIntros (v v'); rewrite valrel_typed_unfold; try by iIntros "#H".
    - iIntros "H". iDestruct "H" as (v1 v2 v1' v2') "(-> & -> & H1 & H2)". simpl_valrel_typed.
      iExists v1, v2, v1', v2'. simpl_valrel_typed. repeat iSplit; auto. iApply ("IH" with "H1"). iApply ("IH1" with "H2").
    - simpl_valrel_typed. iIntros "H". iDestruct "H" as (vi vi') "[(-> & -> & H1) | (-> & -> & H2)]"; iExists vi, vi'; simpl_valrel_typed.
      + iLeft. repeat iSplit; auto. by iApply ("IH" with "H1").
      + iRight. repeat iSplit; auto. by iApply ("IH1" with "H2").
    - iIntros "H". iDestruct "H" as (w w') "(-> & -> & H)". simpl_valrel_typed. iExists w, w'. repeat iSplitL ""; auto.
      iApply bi.later_persistently_1. iNext. by iApply "IHlob".
  Qed.

  Definition exprel_typed : typeO -n> exprO -n> exprO -n> iPropO Σ := λne τ eᵢ eₛ, lift s (valrel_typed τ) eᵢ eₛ.

  Definition open_exprel_typed (Γ : list type) (e e' : expr) (τ : type) :=
    ∀ (vs vs' : list val), big_sepL3 (fun τ v v' => valrel_typed τ v v') Γ vs vs' ⊢
                                     exprel_typed τ e.[subst_list_val vs] e'.[subst_list_val vs'].

  Lemma open_exprel_typed_nil τ e e' : (⊢ exprel_typed τ e e') -> open_exprel_typed [] e e' τ.
  Proof. iIntros (Hee' vs vs') "Hvv'". destruct vs, vs'; auto. asimpl. iApply Hee'. Qed.

  Lemma open_exprel_typed_nil' τ e e' : open_exprel_typed [] e e' τ → (⊢ exprel_typed τ e e').
  Proof. rewrite /open_exprel_typed. iIntros (Hee'). iDestruct (Hee' [] []) as "H". asimpl. by iApply "H". Qed.

  Definition ctx_item_rel_typed (Ci Ci' : ctx_item) Γ τ Γ' τ' :=
    ∀ e e' (pe : expr_scoped (length Γ) e) (pe' : expr_scoped (length Γ) e'), open_exprel_typed Γ e e' τ → open_exprel_typed Γ' (fill_ctx_item Ci e) (fill_ctx_item Ci' e') τ'.

  Definition ctx_rel_typed (C C' : ctx) Γ τ Γ' τ' :=
    ∀ e e' (pe : expr_scoped (length Γ) e) (pe' : expr_scoped (length Γ) e'), open_exprel_typed Γ e e' τ → open_exprel_typed Γ' (fill_ctx C e) (fill_ctx C' e') τ'.

End definition.

Ltac unfold_valrel_typed :=
  (rewrite valrel_typed_TUnit_unfold) ||
  (rewrite valrel_typed_TBool_unfold) ||
  (rewrite valrel_typed_TInt_unfold) ||
  (rewrite valrel_typed_TArrow_unfold) ||
  (rewrite valrel_typed_TSum_unfold) ||
  (rewrite valrel_typed_TProd_unfold) ||
  (rewrite valrel_typed_TRec_unfold).

Ltac simpl_valrel_typed := fold (valrel_typed_gen_pre); repeat rewrite valrel_typed_gen_pre_gen -valrel_typed_unfold; fold (valrel_typed).


From cap_machine Require Export rules_Jmp rules_binary_base.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.

Section cap_lang_spec_rules.
  Context `{cfgSG Σ, MachineParameters, invG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : cap_lang.state.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Lemma step_jmp_success E K pc_p pc_g pc_b pc_e pc_a w r w' :
    decodeInstrW w = Jmp r →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ ▷ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a)
             ∗ ▷ pc_a ↣ₐ w
             ∗ ▷ r ↣ᵣ w'
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ updatePcPerm w'
        ∗ pc_a ↣ₐ w
        ∗ r ↣ᵣ w'.
  Proof.
    iIntros (Hinstr Hvpc Hnclose) "(Hinv & Hj & >HPC & >Hpc_a & >Hr)".
    iDestruct "Hinv" as (ρ) "Hinv". rewrite /spec_inv.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e [σr σm]) "[Hown %] /=".
    iDestruct (@spec_heap_valid with "[$Hown $Hpc_a]") as %?; auto.
    iDestruct (@spec_regs_valid with "[$Hown $HPC]") as %?.
    iDestruct (@spec_regs_valid with "[$Hown $Hr]") as %Hr_r0.
    iDestruct (spec_expr_valid with "[$Hown $Hj]") as %Heq; subst e.
    specialize (normal_always_step (σr,σm)) as [c [ σ2 Hstep]].
    eapply step_exec_inv in Hstep; eauto.

    assert (Hstep':=Hstep).
    rewrite /update_reg /= in Hstep. simplify_pair_eq. cbn.
    assert ((c, σ2) = (NextI, (<[PC:=updatePcPerm w']> σr, σm))) as Heq.
    { inversion Hstep'; simpl in *; simplify_map_eq_alt. rewrite /RegLocate Hr_r0; auto. }
    simplify_eq.
    iMod (@regspec_mapsto_update with "Hown HPC") as "[Hown HPC]".
    iMod (exprspec_mapsto_update _ _ (fill K (Instr NextI)) with "Hown Hj") as "[Hown Hj]".
    iFrame.
    iMod ("Hclose" with "[Hown]") as "_".
    { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
      exists [];eapply step_atomic with (t1:=[]) (t2:=[]);eauto.
      econstructor;eauto;constructor. simpl.
      eapply step_exec_instr with (c:=(NextI, (<[PC:=updatePcPerm w']> σr, σm)));
        rewrite /RegLocate /MemLocate;[simplify_map_eq..|];eauto.
    }
    done.
  Qed.

  Lemma step_jmp_successPC E K pc_p pc_g pc_b pc_e pc_a w :
    decodeInstrW w = Jmp PC →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ ▷ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a)
             ∗ ▷ pc_a ↣ₐ w
    ={E}=∗  ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ updatePcPerm (inr (pc_p,pc_g,pc_b,pc_e,pc_a))
        ∗ pc_a ↣ₐ w.
  Proof.
    iIntros (Hinstr Hvpc Hnclose) "(Hinv & Hj & >HPC & >Hpc_a)".
    iDestruct "Hinv" as (ρ) "Hinv". rewrite /spec_inv.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e [σr σm]) "[Hown %] /=".
    iDestruct (@spec_heap_valid with "[$Hown $Hpc_a]") as %?; auto.
    iDestruct (@spec_regs_valid with "[$Hown $HPC]") as %?.
    iDestruct (spec_expr_valid with "[$Hown $Hj]") as %Heq; subst e.
    specialize (normal_always_step (σr,σm)) as [c [ σ2 Hstep]].
    eapply step_exec_inv in Hstep; eauto. assert (Hstep':=Hstep).

    rewrite /update_reg /= in Hstep. simplify_pair_eq. cbn.
    assert ((c, σ2) = (NextI, (<[PC:=updatePcPerm (inr (pc_p,pc_g, pc_b, pc_e, pc_a))]> σr, σm))) as Heq.
    { inversion Hstep'; simpl in *; simplify_map_eq_alt. rewrite /RegLocate H4; auto. }
    simplify_eq.
    iMod (@regspec_mapsto_update with "Hown HPC") as "[Hown HPC]".
    iMod (exprspec_mapsto_update _ _ (fill K (Instr NextI)) with "Hown Hj") as "[Hown Hj]".
    iFrame.
    iMod ("Hclose" with "[Hown]") as "_".
    { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
      exists [];eapply step_atomic with (t1:=[]) (t2:=[]);eauto.
      econstructor;eauto;constructor. simpl.
      eapply step_exec_instr with (c:=(NextI, (<[PC:=updatePcPerm (inr (pc_p,pc_g, pc_b, pc_e, pc_a))]> σr, σm)));
        rewrite /RegLocate /MemLocate;[simplify_map_eq..|];eauto.
    }
    done.
  Qed.

End cap_lang_spec_rules.


From Coq Require Program.

Section Scope.

#[local] Coercion nat_of_bool (b: bool) : nat :=
  if b then 0 else 1.

Check (refl_equal : true = 0 :> nat).

End Scope.

Fail Check 0 = true :> nat.

#[polymorphic]
Definition ι T (x: T) := x.

Check ι _ ι.

#[program]
Fixpoint f (n: nat) {wf lt n} : nat := _.

#[deprecated(since="8.9.0")]
Ltac foo := foo.


(* -*- coq-prog-args: ("-type-in-type"); -*- *)

Definition some_prop : Prop := Type.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** * Extends relation for analysis result *)

Set Implicit Arguments.

Require Import hpattern vgtac.
Require Import UserProofType Syn Global.
Require Import SemCommon.
Require ExtMem.
Require DomInsen.

Module Make (Import PInput : PINPUT).

Local Open Scope type.

Module Insen := DomInsen.Make PInput.

Include ExtMem.Make PInput.

Definition state_find (mempos : mem_pos) (node : InterNode.t)
           (s : Table.t Mem.t * Table.t Mem.t) : Mem.t :=
  let t := match mempos with
             | Inputof => fst s
             | Outputof => snd s
           end in
  table_find node t.

Definition extends (g : G.t) (s : Table.t Mem.t)
           (insenl_s : Insen.state_t) : Prop :=
  forall cfg f n cmd insenl_m
         (Hcfg: InterCfg.PidMap.MapsTo f cfg (InterCfg.cfgs (G.icfg g)))
         (Hcmd: IntraCfg.NodeMap.MapsTo n cmd (IntraCfg.cmds cfg))
         (Hidx_m : insenl_s ((f, n), Inputof) = insenl_m),
    let mode := UserInputType.Strong in
    let '(m', acc_n) :=
        run_access mode g (f, n) cmd (table_find (f, n) s) in
    let uses_n := Acc.useof acc_n in
    extends_mem uses_n (table_find (f, n) s) insenl_m.

Definition extends' (g : G.t)
           (s1 : Table.t Mem.t) (s2 : Table.t Mem.t * Table.t Mem.t) : Prop :=
  forall cfg f n cmd
         (Hcfg: InterCfg.PidMap.MapsTo f cfg (InterCfg.cfgs (G.icfg g)))
         (Hcmd: IntraCfg.NodeMap.MapsTo n cmd (IntraCfg.cmds cfg)),
    let mode := UserInputType.Strong in
    let '(m', acc_n) :=
        run_access mode g (f, n) cmd (table_find (f, n) s1) in
    let uses_n1 := Acc.useof acc_n in
    extends_mem uses_n1 (table_find (f, n) s1)
                (state_find Inputof (f, n) s2).

Definition extends'' (g : G.t)
           (s : Table.t Mem.t * Table.t Mem.t)
           (insenl_s : Insen.state_t) : Prop :=
  forall n mpos, Mem.eq (state_find mpos n s) (insenl_s (n, mpos)).

Lemma extends_trans :
  forall (g : G.t) x y z
     (He1: extends' g x y) (He2: extends'' g y z),
    extends g x z.
Proof.
unfold extends', extends, extends_mem; i.
specialize He1 with cfg f n cmd.
remember (run_access UserInputType.Strong g (f, n) cmd (table_find (f, n) x))
as x1.
destruct x1 as [v1 acc1]. i.
eapply Val.eq_trans with (Mem.find k (state_find Inputof (f, n) y)).
- by apply He1.
- rewrite <- Hidx_m. by apply He2.
Qed.

Local Close Scope type.

End Make.


Require Import Coq.Strings.String.

From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype choice seq ssrnum ssrint ssralg bigop.
From deriving Require Import deriving.
From extructures Require Import ord fset fmap ffun fperm.

From CoqUtils Require Import nominal.

From memsafe Require Import basic.

From memsafe Require structured.

Module str := structured.

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

Section Properties.

Local Open Scope fset_scope.
Local Open Scope state_scope.

Local Notation locals := {fmap string -> value}.
Local Notation heap := {fmap ptr -> value}.
Local Notation state := (locals * heap)%type.

Implicit Type (e : expr) (c : com) (ls : locals) (h : heap)
              (s : state) (π : {fperm name}) (v : value).

Definition vars_s s := domm s.1.

Definition objs s := names (domm s.2).

Instance vars_s_eqvar : {eqvar vars_s}.
Proof. by rewrite /vars_s; finsupp. Qed.

Instance objs_eqvar : {eqvar objs}.
Proof. by rewrite /objs; finsupp. Qed.

Lemma objs_names s : fsubset (objs s) (names s).
Proof. eapply nom_finsuppP; finsupp. Qed.

Lemma objsU s1 s2 : objs (s1 ∪ s2) = objs s1 :|: objs s2.
Proof.
case: s1 s2=> /= [ls1 h1] [ls2 h2].
by rewrite /stateu /objs /= domm_union namesfsU.
Qed.

Lemma names_stateu s1 s2 :
  fdisjoint (vars_s s1) (vars_s s2) ->
  fdisjoint (objs s1) (objs s2) ->
  names (s1 ∪ s2) = names s1 :|: names s2.
Proof.
case: s1 s2 => /= [ls1 h1] [ls2 h2].
rewrite /vars_s /objs /stateu !namespE /= => dis_v dis_o.
rewrite namesm_union_disjoint // namesm_union_disjoint.
  rewrite 2!fsetUA; congr fsetU.
  by rewrite -2!fsetUA [_ :|: names h1]fsetUC.
by apply: fdisjoint_names_domm.
Qed.

Lemma vars_sE A s : vars_s s = expose (mapr fset0 vars_s (hide A (Restr s))).
Proof. by rewrite /vars_s maprE ?fdisjoint0s ?exposeE. Qed.

Lemma renaming π s c k :
  exists π',
    eval_com true c (rename π s) k =
    rename π' (eval_com true c s k).
Proof.
have [A1 eA1] := str.eval_basic_restr c s k.
have [A2 eA2] := str.eval_basic_restr c (rename π s) k.
move: eA2; rewrite -str.eval_com_eqvar {}eA1.
case: eval_com => [s1'| |]; case: eval_com => //;
try by exists 1%fperm; rewrite rename1.
move=> s2' []; rewrite hide_eqvar Restr_eqvar  => /restr_eqP /= [π' _ [_ <-]].
by exists (π' * π)%fperm; rewrite renameA.
Qed.

Theorem frame_ok s1 s1' s2 c k :
  fsubset (vars_c c) (vars_s s1) ->
  fdisjoint (vars_s s1) (vars_s s2) -> (* This should not be necessary *)
  fdisjoint (objs s1) (objs s2) ->
  eval_com true c s1 k = Done s1' ->
  exists2 π,
    eval_com true c (s1 ∪ s2) k = Done (rename π s1' ∪ s2)
    & fdisjoint (objs (rename π s1')) (objs s2).
Proof.
move=> sub dis_v dis_o ev.
rewrite /vars_s -(eval_com_vars sub ev) in dis_v.
have [A] := str.eval_basic_restr c s1 k; rewrite ev hideI namesrE.
move: (_ :&: _) (fsubsetIr A (names s1'))=> /= {A} A subA ev'.
have {sub} ev'' := str.frame_ok sub dis_o ev'.
have [A'] := str.eval_basic_restr c (s1 ∪ s2) k.
rewrite ev''; case: eval_com=> // s' [] es'.
move: es' ev''; rewrite [hide A' _]hideI namesrE.
move: (_ :&: _) (fsubsetIr A' (names s'))=> /= {A'} A' subA'.
move e: (hide A (Restr s1')) => /= s1''.
case/(restrP (names s1 :|: names s2)): s1'' e => /= A'' s1'' disA'' subA''.
move: disA''; rewrite fdisjointUl=> /andP [dis_s1_A'' dis_s2_A''].
rewrite maprE //.
case/restr_eqP=> /= π dis_π; rewrite (fsetIidPl subA'').
rewrite (fsetIidPl subA).
rewrite -{2 3}(renameK π s1').
rewrite -namesrE in dis_π.
move: (dis_π) subA ev' dis_o.
rewrite -[fsubset _ _](renameT π) fsubset_eqvar (renamefsE _ (names s1')) -names_rename.
rewrite -[hide A _](@renameJ _ π) // ?names_hider // hide_eqvar Restr_eqvar.
move: dis_v; rewrite -[domm s1'.1](renameT π) domm_eqvar fst_eqvar.
move: (rename π A) (rename π s1') => {A s1' dis_π ev} /= A s1' dis_v _ subA ev.
move=> dis [e1 e2]; move: dis_s1_A'' dis_s2_A'' {subA''}.
rewrite -{}e1 -{}e2 {A'' s1''}.
move=> dis_s1_A dis_s2_A; case/restr_eqP=> /= π' dis_π'.
rewrite (fsetIidPl subA').
move=> [_ <-] {A' s' subA'} ev'.
have dis_s1' : fdisjoint (objs s1') (objs s2).
  have:= @str.eval_com_blocks (objs s2) s1 c k dis.
  rewrite ev /= str.pbind_resE.
  have: fdisjoint (names (objs s2)) A.
    by apply: fdisjoint_trans dis_s2_A; eapply nom_finsuppP; finsupp.
  move: (objs s2) => A' disA'.
  by rewrite pbindrE //= namesfsnE.
have e_s2 : rename π' s2 = s2.
  rewrite names_stateu // in dis_π'.
  rewrite renameJ //.
  move: dis_π'; rewrite fsetDUl fdisjointUr=>/andP [_].
  by move/fsetDidPl: dis_s2_A => ->.
exists (π' * π)%fperm; rewrite ?stateu_eqvar renameA fperm_mulsK {π}.
  by congr Done; congr stateu.
by rewrite -e_s2 -objs_eqvar -[objs (rename _ _)]objs_eqvar -fdisjoint_eqvar.
Qed.

Theorem frame_loop s1 s2 c k :
  fsubset (vars_c c) (vars_s s1) ->
  fdisjoint (objs s1) (objs s2) ->
  eval_com true c s1 k = NotYet ->
  eval_com true c (s1 ∪ s2) k = NotYet.
Proof.
move=> sub dis ev.
have [A] := str.eval_basic_restr c s1 k; rewrite ev {A}.
move=> ev'.
have ev'' := str.frame_loop sub dis ev'.
have [A] := str.eval_basic_restr c (s1 ∪ s2) k.
by rewrite ev''; case: eval_com.
Qed.

Theorem frame_error s1 s2 c k :
  fsubset (vars_c c) (vars_s s1) ->
  fdisjoint (names s1) (objs s2) ->
  eval_com true c s1 k = Error ->
  eval_com true c (s1 ∪ s2) k = Error.
Proof.
move=> sub dis ev.
have [A] := str.eval_basic_restr c s1 k; rewrite ev {A}.
move=> ev'.
have ev'' := str.frame_error sub dis ev'.
have [A] := str.eval_basic_restr c (s1 ∪ s2) k.
by rewrite ev''; case: eval_com.
Qed.

Corollary noninterference s1 s21 s' s22 c k :
  fsubset (vars_c c) (vars_s s1) ->
  fdisjoint (vars_s s1) (vars_s s21) -> (* Same applies here *)
  fdisjoint (vars_s s1) (vars_s s22) -> (* And here *)
  fdisjoint (names s1) (objs s21) ->
  fdisjoint (objs s1) (objs s22) ->
  eval_com true c (s1 ∪ s21) k = Done s' ->
  exists s1' π1 π2,
    [/\ eval_com true c s1 k = Done s1',
        s' = rename π1 s1' ∪ s21,
        fdisjoint (objs (rename π1 s1')) (objs s21),
        eval_com true c (s1 ∪ s22) k = Done (rename π2 s1' ∪ s22) &
        fdisjoint (objs (rename π2 s1')) (objs s22) ].
Proof.
move=> sub dis_v1 dis_v2 dis_o1 dis_o2 eval_c.
have dis_o1' : fdisjoint (objs s1) (objs s21).
  apply: fdisjoint_trans; last exact: dis_o1.
  exact: objs_names.
case eval_c': (eval_com true c s1 k) => [s1'| |] //=.
- exists s1'.
  have [π1 eπ1 disπ1] := frame_ok sub dis_v1 dis_o1' eval_c'.
  exists π1; move: eπ1; rewrite eval_c => - [->].
  have [π2 eπ2 disπ2] := frame_ok sub dis_v2 dis_o2 eval_c'.
  by exists π2; split.
- by rewrite (frame_error sub dis_o1 eval_c') in eval_c.
by rewrite (frame_loop sub _ eval_c') // in eval_c.
Qed.

End Properties.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.

Require Import SimMemory.
Require Import SimPromises.

Set Implicit Arguments.

Section Simulation.
  Definition SIM :=
    forall (ths1_src:Threads.t) (sc0_src:TimeMap.t) (mem0_src:Memory.t)
      (ths1_tgt:Threads.t) (sc0_tgt:TimeMap.t) (mem0_tgt:Memory.t), Prop.

  Definition _sim
             (sim: SIM)
             (ths1_src:Threads.t) (sc0_src:TimeMap.t) (mem0_src:Memory.t)
             (ths1_tgt:Threads.t) (sc0_tgt:TimeMap.t) (mem0_tgt:Memory.t): Prop :=
    forall sc1_src mem1_src
      sc1_tgt mem1_tgt
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEMORY1: sim_memory mem1_src mem1_tgt)
      (WF_SRC: Configuration.wf (Configuration.mk ths1_src sc1_src mem1_src))
      (WF_TGT: Configuration.wf (Configuration.mk ths1_tgt sc1_tgt mem1_tgt))
      (CONSISTENT_SRC: Configuration.consistent (Configuration.mk ths1_src sc1_src mem1_src))
      (CONSISTENT_TGT: Configuration.consistent (Configuration.mk ths1_tgt sc1_tgt mem1_tgt))
      (SC_FUTURE_SRC: TimeMap.le sc0_src sc1_src)
      (SC_FUTURE_TGT: TimeMap.le sc0_tgt sc1_tgt)
      (MEM_FUTURE_SRC: Memory.future mem0_src mem1_src)
      (MEM_FUTURE_TGT: Memory.future mem0_tgt mem1_tgt),
      <<TERMINAL:
        forall (TERMINAL_TGT: Threads.is_terminal ths1_tgt),
        exists ths2_src sc2_src mem2_src,
          <<STEPS_SRC: rtc Configuration.tau_step (Configuration.mk ths1_src sc1_src mem1_src) (Configuration.mk ths2_src sc2_src mem2_src)>> /\
          <<SC: TimeMap.le sc2_src sc1_tgt>> /\
          <<MEMORY: sim_memory mem2_src mem1_tgt>> /\
          <<TERMINAL_SRC: Threads.is_terminal ths2_src>>>> /\
      <<STEP:
        forall e tid_tgt ths3_tgt sc3_tgt mem3_tgt
          (STEP_TGT: Configuration.step e tid_tgt (Configuration.mk ths1_tgt sc1_tgt mem1_tgt) (Configuration.mk ths3_tgt sc3_tgt mem3_tgt)),
        exists tid_src ths2_src sc2_src mem2_src ths3_src sc3_src mem3_src,
          <<STEPS_SRC: rtc Configuration.tau_step (Configuration.mk ths1_src sc1_src mem1_src) (Configuration.mk ths2_src sc2_src mem2_src)>> /\
          <<STEP_SRC: Configuration.opt_step e tid_src (Configuration.mk ths2_src sc2_src mem2_src) (Configuration.mk ths3_src sc3_src mem3_src)>> /\
          <<SC3: TimeMap.le sc3_src sc3_tgt>> /\
          <<MEMORY3: sim_memory mem3_src mem3_tgt>> /\
          <<SIM: sim ths3_src sc3_src mem3_src ths3_tgt sc3_tgt mem3_tgt>>>>.

  Lemma _sim_mon: monotone6 _sim.
  Proof.
    ii. exploit IN; try apply SC1; eauto. i. des.
    splits; eauto. i.
    exploit STEP; eauto. i. des.
    esplits; eauto.
  Qed.
  Hint Resolve _sim_mon: paco.

  Definition sim: SIM := paco6 _sim bot6.
End Simulation.
Hint Resolve _sim_mon: paco.

Lemma sim_future
      ths_src sc1_src sc2_src mem1_src mem2_src
      ths_tgt sc1_tgt sc2_tgt mem1_tgt mem2_tgt
      (SIM: sim ths_src sc1_src mem1_src ths_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future mem1_tgt mem2_tgt):
  sim ths_src sc2_src mem2_src ths_tgt sc2_tgt mem2_tgt.
Proof.
  pfold. ii.
  punfold SIM. exploit SIM; (try by etrans; eauto); eauto.
Qed.


Require Import VST.progs.conclib.
Require Import VST.progs.ghosts.
Require Import VST.progs.incr.

Global Open Scope funspec_scope.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Definition freelock_spec := DECLARE _freelock (freelock_spec _).
Definition spawn_spec := DECLARE _spawn spawn_spec.
Definition freelock2_spec := DECLARE _freelock2 (freelock2_spec _).
Definition release2_spec := DECLARE _release2 release2_spec.

Definition cptr_lock_inv g1 g2 ctr := EX z : Z, data_at Ews tuint (Vint (Int.repr z)) ctr *
  EX x : Z, EX y : Z, !!(z = x + y) && ghost_var gsh1 x g1 * ghost_var gsh1 y g2.

Definition incr_spec :=
 DECLARE _incr
  WITH sh : share, g1 : gname, g2 : gname, left : bool, n : Z, gv: globals
  PRE [ ]
         PROP  (readable_share sh)
         PARAMS () GLOBALS (gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 n (if left then g1 else g2))
  POST [ tvoid ]
         PROP ()
         LOCAL ()
         SEP (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 (n+1) (if left then g1 else g2)).

Definition read_spec :=
 DECLARE _read
  WITH sh : share, g1 : gname, g2 : gname, n1 : Z, n2 : Z, gv: globals
  PRE [ ]
         PROP  (readable_share sh)
         PARAMS () GLOBALS (gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 n1 g1; ghost_var gsh2 n2 g2)
  POST [ tuint ]
         PROP ()
         LOCAL (temp ret_temp (Vint (Int.repr (n1 + n2))))
         SEP (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr)); ghost_var gsh2 n1 g1; ghost_var gsh2 n2 g2).

Definition thread_lock_R sh g1 g2 ctr lockc :=
  lock_inv sh lockc (cptr_lock_inv g1 g2 ctr) * ghost_var gsh2 1 g1.

Definition thread_lock_inv sh g1 g2 ctr lockc lockt :=
  selflock (thread_lock_R sh g1 g2 ctr lockc) sh lockt.

Definition thread_func_spec :=
 DECLARE _thread_func
  WITH y : val, x : share * gname * gname * globals
  PRE [ (*_args OF*) (tptr tvoid) ]
         let '(sh, g1, g2, gv) := x in
         PROP  (readable_share sh)
         PARAMS (y) GLOBALS (gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g1 g2 (gv _ctr));
                ghost_var gsh2 0 g1;
                lock_inv sh (gv _thread_lock) (thread_lock_inv sh g1 g2 (gv _ctr) (gv _ctr_lock) (gv _thread_lock)))
  POST [ tptr tvoid ]
         PROP ()
         LOCAL ()
         SEP ().

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs :=   ltac:(with_library prog [acquire_spec; release_spec; release2_spec; makelock_spec;
  freelock_spec; freelock2_spec; spawn_spec; incr_spec; read_spec; thread_func_spec; main_spec]).

Lemma ctr_inv_exclusive : forall g1 g2 p,
  exclusive_mpred (cptr_lock_inv g1 g2 p).
Proof.
  intros; unfold cptr_lock_inv.
  eapply derives_exclusive, exclusive_sepcon1 with (Q := EX x : Z, EX y : Z, _),
    data_at__exclusive with (sh := Ews)(t := tuint); auto; simpl; try lia.
  Intro z; apply sepcon_derives; [cancel|].
  Intros x y; Exists x y; apply derives_refl.
Qed.
#[export] Hint Resolve ctr_inv_exclusive : core.

Lemma thread_inv_exclusive : forall sh g1 g2 ctr lock lockt,
  exclusive_mpred (thread_lock_inv sh g1 g2 ctr lock lockt).
Proof.
  intros; apply selflock_exclusive.
  unfold thread_lock_R.
  apply exclusive_sepcon1; auto.
Qed.
#[export] Hint Resolve thread_inv_exclusive : core.

Lemma body_incr: semax_body Vprog Gprog f_incr incr_spec.
Proof.
  start_function.
  forward.
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  unfold cptr_lock_inv at 2; simpl.
  Intros z x y.
  forward.
  forward.

  gather_SEP (ghost_var _ x g1) (ghost_var _ y g2) (ghost_var _ n _).
  rewrite sepcon_assoc.
  viewshift_SEP 0 (!!((if left then x else y) = n) && ghost_var Tsh (n+1) (if left then g1 else g2) *
    ghost_var gsh1 (if left then y else x) (if left then g2 else g1)).
  { go_lower.
    destruct left.
    - rewrite (sepcon_comm _ (ghost_var _ _ _)), <- sepcon_assoc.
      erewrite ghost_var_share_join' by eauto.
      Intros; rewrite prop_true_andp by auto; eapply derives_trans, bupd_frame_r; cancel.
      apply ghost_var_update.
    - erewrite ghost_var_share_join' by eauto.
      Intros; rewrite prop_true_andp by auto; eapply derives_trans, bupd_frame_r; cancel.
      apply ghost_var_update. }
  Intros; forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  { lock_props.
    unfold cptr_lock_inv; Exists (z + 1).
    erewrite <- ghost_var_share_join by eauto.
    unfold Frame; instantiate (1 := [ghost_var gsh2 (n+1) (if left then g1 else g2)]); simpl.
    destruct left.
    - Exists (n+1) y; entailer!.
    - Exists x (n+1); entailer!. }
  forward.
Qed.

Lemma body_read : semax_body Vprog Gprog f_read read_spec.
Proof.
  start_function.
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  unfold cptr_lock_inv at 2; simpl.
  Intros z x y.
  forward.
  assert_PROP (x = n1 /\ y = n2) as Heq.
  { gather_SEP (ghost_var _ x g1) (ghost_var _ n1 g1).
    erewrite ghost_var_share_join' by eauto.
    gather_SEP (ghost_var _ y g2) (ghost_var _ n2 g2).
    erewrite ghost_var_share_join' by eauto.
    entailer!. }
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g1 g2 (gv _ctr)).
  { lock_props.
    unfold cptr_lock_inv; Exists z x y; entailer!. }
  destruct Heq; forward.
Qed.

Lemma body_thread_func : semax_body Vprog Gprog f_thread_func thread_func_spec.
Proof.
  start_function.
  Intros.
  forward.
  forward_call (sh, g1, g2, true, 0, gv).
  simpl.
  forward_call ((gv _thread_lock), sh, thread_lock_R sh g1 g2 (gv _ctr) (gv _ctr_lock), thread_lock_inv sh g1 g2 (gv _ctr) (gv _ctr_lock) (gv _thread_lock)).
  { lock_props.
    unfold thread_lock_inv, thread_lock_R.
    rewrite selflock_eq at 2; cancel. }
  forward.
Qed.

Ltac cancel_for_forward_call ::=
  match goal with
  | gv: globals |- _ =>
    repeat
    match goal with
    | x := gv ?i |- context [gv ?i] =>
        change (gv i) with x
    end
  | _ => idtac
  end;
  cancel_for_evar_frame.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  set (ctr := gv _ctr); set (lockt := gv _thread_lock); set (lock := gv _ctr_lock).
  forward.
  forward.
  forward.
  ghost_alloc (ghost_var Tsh 0).
  Intro g1.
  ghost_alloc (ghost_var Tsh 0).
  Intro g2.
  forward_call (lock, Ews, cptr_lock_inv g1 g2 ctr).
  forward_call (lock, Ews, cptr_lock_inv g1 g2 ctr).
  { lock_props.
    rewrite <- !(ghost_var_share_join gsh1 gsh2 Tsh) by auto.
    unfold cptr_lock_inv; Exists 0 0 0; entailer!. }
  (* need to split off shares for the locks here *)
  destruct split_Ews as (sh1 & sh2 & ? & ? & Hsh).
  forward_call (lockt, Ews, thread_lock_inv sh1 g1 g2 ctr lock lockt).
  forward_spawn _thread_func nullval (sh1, g1, g2, gv).
  { erewrite <- lock_inv_share_join; try apply Hsh; auto.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto.
    entailer!. }
  forward_call (sh2, g1, g2, false, 0, gv).
  simpl.
  forward_call (lockt, sh2, thread_lock_inv sh1 g1 g2 ctr lock lockt).
  unfold thread_lock_inv at 2; unfold thread_lock_R.
  rewrite selflock_eq.
  Intros.
  forward_call (sh2, g1, g2, 1, 1, gv).
  (* We've proved that t is 2! *)
  forward_call (lock, sh2, cptr_lock_inv g1 g2 ctr).
  forward_call (lockt, Ews, sh1, thread_lock_R sh1 g1 g2 ctr lock, thread_lock_inv sh1 g1 g2 ctr lock lockt).
  { lock_props.
    unfold thread_lock_inv, thread_lock_R.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto; cancel. }
  forward_call (lock, Ews, cptr_lock_inv g1 g2 ctr).
  { lock_props.
    erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto; cancel. }
  forward.
Unshelve. apply xH. (*TODO: fix (I believe) the forward_spawn tactic  so that this ident is not introduces. Is it the y?*)
Qed.

Definition extlink := ext_link_prog prog.
Definition Espec := add_funspecs (Concurrent_Espec unit _ extlink) extlink Gprog.
Existing Instance Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
repeat (apply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | ]).
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons body_incr.
semax_func_cons body_read.
semax_func_cons body_thread_func.
semax_func_cons body_main.
Qed.


Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import Values.
Require Import Maps.
Require Import Integers.
Require Import AST.
Require Import Globalenvs.
Require Import Axioms.

Require Import mem_lemmas. (*needed for definition of mem_forward etc*)
Require Import semantics.
Require Import semantics_lemmas.
Require Import structured_injections.

(** * Effect Semantics *)

(** Effect semantics augment interaction semantics with effects, in the form
    of a set of locations [block -> Z -> bool] associated with each internal
    step of the semantics. *)

(** Unlike general interaction semantics, which are paremetric in the type of
    memory, effect semantics are specialized to CompCert memories. *)

Record EffectSem {G C} :=
  { (** [sem] is a cooperating interaaction semantics. *)
    sem :> CoopCoreSem G C

    (** The step relation of the new semantics. *)
  ; effstep: G -> (block -> Z -> bool) -> C -> mem -> C -> mem -> Prop

    (** The next three fields axiomatize [effstep] and its relation to the
        underlying step relation of [sem]. *)
  ; effax1: forall M g c m c' m',
       effstep g M c m c' m' ->
            corestep sem g c m c' m'
         /\ Mem.unchanged_on (fun b ofs => M b ofs = false) m m'
  ; effax2: forall g c m c' m',
       corestep sem g c m c' m' ->
       exists M, effstep g M c m c' m'
  ; effstep_valid: forall M g c m c' m',
       effstep g M c m c' m' ->
       forall b z, M b z = true -> Mem.valid_block m b
  }.

(** * Lemmas and auxiliary definitions *)

Section effsemlemmas.
  Context {G C:Type} (Sem: @EffectSem G C) (g:G).

  Lemma effstep_corestep: forall M g c m c' m',
      effstep Sem g M c m c' m' -> corestep Sem g c m c' m'.
  Proof. intros. apply effax1 in H. apply H. Qed.

  Lemma effstep_unchanged: forall M g c m c' m',
        effstep Sem g M c m c' m' ->
        Mem.unchanged_on (fun b ofs => M b ofs = false) m m'.
  Proof. intros. apply effax1 in H. apply H. Qed.

  Lemma effstep_fwd: forall U c m c' m',
    effstep Sem g U c m c' m' -> mem_forward m m'.
  Proof. intros. destruct Sem.
         eapply corestep_fwd. eapply effax1. apply H.
  Qed.

  Fixpoint effstepN (n:nat) : (block -> Z -> bool) -> C -> mem -> C -> mem -> Prop :=
    match n with
      | O => fun U c m c' m' => (c,m) = (c',m') /\ U = (fun b z => false)
      | S k => fun U c1 m1 c3 m3 => exists c2, exists m2, exists U1, exists U2,
        effstep Sem g U1 c1 m1 c2 m2 /\
        effstepN k U2 c2 m2 c3 m3 /\
        U = (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b))
    end.

Lemma effstepN_valid: forall n U c1 m1 c2 m2, effstepN n U c1 m1 c2 m2 ->
       forall b z, U b z = true -> Mem.valid_block m1 b.
Proof. intros n.
  induction n; simpl; intros. destruct H; subst. discriminate.
  destruct H as [c [m [U1 [U2 [Step [StepN UU]]]]]]; subst; simpl.
  specialize (IHn _ _ _ _ _ StepN).
  specialize (effstep_valid _ _ _ _ _ _ _ Step b z). intros.
  remember (U1 b z) as d.
  destruct d; simpl in *. apply H; trivial.
  destruct (valid_block_dec m1 b). trivial. simpl in *.
  rewrite andb_false_r in H0. inv H0.
Qed.

  Lemma effstepN_fwd: forall n U c m c' m',
    effstepN n U c m c' m' -> mem_forward m m'.
  Proof. intros n.
         induction n; intros; simpl in *. destruct H.
           inv H. eapply mem_forward_refl.
         destruct H as [c1 [c2 [Eff1 [Eff2 [Step1 [Step2 HU]]]]]].
         eapply mem_forward_trans.
           eapply effstep_fwd; eassumption.
           eapply IHn; eassumption.
  Qed.

  Lemma effstepN_corestepN: forall n E c m c' m',
      effstepN n E c m c' m' -> corestepN Sem g n c m c' m'.
  Proof. intros n.
    induction n; intros; simpl in *.
        apply H.
      destruct H as [c1 [m1 [U1 [U2 [Estep [EN HE]]]]]].
        apply effstep_corestep in Estep.
        apply IHn in EN. exists c1, m1.
        split; eassumption.
  Qed.

  Lemma effstepN_unchanged: forall n U c1 m1 c2 m2,
        effstepN n U c1 m1 c2 m2 ->
        Mem.unchanged_on (fun b z => U b z = false) m1 m2.
  Proof. intros n.
    induction n; simpl; intros.
      destruct H. inv H. apply Mem.unchanged_on_refl.
    rename c2 into c3. rename m2 into m3.
    destruct H as [c2 [m2 [E1 [E2 [Step1 [Step2 HE]]]]]].
    apply IHn in Step2; clear IHn. subst.
    assert (FWD:= effstep_fwd _ _ _ _ _ Step1).
    apply effstep_unchanged in Step1.
    split; intros.
     apply orb_false_iff in H. destruct H.
     remember (valid_block_dec m1 b) as v.
     destruct v; simpl in *; try contradiction.
     clear H0 Heqv.
     rewrite andb_true_r in H1.
     split; intros. apply Step2; trivial.
        apply (FWD _ v).
     apply Step1; try assumption.

     apply Step1; try assumption.
       apply Step2; try assumption.
        apply (FWD _ v).

   apply orb_false_iff in H. destruct H.
     remember (valid_block_dec m1 b) as v.
     destruct v; simpl in *; try contradiction.
     clear Heqv.
     rewrite andb_true_r in H1.
     destruct Step2. rewrite unchanged_on_contents; trivial.
       eapply Step1; try eassumption.
       eapply Step1; try eassumption.
     elim n0. eapply Mem.perm_valid_block; eassumption.
  Qed.

Lemma effstepN_trans: forall n1 n2 U1 st1 m1 st2 m2 U2 st3 m3,
      effstepN n1 U1 st1 m1 st2 m2 ->
      effstepN n2 U2 st2 m2 st3 m3 ->
   effstepN (n1+n2)
        (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) st1 m1 st3 m3.
Proof. intros n1.
induction n1; simpl.
  intros. destruct H; subst. inv H. simpl.
  assert (U2 = (fun b z => U2 b z && valid_block_dec m2 b)).
    extensionality b; extensionality z.
    remember (U2 b z) as d. destruct d; trivial.
    apply eq_sym in Heqd.
    apply (effstepN_valid _ _ _ _ _ _ H0) in Heqd.
    remember (valid_block_dec m2 b) as q.
    destruct q; trivial. contradiction.
  rewrite H in H0. apply H0.
intros. rename st3 into st4. rename m3 into m4.
   rename st2 into st3. rename m2 into m3.
   rename U1 into U. rename U2 into U3.
   destruct H as [st2 [m2 [U1 [U2 [Step1 [Step2 HU]]]]]].
   subst; simpl in *.
   exists st2, m2, U1; simpl.
   specialize (IHn1 _ _ _ _ _ _ _ _ _ Step2 H0).
   clear Step2 H0.
   eexists; split. assumption.
   split. eassumption.
   extensionality b; extensionality z; simpl.
   remember (U1 b z) as d. destruct d; simpl; trivial; apply eq_sym in Heqd.
   remember (U2 b z) as q. destruct q; simpl; trivial; apply eq_sym in Heqq.
     remember (valid_block_dec m1 b) as u.
     destruct u; trivial; simpl. apply andb_false_r.
   remember (U3 b z) as p. destruct p; simpl; trivial; apply eq_sym in Heqp.
     remember (valid_block_dec m1 b) as u.
     destruct u; trivial; simpl. clear Hequ. rewrite andb_true_r.
       apply effstep_fwd in Step1. apply Step1 in v.
       destruct (valid_block_dec m2 b); trivial. destruct v; contradiction.
     rewrite andb_false_r. trivial.
Qed.

Lemma effstepN_trans': forall n1 n2 U U1 st1 m1 st2 m2 U2 st3 m3,
      effstepN n1 U1 st1 m1 st2 m2 ->
      effstepN n2 U2 st2 m2 st3 m3 ->
      U = (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) ->
   effstepN (n1+n2) U st1 m1 st3 m3.
Proof. intros; subst. eapply effstepN_trans; eassumption. Qed.

  Definition effstep_plus U c m c' m' :=
    exists n, effstepN (S n) U c m c' m'.

  Definition effstep_star U c m c' m' :=
    exists n, effstepN n U c m c' m'.

  Lemma effstep_plus_star : forall U c1 c2 m1 m2,
    effstep_plus U c1 m1 c2 m2 -> effstep_star U c1 m1 c2 m2.
  Proof. intros. destruct H as [n1 H1]. eexists. apply H1. Qed.

  Lemma effstep_plus_trans : forall U1 c1 c2 c3 U2 m1 m2 m3,
    effstep_plus U1 c1 m1 c2 m2 -> effstep_plus U2 c2 m2 c3 m3 ->
    effstep_plus (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    exists ((n1 + (S n2))%nat). simpl.
    apply (effstepN_trans (S n1) (S n2) U1 c1 m1 c2 m2 U2 c3 m3 H1 H2).
  Qed.
  Lemma effstep_plus_trans' : forall U U1 c1 c2 c3 U2 m1 m2 m3,
    effstep_plus U1 c1 m1 c2 m2 -> effstep_plus U2 c2 m2 c3 m3 ->
    U = (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) ->
    effstep_plus U c1 m1 c3 m3.
  Proof. intros; subst. eapply effstep_plus_trans; eassumption. Qed.

  Lemma effstep_star_plus_trans : forall U1 c1 c2 c3 U2 m1 m2 m3,
    effstep_star U1 c1 m1 c2 m2 -> effstep_plus U2 c2 m2 c3 m3 ->
    effstep_plus (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    exists ((n1 + n2)%nat).
    specialize (effstepN_trans n1 (S n2) U1 c1 m1 c2 m2 U2 c3 m3 H1 H2); intros H.
    rewrite <- plus_n_Sm in H. assumption.
  Qed.
  Lemma effstep_star_plus_trans' : forall U U1 c1 c2 c3 U2 m1 m2 m3,
    effstep_star U1 c1 m1 c2 m2 -> effstep_plus U2 c2 m2 c3 m3 ->
    U = (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) ->
    effstep_plus U c1 m1 c3 m3.
  Proof. intros; subst. eapply effstep_star_plus_trans; eassumption. Qed.

  Lemma effstep_plus_star_trans: forall U1 c1 c2 c3 U2 m1 m2 m3,
    effstep_plus U1 c1 m1 c2 m2 -> effstep_star U2 c2 m2 c3 m3 ->
    effstep_plus (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    exists ((n1 + n2)%nat).
    apply (effstepN_trans _ _  U1 c1 m1 c2 m2 U2 c3 m3 H1 H2).
  Qed.
  Lemma effstep_plus_star_trans': forall U U1 c1 c2 c3 U2 m1 m2 m3,
    effstep_plus U1 c1 m1 c2 m2 -> effstep_star U2 c2 m2 c3 m3 ->
    U = (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) ->
    effstep_plus U c1 m1 c3 m3.
  Proof. intros; subst. eapply effstep_plus_star_trans; eassumption. Qed.

  Lemma effstep_star_trans: forall U1 c1 c2 c3 U2 m1 m2 m3,
    effstep_star U1 c1 m1 c2 m2 -> effstep_star U2 c2 m2 c3 m3 ->
    effstep_star (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    eexists.
    eapply (effstepN_trans _ _ U1 c1 m1 c2 m2 U2 c3 m3 H1 H2).
  Qed.
  Lemma effstep_star_trans': forall U U1 c1 c2 c3 U2 m1 m2 m3,
    effstep_star U1 c1 m1 c2 m2 -> effstep_star U2 c2 m2 c3 m3 ->
    U = (fun b z => U1 b z || (U2 b z && valid_block_dec m1 b)) ->
    effstep_star U c1 m1 c3 m3.
  Proof. intros; subst. eapply effstep_star_trans; eassumption. Qed.

  Lemma effstep_plus_one: forall U c m c' m',
    effstep Sem g U c m c' m' -> effstep_plus U c m c' m'.
  Proof. intros. exists O. simpl. exists c', m', U, (fun b z =>false).
    intuition.
    extensionality b; extensionality z; simpl.
    rewrite orb_false_r. trivial.
  Qed.

  Lemma effstep_plus_two: forall U1 c m c' m' U2 c'' m'',
    effstep  Sem g U1 c m c' m' -> effstep Sem g U2 c' m' c'' m'' ->
    effstep_plus (fun b z => U1 b z || (U2 b z && valid_block_dec m b)) c m c'' m''.
  Proof. intros.
    exists (S O). exists c', m', U1, U2. split; trivial.
    split; trivial. simpl.
    exists c'', m'', U2, (fun b z =>false).
    intuition.
    extensionality b; extensionality z; simpl.
    rewrite orb_false_r. trivial.
  Qed.

  Lemma effstep_star_zero: forall c m, effstep_star (fun b z =>false) c m c m.
  Proof. intros. exists O. simpl. split; reflexivity. Qed.

  Lemma effstep_star_one: forall U c m c' m',
    effstep  Sem g U c m c' m' -> effstep_star U c m c' m'.
  Proof. intros.
    exists (S O). exists c', m', U, (fun b z =>false).
    simpl; split; trivial. split. split; reflexivity.
    extensionality b; extensionality z; simpl.
    rewrite orb_false_r. trivial.
  Qed.

  Lemma effstep_plus_split: forall U c m c' m',
    effstep_plus U c m c' m' ->
    exists c'', exists m'', exists U1, exists U2,
      effstep Sem g U1 c m c'' m'' /\
      effstep_star U2 c'' m'' c' m' /\
      U = (fun b z => U1 b z || (U2 b z && valid_block_dec m b)).
  Proof. intros.
    destruct H as [n [c2 [m2 [U1 [U2 [Hstep [Hstar HU]]]]]]].
    exists c2, m2, U1, U2. split. assumption. split; try assumption.
    exists n. assumption.
  Qed.

  Lemma effstep_star_fwd: forall U c m c' m',
    effstep_star U c m c' m' -> mem_forward m m'.
  Proof. intros. destruct H as [n H].
      eapply effstepN_fwd; eassumption.
  Qed.

  Lemma effstep_plus_fwd: forall U c m c' m',
    effstep_plus U c m c' m' -> mem_forward m m'.
  Proof. intros. destruct H as [n H].
      eapply effstepN_fwd; eassumption.
  Qed.

End effsemlemmas.

Definition EmptyEffect: Values.block -> Z -> bool := fun b z => false.

Lemma EmptyEffect_alloc: forall m lo hi m' b (ALLOC: Mem.alloc m lo hi = (m', b)),
      Mem.unchanged_on (fun b ofs => EmptyEffect b ofs = false) m m'.
Proof. intros.
       eapply Mem.alloc_unchanged_on; eassumption.
Qed.

Definition FreeEffect m lo hi (sp b:Values.block) (ofs:Z): bool :=
   if valid_block_dec m b
   then eq_block b sp && zle lo ofs && zlt ofs hi
   else false.

Lemma FreeEffectD: forall m lo hi sp b z
   (FREE:FreeEffect m lo hi sp b z = true),
   b = sp /\ Mem.valid_block m b /\ lo <= z /\ z < hi.
Proof. intros.
  unfold FreeEffect in FREE.
  destruct (valid_block_dec m b); simpl in *; try discriminate.
  destruct (eq_block b sp); subst; simpl in *; try discriminate.
  destruct (zle lo z); simpl in *; try discriminate.
  destruct (zlt z hi); simpl in *; try discriminate.
  auto.
Qed.

Lemma FreeEffect_free: forall m sp lo hi m'
             (FREE: Mem.free m sp lo hi = Some m'),
     Mem.unchanged_on  (fun b ofs => FreeEffect m lo hi sp b ofs = false) m m'.
Proof. intros.
       eapply Mem.free_unchanged_on; try eassumption.
               intros. unfold FreeEffect; simpl. intros N.
               destruct (valid_block_dec m sp).
               apply andb_false_iff in N. destruct H.
               destruct (eq_block sp sp); simpl in *.
                 destruct N. destruct (zle lo i). inv H1. xomega.
               destruct (zlt i hi). inv H1. xomega.
               apply n; trivial.
               apply Mem.free_range_perm in FREE.
                 apply n; clear n.
                 eapply Mem.perm_valid_block.
                 eapply (FREE lo). omega.
Qed.

Definition FreelistEffect
  m (L: list (Values.block * Z * Z)) (b:Values.block) (ofs:Z): bool :=
  List.fold_right (fun X E b z => match X with (bb,lo,hi) =>
                                   E b z || FreeEffect m lo hi bb b z
                                 end)
                  EmptyEffect L b ofs.

Lemma FreelistEffect_Dfalse: forall m bb lo hi L b ofs
      (F:FreelistEffect m ((bb, lo, hi) :: L) b ofs = false),
      FreelistEffect m L b ofs = false /\
      FreeEffect m lo hi bb b ofs = false.
Proof. intros.
  unfold FreelistEffect in F. simpl in F.
  apply orb_false_iff in F. apply F.
Qed.

Lemma FreelistEffect_Dtrue: forall m bb lo hi L b ofs
      (F:FreelistEffect m ((bb, lo, hi) :: L) b ofs = true),
      FreelistEffect m L b ofs = true \/
      FreeEffect m lo hi bb b ofs = true.
Proof. intros.
  unfold FreelistEffect in F. simpl in F.
  apply orb_true_iff in F. apply F.
Qed.

Lemma FreelistEffect_same: forall m bb lo hi mm L
          (F:Mem.free m bb lo hi = Some mm)
          b (VB: Mem.valid_block mm b) ofs,
      FreelistEffect mm L b ofs = false <-> FreelistEffect m L b ofs = false.
Proof. intros  m bb lo hi mm L.
  induction L; simpl; intros. intuition.
  intuition.
    apply orb_false_iff in H0. destruct H0.
    specialize (H _ VB ofs).
    apply H in H0. rewrite H0. simpl. clear H H0.
    unfold FreeEffect in *; simpl in *.
    apply Mem.nextblock_free in F.
    destruct (valid_block_dec m b).
      destruct (valid_block_dec mm b); trivial.
      red in v. rewrite <- F in v. elim n. apply v.
    trivial.
  apply orb_false_iff in H0. destruct H0.
    specialize (H _ VB ofs).
    apply H in H0. rewrite H0. simpl. clear H H0.
    unfold FreeEffect in *; simpl in *.
    apply Mem.nextblock_free in F.
    destruct (valid_block_dec mm b).
      destruct (valid_block_dec m b); trivial.
      red in v. rewrite F in v. elim n. apply v.
    trivial.
Qed.

Lemma FreelistEffect_freelist: forall L m m' (FL: Mem.free_list m L = Some m'),
      Mem.unchanged_on (fun b ofs => FreelistEffect m L b ofs = false) m m'.
Proof. intros L.
  induction L; simpl; intros.
    inv FL. apply Mem.unchanged_on_refl.
  destruct a as [[bb lo] hi].
    remember (Mem.free m bb lo hi) as d.
    destruct d; try inv FL. apply eq_sym in Heqd.
    specialize (IHL _ _ H0).
    assert (FF:= FreeEffect_free _ _ _ _ _ Heqd).
    eapply (unchanged_on_trans _ m0 _).
      eapply mem_unchanged_on_sub; try eassumption.
        intuition. apply orb_false_iff in H. apply H.
      clear FF.
      specialize (unchanged_on_validblock_invariant m0 m'
           (fun (b : block) (ofs : Z) => FreelistEffect m0 L b ofs = false)
           (fun (b : block) (ofs : Z) => FreelistEffect m L b ofs = false)).
      intros. apply H in IHL. clear H.
        eapply mem_unchanged_on_sub; try eassumption.
        intuition. apply orb_false_iff in H. apply H.
      clear IHL H. intros.
       eapply FreelistEffect_same; eassumption.
   eapply free_forward; eassumption.
Qed.

Lemma FreeEffect_validblock: forall m lo hi sp b ofs
        (EFF: FreeEffect m lo hi sp b ofs = true),
      Mem.valid_block m b.
Proof. intros.
  unfold FreeEffect in EFF.
  destruct (valid_block_dec m b); trivial; inv EFF.
Qed.

Lemma FreelistEffect_validblock: forall l m b ofs
        (EFF: FreelistEffect m l b ofs = true),
      Mem.valid_block m b.
Proof. intros l.
  induction l; unfold FreelistEffect; simpl; intros.
     unfold EmptyEffect in EFF. inv EFF.
  destruct a as [[bb lo] hi].
  apply orb_true_iff in EFF.
  destruct EFF.
  apply IHl in H. assumption.
  eapply FreeEffect_validblock; eassumption.
Qed.

Definition StoreEffect (tv:val)(vl : list memval) (b:Values.block) (z:Z):bool :=
  match tv with Vptr bb ofs => eq_block bb b &&
             zle (Int.unsigned ofs) z && zlt z (Int.unsigned ofs + Z.of_nat (length vl))
         | _ => false
  end.

Lemma StoreEffect_Storev: forall m chunk tv tv' m'
         (STORE : Mem.storev chunk m tv tv' = Some m'),
      Mem.unchanged_on
        (fun b ofs => StoreEffect tv (encode_val chunk tv') b ofs = false)
        m m'.
Proof. intros.
  destruct tv; inv STORE.
  unfold StoreEffect.
  split; intros.
      split; intros. eapply Mem.perm_store_1; eassumption.
      eapply Mem.perm_store_2; eassumption.
  rewrite (Mem.store_mem_contents _ _ _ _ _ _ H0). clear H0.
  destruct (eq_block b b0); subst; simpl in *.
    rewrite PMap.gss. apply andb_false_iff in H.
    apply Mem.setN_outside.
    destruct H. destruct (zle (Int.unsigned i) ofs ); simpl in *. inv H.
                left. xomega.
    right. remember (Z.of_nat (length (encode_val chunk tv'))).
       destruct (zlt ofs (Int.unsigned i + z)); simpl in *. inv H. apply g.
  rewrite PMap.gso. trivial. intros N; subst. elim n; trivial.
Qed.

Lemma StoreEffectD: forall vaddr v b ofs
      (STE: StoreEffect vaddr v b ofs = true),
      exists i, vaddr = Vptr b i /\
        (Int.unsigned i) <= ofs < (Int.unsigned i + Z.of_nat (length v)).
Proof. intros.
  unfold StoreEffect in STE. destruct vaddr; inv STE.
  destruct (eq_block b0 b); inv H0.
  exists i.
  destruct (zle (Int.unsigned i) ofs); inv H1.
  destruct (zlt ofs (Int.unsigned i + Z.of_nat (length v))); inv H0.
  intuition.
Qed.