Require Import VST.floyd.proofauto.
Require Import VFA.Maps.
Require Import VFA.SearchTree.
Require Import WandDemo.SearchTree_ext.
Require Import WandDemo.bst.
Require Import WandDemo.bst_lemmas.
Require Import WandDemo.VST_lemmas.
Require Import WandDemo.spec_bst.

Lemma if_trueb: forall {A: Type} b (a1 a2: A), b = true -> (if b then a1 else a2) = a1.
Proof. intros; subst; auto. Qed.

Lemma if_falseb: forall {A: Type} b (a1 a2: A), b = false -> (if b then a1 else a2) = a2.
Proof. intros; subst; auto. Qed.

Ltac simpl_compb := first [ rewrite if_trueb by (apply NPeano.Nat.ltb_lt; rewrite Nat2Z.inj_lt; omega)
                          | rewrite if_falseb by (apply NPeano.Nat.ltb_nlt; rewrite Nat2Z.inj_lt; omega)].

Import PartialTreeRep_WandQFrame_Func_Hole.

Definition lookup_inv (p0: val) (t0: tree val) (x: nat): environ -> mpred :=
  EX p: val, EX t: tree val, EX P: tree val -> tree val,
  PROP(lookup nullval x t = lookup nullval x t0; P t = t0)
  LOCAL(temp _p p; temp _x (Vint (Int.repr (Z.of_nat x))))
  SEP(tree_rep t p; partial_tree_rep P p0 p).

Opaque tree_rep.
Arguments tree_rep: simpl never.

Lemma body_lookup: semax_body Vprog Gprog f_lookup lookup_spec.
Proof.
  start_function.
  unfold Map_rep.
  Intros t0.
  apply (semax_post'' (PROP () LOCAL (temp ret_temp (lookup nullval x t0)) SEP (tree_rep t0 p0))); auto.
  {
    unfold Map_rep.
    Exists t0.
    entailer!.
    symmetry; apply lookup_relate; auto.
  }
  clear H0 H1.
  forward_while (lookup_inv p0 t0 x).
  * (* precondition implies loop invariant *)
    Exists p0 t0 (fun t: tree val => t). entailer!.
    apply emp_partial_tree_rep_H.
  * (* type-check loop condition *)
    entailer!.
  * (* loop body preserves invariant *)
    destruct t; rewrite tree_rep_spec at 1. normalize.
    Intros qa qb.
    forward.
    forward_if; [ | forward_if ].
    + (* then clause: x<y *)
      forward. (* q=q<-left *)
      Exists (qa, t1, fun t1 => P (T t1 k v0 t2)). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; auto.
      - sep_apply (partial_tree_rep_singleton_left t2 k v0 p qa qb); auto.
        apply partial_tree_rep_partial_tree_rep.
    + (* else-then clause: y<x *)
      forward. (* q=q<-right *)
      Exists (qb,t2, fun t2 => P (T t1 k v0 t2)). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; simpl_compb; auto.
      - sep_apply (partial_tree_rep_singleton_right t1 k v0 p qa qb); auto.
        apply partial_tree_rep_partial_tree_rep.
    + (* else-else clause: x=y *)
      assert (x=k) by omega. subst x. clear H H4 H5.
      forward. (* v=q->value *)
      forward. (* return v; *)
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; simpl_compb; auto.
      - sep_apply (tree_rep_internal t1 k v0 t2 p qa qb); auto.
        apply tree_rep_partial_tree_rep.
  * (* after the loop *)
    forward. (* return NULL; *)
    entailer!.
    apply tree_rep_partial_tree_rep.
Qed.

Lemma body_turn_left: semax_body Vprog Gprog f_turn_left turn_left_spec.
Proof.
  start_function.
  rewrite (tree_rep_spec (T _ _ _ _)).
  Intros pb pc.
  forward. (* mid=r->left *)
  forward. (* l->right=mid *)
  forward. (* r->left=l *)
  forward. (* _l = r *)
  forward. (* return *)
  (* TODO: simplify the following proof *)
  Exists pc.
  entailer!.
  rewrite (tree_rep_spec (T _ _ _ _)).
  Exists pa pb.
  entailer!.
Qed.

Import PartialTreeboxRep_WandQFrame_Func_Hole.

Definition pushdown_left_inv (b_res: val) (t_res: tree val): environ -> mpred :=
  EX b: val, EX ta: tree val, EX x: nat, EX v: val, EX tb: tree val, EX P: tree val -> tree val,
  PROP  (P (pushdown_left ta tb) = t_res)
  LOCAL (temp _t b)
  SEP   (treebox_rep (T ta x v tb) b; partial_treebox_rep P b_res b).

Lemma body_pushdown_left: semax_body Vprog Gprog f_pushdown_left pushdown_left_spec.
Proof.
  start_function.
  forward_loop (pushdown_left_inv b (pushdown_left ta tb)).
  + (* Precondition *)
    unfold pushdown_left_inv.
    Exists b ta x v tb (fun t: tree val => t).
    entailer!.
    sep_apply (treebox_rep_internal ta x v tb b p); auto.
    entailer!.
    apply emp_partial_treebox_rep_H.
  + (* Loop body *)
    unfold pushdown_left_inv.
    clear x v H H0.
    Intros b0 ta0 x vx tbc0 P.
    rewrite treebox_rep_tree_rep.
    Intros p0.
    forward. (* p = *t; *)
    rewrite tree_rep_spec.
    Intros pa pbc.
    forward. (* q = p->right *)
    forward_if.
    - subst.
      assert_PROP (tbc0 = (@E _)).
        1: entailer!.
      subst.
      forward. (* q=p->left *)
      forward. (* *t=q *)
      forward_call (p0, sizeof t_struct_tree). (* freeN(p, sizeof ( *p )); *)
      {
        entailer!.
        rewrite memory_block_data_at_ by auto.
        cancel.
      }
      forward. (* return *)
      rewrite (tree_rep_spec E).
      rewrite <- H.
      eapply derives_trans; [| apply (treebox_rep_partial_treebox_rep _ _ b0)].
      entailer!.
      simpl.
      rewrite treebox_rep_tree_rep.
      Exists pa.
      cancel.
    - destruct tbc0 as [| tb0 y vy tc0].
        { rewrite (tree_rep_spec E). normalize. }
      forward_call (ta0, x, vx, tb0, y, vy, tc0, b0, p0, pa, pbc). (* turn_left(t, p, q); *)
      Intros pc.
      forward. (* t = &q->left; *) simpl in H.
      Exists (field_address t_struct_tree [StructField _left] pbc) ta0 x vx tb0 (fun t => P (T t y vy tc0)).
      entailer!.
      unfold_data_at (data_at _ _ _ pbc).
      rewrite (treebox_rep_tree_rep (T _ _ _ _)). Exists p0. rewrite (field_at_data_at _ _ [StructField _left]); cancel.
      eapply derives_trans; [| apply (partial_treebox_rep_partial_treebox_rep _ _ _ b0)].
      cancel.
      eapply derives_trans; [| apply partial_treebox_rep_singleton_left; auto].
      cancel.
      rewrite treebox_rep_tree_rep. Exists pc. rewrite field_at_data_at; cancel.
Qed.

Definition delete_inv (b0: val) (t0: tree val) (x: nat): environ -> mpred :=
  EX b: val, EX t: tree val, EX P: tree val -> tree val,
  PROP(P (delete x t) = delete x t0)
  LOCAL(temp _t b; temp _x (Vint (Int.repr (Z.of_nat x))))
  SEP(treebox_rep t b; partial_treebox_rep P b0 b).

Lemma body_delete: semax_body Vprog Gprog f_delete delete_spec.
Proof.
  start_function.
  forward_loop (delete_inv b t x).
  * (* Precondition *)
    unfold delete_inv.
    Exists b t (fun t: tree val => t). entailer!.
    apply emp_partial_treebox_rep_H.
  * (* Loop body *)
    unfold delete_inv.
    Intros b1 t1 P.
    rewrite treebox_rep_tree_rep. Intros p1.
    forward. (* p = *t; *)
    forward_if.
    + (* then clause *)
      subst p1.
      assert_PROP (t1= (@E _)).
        1: entailer!.
      subst t1. rewrite (tree_rep_spec E). rewrite !prop_true_andp by auto.
      forward. (* return; *)
      rewrite <- H0.
      eapply derives_trans; [| apply (treebox_rep_partial_treebox_rep _ _ b1); auto].
      cancel.
      rewrite treebox_rep_spec; Exists nullval; simpl.
      entailer!.
    + (* else clause *)
      destruct t1.
        { rewrite (tree_rep_spec E). normalize. }
      rewrite tree_rep_treebox_rep; Intros.
      clear H1.
      forward. (* y=p->key; *)
      forward_if; [ | forward_if ].
      - (* Inner if, then clause: x<k *)
        forward. (* t=&p->left *)
        unfold delete_inv.
        Exists (field_address t_struct_tree [StructField _left] p1) t1_1 (fun t => P (T t k v t1_2)).
        entailer!.
       ** rewrite <- H0.
          simpl; simpl_compb; auto.
       ** sep_apply (partial_treebox_rep_singleton_left t1_2 k v p1 b1); auto.
          apply partial_treebox_rep_partial_treebox_rep.
      - (* Inner if, second branch:  k<x *)
        forward. (* t=&p->right *)
        unfold delete_inv.
        Exists (field_address t_struct_tree [StructField _right] p1) t1_2 (fun t => P (T t1_1 k v t)).
        entailer!.
       ** rewrite <- H0.
          simpl; simpl_compb; simpl_compb; auto.
       ** sep_apply (partial_treebox_rep_singleton_right t1_1 k v p1 b1); auto.
          apply partial_treebox_rep_partial_treebox_rep.
      - (* Inner if, third branch: x=k *)
        assert (x=k) by omega.
        subst x.
        forward_call (t1_1, k, v, t1_2, b1, p1).
        forward. (* return *)
        rewrite <- H0.
        simpl; simpl_compb; simpl_compb.
        apply treebox_rep_partial_treebox_rep.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

   Some K Lemmas.

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_Ok_Lemmas Cyclone_LN_Types_Lemmas.
Require Export Cyclone_Fset_Lemmas Cyclone_Get_Lemmas.
Require Export Cyclone_WFD_Lemmas.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Lemma K_weakening:
  forall tau d,
    K d tau A ->
    forall d',
      WFD d ->
      extends d d' ->
      K d'     tau A.
Proof.
  introv Kempty.
  induction Kempty; try solve[auto].
  intros.
  apply_fresh K_utype; intros.
  assert(I: y \notin L); auto.
  intros.
  apply_fresh K_etype; intros.
  assert(I: y \notin L); auto.
Qed.

Lemma K_empty_var:
  forall v k,
    K empty (ftvar v) k -> False.
Proof.
  intros.
  inversions H.
  rewrite get_empty in H2.
  inversion H2.
  inversions H0.
  rewrite get_empty in H2.
  inversion H2.
Qed.
Hint Immediate K_empty_var.

(* I need a stronger lemma, = or to rewrite. *)

Lemma open_var_fv_eq : forall t n x,
    T.fv (T.open_rec n (ftvar x) t) = (T.fv t \u \{x}) \/
    T.fv (T.open_rec n (ftvar x) t) = (T.fv t).
Proof.
  intros t.
  induction t; intros; simpl; try case_nat; auto with fset;
  try solve[
        simpl;
        left;
        rewrite union_empty_l;
        auto with fset].
(* Bug ugly won't ltac. *)

  specialize(IHt1 n x);
  specialize(IHt2 n x);
  inversion IHt1; inversion IHt2;
  rewrite H; rewrite H0.
  left.
  rewrite <- union_assoc.
  rewrite <- union_assoc.
  rewrite* union_middle_shuffle.
  left.
  rewrite <- union_assoc.
  rewrite <- union_assoc.
  rewrite* union_middle_r.
  left.
  rewrite* <- union_assoc.
  right*.

  specialize(IHt1 n x);
  specialize(IHt2 n x);
  inversion IHt1; inversion IHt2;
  rewrite H; rewrite H0.
  left.
  rewrite <- union_assoc.
  rewrite <- union_assoc.
  rewrite* union_middle_shuffle.
  left.
  rewrite <- union_assoc.
  rewrite <- union_assoc.
  rewrite* union_middle_r.
  left.
  rewrite* <- union_assoc.
  right*.
Qed.

Lemma fv_var:
  forall A alpha tau (d : env A),
    alpha \notin T.fv tau ->
    T.fv tau \c \{ alpha} \u dom d ->
    T.fv tau \c dom d.
Proof.
  intros.
  induction tau; simpl; simpl in H; simpl in H0; auto with fset.
  assert(alpha <> v); auto.
  lets: subset_remove_r (fset Tau).
  apply subset_remove_r with (b:= alpha); auto.
  assert(alpha \notin T.fv tau1); auto.
  assert(alpha \notin T.fv tau2); auto.
  specialize (IHtau1 H1).
  specialize (IHtau2 H2).
  assert(H3 : (T.fv tau1 \u T.fv tau2 \c \{ alpha} \u dom d)); auto.
  apply subset_remove_l_r in H0.
  apply subset_remove_l_l in H3.
  auto with fset.

  assert(H3 : (T.fv tau1 \u T.fv tau2 \c \{ alpha} \u dom d)); auto.
  apply subset_remove_l_r in H0.
  apply subset_remove_l_l in H3.
  auto with fset.
Qed.

Lemma fv_var_2:
  forall A alpha tau (d : env A),
    alpha \notin T.fv tau ->
    T.fv tau \u \{ alpha} \c \{ alpha} \u dom d ->
    T.fv tau \c dom d.
Proof.
  intros.
  apply subset_remove_l_r in H0.
  apply fv_var with (alpha:= alpha); auto.
Qed.

Lemma K_fv:
  forall tau d k,
    WFD d ->
    K d tau k ->
    T.fv tau \c fv_delta d.
Proof.
(* BUG ugly, repetition, will not ltac *)
  introv WFDd Kd.
  induction Kd; assert(ok d); auto; try solve[simpl; auto with fset].

  pick_fresh alpha.
  assert(NI: alpha \notin L); auto.
  assert(OKda: ok(d & alpha ~ k)); auto.
  assert(WFDda: WFD(d & alpha ~k)); auto.
  specialize (H0 alpha NI OKda WFDda).
  lets: open_var_fv_eq tau 0 alpha.
  inversion H2.
  rewrite H3 in H0.
  unfold fv_delta.
  unfold fv_delta in H0.
  rewrite dom_push in H0.
  apply fv_var_2 with (alpha:=alpha); auto.
  rewrite H3 in H0.
  unfold fv_delta in H0.
  unfold fv_delta.
  apply fv_var with (alpha:= alpha); auto.
  unfold fv_delta in H0.
  unfold fv_delta.
  rewrite dom_push in H0.
  auto.

  pick_fresh alpha.
  assert(NI: alpha \notin L); auto.
  assert(OKda: ok(d & alpha ~ k)); auto.
  assert(WFDda: WFD(d & alpha ~k)); auto.
  specialize (H0 alpha NI OKda WFDda).
  lets: open_var_fv_eq tau 0 alpha.
  inversion H2.
  rewrite H3 in H0.
  unfold fv_delta.
  unfold fv_delta in H0.
  rewrite dom_push in H0.
  apply fv_var_2 with (alpha:=alpha); auto.
  rewrite H3 in H0.
  unfold fv_delta in H0.
  unfold fv_delta.
  apply fv_var with (alpha:= alpha); auto.
  unfold fv_delta in H0.
  unfold fv_delta.
  rewrite dom_push in H0.
  auto.
Qed.

Lemma K_empty_closed:
  forall tau k,
    K empty tau k ->
    T.fv tau = \{}.
Proof.
  intros.
  lets: K_fv tau (@empty Kappa).
  apply H0 in H.
  unfold fv_delta in H.
  rewrite dom_empty in H.
  apply contained_in_empty in H; auto.
  auto.
Qed.


Require config.
Require Import config_tactics.

Require Import syntax.
Require Import tt.
Require ptt ett.

Section Ptt2Ett.

Context `{configReflection : config.Reflection}.
Context `{configBinaryProdType : config.BinaryProdType}.
Context `{configProdEta : config.ProdEta}.
Context `{configUniverses : config.Universes}.
Context `{configPropType : config.PropType}.
Context `{configIdType : config.IdType}.
Context `{configIdEliminator : config.IdEliminator}.
Context `{configEmptyType : config.EmptyType}.
Context `{configUnitType : config.UnitType}.
Context `{configBoolType : config.BoolType}.
Context `{configProdType : config.ProdType}.
Context `{configSyntax : syntax.Syntax}.

Fixpoint sane_isctx G (P : ptt.isctx G) : ett.isctx G

with sane_issubst sbs G D (P : ptt.issubst sbs G D) {struct P} : ett.issubst sbs G D

with sane_istype G A (P : ptt.istype G A) {struct P} : ett.istype G A

with sane_isterm G u A (P : ptt.isterm G u A) {struct P} : ett.isterm G u A

with sane_eqctx G D (P : ptt.eqctx G D) {struct P} : ett.eqctx G D

with sane_eqsubst sbs sbt G D (P : ptt.eqsubst sbs sbt G D) {struct P} : ett.eqsubst sbs sbt G D

with sane_eqtype G A B (P : ptt.eqtype G A B) {struct P} : ett.eqtype G A B

with sane_eqterm G u v A (P : ptt.eqterm G u v A) {struct P} : ett.eqterm G u v A.

Proof.
  all:unfold ett.isctx in *.
  all:unfold ett.issubst in *.
  all:unfold ett.istype in *.
  all:unfold ett.isterm in *.
  all:unfold ett.eqctx in *.
  all:unfold ett.eqsubst in *.
  all:unfold ett.eqtype in *.
  all:unfold ett.eqterm in *.

  (* sane_isctx *)
  - { destruct P; doConfig.
      - now apply CtxEmpty.
      - capply CtxExtend. auto.
    }

  (* sane_issubst *)
  - { destruct P; doConfig.

      (* SubstZero *)
      - capply SubstZero ; auto.

      (* SubstWeak *)
      - capply SubstWeak ; auto.

      (* SubstShift *)
      - { capply SubstShift ; auto. }

      (* SubstId *)
      - capply SubstId ; auto.

      (* SubstComp *)
       - { config apply @SubstComp with (D := D) ; auto. }

       (* SubstTerminal *)
       - { capply SubstTerminal ; auto. }

      (* SubstCtxConv *)
      - { config apply @SubstCtxConv with (G1 := G1) (D1 := D1) ; auto. }
  }

  (* sane_istype *)
  - { destruct P; doConfig.

      (* TyCtxConv *)
      - config apply @TyCtxConv with (G := G) ; auto.

      (* TySubst *)
      - config apply @TySubst with (D := D) ; auto.

      (* TyProd *)
      - capply TyProd ; auto.

      (* TyId *)
      - capply TyId ; auto.

      (* TyEmpty *)
      - capply TyEmpty ; auto.

      (* TyUnit *)
      - capply TyUnit ; auto.

      (* TyBool *)
      - capply TyBool ; auto.

      (* TyBinaryProd *)
      - capply TyBinaryProd ; auto.

      (* TyUni *)
      - capply TyUni ; auto.

      (* TyEl *)
      - ceapply TyEl ; eauto.
  }

  (* sane_isterm *)
  - { destruct P; doConfig.

      (* TermTyConv *)
       - apply @TermTyConv with (A := A) ; auto.

      (* TermCtxConv *)
      - apply @TermCtxConv with (G := G) ; auto.

      (* TermSubst *)
      - apply @TermSubst with (D := D) ; auto.

      (* TermVarZero *)
      - apply TermVarZero ; auto.

      (* TermVarSucc *)
      - apply TermVarSucc ; auto.

      (* TermAbs *)
      - apply TermAbs ; auto.

      (* TermApp *)
      - apply TermApp ; auto.

      (* TermRefl *)
      - apply TermRefl ; auto.

      (* TermJ *)
      - apply TermJ ; auto.

      (* TermExfalso *)
      - apply TermExfalso ; auto.

      (* TermUnit *)
      - apply TermUnit ; auto.

      (* TermTrue *)
      - apply TermTrue ; auto.

      (* TermFalse *)
      - apply TermFalse ; auto.

      (* TermCond *)
      - apply TermCond ; auto.

      (* TermPair *)
      - apply TermPair ; auto.

      (* TermProjOne *)
      - apply TermProjOne ; auto.

      (* TermProjTwo *)
      - apply TermProjTwo ; auto.

      (* TermUniProd *)
      - apply TermUniProd ; auto.

      (* TermUniProdProp *)
      - apply TermUniProdProp ; auto.

      (* TermUniId *)
      - apply TermUniId ; auto.

      (* TermUniEmpty *)
      - apply TermUniEmpty ; auto.

      (* TermUniUnit *)
      - apply TermUniUnit ; auto.

      (* TermUniBool *)
      - apply TermUniBool ; auto.

      (* TermUniBinaryProd *)
      - apply TermUniBinaryProd ; auto.

      (* TermUniBinaryProdProp *)
      - apply TermUniBinaryProdProp ; auto.

      (* TermUniUni *)
      - apply TermUniUni ; auto.

      (* TermUniProp *)
      - apply TermUniProp ; auto.
  }

  (* sane_eqctx *)
  - { destruct P; doConfig.

      (* CtxRefl *)
      - apply CtxRefl ; auto.

      (* CtxSym *)
      - apply CtxSym ; auto.

      (* CtxTrans *)
      - apply @CtxTrans with (D := D) ; auto.

      (* EqCtxEmpty *)
      - apply CtxRefl, CtxEmpty.

      (* EqCtxExtend *)
      - apply EqCtxExtend ; auto.
  }

  (* sane_eqsubst *)
  - { destruct P; doConfig.

      (* SubstRefl *)
      - apply SubstRefl ; auto.

      (* SubstSym *)
      - apply SubstSym ; auto.

      (* SubstTrans *)
      - apply @SubstTrans with (sb2 := sb2) ; auto.

      (* CongSubstZero *)
      - apply @CongSubstZero with (G := G) ; auto.

      (* CongSubstWeak *)
      - apply CongSubstWeak ; auto.

      (* CongSubstShift *)
      - apply CongSubstShift ; auto.

      (* CongSubstComp *)
      - apply @CongSubstComp with (D := D) ; auto.

      (* EqSubstCtxConv *)
      - apply @EqSubstCtxConv with (G1 := G1) (D1 := D1) ; auto.

      (* CompAssoc *)
      - apply @CompAssoc with (D := D) (E := E) ; auto.

      (* WeakNat *)
      - apply WeakNat ; auto.

      (* WeakZero *)
      - apply WeakZero ; auto.

      (* ShiftZero *)
      - apply ShiftZero ; auto.

      (* CompShift *)
      - apply @CompShift with (D := D) ; auto.

      (* CompIdRight *)
      - apply CompIdRight ; auto.

      (* CompIdLeft *)
      - apply CompIdLeft ; auto.
  }

  (* sane_eqtype *)
  - { destruct P; doConfig.

      (* EqTyCtxConv *)
      - apply @EqTyCtxConv with (G := G) ; auto.

      (* EqTyRefl*)
      - apply EqTyRefl ; auto.

      (* EqTySym *)
      - apply EqTySym ; auto.

      (* EqTyTrans *)
      - apply @EqTyTrans with (B := B) ; auto.

      (* EqTyIdSubst *)
      - apply EqTyIdSubst ; auto.

      (* EqTySubstComp *)
      - apply @EqTySubstComp with (D := D) (E := E) ; auto.

      (* EqTySubstProd *)
      - apply @EqTySubstProd with (D := D) ; auto.

      (* EqTySubstId *)
      - apply @EqTySubstId with (D := D) ; auto.

      (* EqTySubstEmpty *)
      - apply @EqTySubstEmpty with (D := D) ; auto.

      (* EqTySubstUnit *)
      - apply @EqTySubstUnit with (D := D) ; auto.

      (* EqTySubstBool *)
      - apply @EqTySubstBool with (D := D) ; auto.

      (* EqTyExfalso *)
      - apply @EqTyExfalso with (u := u) ; auto.

      (* CongProd *)
      - apply CongProd ; auto.

      (* CongId *)
      - apply CongId ; auto.

      (* CongTySubst *)
      - apply @CongTySubst with (D := D) ; auto.

      (* CongBinaryProd *)
      - apply CongBinaryProd ; auto.

      (* EqTySubstBinaryProd *)
      - apply @EqTySubstBinaryProd with (D := D) ; auto.

      (* EqTySubstUni *)
      - apply @EqTySubstUni with (D := D) ; auto.

      (* ElProd *)
      - eapply ElProd ; eauto.

      (* ElProdProp *)
      - eapply ElProdProp ; eauto.

      (* ElId *)
      - eapply ElId ; eauto.

      (* ElSubst *)
      - eapply ElSubst ; eauto.

      (* ElEmpty *)
      - eapply ElEmpty ; eauto.

      (* ElUnit *)
      - eapply ElUnit ; eauto.

      (* ElBool *)
      - eapply ElBool ; eauto.

      (* ElBinaryProd *)
      - eapply ElBinaryProd ; eauto.

      (* ElBinaryProdProp *)
      - eapply ElBinaryProdProp ; eauto.

      (* ElUni *)
      - apply ElUni ; auto.

      (* ElProp *)
      - apply ElProp ; auto.

      (* CongEl *)
      - eapply CongEl ; eauto.
  }

  (* sane_eqterm *)
  - { destruct P ; doConfig.

      (* EqTyConv *)
      - apply @EqTyConv with (A := A) ; auto.

      (* EqCtxConv *)
      - apply @EqCtxConv with (G := G) ; auto.

      (* EqRefl *)
      - apply EqRefl ; auto.

      (* EqSym *)
      - apply EqSym ; auto.

      (* EqTrans *)
      - apply @EqTrans with (v := v) ; auto.

      (* EqIdSubst *)
      - apply EqIdSubst ; auto.

      (* EqSubstComp *)
      - apply @EqSubstComp with (D := D) (E := E) ; auto.

      (* EqSubstWeak *)
      - apply EqSubstWeak ; auto.

      (* EqSubstZeroZero *)
      - apply EqSubstZeroZero ; auto.

      (* EqSubstZeroSucc *)
      - apply EqSubstZeroSucc ; auto.

      (* EqSubstShiftZero *)
      - apply @EqSubstShiftZero with (D := D) ; auto.

      (* EqSubstShiftSucc *)
      - apply @EqSubstShiftSucc with (D := D) ; auto.

      (* EqSubstAbs *)
      - apply @EqSubstAbs with (D := D) ; auto.

      (* EqSubstApp *)
      - apply @EqSubstApp with (D := D) ; auto.

      (* EqSubstRefl *)
      - apply @EqSubstRefl with (D := D) ; auto.

      (* EqSubstJ *)
      - apply @EqSubstJ with (D := D) ; auto.

     (* This rule is subsumed by EqTermExfalso *)
      (* EqSubstExfalso *)
      - apply @EqSubstExfalso with (D := D) ; auto.

      (* EqSubstUnit *)
      - apply @EqSubstUnit with (D := D) ; auto.

      (* EqSubstTrue *)
      - apply @EqSubstTrue with (D := D) ; auto.

      (* EqSubstFalse *)
      - apply @EqSubstFalse with (D := D) ; auto.

      (* EqSubstCond *)
      - apply @EqSubstCond with (D := D) ; auto.

      (* EqTermExfalso *)
      - apply @EqTermExfalso with (w := w) ; auto.

      (* UnitEta *)
      - apply UnitEta ; auto.

      (* EqReflection *)
      - apply @EqReflection with (p := p) ; auto.

      (* ProdBeta *)
      - apply ProdBeta ; auto.

      (* CondTrue *)
      - apply CondTrue ; auto.

      (* CondFalse *)
      - apply CondFalse ; auto.

      (* ProdEta *)
      - apply ProdEta ; auto.

      (* JRefl *)
      - apply JRefl ; auto.

      (* CongAbs *)
      - apply CongAbs ; auto.

      (* CongApp *)
      - apply CongApp ; auto.

      (* CongRefl *)
      - apply CongRefl ; auto.

      (* CongJ *)
      - apply CongJ ; auto.

      (* CongCond *)
      - apply CongCond ; auto.

      (* CongTermSubst *)
      - apply @CongTermSubst with (D := D) ; auto.

      (* CongPair *)
      - apply CongPair ; auto.

      (* CongProjOne *)
      - apply CongProjOne ; auto.

      (* CongProjTwo *)
      - apply CongProjTwo ; auto.

      (* EqSubstPair *)
      - apply @EqSubstPair with (D := D) ; auto.

      (* EqSubstProjOne *)
      - apply @EqSubstProjOne with (D := D) ; auto.

      (* EqSubstProjTwo *)
      - apply @EqSubstProjTwo with (D := D) ; auto.

      (* ProjOnePair *)
      - apply ProjOnePair ; auto.

      (* ProjTwoPair *)
      - apply ProjTwoPair ; auto.

      (* PairEta *)
      - apply PairEta ; auto.

      (* EqSubstUniProd *)
      - apply @EqSubstUniProd with (D := D) ; auto.

      (* EqSubstUniProdProp *)
      - apply @EqSubstUniProdProp with (D := D) ; auto.

      (* EqSubstUniId *)
      - apply @EqSubstUniId with (D := D) ; auto.

      (* EqSubstUniEmpty *)
      - apply @EqSubstUniEmpty with (D := D) ; auto.

      (* EqSubstUniUnit *)
      - apply @EqSubstUniUnit with (D := D) ; auto.

      (* EqSubstUniBool *)
      - apply @EqSubstUniBool with (D := D) ; auto.

      (* EqSubstUniBinaryProd *)
      - apply @EqSubstUniBinaryProd with (D := D) ; auto.

      (* EqSubstUniBinaryProdProp *)
      - apply @EqSubstUniBinaryProdProp with (D := D) ; auto.

      (* EqSubstUniUni *)
      - apply @EqSubstUniUni with (D := D) ; auto.

      (* EqSubstUniProp *)
      - apply @EqSubstUniProp with (D := D) ; auto.

      (* CongUniProd *)
      - apply CongUniProd ; auto.

      (* CongUniProdProp *)
      - apply CongUniProdProp ; auto.

      (* CongUniId *)
      - apply CongUniId ; auto.

      (* CongUniBinaryProd *)
      - apply CongUniBinaryProd ; auto.

      (* CongUniBinaryProdProp *)
      - apply CongUniBinaryProdProp ; auto.
    }
Defined.

End Ptt2Ett.


Require Export MinBFTinv.
Require Export MinBFTprops2.
Require Export MinBFTrun.

Section MinBFTass_new.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Opaque KE_TOWNS.
  Opaque KE_ID_BEFORE.

  Lemma ASSUMPTION_generates_new_true :
    forall (eo : EventOrdering), assume_eo eo ASSUMPTION_generates_new_ex.
  Proof.
    introv h; simpl in *.
    allrw interp_KE_ID_BEFORE.
    unfold ui_has_counter in h.
    repnd; GC; subst.

    unfold id_before, id_after in *; simpl; exrepnd; subst.
    rename mem0 into mem1.
    rename mem into mem2.
    simpl in *.
    unfold trusted_state_before, trusted_state_after in *; simpl in *.
    exrepnd.
    rewrite h2 in h1; ginv.
    rewrite h2 in h0; ginv.
    unfold disseminate_data in *; exrepnd; simpl in *.

    unfold M_byz_state_sys_on_event in *; simpl in *.
    unfold M_byz_state_sys_before_event in *; simpl in *.
    unfold M_byz_output_sys_on_event in *.
    revert dependent o.
    rewrite h2 in *; simpl in *.
    introv out dout.

    applydup preserves_usig_id in h4 as eqid; auto;[].

    (*pose proof (M_byz_compose_step_trusted e (MinBFTlocalSys c2) (incr_n_proc (USIG_comp c2))) as h.
    repeat (autodimp h hyp); eauto 3 with minbft.
    exrepnd; simpl in *.*)

    rewrite M_byz_output_ls_on_event_as_run in out; simpl in *.

    apply map_option_Some in h4; exrepnd; rev_Some; simpl in *; minbft_simp.
    apply map_option_Some in h5; exrepnd; rev_Some; simpl in *; minbft_simp.

    rewrite M_byz_run_ls_on_event_unroll2 in h1; simpl in *.

    match goal with
    | [ H : context[M_byz_run_ls_before_event ?ls ?e] |- _ ] =>
      remember (M_byz_run_ls_before_event ls e) as run; symmetry in Heqrun
    end.
    apply M_byz_run_ls_before_event_ls_is_minbft in Heqrun.
    repndors; exrepnd; subst; simpl in *.

    { unfold M_byz_output_ls_on_this_one_event in *; simpl in *.
      unfold M_byz_run_ls_on_this_one_event in *; simpl in *.
      unfold M_byz_run_ls_on_one_event in *; simpl in *.
      unfold M_byz_run_ls_on_input in *; simpl in *.
      unfold data_is_in_out, event2out in *; simpl in *.

      remember (trigger e) as trig; symmetry in Heqtrig.
      destruct trig; simpl in *; tcsp.

      { match goal with
        | [ H : context[M_run_ls_on_input ?ls ?cn ?i] |- _ ] =>
          remember (M_run_ls_on_input ls cn i) as oni; symmetry in Heqoni
        end.
        repnd; simpl in *; subst; simpl in *; minbft_simp.
        applydup (M_run_ls_on_input_ls_is_minbft_new (msg_comp_name 0)) in Heqoni.
        exrepnd; subst; simpl in *; ginv; simpl in *.
        apply in_flat_map in dout; exrepnd; simpl in *.

        unfold M_run_ls_on_input in *; simpl in *.
        autorewrite with minbft in *; simpl in *.

        Time minbft_dest_msg Case;
          repeat (simpl in *; autorewrite with minbft in *; smash_minbft2); repndors; smash_minbft2;
            unfold lower_out_break in *; simpl in *; minbft_simp;
            repeat (repndors; ginv; subst; tcsp; simpl in *; tcsp);
            unfold ui_has_counter, ui2counter, state_of_trusted in *; simpl in *;
              try (eexists; dands;[| | |right;eauto|]; simpl; auto; try omega);
              try (rename_hyp_with invalid_prepare inv);
              try (complete (eapply data_is_owned_by_invalid_prepare_implies_false in inv; eauto; tcsp));
              try (rename_hyp_with invalid_commit invc);
              try (eapply data_is_owned_by_invalid_commit_not_pil_implies_false in invc; eauto; tcsp);
              remember (usig_counters u) as K; destruct K; simpl in *; tcsp;
                destruct n; simpl in *; tcsp; try omega;
                  try (complete (f_equal; apply Max.max_l; try omega));
                  try (complete (left; dands; try omega; apply les_reflexive));
                  try (complete (left; dands; try apply les_reflexive; apply lt_n_S; apply Nat.max_lt_iff; left; try omega)). }

      { pose proof (snd_M_run_ls_on_trusted_incr_n_procs_eq (USIGlocalSys u) i) as z.
        unfold LocalSystem in *; simpl in *; rewrite z in out; clear z.
        rewrite rw_M_run_ls_on_trusted_USIGlocalSys in out.
        destruct i as [cn i]; simpl in *; dest_cases w;[].
        subst; simpl in *.
        destruct i; repnd; repeat (simpl in *; repndors; ginv; tcsp).
        unfold ui_has_counter, ui2counter, state_of_trusted in *; simpl in *.
        eexists; dands;[| | |right;eauto|]; simpl; auto; try omega; eauto 3 with minbft. } }

    { unfold M_byz_output_ls_on_this_one_event in *; simpl in *.
      unfold M_byz_run_ls_on_this_one_event in *; simpl in *.
      unfold M_byz_run_ls_on_one_event in *; simpl in *.
      unfold M_byz_run_ls_on_input in *; simpl in *.
      unfold data_is_in_out, event2out in *; simpl in *.

      remember (trigger e) as trig; symmetry in Heqtrig.
      destruct trig; simpl in *; tcsp;[].

      pose proof (snd_M_run_ls_on_trusted_incr_n_procs_eq (USIGlocalSys u) i) as z.
      unfold LocalSystem in *; simpl in *; rewrite z in out; clear z.
      rewrite rw_M_run_ls_on_trusted_USIGlocalSys in out.
      destruct i as [cn i]; simpl in *; dest_cases w;[].
      subst; simpl in *.
      destruct i; repnd; repeat (simpl in *; repndors; ginv; tcsp).
      unfold ui_has_counter, ui2counter, state_of_trusted in *; simpl in *.
      eexists; dands;[| | |right;eauto|]; simpl; auto; try omega; eauto 3 with minbft. }
  Qed.
  Hint Resolve ASSUMPTION_generates_new_true : minbft.

End MinBFTass_new.

Hint Resolve ASSUMPTION_generates_new_true : minbft.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import RVIC.Specs.is_trusted_intid.
Require Import RVIC.LowSpecs.is_trusted_intid.
Require Import RVIC.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Lemma is_trusted_intid_spec_exists:
    forall habd  labd intid res
      (Hspec: is_trusted_intid_spec intid habd = Some res)
      (Hrel: relate_RData habd labd),
      is_trusted_intid_spec0 intid labd = Some res.
  Proof.
    intros. inv Hrel.
    unfold is_trusted_intid_spec, is_trusted_intid_spec0 in *.
    repeat hsimpl_hyp Hspec; bool_rel_all; repeat destruct_dis; inv Hspec;
      repeat simpl_htarget; reflexivity.
  Qed.

End Refine.


From sflib Require Import sflib.
From Paco Require Import paco.
Require Import Program.
Require Import Arith.
Require Import Permutation.
Require Import SetoidList.
Require Import SetoidPermutation.
Require Import Lists.List.
Require Import Lia.
From Fairness Require Import
  Mod
  FairSim
  Concurrency
  FIFOSched
  SchedSim.
From ExtLib Require Import FMapAList.

Section SIM.

  Context {_Ident : ID}.

  Variable wf : WF.
  Variable State : Type.
  Variable R : Type.

  Let thread R := thread _Ident (sE State) R.
  Import Th.

  Theorem ssim_nondet_fifo
    p_src p_tgt tid ths_src ths_tgt
    (THREADS : Permutation (TIdSet.elements ths_src) ths_tgt)
    (TID : ~ NatMap.In tid ths_src)
    : forall m_tgt, exists m_src, @ssim nat_wf nat_wf R R R eq p_src m_src p_tgt m_tgt
                          (sched_nondet R (tid, ths_src))
                          (sched_fifo R (tid, ths_tgt)).
  Proof.
    i.

    remember (fun (i : thread_id) => List.length ths_tgt + 1) as m_src.
    assert (M_SRC0 : m_src tid > List.length ths_tgt) by (subst; lia).
    assert (M_SRC1 : forall i tid, nth_error ths_tgt i = Some tid -> m_src tid > i).
    { subst. i. eapply nth_error_Some' in H. lia. }
    clear Heqm_src.
    exists m_src.

    revert p_src p_tgt m_src m_tgt tid ths_src ths_tgt THREADS TID M_SRC0 M_SRC1.
    pcofix CIH. i.

    rewrite unfold_sched_nondet.
    rewrite unfold_sched_fifo.
    rewrite ! bind_trigger.
    pfold. econs. intros [].
    - left.
      destruct (NatMap.is_empty ths_src) eqn: H.
      + eapply NatMap.is_empty_2 in H.
        eapply Empty_nil in H.
        rewrite H in THREADS.
        eapply Permutation_nil in THREADS.
        subst ths_tgt.
        pfold. econs; ss.
      + assert (~ TIdSet.Empty ths_src).
        { ii. eapply NatMap.is_empty_1 in H0. rewrite H in H0; ss. }
        clear H. eapply Empty_nil_neg in H0.
        destruct ths_tgt as [| tid' ths_tgt' ].
        { symmetry in THREADS. eapply Permutation_nil in THREADS. ss. }
        pfold. eapply ssim_chooseL. exists tid'. unfold nm_pop.
        replace (NatMap.find tid' ths_src) with (Some tt); cycle 1.
        { symmetry. eapply find_1. eapply NatSet_In_MapsTo. eapply In_NatSetIn.
          rewrite THREADS. econs; ss.
        }
        rewrite bind_trigger.
        eapply ssim_fairL.
        remember (fun i => if Nat.eq_dec i tid'
                        then List.length ths_tgt' + 1
                        else if NatMapP.F.In_dec (NatMap.remove tid' ths_src) i
                             then m_src i - 1
                             else m_src i) as m_src'.
        exists m_src'. splits.
        { ii. unfold tids_fmap; ss. des_ifs.
          assert (List.In i (TIdSet.elements ths_src)).
          { eapply NatSetIn_In. eapply NatMapP.F.remove_neq_in_iff with (x := tid'). eauto. ss. }
          rewrite THREADS in H. eapply In_nth_error in H. destruct H as [i' H].
          enough (m_src i > i') by lia. eapply M_SRC1; eauto.
        }
        do 3 econs; eauto. right. eapply CIH.
        * eapply NatSet_Permutation_remove. eapply THREADS.
        * eapply NatMap.remove_1; ss.
        * subst. des_if; ss. lia.
        * subst. i. des_if.
          -- eapply nth_error_Some' in H. lia.
          -- enough (m_src tid0 > 1 + i) by (des_if; lia). eapply M_SRC1. eauto.
    - left.
      match goal with
      | [ |- paco10 _ _ _ _ _ _ _ _ _ _ _ (match ?x with
                                          | [] => _
                                          | t' :: ts' => _
                                          end)] => destruct x as [| tid' ths_tgt'] eqn: E_ths_tgt
      end.
      { eapply app_eq_nil in E_ths_tgt. des. ss. }
      pfold. eapply ssim_chooseL. exists tid'. unfold nm_pop.
      replace (NatMap.find tid' (TIdSet.add tid ths_src)) with (Some tt); cycle 1.
      { symmetry. eapply find_1.
        destruct ths_tgt; ss; inversion E_ths_tgt; subst.
        - eapply NatMap.add_1; ss.
        - eapply NatMap.add_2.
          + intro. subst. eapply TID. eapply In_NatSetIn. rewrite THREADS. econs; ss.
          + eapply NatSet_In_MapsTo. eapply In_NatSetIn. rewrite THREADS. econs; ss.
      }
      rewrite bind_trigger. eapply ssim_fairL.
      remember (fun i => if Nat.eq_dec i tid'
                      then List.length ths_tgt' + 1
                      else if NatMapP.F.In_dec (NatMap.remove tid' (NatSet.add tid ths_src)) i
                           then m_src i - 1
                           else m_src i) as m_src'.
      exists m_src'. splits.
      { ii. unfold tids_fmap; ss. des_ifs.
        assert (i = tid \/ i <> tid) by lia. destruct H; try (subst; lia).
        assert (List.In i (TIdSet.elements ths_src)).
        { eapply NatSetIn_In. exists tt. eapply NatSet_In_MapsTo, NatMap.remove_3, NatMap.add_3 in i0; eauto. }
        rewrite THREADS in H0. eapply In_nth_error in H0. destruct H0 as [i' H0].
        enough (m_src i > i') by lia. eapply M_SRC1; eauto.
      }
      do 3 econs; ss. right. unfold NatMap.key in *. eapply CIH.
      + eapply NatSet_Permutation_remove.
        rewrite NatSet_Permutation_add.
        * eapply Permutation_refl' in E_ths_tgt. rewrite Permutation_app_comm in E_ths_tgt. eapply E_ths_tgt.
        * intro H. eapply TID. eapply H.
        * ss.
      + eapply NatMap.remove_1; ss.
      + subst. des_if; ss. lia.
      + subst. i. des_if.
        * eapply nth_error_Some' in H. lia.
        * enough (m_src tid0 > 1 + i) by (des_if; lia).
          assert (nth_error (ths_tgt ++ [tid]) (1 + i) = Some tid0) by (rewrite E_ths_tgt; ss).
          assert (1 + i < List.length ths_tgt \/ 1 + i >= List.length ths_tgt) by lia.
          destruct H1.
          -- rewrite nth_error_app1 in H0 by ss. eapply M_SRC1; eauto.
          -- rewrite nth_error_app2 in H0 by ss.
             assert (1 + i - List.length ths_tgt = 0)
               by (destruct (1 + i - List.length ths_tgt) as [|[]] in *; ss).
             rewrite H2 in H0. inversion H0. subst. lia.
  Qed.

  Lemma gsim_nondet_fifo tid st (ths : @threads _Ident (sE State) R)
    : gsim nat_wf nat_wf eq
           (interp_all st ths tid)
           (interp_all_fifo st ths tid).
  Proof.
    eapply ssim_implies_gsim.
    { instantiate (1 := fun x => x). ss. }
    eapply ssim_nondet_fifo; ss.
    eapply NatMap.remove_1; ss.
    Unshelve. all: exact true.
  Qed.

  Definition sched_fifo_set: schedulerT R :=
    fun '(tid, tset) => @sched_fifo R (tid, TIdSet.elements tset).

  Theorem fifo_is_fair: isFairSch (_Ident:=_Ident) R (sched_fifo_set).
  Proof.
    eapply ssim_isFairSch.
    4:{ i. eapply ssim_nondet_fifo. apply Permutation_refl. eapply NatMap.remove_1. ss. }
    { instantiate (1:=id). auto. }
    { econs. exact 0. }
    { i. exists (S o0). ss. }
    Unshelve. all: exact true.
  Qed.

End SIM.


Require Export Coq.Vectors.Vector.
Require Import Coq.Vectors.Fin.
(* Coding of the element of particular ordinal with two natural numbers.
(n+1) - total, m - number.  $m \in (n+1)$ *)
Fixpoint code (n m:nat): t (S n).
Proof.
destruct n.
+ exact (F1).
+ destruct m.
  - exact (F1).
  - refine (FS _).
    exact (code n m).
Defined.

Section sec0.
Parameter SetFVars : Set.
Parameter SetBVars : Set.
Parameter Constants : Set.
Parameter FuncSymb : Set.
Parameter PredSymb : Set.
Parameter valfs : FuncSymb -> nat.
Parameter valpr : PredSymb -> nat.

(*
Hypothesis PVarseq_dec:forall x y:PropVars,{x=y}+{not(x=y)}.
Hypothesis FVarseq_dec:forall x y:SetFVars,{x=y}+{not(x=y)}.
Hypothesis BVarseq_dec:forall x y:SetBVars,{x=y}+{not(x=y)}.
*)

Inductive Term:Set:=
| CC  :> Constants -> Term
| FVC :> SetFVars  -> Term
| FSC (f:FuncSymb) :  (t (valfs f)-> Term) -> Term.

Check prod.

Inductive it:Set:=
|co1 :it
|co2 :it.

Fixpoint ni0 (x:SetFVars) (a:it) : Prop.
destruct a.
exact False.
exact True.
Defined.
Print ni0.

(*Incorrect Formulas*)
Inductive Fo:(list SetBVars) -> Set:=
(*|Atom (p:PredSymb): (t (valpr p)-> Term) ->  Fo
|Bot :Fo
|Conj:Fo->Fo->Fo
|Disj:Fo->Fo->Fo
|Impl:Fo->Fo->Fo
|Fora(a:SetFVars)(x:SetBVars)(f:Fo): Fo
|Exis(a:SetFVars)(x:SetBVars)(f:Fo): Fo*)
.

Context (M:Prop).
Check False->False.
Check M->False.

Inductive frm:Prop :=
|atom:Prop->frm
|cand:frm->frm->frm.
Definition det (p:Prop): Prop.
Print and.


Require Import Leapfrog.Benchmarks.ProofHeader.
Require Import Leapfrog.Benchmarks.BabyIP.

Lemma babyip_equiv:
  lang_equiv_state
    (P4A.interp BabyIP1.aut)
    (P4A.interp BabyIP2.aut)
    BabyIP1.Start
    BabyIP2.Start.
Proof.
  solve_lang_equiv_state_admit BabyIP1.state_eqdec BabyIP2.state_eqdec false.
Time Admitted.
Print Assumptions babyip_equiv.


Require Import compcert.common.Events.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.

Require Import VST.msl.Coqlib2.

Import BinInt.
Import List.
Import Relation_Definitions.
Import RelationClasses.

(** *Monotonicity (inject_incr)*)
Class Inject_Monotonic {A:Type}(R: meminj -> relation A):=
  monotonicity: forall j j' a1 a2,
    R j a1 a2 ->
    inject_incr j j' ->
    R j' a1 a2.

Ltac emonotonicity:=
  try (unfold Inject_Monotonic);
  eapply monotonicity.

Instance list_map_rel_monotonicity:
  forall {A} {R: meminj -> relation A},
    Inject_Monotonic R ->
    Inject_Monotonic (fun j => list_map_rel (R j)).
Proof.
  intros ? ? ? j j' vals1.
  induction vals1; intros.
  - inversion H0; subst. constructor.
  - inversion H0; subst. constructor; auto.
    + emonotonicity; eauto.
Qed.

Lemma list_map_rel_monotonicity':
  forall {A} {R: meminj -> relation A},
    (forall j j' vals1 vals2,
        R j vals1 vals2 ->
        inject_incr j j' ->
        R j' vals1 vals2) ->
    forall j j' vals1 vals2,
      (list_map_rel (R j)) vals1 vals2 ->
      inject_incr j j' ->
      (list_map_rel (R j')) vals1 vals2.
Proof.
  intros ? ? ? j j' vals1.
  eapply list_map_rel_monotonicity.
  unfold Inject_Monotonic. eapply H.
Qed.
Instance memval_inject_monotonic:
  Inject_Monotonic memval_inject:=
  memval_inject_incr.
Instance list_memval_inject_monotonic:
  Inject_Monotonic list_memval_inject.
Proof.
  eapply list_map_rel_monotonicity.
  emonotonicity.
Qed.
Instance inject_hi_low_monotonic:
  Inject_Monotonic inject_hi_low.
Proof. intros ???? H H0.
       inversion H; subst.
       econstructor. apply H0; auto.
Qed.
Instance list_inject_hi_low_monotonic:
  Inject_Monotonic list_inject_hi_low.
Proof. eapply list_map_rel_monotonicity; emonotonicity. Qed.

Instance inject_mem_effect_monotonic:
  Inject_Monotonic Events.inject_mem_effect.
Proof.
  intros ??????.
  inversion H; subst;
    econstructor; eauto.
  - emonotonicity; eassumption.
  - emonotonicity; eassumption.
Qed.
Instance list_inject_mem_effect_monotonic :
  Inject_Monotonic Events.list_inject_mem_effect.
Proof.
  emonotonicity.
Qed.

(** *strict_injection_evolution *)

Inductive injection_evolution_effect:
  meminj -> meminj ->
  Events.mem_effect -> Events.mem_effect -> Prop:=
|EffEvolWrite: forall b1 b2 ofs1 ofs2 mvs1 mvs2 j,
    Events.inject_mem_effect
      j
      (common.Events.Write b1 ofs1 mvs1)
      (common.Events.Write b2 ofs2 mvs2) ->
    injection_evolution_effect
      j j
      (common.Events.Write b1 ofs1 mvs1)
      (common.Events.Write b2 ofs2 mvs2)
|EffEvolAlloc: forall j j' (b1 b2:block) ofs1 ofs1',
    j b1 = None -> (* Do we need this? *)
    j' = (fun b => if eq_block b b1 then
                  Some (b2, 0%Z) else j b) ->
    injection_evolution_effect
      j j'
      (common.Events.Alloc b1 ofs1 ofs1')
      (common.Events.Alloc b2 ofs1 ofs1')
|EffEvolFree: forall  j ls1 ls2,
    Events.inject_mem_effect j
                             (common.Events.Free ls1)
                             (common.Events.Free ls2) ->
    injection_evolution_effect
      j j
      (common.Events.Free ls1)
      (common.Events.Free ls2).

Inductive strict_injection_evolution:
  meminj -> meminj ->
  list Events.mem_effect -> list Events.mem_effect -> Prop:=
| EvolutionNil: forall j,
    strict_injection_evolution j j nil nil
| EvolutionCons: forall j j' j'' ev1 ev2 ls1 ls2,
    injection_evolution_effect j j' ev1 ev2 ->
    strict_injection_evolution j' j'' ls1 ls2 ->
    strict_injection_evolution
      j j''
      (ev1::ls1) (ev2::ls2).

Lemma evolution_inject_effect:
  forall j j' ev1 ev2,
    injection_evolution_effect j j' ev1 ev2 ->
    Events.inject_mem_effect j' ev1 ev2.
Proof.
  intros. inversion H; subst; eauto.
  econstructor.
  destruct (eq_block b1 b1); eauto.
  contradict n; reflexivity.
Qed.
Lemma effect_evolution_incr:
  forall j j' ev1 ev2,
    injection_evolution_effect j j' ev1 ev2 ->
    inject_incr j j'.
Proof.
  intros. inversion H; subst;
            try eapply inject_incr_refl.
  intros b1' b2' delt HH.
  destruct (eq_block b1' b1); auto.
  + subst. congruence.
Qed.
Lemma evolution_inject_incr:
  forall j j' lev1 lev2,
    strict_injection_evolution j j' lev1 lev2 ->
    inject_incr j j'.
Proof.
  intros j j' lev1; revert j j'.
  induction lev1; intros.
  - inversion H; subst.
    eapply inject_incr_refl.
  - inversion H; subst.
    eapply (inject_incr_trans _ j'0).
    + eapply effect_evolution_incr; eassumption.
    + eapply IHlev1.
      eauto.
Qed.

Lemma evolution_list_inject_mem:
  forall j j' lev1 lev2,
    strict_injection_evolution j j' lev1 lev2 ->
    Events.list_inject_mem_effect j' lev1 lev2.
Proof.
  intros j j' lev1; revert j j'.
  induction lev1; intros.
  - inversion H; subst. econstructor.
  - inversion H; subst. econstructor.
    + eapply evolution_inject_effect in H4.
      eapply inject_mem_effect_monotonic; try eassumption.
      eapply evolution_inject_incr; eassumption.
    + eapply IHlev1; eauto.
Qed.

(** *Lessdef*)
Instance list_map_rel_preorder {A} (R: relation A) {Pre: PreOrder R}:
  PreOrder (list_map_rel R).
Proof. constructor.
       - intros ls; induction ls; econstructor; auto.
         reflexivity.
       - intros ls1.
         induction ls1; intros.
         + inversion H; subst; inversion H0; subst. constructor.
         + inversion H; subst; inversion H0; subst. constructor; eauto.
           etransitivity; eauto.
Qed.

Inductive memval_lessdef: relation memval:=
| MvUndefLessDef : forall mv, memval_lessdef Undef mv
| MvBytelLessDef : forall b, memval_lessdef (Byte b) (Byte b)
| MvReflLessDef : forall v v' q n,
    Val.lessdef v v' ->
    memval_lessdef (Fragment v q n) (Fragment v' q n).
Instance memval_lessdef_preorder: PreOrder memval_lessdef.
Proof. constructor.
       - intros x; destruct x; econstructor. apply Val.lessdef_refl.
       - intros x y z ? ?.
         inversion H; subst; inversion H0; subst; econstructor.
         eapply Val.lessdef_trans; eassumption.
Qed.

Inductive effect_lessdef:
  relation Events.mem_effect:=
| EvWriteLessDef:
    forall b ofs mvs mvs',
      (list_map_rel memval_lessdef) mvs mvs' ->
      effect_lessdef (common.Events.Write b ofs mvs)
                     (common.Events.Write b ofs mvs')
| EvReflLessDef: forall eff,  effect_lessdef eff eff.
Instance effect_lessdef_preorder: PreOrder effect_lessdef.
Proof. constructor.
       - intros x; destruct x; econstructor. reflexivity.
       - intros x y z ? ?.
         inversion H; subst; inversion H0; subst; econstructor; try eassumption.
         + etransitivity; eassumption.
Qed.

Definition effects_lessdef:
  relation (list Events.mem_effect):=
  Events.list_map_rel effect_lessdef.

(** *Consecutive*)
Inductive consecutive: block -> list Events.mem_effect -> Prop:=
| consecutiveNil: forall nb,
    consecutive nb nil
| consecutiveWrite: forall nb b ofs mvals lev',
    (b <= nb)%positive -> (* needed?*)
    consecutive nb lev' ->
    consecutive nb ((common.Events.Write b ofs mvals):: lev')
| consecutiveAlloc: forall nb b ofs mvals lev',
    (b = nb)%positive -> (* needed?*)
    consecutive (Pos.succ nb) lev' ->
    consecutive nb ((common.Events.Alloc b ofs mvals):: lev')
| consecutiveFree: forall nb lsbzz lev',
    (Forall (fun x => (fst (fst x)) <= nb)%positive lsbzz) ->
    consecutive nb lev' ->
    consecutive nb ((common.Events.Free lsbzz):: lev').
Lemma consecutive_monotonic:
  forall nb lev0 lev,
    effects_lessdef lev0 lev ->
    consecutive nb lev ->
    consecutive nb lev0.
Proof.
  intros nb lev0. revert nb.
  induction lev0; intros.
  - econstructor.
  - inversion H; subst.
    inversion H0; subst;
      inversion H3; subst;
        econstructor; eauto.
Qed.

(** *Section Diagrams *)
Record diagram
       (nb: block) (j j': meminj)
       (lev1 lev2: list Events.mem_effect):=
  { Dincr: inject_incr j j'
    ; Dinj: Events.list_inject_mem_effect j' lev1 lev2
    ; Dconsec: consecutive nb lev2
  }.

Record principled_diagram
       (nb: block) (j j': meminj)
       (lev1 lev2: list Events.mem_effect):=
  { PDevol: strict_injection_evolution j j' lev1 lev2
    ; PDinj_str: Events.list_inject_mem_effect_strong j' lev1 lev2
    ; PDconsec: consecutive nb lev2
  }.

Inductive principled_diagram':
  block -> meminj -> meminj -> list Events.mem_effect -> Prop :=
|build_pd': forall  nb j j0 lev1 lev20,
    principled_diagram nb j j0 lev1 lev20 ->
    principled_diagram' nb j j0 lev1.
Inductive diagram':
  block -> meminj -> meminj -> list Events.mem_effect -> Prop :=
|build_d': forall nb j j' lev1 lev2,
    diagram nb j j' lev1 lev2 ->
    diagram' nb j j' lev1.

(** *Principaled Effects and values*)
Lemma principaled_val_exists:
  forall j v1 v2,
    Val.inject j v1 v2 ->
    exists v20,
      Events.inject_strong j v1 v20 /\
      Val.lessdef v20 v2.
Proof.
  intros. induction H;
            try (eexists; split; econstructor); eassumption.
Qed.
Lemma principaled_memval_exists:
  forall j mv1 mv2,
    memval_inject j mv1 mv2 ->
    exists mv20,
      Events.memval_inject_strong j mv1 mv20 /\
      memval_lessdef mv20 mv2.
Proof.
  intros. induction H;
            try solve[eexists; split; econstructor].
  - eapply principaled_val_exists in H.
    destruct H as (v20&?&?).
    eexists; split. econstructor; eassumption.
    econstructor; eauto.
Qed.
Lemma principaled_memvals_exists:
  forall j mv1 mv2,
    Events.list_memval_inject j mv1 mv2 ->
    exists mv20,
      Events.list_memval_inject_strong j mv1 mv20 /\
      Events.list_map_rel memval_lessdef mv20 mv2.
Proof.
  intros. induction H; subst.
  - exists nil; split; econstructor.
  - destruct (principaled_memval_exists _ _ _ H) as (v20&?&?).
    destruct IHlist_map_rel as (mv20&?&?).
    exists (v20::mv20); split. constructor; eassumption.
    econstructor; eauto.
Qed.
Lemma principaled_effect_exists:
  forall j eff1 eff2,
    Events.inject_mem_effect j eff1 eff2 ->
    exists eff20,
      Events.inject_mem_effect_strong j eff1 eff20 /\
      effect_lessdef eff20 eff2.
Proof.
  intros. inversion H; subst;
            try solve[eexists; split; econstructor; eauto].
  + destruct (principaled_memvals_exists _ _ _ H1) as (mv20&?&?).
    eexists; split. econstructor; eauto.
    econstructor; eassumption.
Qed.
Lemma principaled_effects_exists:
  forall j lev1 lev2,
    Events.list_inject_mem_effect j lev1 lev2 ->
    exists lev20,
      Events.list_inject_mem_effect_strong j lev1 lev20 /\
      effects_lessdef lev20 lev2.
Proof.
  intros j lev1 lev2; revert j lev1.
  induction lev2; intros.
  - inversion H; subst.
    exists nil; split; econstructor.
  - inversion H; subst; clear H.
    destruct (principaled_effect_exists _ _ _ H3) as (eff20&?&?).
    destruct (IHlev2 _ _ H4) as (lev20&?&?).
    eexists; split.
    + econstructor; eassumption.
    + econstructor; eassumption.
Qed.

Lemma principaled_injection_exists:
  forall j j' lev1 lev2 lev20,
    strict_injection_evolution j j' lev1 lev2 ->
    Events.list_inject_mem_effect_strong j' lev1 lev20 ->
    effects_lessdef lev20 lev2 ->
    strict_injection_evolution j j' lev1 lev20.
Proof.
  intros j j' lev1; revert j j'.
  induction lev1; intros.
  - inversion H0; inversion H; subst. econstructor.
  - inversion H0; inversion H; subst; inversion H1;
      subst.
    econstructor; eauto.
    +

      admit. (*  injection_evolution_effect j j'0 a ev2
                                     effect_lessdef b ev2
                                     injection_evolution_effect j j'0 a b*)
Admitted.

Lemma principled_diagram_exists:
  forall nb j j' lev1 lev2,
    strict_injection_evolution j j' lev1 lev2 ->
    consecutive nb lev2 ->
    exists lev20,
      principled_diagram nb j j' lev1 lev20 /\
      effects_lessdef lev20 lev2.
Proof.
  intros.
  pose proof (evolution_list_inject_mem _ _ _ _ H).
  destruct (principaled_effects_exists _ _ _ H1) as (lev20 & HH & Horder).
  exists lev20.
  econstructor; repeat split.
  -
    eapply principaled_injection_exists; eauto.
  - eauto.
  -
    eapply consecutive_monotonic; eassumption.
  - assumption.
Qed.
Lemma principled_diagram_exists':
  forall (nb : block) (j j' : meminj) (lev1 lev2 : list Events.mem_effect),
    strict_injection_evolution j j' lev1 lev2 ->
    consecutive nb lev2 ->
    principled_diagram' nb j j' lev1.
Proof.
  intros.
  edestruct principled_diagram_exists as (?&?&?); eauto.
  econstructor; eauto.
Qed.
Lemma consecutive_head:
  forall nb ev ls,
    consecutive nb (ev :: ls) ->
    consecutive nb (ev :: nil).
Proof. intros. inversion H; subst;
                 econstructor; auto; constructor.
Qed.
Definition nextblock_eff (nb:block) (ev:mem_effect):=
  match ev with
  | Write _ _ _ => nb
  | Alloc _ _ _ => Pos.succ nb
  | Free _ => nb
  end.
Lemma consecutive_tail:
  forall nb ev ls,
    consecutive nb (ev :: ls) ->
    consecutive (nextblock_eff nb ev ) (ls).
Proof. intros. inversion H; subst; simpl; auto. Qed.

Lemma inject_lessdef:
  forall j' j0 : meminj,
    inject_incr j0 j' ->
    forall v1 v3 v2 : val,
      Val.inject j' v1 v2 ->
      inject_strong j0 v1 v3 -> Val.lessdef v3 v2.
Proof.
  intros j' j0 Hincr v1 v3 v2 H0 H1.
  inversion H0; subst;
    inversion H1; subst;
      try solve[constructor].
  - apply Hincr in H4.
    rewrite H4 in H; inversion H; subst.
    constructor.
Qed.
Lemma inject_memval_lessdef:
  forall (a : memval) (j' j0 : meminj),
    inject_incr j0 j' ->
    forall b b0 : memval,
      memval_inject j' a b ->
      memval_inject_strong j0 a b0 -> memval_lessdef b0 b.
Proof.
  intros a j' j0 H b b0 H4 H5.
  inversion H4; subst;
    inversion H5; subst;
      try solve[constructor].
  - constructor.
    eapply inject_lessdef; eassumption.
Qed.
Lemma list_inject_memval_lessdef:
  forall (j' j0 : meminj) (mvs1 mvs2 : list memval),
    inject_incr j0 j' ->
    forall vals2 : list memval,
      list_memval_inject j' mvs1 vals2 ->
      list_memval_inject_strong j0 mvs1 mvs2 ->
      list_map_rel memval_lessdef mvs2 vals2.
Proof.
  intros j' j0 mvs1. revert j' j0.
  induction mvs1; intros.
  - inversion H0; subst;
      inversion H1; subst;
        constructor.
  - inversion H0; subst;
      inversion H1; subst;
        try solve[econstructor; eauto].
    econstructor.

    +eapply inject_memval_lessdef; eassumption.
    + eapply IHmvs1; eassumption.
Qed.

Lemma list_inject_hi_low_lessdef:
  forall j0 j ls1 ls2 ls20,
    inject_incr j0 j ->
    list_inject_hi_low j0 ls1 ls20 ->
    list_inject_hi_low j ls1 ls2 ->
    ls20 = ls2.
Proof.
  intros j0 j ls1; revert j0 j.
  induction ls1; intros.
  - inversion H0; subst;
      inversion H1; subst; auto.
  - inversion H0; subst;
      inversion H1; subst; auto.
    f_equal.
    + clear - H4 H5 H.
      inversion H4; subst;
        inversion H5; subst.
      apply H in H0; rewrite H0 in H7.
      inversion H7; subst. reflexivity.
    + eapply IHls1; eassumption.
Qed.

Lemma incr_inject_strong:
  forall (j0 j0' : meminj) v1 v2,
    inject_incr j0 j0' ->
    inject_strong j0' v1 v2 ->
    Val.inject j0 v1 v2 ->
    inject_strong j0 v1 v2.
Proof.
  intros.
  inversion H0; subst;
    inversion H1; subst;
      econstructor; eauto.
Qed.
Lemma incr_memval_inject_strong:
  forall (j0 j0' : meminj) (val1 val2 : memval),
    inject_incr j0 j0' ->
    memval_inject_strong j0' val1 val2 ->
    memval_inject j0 val1 val2 ->
    memval_inject_strong j0 val1 val2.
Proof.
  intros.
  inversion H0; subst;
    inversion H1; subst;
      econstructor; eauto.
  eapply incr_inject_strong; eassumption.
Qed.
Lemma incr_list_memval_inject_strong:
  forall (j0 j0' : meminj) (vals1 vals2 : list memval),
    inject_incr j0 j0' ->
    list_memval_inject_strong j0' vals1 vals2 ->
    list_memval_inject j0 vals1 vals2 -> list_memval_inject_strong j0 vals1 vals2.
Proof.
  intros j0 j0' vals1; revert j0 j0'.
  induction vals1; intros j0 j0' vals2 H0 H3 H11.
  - inversion H3; subst;
      inversion H11; subst;
        econstructor; eauto.
  - inversion H3; subst;
      inversion H11; subst;
        econstructor; eauto.

    eapply incr_memval_inject_strong; eassumption.
    eapply IHvals1; eauto.
Qed.
Lemma evolution_injection_lessdef:
  forall j j' j0 ev1 ev2 ev20 nb,
    inject_incr j j' ->
    injection_evolution_effect j j0 ev1 ev2 ->
    inject_mem_effect_strong j0 ev1 ev2 ->
    inject_mem_effect j' ev1 ev20 ->
    consecutive nb (ev2 :: nil) ->
    consecutive nb (ev20 :: nil) ->
    effect_lessdef ev2 ev20.
Proof.
  intros
    ??????? Hincr Hevol Hinj_str Hinject Hconsec Hconsec'.
  inversion Hevol; subst; clear Hevol;
    inversion Hinject; subst; clear Hinject.
  - inversion Hinj_str; subst.
    apply Hincr in H2.
    rewrite H2 in H4; inversion H4; subst.
    econstructor.

    eapply list_inject_memval_lessdef; eassumption.
  - inversion Hconsec; subst.
    inversion Hconsec'; subst.
    econstructor.
  - inversion H; subst.
    inversion Hinj_str; subst.
    eapply list_inject_hi_low_lessdef in H1; eauto.
    subst; econstructor.
Qed.
Lemma incr_inject_mem_effect_strong:
  forall j0 j0' ev1 ev2,
    inject_mem_effect_strong j0' ev1 ev2 ->
    inject_incr j0 j0' ->
    inject_mem_effect j0 ev1 ev2 ->
    inject_mem_effect_strong j0 ev1 ev2.
Proof.
  intros.
  inversion H; subst;
    inversion H1; subst;
      econstructor; eauto.
  - apply H0 in H6;
      rewrite H2 in H6;
      inversion H6; subst.
    eapply incr_list_memval_inject_strong; eassumption.
Qed.

Lemma principled_diagram_correct:
  forall nb j j' j0 lev1 lev2 lev20,
    principled_diagram nb j j0 lev1 lev20 ->
    diagram nb j j' lev1 lev2 ->
    inject_incr j0 j' /\  effects_lessdef lev20 lev2.
Proof.
  intros nb j j' j0 lev1; revert nb j j' j0 .
  induction lev1; intros.
  - inversion H as [Hevol Hinj_str Hconsec];
      inversion H0 as [Hincr  Hinj Hconsec'].
    inversion Hevol; inversion Hinj; subst.
    split; auto. reflexivity.
  -  inversion H as [Hevol Hinj_str Hconsec];
       inversion H0 as [Hincr  Hinj Hconsec'].
     inversion Hevol; inversion Hinj; subst.
     inversion Hinj_str; subst.

     assert (Hincr0: inject_incr j'0 j0).
     { eapply evolution_inject_incr; eassumption. }

     assert (Hpdiagram: principled_diagram (nextblock_eff nb ev2) j'0 j0 lev1 ls2).
     { econstructor; eauto.
       eapply consecutive_tail; eassumption. }

     assert (Hdiagram: diagram (nextblock_eff nb b) j'0 j' lev1 l2).
     {  econstructor; try eassumption.
        - clear - Hincr H5 H10 Hconsec' Hconsec.
          inversion H5; subst; eauto.
          inversion H10; subst.
          intros ????.
          if_tac in H0; subst; auto.
          + inversion H0; subst.
            inversion Hconsec'; subst.
            inversion Hconsec; subst.
            auto.
        - eapply consecutive_tail; eassumption.
     }

     assert (Hlessdef: effect_lessdef ev2 b).
     {
       eapply (evolution_injection_lessdef j j'); try eassumption.
       * eapply incr_inject_mem_effect_strong; try eassumption.
         inversion H5; subst; eauto.
         -- eapply evolution_inject_effect; eassumption.
       * eapply consecutive_head; eauto.
       * eapply consecutive_head; eauto. }

     replace (nextblock_eff nb b) with (nextblock_eff nb ev2) in Hdiagram by
         (inversion Hlessdef; reflexivity).

     edestruct (IHlev1 _ _ _ _ _ _ Hpdiagram Hdiagram) as (Hincr'&Hlessdef').
     split.
     + assumption.
     + econstructor; auto.
Qed.

Lemma principled_diagram_correct':
  forall (nb : block)
    (j j' j0 : meminj)
    (lev1: list Events.mem_effect),
    principled_diagram' nb j j0 lev1 ->
    diagram' nb j j' lev1 ->
    inject_incr j0 j'.
Proof.
  intros * H1 H2; inversion H1; inversion H2;subst;
    eapply principled_diagram_correct; eassumption.
Qed.

  Record same_visible (m1 m2: mem):=
    { same_cur:
        forall b ofs p,
          (Mem.perm m1 b ofs Cur p <->
                Mem.perm m2 b ofs Cur p);
      same_visible12:
        forall b ofs,
          Mem.perm m1 b ofs Cur Readable ->
          (Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m1))) =
          (Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m2)));
      same_visible21:
        forall b ofs,
          Mem.perm m2 b ofs Cur Readable ->
          (Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m1))) =
          (Maps.ZMap.get ofs (Maps.PMap.get b (Mem.mem_contents m2)));
    }.
  Instance same_vis_equiv: (Equivalence same_visible).
  Admitted.

(** *mem_interference with mem_effect *)
Section MemInterference.
  Definition mem_effect_forward: mem -> Events.mem_effect -> mem -> Prop.
  (* Definition mem_effect_forward m ev m':=
         execute ev in m, without checking for permissions.
   *)
  Admitted.

  Inductive mem_interference: mem -> list Events.mem_effect -> mem -> Prop:=
  | Nil_mem_interference: forall m, mem_interference m nil m
  | Build_mem_interference: forall m m' m'' ev lev,
      mem_effect_forward m ev m' ->
      mem_interference m' lev m'' ->
      mem_interference m (ev::lev) m''.
  (* OLD_mem_interference:= Mem.unchanged_on (loc_readable_cur m) m *)

  Lemma mem_interference_one:
    forall m m' ev,
      mem_effect_forward m ev m' ->
      mem_interference m (ev::nil) m'.
  Proof. intros; econstructor; [eauto| econstructor].
  Qed.

  Lemma mem_interference_trans:
    forall lev lev' m m' m'',
      mem_interference m lev m' ->
      mem_interference m' lev' m'' ->
      mem_interference m (lev ++ lev') m''.
  Proof.
    induction lev.
    - simpl; intros.
      inversion H; subst; auto.
    - simpl; intros.
      inversion H; subst; auto.
      econstructor; eauto.
  Qed.

  Lemma mem_effect_forward_determ:
    forall eff m m1' m2',
      mem_effect_forward m eff m1' ->
      mem_effect_forward m eff m2' ->
      m1' = m2'.
  Proof.
    intros.
  Admitted.
  Lemma mem_interference_determ:
    forall lev m m1' m2',
      mem_interference m lev m1' ->
      mem_interference m lev m2' ->
      m1' = m2'.
  Proof.
    intros lev; induction lev; intros.
    - inversion H; subst;
        inversion H0; subst; reflexivity.
    - inversion H; subst; inversion H0; subst.
      pose proof (mem_effect_forward_determ
                    _ _ _ _
                    H4 H5); subst.
      eapply IHlev; eassumption.
  Qed.

Lemma interference_same_visible:
  forall m m' lev, mem_interference m lev m' ->
              same_visible m m'.
Admitted.

End MemInterference.

Definition consecutive_until: block -> list Events.mem_effect -> block -> Prop.
Admitted.
Lemma consecutive_until_cat:
  forall lev lev' b b' b'',
    consecutive_until b lev b' ->
    consecutive_until b' lev' b'' ->
    consecutive_until b (lev ++ lev') b''.
Proof.
Admitted.
Lemma consecutive_until_consecutive:
  forall lev b b',
    consecutive_until b lev b' ->
    consecutive b lev.
Proof.
Admitted.

Lemma strict_inj_evolution_cat:
  forall j j' j'' lev1 lev1' lev2 lev2' nb nb' nb'',
    strict_injection_evolution j j' lev1 lev2 ->
    strict_injection_evolution j' j'' lev1' lev2' ->
    consecutive_until nb lev2 nb' ->
    consecutive_until nb' lev2' nb'' ->
    strict_injection_evolution j j'' (lev1++lev1') (lev2++lev2').
Proof.
Admitted.

Lemma interference_consecutive: forall m lev m',
    mem_interference m lev m' ->
    consecutive (Mem.nextblock m) lev.
Proof.
  intros. induction lev; try econstructor.
Admitted.
Lemma interference_consecutive_until:
  forall {m lev m'},
    mem_interference m lev m' ->
    consecutive_until (Mem.nextblock m) lev (Mem.nextblock m').
Proof. Admitted.


Require Import String ZArith Basics.
From ConCert Require Import Ast Notations PCUICTranslate PCUICtoTemplate.
From ConCert Require Import Utils Prelude SimpleBlockchain CustomTactics.
Require Import List PeanoNat ssrbool.

Import ListNotations.
From MetaCoq.Template Require Import All.

Import MonadNotation.
Import BaseTypes.
Open Scope list.

Import AcornBlockchain.

Import Lia.

Run TemplateProgram
      (mkNames ["State" ; "mkState"; "count"; "dummy";
                "Res" ; "Error";
                "Msg"; "Tick"; "NOP";
               "Action"; "Transfer"; "Empty" ] "_coq").

Import ListNotations.

Definition state_syn : global_dec :=
  [\ record State := mkState { count : Nat ;
                               dummy : Bool} \].

Set Nonrecursive Elimination Schemes.
Make Inductive (global_to_tc state_syn).

Definition msg_syn :=
  [\ data Msg =
   Tick [_] |
   NOP [_] \].

Make Inductive (global_to_tc msg_syn).

Print Msg_coq.

  Notation "'Tick'" :=
    (pConstr Tick []) ( in custom pat at level 0).
  Notation "'NOP'" :=
    (pConstr NOP []) ( in custom pat at level 0).

  Notation "'Just' x" :=
    (pConstr "Some" [x]) (in custom pat at level 0,
                             x constr at level 4).
  Notation "'Nothing'" := (pConstr "None" [])
                            (in custom pat at level 0).
  (** Projections *)
  Notation "'count' a" :=
    [| {eConst count} {a} |]
      (in custom expr at level 0).

  Notation "'dummy' a" :=
    [| {eConst dummy} {a} |]
      (in custom expr at level 0).

  Notation "'Nil'" := [| {eConstr "list" "nil"} {eTy (tyInd SActionBody)} |]
                        (in custom expr at level 0).

  Notation " x ::: xs" := [| {eConstr "list" "cons"} {eTy (tyInd SActionBody)} {x} {xs} |]
                            ( in custom expr at level 0).

  Notation "[ x ]" := [| {eConstr "list" "cons"} {eTy (tyInd SActionBody)} {x} Nil |]
                        ( in custom expr at level 0,
                             x custom expr at level 1).

 Definition actions_ty := [! "list" "SimpleActionBody" !].

  Notation "'Result'" := [!"prod" State ("list" "SimpleActionBody") !]
                           (in custom type at level 2).

  Notation "'Just' a" := [| {eConstr "option" "Some"}  {eTy [! Result!]} {a}|]
                           (in custom expr at level 0,
                               a custom expr at level 1).

  Notation "'Pair' a b" := [| {eConstr "prod" "pair"}
                               {eTy (tyInd State)}
                               {eTy actions_ty} {a} {b} |]
                           (in custom expr at level 0,
                               a custom expr at level 1,
                               b custom expr at level 1).

  Definition mk_res a b := [| {eConstr "option" "Some"}
                                {eTy [! Result !]}
                                 ({eConstr "prod" "pair"} {eTy (tyInd State)}
                                 {eTy actions_ty} {a} {b}) |].
  Notation "'Res' a b" := (mk_res a b)
      (in custom expr at level 2,
          a custom expr at level 4,
          b custom expr at level 4).

  Notation "'Nothing'" := (eApp (eConstr "option" "None") (eTy [!Result!]))
                      (in custom expr at level 0).

  Notation "'mkState' a b" :=
    [| {eConstr State "mkState_coq"} {a} {b} |]
      (in custom expr at level 0,
          a custom expr at level 1,
          b custom expr at level 1).

  Notation "'Transfer' a b" :=
    [| {eConstr SActionBody "Act_transfer"} {b} {a} |]
      (in custom expr at level 0,
          a custom expr at level 1,
          b custom expr at level 1).

  Notation "'Empty'" := (eConstr Action Empty)
                      (in custom expr at level 0).

  Definition Σ' :=
    Prelude.Σ ++ [ Prelude.AcornMaybe;
           state_syn;
           msg_syn;
           addr_map_acorn;
           AcornBlockchain.SimpleChainAcorn;
           AcornBlockchain.SimpleContractCallContextAcorn;
           AcornBlockchain.SimpleActionBodyAcorn;
           gdInd "Z" 0 [("Z0", []); ("Zpos", [(None,tyInd "positive")]);
                          ("Zneg", [(None,tyInd "positive")])] false].

  Notation "0 'z'" := (eConstr "Z" "Z0") (in custom expr at level 0).

  Import Prelude.
  (** Generating string constants for variable names *)

  Run TemplateProgram (mkNames ["c";"s";"e";"m";"v";"dl"; "g"; "chain";
                              "tx_amount"; "bal"; "sender"; "own"; "isdone" ;
                              "accs"; "now";
                               "newstate"; "newmap"; "cond"] "").
  (** A shortcut for [if .. then .. else ..]  *)
  Notation "'if' cond 'then' b1 'else' b2 : ty" :=
    (eCase (Bool,[]) ty cond
           [(pConstr true_name [],b1);(pConstr false_name [],b2)])
      (in custom expr at level 4,
          cond custom expr at level 4,
          ty custom type at level 4,
          b1 custom expr at level 4,
          b2 custom expr at level 4).

  Notation SCtx := "SimpleContractCallContext".
  Definition test := [| 1 |].
  Unset Printing Notations.
  Print test.
  Make Definition test_coq :=
        (expr_to_tc Σ' (indexify nil test)).
      Print test_coq.
  Set Printing Notations.

  Module CrowdfundingContract.
    Import AcornBlockchain.
    Module Init.
      Import Notations.
          Definition crowdfunding_init : expr :=
            [| \c : SCtx => \dl : Nat => \g : Money => mkState dl False|].
          Make Definition init :=
            (expr_to_tc Σ' (indexify nil crowdfunding_init)).
          Check init.
    End Init.
    Module Receive.
      Import Notations.
      Import Prelude.

      Notation SCtx := "SimpleContractCallContext".
      Notation SChain := "SimpleChain".
      Definition counter : expr :=
        [| \chain : SChain =>  \c : SCtx => \m : Msg => \s : State =>
           case m : Msg return Maybe Result of
            | Tick ->
              Just (Pair (mkState (Suc(count s)) False) Nil )
            | NOP -> Just (Pair s Nil )
            |].
      Compute (expr_to_tc Σ' (indexify nil counter)).
      Make Definition receive :=
        (expr_to_tc Σ' (indexify nil counter)).
      Print receive.
    End Receive.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InferenceRules.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Module ResourceProtocol.
Section ResourceProtocol.

Variable server : nid.
Variable clients : seq nid.

Hypothesis Hnin : server \notin clients.
Hypothesis Huniq : uniq clients.

Lemma client_not_server n : n \in clients -> (n == server) = false.
Proof.
  move=>H.
  case E: (n == server)=>//.
  move/eqP in E. subst n.
  move: (Hnin).
  by rewrite H.
Qed.

Definition nodes := [:: server] ++ clients.

Lemma client_nodes n : n \in clients -> n \in nodes.
Proof.
  by rewrite inE orbC/= =>->.
Qed.

Notation epoch := nat (only parsing).
Notation client := nid (only parsing).

Definition value := nat.

Inductive request :=
| Update of client * epoch * value
| Read of client * epoch.

Definition request_eq (r1 r2 : request) : bool :=
  match r1, r2 with
  | Update x1, Update x2 => x1 == x2
  | Read x1, Read x2 => x1 == x2
  | _, _ => false
  end.

Lemma request_eqP : Equality.axiom request_eq.
Proof.
  case=>x[]y; do? [by constructor];
  apply: (iffP eqP); congruence.
Qed.

Canonical request_eqMixin := EqMixin request_eqP.
Canonical request_eqType := Eval hnf in EqType request request_eqMixin.

Record server_state :=
  ServerState {
      current_epoch : epoch;
      current_value : value;
      outstanding : seq request
    }.

Definition update_tag := 0.
Definition update_response_tag := 1.
Definition read_tag := 2.
Definition read_response_tag := 3.

Definition msg_from_client ms :=
  (tag ms == update_tag /\ exists e v, tms_cont ms = [:: e; v]) \/
  (tag ms == read_tag /\ exists e, tms_cont ms = [:: e]).

Definition msg_from_server ms :=
  (tag ms == update_response_tag /\ exists e v b, tms_cont ms = [:: e; v; b]) \/
  (tag ms == read_response_tag /\
     ((exists e v, tms_cont ms = [:: e; v] (* success *)) \/
      (exists e, tms_cont ms = [:: e] (* failure *)))).

Definition coh_msg pkt :=
  if from pkt == server
  then to pkt \in clients /\ msg_from_server (content pkt)
  else if from pkt \in clients
  then to pkt == server /\ msg_from_client (content pkt)
  else False.

Definition st := ptr_nat 1.

Definition client_local_coh :=
  [Pred h | h = Heap.empty].

Definition server_local_coh (ss : server_state) :=
  [Pred h | h = st :-> ss].

Definition local_coh (n : nid) :=
  [Pred h | valid h /\
   if n == server
   then exists ss, server_local_coh ss h
   else n \in clients /\
        client_local_coh h].

Definition soup_coh : Pred soup :=
  [Pred s |
    valid s /\
    forall m ms, find m s = Some ms -> active ms -> coh_msg ms].

Lemma soup_coh_post_msg d m:
    soup_coh (dsoup d) -> coh_msg m -> soup_coh (post_msg (dsoup d) m).1.
Proof.
move=>[H1 H2]Cm; split=>[|i ms/=]; first by rewrite valid_fresh.
rewrite findUnL; last by rewrite valid_fresh.
case: ifP=>E; first by move/H2.
by move/findPt_inv=>[Z G]; subst i m.
Qed.

Definition state_coh d :=
  forall n, n \in nodes -> local_coh n (getLocal n d).

Definition resource_coh d :=
  let: dl := dstate d in
  let: ds := dsoup d in
  [/\ soup_coh ds
   , dom dl =i nodes
   , valid dl
   & state_coh d].

Lemma l1 d: resource_coh d -> valid (dstate d).
Proof. by case. Qed.

Lemma l2 d: resource_coh d -> valid (dsoup d).
Proof. by case; case. Qed.

Lemma l3 d: resource_coh d -> dom (dstate d) =i nodes.
Proof. by case. Qed.

Definition ResourceCoh := CohPred (CohPredMixin l1 l2 l3).

Lemma consume_coh d m : ResourceCoh d -> soup_coh (consume_msg (dsoup d) m).
Proof.
move=>C; split=>[|m' msg]; first by apply: consume_valid; rewrite (cohVs C).
case X: (m == m');[move/eqP: X=><-{m'}|].
- case/(find_mark (cohVs C))=>tms[E]->{msg}.
  by case:(C); case=>_/(_ m tms E).
rewrite eq_sym in X.
rewrite (mark_other (cohVs C) X)=>E.
by case:(C); case=>_; move/(_ m' msg E).
Qed.

Lemma coh_dom_upd this d s :
  this \in nodes -> ResourceCoh d -> dom (upd this s (dstate d)) =i nodes.
Proof.
move=>D C z; rewrite -(cohDom C) domU inE/=.
by case: ifP=>///eqP->{z}; rewrite (cohDom C) D; apply: cohVl C.
Qed.

Definition server_send_step (ss : server_state) (to : nid) (tag : nat) (msg : seq nat)
  : server_state :=
  if to \in clients
  then if tag == update_response_tag
       then if msg is [:: e; v; b]
            then let: r := Update (to, e, v)
                 in if current_epoch ss <= e
                    then ServerState e v (seq.rem r (outstanding ss))
                    else ServerState (current_epoch ss) (current_value ss) (seq.rem r (outstanding ss))
            else ss
       else if tag == read_response_tag
       then if msg is e :: _
            then let: r := Read (to, e)
                 in ServerState (current_epoch ss) (current_value ss) (seq.rem r (outstanding ss))
            else ss
       else ss
  else ss.

Definition server_recv_step (ss : server_state) (from : nid)
           (mtag : nat) (mbody : seq nat) : server_state :=
  if mtag == update_tag
  then
    if mbody is [:: e; v]
    then ServerState (current_epoch ss) (current_value ss) (cons (Update (from, e, v)) (outstanding ss))
    else ss
  else (* mtag == read_tag *)
    if mbody is [:: e]
    then ServerState (current_epoch ss) (current_value ss) (cons (Read (from, e)) (outstanding ss))
    else ss.

Section GetterLemmas.

Lemma getLocal_coh n d (C : ResourceCoh d):
  n \in nodes ->
  valid (getLocal n d) /\
  if n == server
  then exists (ss : server_state),
      getLocal n d = st :-> ss
  else (n \in clients) /\
       getLocal n d = Unit.
Proof.
  by case: C=>_ _ _ /(_ n)G; rewrite /local_coh/=.
Qed.

Lemma getLocal_server_st_tp d (C : ResourceCoh d) s:
  find st (getLocal server d) = Some s ->
  dyn_tp s = server_state.
Proof.
have pf: server \in nodes by rewrite inE eqxx.
move: (getLocal_coh C pf); rewrite eqxx; move =>[V][s']Z; rewrite Z in V *.
by rewrite findPt /=; case=><-.
Qed.

Definition getSt_server d (C : ResourceCoh d) : server_state :=
  match find st (getLocal server d) as f return _ = f -> _ with
    Some v => fun epf => icast (sym_eq (getLocal_server_st_tp C epf)) (dyn_val v)
  | _ => fun epf => ServerState 0 0 [::]
  end (erefl _).

Lemma getSt_server_K d (C : ResourceCoh d) m :
  getLocal server d = st :-> m -> getSt_server C = m.
Proof.
move=>E; rewrite /getSt_server/=.
have pf: server \in nodes by rewrite inE eqxx.
have V: valid (getLocal server d) by case: (getLocal_coh C pf).
move: (getLocal_server_st_tp C); rewrite !E=>/= H.
by apply: eqc.
Qed.

End GetterLemmas.

Section ServerGenericSendTransitions.

Definition HServ this to := (this == server /\ to \in clients).

Variable the_tag : nat.

Variable prec : server_state -> nid -> seq nat -> Prop.

Hypothesis prec_safe :
  forall this to s m,
    HServ this to ->
    prec s to m ->
    coh_msg (Msg (TMsg the_tag m) this to true).

Notation coh := ResourceCoh.

Definition server_send_safe (this n : nid)
           (d : dstatelet) (msg : seq nat) :=
  HServ this n /\
  exists (C : coh d), prec (getSt_server C) n msg.

Lemma server_send_safe_coh this to d m : server_send_safe this to d m -> coh d.
Proof. by case=>_[]. Qed.

Lemma server_send_this_in this to : HServ this to -> this \in nodes.
Proof. by case=>/eqP->; rewrite inE eqxx. Qed.

Lemma server_send_to_in this to : HServ this to -> to \in nodes.
Proof. by case=>_; rewrite /nodes inE/= orbC=>->. Qed.

Lemma server_send_safe_in this to d m : server_send_safe this to d m ->
                                  this \in nodes /\ to \in nodes.
Proof.
by case=>[]=>G _; move/server_send_to_in: (G)->; case: G=>/eqP-> _; rewrite inE eqxx.
Qed.

Definition server_step (this to : nid) (d : dstatelet)
           (msg : seq nat)
           (pf : server_send_safe this to d msg) :=
  let C := server_send_safe_coh pf in
  let s := getSt_server C in
  Some (st :-> server_send_step s to the_tag msg).

Lemma server_step_coh : s_step_coh_t coh the_tag server_step.
Proof.
move=>this to d msg pf h[]->{h}.
have C : (coh d) by case: pf=>?[].
have E: this = server by case: pf=>[][]/eqP.
split=>/=.
- apply: soup_coh_post_msg; first by case:(server_send_safe_coh pf).
  case: (pf)=>H[C']P/=.
  by apply: (prec_safe _ P).
- by apply: coh_dom_upd=>//; case: (server_send_safe_in pf).
- by rewrite validU; apply: cohVl C.
move=>n Ni. rewrite /local_coh/=.
rewrite /getLocal/=findU; case: ifP=>B; last by case: C=>_ _ _/(_ n Ni).
move/eqP: B=>Z; subst n this; rewrite eqxx (cohVl C)/=.
split.
by rewrite validPt.
by eexists.
Qed.

Lemma server_step_def this to d msg :
      server_send_safe this to d msg <->
      exists b pf, @server_step this to d msg pf = Some b.
Proof.
split=>[pf/=|]; last by case=>?[].
rewrite /server_step.
by eexists _, pf.
Qed.

Definition server_send_trans :=
  SendTrans server_send_safe_coh server_send_safe_in server_step_def server_step_coh.

End ServerGenericSendTransitions.

Section ServerSendTransitions.

Definition server_send_update_response_prec (ss : server_state) to m :=
  exists e v b e0 v0 outstanding,
    m = [:: e; v; b] /\
    let: r := Update (to, e, v)
    in r \in outstanding /\
       ss = ServerState e0 v0 outstanding /\
       b = if e0 <= e then 1 else 0.

Program Definition server_send_update_response_trans : send_trans ResourceCoh :=
  @server_send_trans update_response_tag server_send_update_response_prec _.
Next Obligation.
case: H=>/eqP->H; rewrite /coh_msg eqxx; split=>//=.
case: H0=>[e][v][b][e0][v0][out][]->[U][_]->.
rewrite /msg_from_server /= eqxx. left. split=>//. by eexists _, _, _.
Qed.

Definition server_send_read_response_prec (ss : server_state) to m :=
  exists e e0 v0 outstanding,
    ss = ServerState e0 v0 outstanding /\
    let: r := Read (to, e)
    in r \in outstanding /\
       m = if e0 <= e
           then [:: e; v0 ]
           else [:: e].

Program Definition server_send_read_response_trans : send_trans ResourceCoh :=
  @server_send_trans read_response_tag server_send_read_response_prec _.
Next Obligation.
case: H=>/eqP->H; rewrite /coh_msg eqxx; split=>//=.
case: H0=>[e][e0][v0][out][_][R]->.
rewrite /msg_from_server /= eqxx. right. split=>//.
by case: ifP=>_; [left; eexists _,_|right; eexists].
Qed.

End ServerSendTransitions.

Section ServerGenericReceiveTransitions.

Notation coh := ResourceCoh.

Variable the_tag : nat.
Variable server_recv_wf : forall d, coh d -> nid -> nid -> TaggedMessage -> bool.

Definition rs_step : receive_step_t coh :=
  fun this (from : nid) (m : seq nat) d (pf : coh d) (pt : this \in nodes) =>
    if (this == server)
    then let s := getSt_server pf in
         st :-> server_recv_step s from the_tag m
    else getLocal this d.

Lemma rs_step_coh : r_step_coh_t server_recv_wf the_tag rs_step.
Proof.
move=>d from this m C pf tms D F Wf T/=.
rewrite /rs_step; case X: (this == server); last first.
- split=>/=; first by apply: consume_coh.
  + by apply: coh_dom_upd.
  + by rewrite validU; apply: cohVl C.
  by move=>n Ni/=; case: (C)=>_ _ _/(_ n Ni)=>L; rewrite -(getLocalU)// (cohVl C).
split=>/=; first by apply: consume_coh.
- by apply: coh_dom_upd.
- by rewrite validU; apply: cohVl C.
move=>n Ni/=; rewrite /local_coh/=.
rewrite /getLocal/=findU; case: ifP=>B/=; last by case: (C)=>_ _ _/(_ n Ni).
move/eqP: B X=>Z/eqP X; subst n this; rewrite eqxx (cohVl C)/=.
split; first by rewrite validPt.
by eexists.
Qed.

Definition rs_recv_trans := ReceiveTrans rs_step_coh.

End ServerGenericReceiveTransitions.

Section ServerReceiveTransitions.

Definition s_matches_tag (ss : server_state) (from : nid) t :=
  (t == read_tag) || (t == update_tag).

Definition server_msg_wf d (C : ResourceCoh d) (this from : nid) :=
  [pred m : TaggedMessage | s_matches_tag (getSt_server C) from (tag m)].

Definition server_recv_update_trans := rs_recv_trans update_tag server_msg_wf.

Definition server_recv_read_trans := rs_recv_trans read_tag server_msg_wf.

End ServerReceiveTransitions.

Section ClientGenericSendTransitions.

Definition HClient this to := (this \in clients /\ to == server).

Variable the_tag : nat.

Variable prec : nid -> seq nat -> Prop.

Hypothesis prec_safe :
  forall this to m,
    HClient this to ->
    prec to m ->
    msg_from_client (TMsg the_tag m).

Notation coh := ResourceCoh.

Lemma client_send_this_in this to : HClient this to -> this \in nodes.
Proof. case=>H _. by apply /client_nodes. Qed.

Definition client_send_safe (this n : nid)
           (d : dstatelet) (msg : seq nat) :=
  [/\ HClient this n, coh d & prec n msg].

Lemma client_send_safe_coh this to d m : client_send_safe this to d m -> coh d.
Proof. by case. Qed.

Lemma client_send_to_in this to : HClient this to -> to \in nodes.
Proof. by case=>_/eqP->; rewrite /nodes inE/= eqxx. Qed.

Lemma client_send_safe_in this to d m : client_send_safe this to d m ->
                                  this \in nodes /\ to \in nodes.
Proof.
case=>HC C P.
split.
- exact: (client_send_this_in HC).
exact: (client_send_to_in HC).
Qed.

Definition client_step (this to : nid) (d : dstatelet)
           (msg : seq nat)
           (pf : client_send_safe this to d msg) :=
  Some Heap.empty.

Lemma client_step_coh : s_step_coh_t coh the_tag client_step.
Proof.
move=>this to d msg pf h[]->{h}.
have C : (coh d) by exact: (client_send_safe_coh pf).
have E: this \in clients by case: pf=>[][].
split=>/=.
- apply: soup_coh_post_msg; first by case:(client_send_safe_coh pf).
  case: (pf)=>H _ P/=.
  rewrite/coh_msg/= client_not_server// E.
  split; first by case: (H).
  by apply: (prec_safe H P).
- by apply: coh_dom_upd=>//; case: (client_send_safe_in pf).
- by rewrite validU; apply: cohVl C.
move=>n Ni. rewrite /local_coh/=.
rewrite /getLocal/=findU; case: ifP=>B; last by case: C=>_ _ _/(_ n Ni).
move/eqP: B=>Z; subst n.
by rewrite client_not_server// (cohVl C)/=.
Qed.

Lemma client_step_def this to d msg :
      client_send_safe this to d msg <->
      exists b pf, @client_step this to d msg pf = Some b.
Proof.
split=>[pf/=|]; last by case=>?[].
by eexists _, pf.
Qed.

Definition client_send_trans :=
  SendTrans client_send_safe_coh client_send_safe_in client_step_def client_step_coh.

End ClientGenericSendTransitions.

Section ClientSendTransitions.

Definition client_send_update_prec (to : nid) (m : seq nat) :=
  exists e v, m = [:: e; v].

Program Definition client_send_update_trans : send_trans ResourceCoh :=
  @client_send_trans update_tag client_send_update_prec _.
Next Obligation.
by left.
Qed.

Definition client_send_read_prec (to : nid) (m : seq nat) :=
  exists e, m = [:: e].

Program Definition client_send_read_trans : send_trans ResourceCoh :=
  @client_send_trans read_tag client_send_read_prec _.
Next Obligation.
by right.
Qed.

End ClientSendTransitions.

Section ClientGenericReceiveTransitions.

Notation coh := ResourceCoh.

Variable the_tag : nat.
Variable client_recv_wf : forall d, coh d -> nid -> nid -> TaggedMessage -> bool.

Definition rc_step : receive_step_t coh :=
  fun this (from : nid) (m : seq nat) d (pf : coh d) (pt : this \in nodes) =>
    getLocal this d.

Lemma rc_step_coh : r_step_coh_t client_recv_wf the_tag rc_step.
Proof.
move=>d from this m C pf tms D F Wf T/=.
rewrite /resource_coh.
split=>/=.
by apply: consume_coh.
by apply: coh_dom_upd.
by rewrite validU; apply: cohVl C.
  have Y: forall z : nat_eqType, z \in nodes -> local_coh z (getLocal z d)
      by case: (C).
by move=>n Ni/=; move: (Y n Ni)=>L; rewrite -(getLocalU) // (cohVl C).
Qed.

Definition rc_recv_trans := ReceiveTrans rc_step_coh.

End ClientGenericReceiveTransitions.

Section ClientReceiveTransitions.

Definition client_msg_wf d (_ : ResourceCoh d) (this from : nid) :=
  [pred m : TaggedMessage | true].

Definition client_recv_update_response_trans := rc_recv_trans update_response_tag client_msg_wf.

Definition client_recv_read_response_trans := rc_recv_trans read_response_tag client_msg_wf.

End ClientReceiveTransitions.

Section Protocol.

Variable l : Label.

(* All send-transitions *)
Definition resource_sends :=
  [::
     server_send_update_response_trans;
     server_send_read_response_trans;
     client_send_update_trans;
     client_send_read_trans
  ].

(* All receive-transitions *)
Definition resource_receives :=
  [::
     server_recv_update_trans;
     server_recv_read_trans;
     client_recv_update_response_trans;
     client_recv_read_response_trans
  ].

Program Definition ResourceProtocol : protocol :=
  @Protocol _ l _ resource_sends resource_receives _ _.

End Protocol.

End ResourceProtocol.

Module Exports.
Section Exports.

Definition ResourceProtocol := ResourceProtocol.

End Exports.
End Exports.

End ResourceProtocol.

Export ResourceProtocol.Exports.


(*
 * Listkit: A library for working with lists in Coq.
 * Copyright Ezra Cooper, 2008-2020.
 *)

Require Import List.

Require Export NthError.

Require Export Foreach.

Require Export All.

Lemma nth_error_foreach_ty :
  forall A P v n xs,
    nth_error xs n = value v -> foreach_ty A xs P -> P v.
Proof.
 induction n; simpl; intros; (destruct xs; [discriminate | ]).
  destruct X as [H0 ?].
  inversion H.
  congruence.
 firstorder.
Qed.

Lemma nth_error_In:
  forall A xs x (v:A),
    nth_error xs x = value v -> ListSet.set_In v xs.
Proof.
 induction xs; unfold nth_error; simpl.
  intros.
  destruct x; discriminate.
 intros x v H.
 destruct x.
  inversion H.
  auto.
 right.
 eapply IHxs; eauto.
Qed.

Lemma nth_error_all:
  forall A xs x v f,
    nth_error xs x = value v ->
    all A f xs ->
    f v.
Proof.
 induction xs; unfold all; simpl; intros.
  unfold nth_error in H.
   destruct x; discriminate.
 apply H0.
 destruct x; simpl in *.
  left; inversion H; auto.
 right.
 apply nth_error_In with x; auto.
Qed.


Require bedrock2.BasicC64Semantics bedrock2.NotationsCustomEntry.
Import BinInt String List.ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.
Require Import coqutil.Macros.ident_to_string.

Section chacha20.
  Import bedrock2.Syntax Syntax.Coercions NotationsCustomEntry.

  Local Notation "x <<<= n" := (cmd.set (ident_to_string! x) (expr.op bopname.slu (ident_to_string! x) n)) (in custom bedrock_cmd at level 0, x ident, n bigint).
  Local Notation "x ^= e" := (cmd.set (ident_to_string! x) (expr.op bopname.xor (ident_to_string! x) e)) (in custom bedrock_cmd at level 0, x ident, e custom bedrock_expr).
  Local Notation "x += e" := (cmd.set (ident_to_string! x) (expr.op bopname.add (ident_to_string! x) e)) (in custom bedrock_cmd at level 0, x ident, e custom bedrock_expr).

  Definition chacha20_quarter : func :=
    ("chacha20_quarter", (["a";"b";"c";"d"], ["a";"b";"c";"d"], bedrock_func_body:(
      a += b; d ^= a; d <<<= 16;
      c += d; b ^= c; b <<<= 12;
      a += b; d ^= a; d <<<= 8;
      c += d; b ^= c; b <<<= 7
    ))).

  Local Notation "'xorout' o x" := (
      let addr := bedrock_expr:(out+coq:(expr.literal(4*o))) in
      bedrock_cmd:(store4($addr, load4($addr)^$(expr.var (ident_to_string! x)))))
      (in custom bedrock_cmd at level 0, o bigint, x ident).

  Definition chacha20_block : func :=
    (* NOTE: I (REDACTED) don't understand why xorout needs these *)
    let x0  := "x0" in let x1  := "x1" in let x2  := "x2" in let x3  := "x3" in
    let x4  := "x4" in let x5  := "x5" in let x6  := "x6" in let x7  := "x7" in
    let x8  := "x8" in let x9  := "x9" in let x10 := "x10" in let x11 := "x11" in
    let x12 := "x12" in let x13 := "x13" in let x14 := "x14" in let x15 := "x15" in
    ("chacha20_block", (["out"; "key"; "nonce"; "countervalue"], [], bedrock_func_body:(
      x0 = $0x61707865;   x1 = $0x3320646e;   x2 = $0x79622d32;    x3 = $0x6b206574;
      x4 = load4(key);           x5 = load4(key+$4);   x6 = load4(key+$8);    x7 = load4(key+$12);
      x8 = load4(key+$16);  x9 = load4(key+$20); x10 = load4(key+$24);  x11 = load4(key+$28);
      x12 = countervalue;       x13 = load4(nonce);        x14 = load4(nonce+$4); x15 = load4(nonce+$8);
      i = $0; while (i < $10) { i += $1;
        (x0, x4,  x8, x12) = chacha20_quarter( x0, x4, x8,  x12);
        (x1, x5,  x9, x13) = chacha20_quarter( x1, x5, x9,  x13);
        (x2, x6, x10, x14) = chacha20_quarter( x2, x6, x10, x14);
        (x3, x7, x11, x15) = chacha20_quarter( x3, x7, x11, x15);
        (x0, x5, x10, x15) = chacha20_quarter( x0, x5, x10, x15);
        (x1, x6, x11, x12) = chacha20_quarter( x1, x6, x11, x12);
        (x2, x7,  x8, x13) = chacha20_quarter( x2, x7, x8,  x13);
        (x3, x4,  x9,  x1) = chacha20_quarter( x3, x4, x9,  x14)
      };
      x0 += $0x61707865;  x1 += $0x3320646e;   x2 += $0x79622d32;    x3 += $0x6b206574;
      x4 += load4(key);          x5 += load4(key+$4);   x6 += load4(key+$8);    x7 += load4(key+$12);
      x8 += load4(key+$16); x9 += load4(key+$20); x10 += load4(key+$24);  x11 += load4(key+$28);
      x12 += countervalue;      x13 += load4(nonce);        x14 += load4(nonce+$4); x15 += load4(nonce+$8);
      xorout  0  x0;   xorout 1 x1; xorout 2   x2;  xorout 3  x3;
      xorout  4  x4;   xorout 5 x5; xorout 6   x6;  xorout 7  x7;
      xorout  8  x8;   xorout 9 x9; xorout 10 x10; xorout 11 x11;
      xorout 12 x12; xorout 13 x13; xorout 14 x14; xorout 15 x15
  ))).
End chacha20.

(*
Require bedrock2.ToCString.
Example chacha20_block_c_string := Eval vm_compute in
  ToCString.c_module [chacha20_quarter; chacha20_block].
Print chacha20_block_c_string.
*)


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.backtranslations.un_syn Require Import expressions universe.base.

Inductive refinement :=
  | syn_le_un (* syntactically-typed in universe ≤ untyped *)
  | un_le_syn. (* untyped ≤ syntactically-typed in universe *)

Existing Class refinement.

Section definitions.

  Context `{Σ : !gFunctors}.
  Context `{irisGS_inst : !irisGS STLCmuVS_lang Σ}.

  Context {rfn : refinement}.

  Definition s : stuckness := MaybeStuck.
    (* match rfn with *)
    (* | syn_le_un => NotStuck *)
    (* | un_le_syn => MaybeStuck (* untyped can of course get stuck *) *)
    (* end. *)

  Definition canon_tc_lift (tc : type_constructor) (Ψ : valO -n> valO -n> iPropO Σ) (xᵢ xₛ : valO) : iPropO Σ :=
    (match tc with
     | TCUnit => ⌜ xᵢ = ()%Vₙₒ ⌝ ∧ ⌜ xₛ = ()%Vₙₒ ⌝
     | TCBool => ∃ b : bool, ⌜ xᵢ = b%Vₙₒ ⌝ ∧ ⌜ xₛ = b ⌝
     | TCInt => ∃ z : Z, ⌜ xᵢ = z%Vₙₒ ⌝ ∧ ⌜ xₛ = z ⌝
     | TCProd => ∃ v1 v2 v1' v2', ⌜ xᵢ = (v1, v2)%Vₙₒ ⌝ ∧ ⌜ xₛ = (v1', v2')%Vₙₒ ⌝ ∧ (▷ Ψ v1 v1') ∗ (▷ Ψ v2 v2')
     | TCSum => ∃ vi vi', (⌜ xᵢ = InjLV vi ⌝ ∧ ⌜ xₛ = InjLV vi' ⌝ ∧ ▷ Ψ vi vi') ∨
                         (⌜ xᵢ = InjRV vi ⌝ ∧ ⌜ xₛ = InjRV vi' ⌝ ∧ ▷ Ψ vi vi')
     | TCArrow => ∃ e , ⌜ xᵢ = LamV e ⌝ ∧ ▷ □ (∀ w w', Ψ w w' -∗ lift s Ψ e.[of_val w/] (of_val xₛ w'))
     | TCRec => ∃ w w', ⌜ xᵢ = FoldV w ⌝ ∧ ⌜ xₛ = FoldV w' ⌝ ∧ ▷ Ψ w w'
     end)%I.

  Definition valrel_gen_pre (Ψ : valO -n> valO -n> iPropO Σ) (vᵢ vₛ : valO) : iPropO Σ :=
    match rfn with
    | syn_le_un => (∃ tc vᵢ', ⌜ vᵢ = inject_val tc vᵢ' ⌝ ∧ canon_tc_lift tc Ψ vᵢ' vₛ)%I
    | un_le_syn => (∃ tc vₛ', ⌜ vₛ = inject_val tc vₛ' ⌝ ∧ canon_tc_lift tc Ψ vᵢ vₛ')%I
    end.

  Definition valrel_gen (Ψ : valO -n> valO -n> iPropO Σ) : valO -n> valO -n> iPropO Σ := λne v v', valrel_gen_pre Ψ v v'.

  Instance valrel_gen_contractive : Contractive valrel_gen.
  Proof.
    intros n P1 P2 dl. rewrite /valrel_gen. intros v v'. simpl.
    rewrite /valrel_gen_pre; destruct rfn; f_equiv; intro tc; rewrite /inject_val /InjVTC /canon_tc_lift; destruct tc; rewrite /lift; solve_contractive.
  Qed.

  Definition valrel := fixpoint valrel_gen.

  Lemma valrel_unfold v1 v2 : fixpoint valrel_gen v1 v2 ≡ valrel_gen (fixpoint valrel_gen) v1 v2.
  Proof. do 2 f_equiv. by rewrite -fixpoint_unfold. Qed.

  Global Instance valrel_persistent u v' : Persistent (valrel u v').
  Proof.
    rewrite /Persistent. revert u v'. iLöb as "IHlob". iIntros (u v') "Huv'".
    rewrite valrel_unfold /= /valrel_gen_pre. destruct rfn.
    { iDestruct "Huv'" as (tc v) "[-> Hvv']".
    iExists tc, v. iSplit; auto. destruct tc; try by iDestruct "Hvv'" as "#Hvv'".
    - simpl; fold valrel. iDestruct "Hvv'" as (v1 v2 v1' v2') "(-> & -> & H1 & H2)".
      iExists v1, v2, v1', v2'. repeat iSplit; auto.
      iApply bi.later_persistently_1. iNext. by iApply "IHlob".
      iApply bi.later_persistently_1. iNext. by iApply "IHlob".
    - simpl; fold valrel. iDestruct "Hvv'" as (vi vi') "[(-> & -> & H) | (-> & -> & H)]".
      iExists _, _. iLeft. repeat iSplit; auto. iApply bi.later_persistently_1. by iApply "IHlob".
      iExists _, _. iRight. repeat iSplit; auto. iApply bi.later_persistently_1. by iApply "IHlob".
    - simpl. fold valrel. iDestruct "Hvv'" as (w w') "(-> & -> & H)".
      iExists _,_. repeat iSplit; auto. iApply bi.later_persistently_1. by iApply "IHlob". }
    { iDestruct "Huv'" as (tc v) "[-> Hvv']".
    iExists tc, v. iSplit; auto. destruct tc; try by iDestruct "Hvv'" as "#Hvv'".
    - simpl; fold valrel. iDestruct "Hvv'" as (v1 v2 v1' v2') "(-> & -> & H1 & H2)".
      iExists v1, v2, v1', v2'. repeat iSplit; auto.
      iApply bi.later_persistently_1. iNext. by iApply "IHlob".
      iApply bi.later_persistently_1. iNext. by iApply "IHlob".
    - simpl; fold valrel. iDestruct "Hvv'" as (vi vi') "[(-> & -> & H) | (-> & -> & H)]".
      iExists _, _. iLeft. repeat iSplit; auto. iApply bi.later_persistently_1. by iApply "IHlob".
      iExists _, _. iRight. repeat iSplit; auto. iApply bi.later_persistently_1. by iApply "IHlob".
    - simpl. fold valrel. iDestruct "Hvv'" as (w w') "(-> & -> & H)".
      iExists _,_. repeat iSplit; auto. iApply bi.later_persistently_1. by iApply "IHlob". }
  Qed.

  Definition exprel : exprO -n> exprO -n> iPropO Σ :=
    λne eᵢ eₛ, lift s valrel eᵢ eₛ.

  Definition open_exprel (n : nat) (e : expr) (e' : expr) : Prop :=
    ∀ (us : list val) (vs' : list val), length us = n →
      ([∗ list] uᵢ ; vᵢ' ∈ us ; vs', valrel uᵢ vᵢ') ⊢
        exprel e.[subst_list_val us] e'.[subst_list_val vs'].

  Lemma open_exprel_nil e e' : (⊢ exprel e e') -> open_exprel 0 e e'.
  Proof. iIntros (Hee' vs vs' Hl) "Hvv'". destruct vs, vs'; try by inversion Hl. asimpl. iApply Hee'. Qed.

  Lemma open_exprel_nil' e e' : open_exprel 0 e e' → (⊢ exprel e e').
  Proof. iIntros (Hee'). iDestruct (Hee' [] []) as "H". auto. asimpl. by iApply "H". Qed.

  Definition ctx_rel (n m : nat)
             (C : ctx)
             (C' : ctx) :=
    ∀ e e' , open_exprel n e e' → open_exprel m (fill_ctx C e) (fill_ctx C' e').

  Lemma ctx_rel_app (n m l : nat) (C1 C1' C2 C2' : ctx) :
    ctx_rel n m C2 C2' → ctx_rel m l C1 C1' →
    ctx_rel n l (C1 ++ C2) (C1' ++ C2').
  Proof. intros H2 H1 e e' Hee'. rewrite -!fill_ctx_app. apply H1, H2, Hee'. Qed.

End definitions.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From fcsl
Require Import prelude pred pcm unionmap heap.
From HTT
Require Import stmod stsep stlog stlogR.
From SSL
Require Import core.
From Hammer Require Import Hammer.
(* Configure Hammer *)
Set Hammer ATPLimit 60.
Unset Hammer Eprover.
Unset Hammer Vampire.
Add Search Blacklist "fcsl.".
Add Search Blacklist "HTT.".
Add Search Blacklist "Coq.ssr.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.bigop".
Add Search Blacklist "mathcomp.ssreflect.choice".
Add Search Blacklist "mathcomp.ssreflect.div".
Add Search Blacklist "mathcomp.ssreflect.finfun".
Add Search Blacklist "mathcomp.ssreflect.fintype".
Add Search Blacklist "mathcomp.ssreflect.path".
Add Search Blacklist "mathcomp.ssreflect.tuple".

Inductive bst (x : ptr) (sz : nat) (lo : nat) (hi : nat) (h : heap) : Prop :=
| bst_1 of (x) == (null) of
  (hi) == (0) /\ (lo) == (7) /\ (sz) == (0) /\ h = empty
| bst_2 of ~~ ((x) == (null)) of
  exists (sz1 : nat) (sz2 : nat) (v : nat) (hi2 : nat) (hi1 : nat) (lo1 : nat) (lo2 : nat) (l : ptr) (r : ptr),
  exists h_bst_lsz1lo1hi1_0 h_bst_rsz2lo2hi2_1,
  (0) <= (sz1) /\ (0) <= (sz2) /\ (0) <= (v) /\ (hi) == ((if (hi2) <= (v) then v else hi2)) /\ (hi1) <= (v) /\ (lo) == ((if (v) <= (lo1) then v else lo1)) /\ (sz) == (((1) + (sz1)) + (sz2)) /\ (v) <= (7) /\ (v) <= (lo2) /\ h = x :-> (v) \+ x .+ 1 :-> (l) \+ x .+ 2 :-> (r) \+ h_bst_lsz1lo1hi1_0 \+ h_bst_rsz2lo2hi2_1 /\ bst l sz1 lo1 hi1 h_bst_lsz1lo1hi1_0 /\ bst r sz2 lo2 hi2 h_bst_rsz2lo2hi2_1.