Set Implicit Arguments.

Require Import Coq.Lists.List.
Require Import Bedrock.Platform.Cito.ListFacts1 Bedrock.Platform.Cito.ListFacts2 Bedrock.Platform.Cito.ListFacts3.
Require Import Bedrock.ListFacts.
Require Import Bedrock.Platform.Cito.GeneralTactics.
Require Import Bedrock.Platform.Cito.GeneralTactics4.
Require Import Bedrock.Platform.Cito.Option.

Lemma combine_length_eq A B (ls1 : list A) : forall (ls2 : list B), length ls1 = length ls2 -> length (combine ls1 ls2) = length ls1.
Proof.
  induction ls1; destruct ls2; simpl in *; intros; intuition.
Qed.

Lemma nth_error_combine A B ls1 : forall ls2 i (a : A) (b : B), nth_error ls1 i = Some a -> nth_error ls2 i = Some b -> nth_error (combine ls1 ls2) i = Some (a, b).
Proof.
  induction ls1; destruct ls2; destruct i; simpl in *; intros; try discriminate.
  inject H; inject H0; eauto.
  eauto.
Qed.

Lemma nth_error_combine_elim A B ls1 : forall ls2 i (a : A) (b : B), nth_error (combine ls1 ls2) i = Some (a, b) -> nth_error ls1 i = Some a /\ nth_error ls2 i = Some b.
Proof.
  induction ls1; destruct ls2; destruct i; simpl in *; intros; try discriminate.
  inject H; eauto.
  eauto.
Qed.

Lemma nth_error_map_elim : forall A B (f : A -> B) ls i b, nth_error (List.map f ls) i = Some b -> exists a, nth_error ls i = Some a /\ f a = b.
  intros.
  rewrite ListFacts.map_nth_error_full in H.
  destruct (option_dec (nth_error ls i)).
  destruct s; rewrite e in *; inject H; eexists; eauto.
  rewrite e in *; discriminate.
Qed.

Lemma map_nth_error_1 : forall A B (f : A -> B) ls1 ls2 i a, List.map f ls1 = ls2 -> nth_error ls1 i = Some a -> nth_error ls2 i = Some (f a).
  intros.
  rewrite <- H.
  erewrite map_nth_error; eauto.
Qed.

Lemma map_nth_error_2 A B (f : A -> B) ls1 : forall ls2 i b, List.map f ls1 = ls2 -> nth_error ls2 i = Some b -> exists a, nth_error ls1 i = Some a /\ f a = b.
Proof.
  induction ls1; destruct ls2; destruct i; simpl in *; intros; try discriminate.
  inject H; inject H0; eexists; eauto.
  inject H; eauto.
Qed.

Lemma map_eq_nth_error_1 : forall A1 A2 B (f1 : A1 -> B) (f2 : A2 -> B) ls1 ls2 i a1, List.map f1 ls1 = List.map f2 ls2 -> nth_error ls1 i = Some a1 -> exists a2, nth_error ls2 i = Some a2 /\ f1 a1 = f2 a2.
  intros.
  eapply map_nth_error_1 in H; eauto.
  eapply nth_error_map_elim in H; openhyp.
  eexists; eauto.
Qed.

Lemma in_nth_error A ls : forall (a : A), List.In a ls -> exists i, nth_error ls i = Some a.
Proof.
  induction ls; simpl in *; intros.
  intuition.
  openhyp.
  subst.
  exists 0; eauto.
  eapply IHls in H; eauto.
  openhyp.
  exists (S x); eauto.
Qed.

Lemma nth_error_nil A i : nth_error (@nil A) i = None.
Proof.
  destruct i; simpl in *; eauto.
Qed.

Fixpoint mapM A B (f : A -> option B) ls :=
  match ls with
    | x :: xs =>
      match f x, mapM f xs with
        | Some y, Some ys => Some (y :: ys)
        | _, _ => None
      end
    | nil => Some nil
  end.

Lemma mapM_length A B (f : A -> option B) ls1 : forall ls2, mapM f ls1 = Some ls2 -> length ls1 = length ls2.
Proof.
  induction ls1; destruct ls2; simpl in *; intros; try discriminate.
  eauto.
  destruct (option_dec (f a)) as [[y Hy] | Hnone].
  rewrite Hy in *.
  destruct (option_dec (mapM f ls1)) as [[ys Hys] | Hnone].
  rewrite Hys in *.
  discriminate.
  rewrite Hnone in *; discriminate.
  rewrite Hnone in *; discriminate.

  f_equal.
  destruct (option_dec (f a)) as [[y Hy] | Hnone].
  rewrite Hy in *.
  destruct (option_dec (mapM f ls1)) as [[ys Hys] | Hnone].
  rewrite Hys in *.
  inject H; eauto.
  rewrite Hnone in *; discriminate.
  rewrite Hnone in *; discriminate.
Qed.

Lemma mapM_nth_error_1 A B (f : A -> option B) ls1 : forall ls2 i a, mapM f ls1 = Some ls2 -> nth_error ls1 i = Some a -> exists b, nth_error ls2 i = Some b /\ f a = Some b.
Proof.
  induction ls1; destruct ls2; destruct i; simpl in *; intros; try discriminate.
  destruct (option_dec (f a)) as [[y Hy] | Hnone].
  rewrite Hy in *.
  destruct (option_dec (mapM f ls1)) as [[ys Hys] | Hnone].
  rewrite Hys in *.
  discriminate.
  rewrite Hnone in *; discriminate.
  rewrite Hnone in *; discriminate.
  destruct (option_dec (f a)) as [[y Hy] | Hnone].
  rewrite Hy in *.
  destruct (option_dec (mapM f ls1)) as [[ys Hys] | Hnone].
  rewrite Hys in *.
  discriminate.
  rewrite Hnone in *; discriminate.
  rewrite Hnone in *; discriminate.
  destruct (option_dec (f a)) as [[y Hy] | Hnone].
  rewrite Hy in *.
  destruct (option_dec (mapM f ls1)) as [[ys Hys] | Hnone].
  rewrite Hys in *.
  inject H; inject H0; eexists; eauto.
  rewrite Hnone in *; discriminate.
  rewrite Hnone in *; discriminate.
  destruct (option_dec (f a)) as [[y Hy] | Hnone].
  rewrite Hy in *.
  destruct (option_dec (mapM f ls1)) as [[ys Hys] | Hnone].
  rewrite Hys in *.
  inject H; eauto.
  rewrite Hnone in *; discriminate.
  rewrite Hnone in *; discriminate.
Qed.

Lemma length_eq_nth_error A B ls1 : forall ls2 i (a : A), nth_error ls1 i = Some a -> length ls1 = length ls2 -> exists b : B, nth_error ls2 i = Some b.
Proof.
  induction ls1; destruct ls2; destruct i; simpl in *; intros; try discriminate.
  inject H; inject H0; eexists; eauto.
  inject H0; eauto.
Qed.

Lemma mapM_nth_error_2 A B (f : A -> option B) ls1 ls2 i a2 : mapM f ls1 = Some ls2 -> nth_error ls2 i = Some a2 -> exists a1, nth_error ls1 i = Some a1 /\ f a1 = Some a2.
Proof.
  intros Hmm Ha2.
  copy_as Ha2 Ha2'; eapply length_eq_nth_error in Ha2'.
  2 : symmetry; eapply mapM_length; eauto.
  destruct Ha2' as [a1 Ha1].
  eapply mapM_nth_error_1 in Hmm; eauto.
  destruct Hmm as [a2' [Ha2' Hf]].
  unif a2'.
  rewrite <- Hf in *.
  eexists; eauto.
Qed.

Lemma cons_incl_elim A (a : A) ls1 ls2 : incl (a :: ls1) ls2 -> List.In a ls2 /\ incl ls1 ls2.
Proof.
  unfold incl.
  intros Hincl.
  split.
  eapply Hincl.
  eapply in_eq.
  intros a' Hin.
  eapply Hincl.
  eapply in_cons; eauto.
Qed.

Lemma incl_nth_error A ls1 : forall i ls2 (a : A), List.incl ls1 ls2 -> nth_error ls1 i = Some a -> exists i', nth_error ls2 i' = Some a.
Proof.
  induction ls1; destruct i; simpl in *; intros; try discriminate.
  inject H0.
  eapply cons_incl_elim in H.
  openhyp.
  eapply in_nth_error; eauto.
  eapply IHls1; eauto.
  eapply cons_incl_elim in H.
  openhyp.
  eauto.
Qed.

Lemma combine_map A B C (f1 : A -> B) (f2 : A -> C) ls : combine (List.map f1 ls) (List.map f2 ls) = List.map (fun x => (f1 x, f2 x)) ls.
Proof.
  induction ls; simpl in *; intros; try f_equal; eauto.
Qed.

Lemma nth_error_In : forall A (x : A) ls n,
                       nth_error ls n = Some x
                       -> In x ls.
  induction ls; destruct n; simpl; intuition; try discriminate; eauto.
  injection H; intros; subst; auto.
Qed.

Lemma NoDup_nth_error A ls : NoDup ls -> forall i i' (x : A), nth_error ls i = Some x -> nth_error ls i' = Some x -> i = i'.
Proof.
  induction 1; destruct i; destruct i'; simpl in *; intros; try discriminate.
  eauto.
  inject H1.
  contradict H; eapply nth_error_In; eauto.
  inject H2.
  contradict H; eapply nth_error_In; eauto.
  f_equal; eauto.
Qed.

Arguments fst {A B} _ .
Arguments snd {A B} _ .

Lemma map_fst_combine A B (ls1 : list A) : forall (ls2 : list B), length ls1 = length ls2 -> List.map fst (combine ls1 ls2) = ls1.
  induction ls1; destruct ls2; simpl in *; intros; try discriminate; intuition.
  f_equal; eauto.
Qed.

Lemma map_snd_combine A B (ls1 : list A) : forall (ls2 : list B), length ls1 = length ls2 -> List.map snd (combine ls1 ls2) = ls2.
  induction ls1; destruct ls2; simpl in *; intros; try discriminate; intuition.
  f_equal; eauto.
Qed.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.

Global Add Parametric Morphism A B : (@List.map A B)
    with signature pointwise_relation A eq ==> eq ==> eq as list_map_m.
Proof.
  intros; eapply map_ext; eauto.
Qed.

Lemma In_map_ext A B (f g : A -> B) : forall ls, (forall x, List.In x ls -> f x = g x) -> List.map f ls = List.map g ls.
Proof.
  induction ls; simpl; intros Hfg; trivial.
  f_equal.
  {
    eapply Hfg.
    eauto.
  }
  eapply IHls.
  intuition.
Qed.

Lemma in_singleton_iff A (x' x : A) : List.In x' (x :: nil) <-> x' = x.
Proof.
  intros; subst; simpl in *; intuition.
Qed.

Require Import Bedrock.Platform.Cito.GeneralTactics2.

Lemma singleton_iff_not : forall elt (e e' : elt), ~ List.In e' (e :: nil) <-> e <> e'.
  unfold List.In; split; intros; not_not; intuition.
Qed.

Lemma combine_fst_snd A B (pairs : list (A * B)) : List.combine (List.map fst pairs) (List.map snd pairs) = pairs.
Proof.
  rewrite combine_map.
  setoid_rewrite <- surjective_pairing.
  rewrite map_id.
  eauto.
Qed.

Lemma map_eq_length_eq : forall A B C (f1 : A -> B) ls1 (f2 : C -> B) ls2, map f1 ls1 = map f2 ls2 -> length ls1 = length ls2.
  intros; assert (length (map f1 ls1) = length (map f2 ls2)) by congruence; repeat rewrite map_length in *; eauto.
Qed.

Lemma Forall_forall_1 A P (ls : list A) : Forall P ls -> (forall x, List.In x ls -> P x).
  intros; eapply Forall_forall; eauto.
Qed.


Require Import Util MapDefined LengthEq Map CSet AutoIndTac AllInRel.
Require Import Var Val Exp Envs IL Sawtooth SimF BisimEq MoreCtxEq ILStateType.

Set Implicit Arguments.
Unset Printing Records.

(** * Contextual Equivalence *)

Inductive stmtCtx : Type :=
| ctxExp    (x : var) (e: exp) (C : stmtCtx) : stmtCtx
| ctxIfS     (e : op) (C : stmtCtx) (t : stmt) : stmtCtx
| ctxIfT     (e : op) (s : stmt) (C : stmtCtx) : stmtCtx
(* block f Z : rt = s in b  *)
| ctxLetS    (F1: list (params*stmt)) (Z:params) (C : stmtCtx) (F2: list (params*stmt)) (t : stmt) : stmtCtx
| ctxLetT    (F: list (params*stmt)) (C : stmtCtx) : stmtCtx
| ctxHole.

Fixpoint fill (ctx:stmtCtx) (s':stmt) : stmt :=
  match ctx with
    | ctxExp x e ctx => stmtLet x e (fill ctx s')
    | ctxIfS e ctx t => stmtIf e (fill ctx s') t
    | ctxIfT e s ctx => stmtIf e s (fill ctx s')
    | ctxLetS F1 Z ctx F2 t => stmtFun (F1 ++ (Z,fill ctx s')::F2) t
    | ctxLetT F ctx => stmtFun F (fill ctx s')
    | ctxHole => s'
  end.

Fixpoint fillC (ctx:stmtCtx) (s':stmtCtx) : stmtCtx :=
  match ctx with
    | ctxExp x e ctx => ctxExp x e (fillC ctx s')
    | ctxIfS e ctx t => ctxIfS e (fillC ctx s') t
    | ctxIfT e s ctx => ctxIfT e s (fillC ctx s')
    | ctxLetS F1 Z ctx F2 t => ctxLetS F1 Z (fillC ctx s') F2 t
    | ctxLetT F ctx => ctxLetT F (fillC ctx s')
    | ctxHole => s'
  end.

(** ** Program Equivalence is contextual *)

Lemma simeq_contextual p s s' ctx
: bisimeq bot3 p s s'
  -> bisimeq bot3 p (fill ctx s) (fill ctx s').
Proof.
  intros. general induction ctx; simpl; hnf; intros; eauto.
  - destruct e.
    + eapply (sim_let_op il_statetype_F); eauto.
      intros. left. eapply IHctx; eauto.
    + eapply (sim_let_call il_statetype_F); eauto.
      intros. left. eapply IHctx; eauto.
  - eapply (sim_cond il_statetype_F); eauto; intros; left.
    + eapply IHctx; eauto.
    + eapply bisimeq_refl; eauto.
  - eapply (sim_cond il_statetype_F); eauto; intros; left.
    + eapply bisimeq_refl; eauto.
    + eapply IHctx; eauto.
  - pone_step. left.
    eapply bisimeq_refl; eauto 20 with len.
    rewrite !map_app. intros.
    eapply labenv_sim_extension_ptw; simpl; eauto 20 with len.
    + intros; hnf; intros.
      { destruct (get_subst _ _ _ H5) as [? |[?|?]].
        - inv_get; simpl in *; dcr; subst.
          inv_get.
          eapply bisimeq_refl; eauto 20 with len.
          rewrite !map_app. eauto.
        - simpl in *. dcr; subst. subst. invc H9.
          inv_get. simpl in *.
          eapply bisimeq_bot; eauto with len.
          rewrite !map_app. intros; eauto.
        - simpl in *; dcr; subst.
          inv_get. simpl in *.
          eapply bisimeq_refl; eauto 20 with len.
          rewrite !map_app; eauto.
      }
    + hnf; intros; simpl in *; subst; inv_get; simpl.
      destruct (get_subst _ _ _ H4) as [? |[?|?]].
      * inv_get; simpl in *; dcr; subst; eauto.
      * dcr; subst. invc H5. inv_get; eauto with len.
      * simpl in *; dcr; subst. inv_get; eauto.
  - pone_step. left.
    eapply IHctx; eauto with len.
    rewrite !map_app. intros.
    eapply labenv_sim_extension_ptw; simpl; eauto 20 with len.
    + intros; hnf; simpl; intros; dcr; subst; inv_get. simpl in *.
      eapply bisimeq_refl; eauto 20 with len.
      rewrite !map_app; eauto.
    + hnf; simpl; intros; subst; inv_get; simpl; eauto.
Qed.

Lemma fun_congrunence p F F' t t' (LEN:length F = length F')
  : bisimeq bot3 p t t'
    -> (forall n Z s Z' s', get F n (Z, s) -> get F' n (Z', s') -> Z = Z' /\ bisimeq bot3 p s s')
    -> bisimeq bot3 p (stmtFun F t) (stmtFun F' t').
Proof.
  intros SIMt SIMF.
  hnf; intros ? ? ? LAB Len.
  eapply sim_fun_ptw; eauto using labenv_sim_refl.
  - intros. left.
    eapply bisimeq_bot; eauto with len.
    rewrite !map_app in *; eauto.
  - intros; hnf; intros.
    hnf in H0; dcr; subst.
    hnf in H4; dcr; subst. inv_get.
    simpl in *. edestruct SIMF; eauto; subst.
    eapply bisimeq_bot; eauto with len.
    rewrite !map_app in *; eauto.
  -  hnf; intros. simpl in *; subst. inv_get.
     edestruct SIMF; dcr; eauto; subst.
     eauto.
  - eauto with len.
Qed.

Lemma fill_fillC C C' s
  :  fill (fillC C C') s = fill C (fill C' s).
Proof.
  general induction C; simpl; f_equal; eauto.
  rewrite IHC; eauto.
Qed.

Definition lessDef (G:set var) (E E':onv val)
  := forall x, x ∈ G -> E' x = None -> E x = None.

Fixpoint fix_vars (E:onv val) (xl: list var) : stmtCtx :=
  match xl with
  | x::xl =>
    match E x with
    | Some v => ctxExp x (Operation (Con v)) (fix_vars E xl)
    | None => fix_vars E xl
    end
  | nil => ctxHole
  end.

Lemma fix_vars_correct G E' xl E (LD:lessDef (of_list xl) E E') (ND:NoDupA eq xl)
  : exists E'', (forall L s, star2 F.step (L, E, fill (fix_vars E' xl) s) nil (L, E'', s))
           /\ agree_on eq (of_list xl) E' E''
           /\ agree_on eq (G \ of_list xl) E E''.
Proof.
  general induction xl; simpl in * |- *; eauto 20 using star2_refl, agree_on_refl, agree_on_empty.
  - cases; simpl; eauto.
    + edestruct (IHxl {a; G}); dcr; swap 1 3.
      eexists x; split.
      * intros. eapply star2_silent; eauto. econstructor. reflexivity.
      * split.
        -- hnf; intros. cset_tac'. rewrite <- H3; lud; try cset_tac.
           inv ND. cset_tac.
        -- hnf; intros. cset_tac'.
           rewrite <- H3; lud; eauto. cset_tac.
      * eauto.
      * hnf; intros. lud; eauto. congruence.
        exploit LD; eauto. cset_tac.
    + edestruct (IHxl {a; G}); swap 1 3; dcr.
      eexists x; split; [|split]; eauto.
      * hnf; intros. cset_tac'.
        rewrite <- H3; eauto.
        exploit LD; eauto. cset_tac.
        congruence.
        inv ND; cset_tac.
      * eapply agree_on_incl; eauto.
        cset_tac.
      * eauto.
      * hnf; intros; eapply LD; cset_tac.
Qed.

Local Notation EMP := (fun _ : positive => ⎣⎦).

Lemma tooth_smaller L
  : tooth 0 L
    -> smaller L.
Proof.
  intros; hnf; intros.
  change f with (0 + f).
  revert H. generalize 0.
  intros.
  general induction H0; invt tooth; try omega.
  eapply IHget in H4. omega.
Qed.

Lemma freeVarSimF_sim r t s E E'
      (AG:agree_on eq (IL.freeVars s) E E')
  : forall (L L' : 〔F.block〕),
      labenv_sim t (sim r) SR (length (A:=positive) ⊝ F.block_Z ⊝ L') L L'
      -> ❬L❭ = ❬L'❭
      -> sim r t (L : F.labenv, E, s) (L', E', s).
Proof.
  revert r E E' AG.
  sind s; destruct s; simpl in *; intros.
  - destruct e; simpl in *.
    + eapply (sim_let_op il_statetype_F); intros.
      * erewrite op_eval_agree; eauto.
        symmetry.
        eapply agree_on_incl; eauto.
      * left. eapply IH; eauto.
        eapply agree_on_update_same; eauto using agree_on_incl.
    + eapply (sim_let_call il_statetype_F); intros.
      * exploit omap_op_eval_agree; eauto using agree_on_incl.
        symmetry.
        eapply agree_on_incl; eauto.
      * left. eapply IH; eauto.
        eapply agree_on_update_same; eauto using agree_on_incl.
  - eapply (sim_cond il_statetype_F); eauto.
    + erewrite op_eval_agree; eauto.
      symmetry.
      eapply agree_on_incl; eauto.
    + intros.
      left. eapply IH; eauto using agree_on_incl with cset.
    + intros.
      left. eapply IH; eauto using agree_on_incl with cset.
  - destruct (get_dec L' l) as [[? ?]|?].
    + eapply labenv_sim_app; eauto using map_get_1.
      intros; simpl in *; dcr; split; intros.
      exploit omap_op_eval_agree; eauto using agree_on_incl.
      eexists; repeat split; eauto. congruence. congruence.
      destruct t; simpl. split; eauto; intros.
      exploit omap_op_eval_agree; eauto using agree_on_incl. congruence.
      eauto.
      eauto.
    + pno_step.
  - pno_step. simpl.
    erewrite op_eval_agree; symmetry; eauto using agree_on_incl with cset.
  - eapply sim_fun_ptw with (AL':=length (A:=positive) ⊝ F.block_Z ⊝ mapi (F.mkBlock E') F);
      try eapply H; eauto with len.
    + intros.
      left. eapply IH; eauto using agree_on_incl with cset.
      rewrite !map_app. eauto. eauto with len.
    + intros. hnf; intros. simpl in *. subst. inv_get; dcr; subst.
      eapply IH; eauto.
      eapply update_with_list_agree; eauto with len.
      eapply agree_on_incl; eauto.
      eapply incl_union_left.
      eapply incl_list_union; eauto using map_get_1.
      rewrite !map_app. eauto. eauto with len.
    + hnf; intros; simpl in *. subst. inv_get; eauto.
Qed.

Arguments of_list : simpl never.
Arguments to_list : simpl never.

Lemma ctx_constr t L' (STL':sawtooth L')
  : exists C LC, labenv_sim t (sim bot3) SR (@length _ ⊝ block_Z ⊝ L') LC L'
            /\ forall L s, star2 step (L, fun _ => None, fill C s) nil ((LC++L)%list, fun _ => None, s).
Proof.
  intros. induction STL'.
  - eexists ctxHole, nil; simpl.
    split; eauto using star2_refl.
  - destruct IHSTL' as [IHCR [IHLC [IHH1 IHH2]]]; eauto.
    assert (CTXT:
              exists F,
                labenv_sim t (sim bot3) SR (length (A:=positive) ⊝ block_Z ⊝ (L ++ L'))
                           (mapi (F.mkBlock (fun _ => ⎣⎦)) F ++ IHLC) (L ++ L')).
    {
      exists ((fun b => (F.block_Z b,
                 fill (fix_vars (F.block_E b)
                                (to_list (freeVars (F.block_s b) \ of_list (F.block_Z b))))
                      (F.block_s b))) ⊝ L).
      rewrite !map_app.
      eapply labenv_sim_extension_ptw'; eauto with len.
      - hnf; intros. simpl in *.
        hnf; intros. simpl in *. subst.
        dcr; subst; inv_get. simpl in *.
        edestruct fix_vars_correct; swap 1 3; dcr.
        eapply sim_expansion_closed; [| eapply H2 | eapply star2_refl].
        rewrite get_app_lt in H4. inv_get. simpl in *.
        orewrite (i - i = 0); simpl.
        exploit tooth_index; eauto. simpl in *.
        orewrite (i - i' = 0); simpl.
        rewrite <- !map_app in *.
        eapply freeVarSimF_sim; eauto.
        instantiate (1:=of_list Z') in H7.
        assert (freeVars s' ⊆ of_list Z'  ∪ (freeVars s' \ of_list Z')) by (clear; cset_tac).
        eapply agree_on_incl; eauto.
        eapply agree_on_union.
        etransitivity. symmetry. eapply agree_on_incl; eauto.
        rewrite of_list_3. clear; cset_tac.
        eapply update_with_list_agree; eauto with len.
        eapply agree_on_empty. clear; cset_tac.
        eapply agree_on_update_list_dead.
        rewrite of_list_3 in H6. symmetry. eauto.
        clear. cset_tac.
        len_simpl. destruct H0. len_simpl. eauto.
        eauto with len. eapply nodup_to_list_eq.
        hnf. intros. rewrite of_list_3 in H1.
        rewrite lookup_set_update_not_in_Z; eauto.
        cset_tac.
      - rewrite <- !map_app.
        hnf; intros; simpl in *.
        destruct f, f'; simpl in *; subst.
        inv_get. simpl in *. eauto.
      - rewrite <- app_nil_r.
        econstructor 2; eauto using @sawtooth.
    }
    destruct CTXT as [F TSIM].
    eexists (fillC IHCR (ctxLetT F ctxHole)).
    eexists (mapi (F.mkBlock (fun _ : positive => ⎣⎦)) F ++ IHLC).
    split.
    + eauto.
    + intros.
      rewrite !fill_fillC.
      eapply star2_trans_silent; eauto. simpl.
      eapply star2_silent. single_step.
      rewrite app_assoc. eapply star2_refl.
Qed.

Definition ctxeq1 t s s' := forall C, bisimeq bot3 t (fill C s) (fill C s').

Lemma ctxeq_simeq1 t s s'
  : ctxeq1 t s s' <-> bisimeq bot3 t s s'.
Proof.
  split; intros; eauto.
  - eapply (H ctxHole).
  - hnf; intros.
    eapply simeq_contextual. eauto.
Qed.

Definition ctxeq2 t s s' := forall C, sim bot3 t (nil:F.labenv, fun _ : positive => ⎣⎦, fill C s) (nil:F.labenv, fun _ : positive => ⎣⎦, fill C s').

Lemma ctxeq_simeq2 t s s'
  : ctxeq2 t s s' <-> bisimeq bot3 t s s'.
Proof.
  split; intros.
  - hnf; intros L1 L2 E SIM Len.
    edestruct (@fix_vars_correct ∅ E (to_list (freeVars s ∪ freeVars s')) EMP) as [E'' CCH].
    hnf; intros; eauto. eapply nodup_to_list_eq.
    destruct CCH as [RED [AGR1 AGR2]].
    rewrite of_list_3 in AGR1.
    rewrite of_list_3 in AGR2.
    edestruct (ctx_constr Bisim) as [C1 [L1' [LC1 ?]]].
    instantiate (1:=L2). eapply SIM.
    set (CE:=(fix_vars E (to_list (freeVars s ∪ freeVars s')))).
    exploit (H (fillC C1 CE)).
    rewrite !fill_fillC in *.
    eapply sim_reduction_closed in H1; swap 1 3; eauto.
    eapply sim_reduction_closed in H1; swap 1 3; eauto.
    rewrite app_nil_r in *.
    assert (LC2:labenv_sim t (sim bot3) SR (length (A:=positive) ⊝ block_Z ⊝ L2) L1' L2). {
      destruct LC1; dcr.
      repeat (split; eauto). hnf; intros.
      eapply bisim_sim; eauto.
    }
    eapply sim_trans with (S2:=F.state); swap 1 2.
    + eapply (bisimeq_refl _ _ LC2).
    + eapply sim_trans with (S2:=F.state); swap 1 2. {
        instantiate (1:=(L1', E'', s')).
        eapply freeVarSimF_sim.
        symmetry. eauto using agree_on_incl with cset.
        eapply labenv_sim_refl. eapply LC1. reflexivity.
      }
      eapply sim_trans with (S2:=F.state); swap 1 2; eauto.
      eapply sim_trans with (S2:=F.state). {
        instantiate (1:=(L1, E'', s)).
        eapply freeVarSimF_sim.
        eauto using agree_on_incl with cset.
        eapply labenv_sim_refl. eapply SIM. reflexivity.
      }
      eapply sim_trans with (S2:=F.state). {
        eapply (bisimeq_refl _ _ SIM).
      }
      assert (sim bot3 Bisim (L2, E'', s) (L1', E'', s)). {
        eapply @bisim_sym.
        eapply (bisimeq_refl). eauto.
      }
      eapply bisim_sim; eauto.
  - hnf; intros.
    eapply simeq_contextual with (ctx:=C) in H.
    exploit (H nil nil); simpl; eauto using labenv_sim_nil.
Qed.


From Coq Require Import Arith.Arith.

From Elo Require Import Util.
From Elo Require Import Array.
From Elo Require Import Map.
From Elo Require Import Core.
From Elo Require Import Access.
From Elo Require Import UnsafeAccess.

(* ------------------------------------------------------------------------- *)
(* NotMut                                                                    *)
(* ------------------------------------------------------------------------- *)

(* A term is NoMut if it has no mutable references. *)
Inductive NoMut : tm -> Prop :=
  | nomut_unit :
    NoMut <{ unit }>

  | nomut_num : forall n,
    NoMut <{ N n }>

  | nomut_refI : forall ad T,
    NoMut <{ &ad :: i&T }>

  | nomut_new : forall T t,
    NoMut t ->
    NoMut <{ new T t }>

  | nomut_load : forall t,
    NoMut t ->
    NoMut <{ *t }>

  | nomut_asg : forall t1 t2,
    NoMut t1 ->
    NoMut t2 ->
    NoMut <{ t1 = t2 }>

  | nomut_var : forall x,
    NoMut <{ var x }>

  | nomut_fun : forall x Tx t,
    NoMut t ->
    NoMut <{ fn x Tx --> t }>

  | nomut_call : forall t1 t2,
    NoMut t1 ->
    NoMut t2 ->
    NoMut <{ call t1 t2 }>

  | nomut_seq : forall t1 t2,
    NoMut t1 ->
    NoMut t2 ->
    NoMut <{ t1; t2 }>

  | nomut_spawn : forall t,
    NoMut t ->
    NoMut <{ spawn t }>
  .

Ltac inversion_nomut :=
  match goal with
  | H : NoMut <{ unit         }> |- _ => inversion H; subst
  | H : NoMut <{ N _          }> |- _ => inversion H; subst
  | H : NoMut <{ & _ :: _     }> |- _ => inversion H; subst
  | H : NoMut <{ new _ _      }> |- _ => inversion H; subst
  | H : NoMut <{ * _          }> |- _ => inversion H; subst
  | H : NoMut <{ _ = _        }> |- _ => inversion H; subst
  | H : NoMut <{ var _        }> |- _ => inversion H; subst
  | H : NoMut <{ fn _ _ --> _ }> |- _ => inversion H; subst
  | H : NoMut <{ call _ _     }> |- _ => inversion H; subst
  | H : NoMut <{ _ ; _        }> |- _ => inversion H; subst
  | H : NoMut <{ spawn _      }> |- _ => inversion H; subst
  end.

Ltac inversion_clear_nomut :=
  match goal with
  | H : NoMut <{ unit         }> |- _ => inversion_subst_clear H
  | H : NoMut <{ N _          }> |- _ => inversion_subst_clear H
  | H : NoMut <{ & _ :: _     }> |- _ => inversion_subst_clear H
  | H : NoMut <{ new _ _      }> |- _ => inversion_subst_clear H
  | H : NoMut <{ * _          }> |- _ => inversion_subst_clear H
  | H : NoMut <{ _ = _        }> |- _ => inversion_subst_clear H
  | H : NoMut <{ var _        }> |- _ => inversion_subst_clear H
  | H : NoMut <{ fn _ _ --> _ }> |- _ => inversion_subst_clear H
  | H : NoMut <{ call _ _     }> |- _ => inversion_subst_clear H
  | H : NoMut <{ _ ; _        }> |- _ => inversion_subst_clear H
  | H : NoMut <{ spawn _      }> |- _ => inversion_subst_clear H
  end.

Local Lemma nomut_subst : forall x t t',
  NoMut t ->
  NoMut t' ->
  NoMut ([x := t'] t).
Proof.
  intros. induction t; intros;
  inversion_nomut; eauto using NoMut;
  simpl; destruct String.string_dec; subst; eauto using NoMut.
Qed.

(* ------------------------------------------------------------------------- *)
(* SafeSpawns                                                                *)
(* ------------------------------------------------------------------------- *)

(* A term has safe spawns if all of its spawns have no mutable references. *)
Inductive SafeSpawns : tm -> Prop :=
  | safe_spawns_unit :
      SafeSpawns <{ unit }>

  | safe_spawns_num : forall n,
      SafeSpawns <{ N n }>

  | safe_spawns_ref : forall ad T,
      SafeSpawns <{ &ad :: T }>

  | safe_spawns_new : forall T t,
      SafeSpawns t ->
      SafeSpawns <{ new T t }>

  | safe_spawns_load : forall t,
      SafeSpawns t ->
      SafeSpawns <{ *t }>

  | safe_spawns_asg : forall t1 t2,
      SafeSpawns t1 ->
      SafeSpawns t2 ->
      SafeSpawns <{ t1 = t2 }>

  | safe_spawns_var : forall x,
      SafeSpawns <{ var x }>

  | safe_spawns_fun : forall x Tx t,
      SafeSpawns t ->
      SafeSpawns <{ fn x Tx --> t }>

  | safe_spawns_call : forall t1 t2,
      SafeSpawns t1 ->
      SafeSpawns t2 ->
      SafeSpawns <{ call t1 t2 }>

  | safe_spawns_seq : forall t1 t2,
      SafeSpawns t1 ->
      SafeSpawns t2 ->
      SafeSpawns <{ t1; t2 }>

  | safe_spawns_spawn : forall t,
      NoMut t ->
      SafeSpawns <{ spawn t }>
  .

Ltac inversion_ss :=
  match goal with
  | H : SafeSpawns <{ unit         }> |- _ => inversion H; subst
  | H : SafeSpawns <{ N _          }> |- _ => inversion H; subst
  | H : SafeSpawns <{ & _ :: _     }> |- _ => inversion H; subst
  | H : SafeSpawns <{ new _ _      }> |- _ => inversion H; subst
  | H : SafeSpawns <{ * _          }> |- _ => inversion H; subst
  | H : SafeSpawns <{ _ = _        }> |- _ => inversion H; subst
  | H : SafeSpawns <{ var _        }> |- _ => inversion H; subst
  | H : SafeSpawns <{ fn _ _ --> _ }> |- _ => inversion H; subst
  | H : SafeSpawns <{ call _ _     }> |- _ => inversion H; subst
  | H : SafeSpawns <{ _ ; _        }> |- _ => inversion H; subst
  | H : SafeSpawns <{ spawn _      }> |- _ => inversion H; subst
  end.

Ltac inversion_clear_ss :=
  match goal with
  | H : SafeSpawns <{ unit         }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ N _          }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ & _ :: _     }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ new _ _      }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ * _          }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ _ = _        }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ var _        }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ fn _ _ --> _ }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ call _ _     }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ _ ; _        }> |- _ => inversion_subst_clear H
  | H : SafeSpawns <{ spawn _      }> |- _ => inversion_subst_clear H
  end.

(* ------------------------------------------------------------------------- *)
(* HasVar                                                                    *)
(* ------------------------------------------------------------------------- *)

Inductive HasVar (x : id) : tm  -> Prop :=
  | hasvar_new : forall T t,
      HasVar x t ->
      HasVar x <{ new T t }>

  | hasvar_load : forall t,
      HasVar x t ->
      HasVar x <{ *t }>

  | hasvar_asg1 : forall t1 t2,
      HasVar x t1 ->
      HasVar x <{ t1 = t2 }>

  | hasvar_asg2 : forall t1 t2,
      HasVar x t2 ->
      HasVar x <{ t1 = t2 }>

  | hasvar_var :
      HasVar x <{ var x }>

  | hasvar_fun : forall x' Tx t,
      x <> x' ->
      HasVar x t ->
      HasVar x <{ fn x' Tx --> t }>

  | hasvar_call1 : forall t1 t2,
      HasVar x t1 ->
      HasVar x <{ call t1 t2 }>

  | hasvar_call2 : forall t1 t2,
      HasVar x t2 ->
      HasVar x <{ call t1 t2 }>

  | hasvar_seq1 : forall t1 t2,
      HasVar x t1 ->
      HasVar x <{ t1; t2 }>

  | hasvar_seq2 : forall t1 t2,
      HasVar x t2 ->
      HasVar x <{ t1; t2 }>

  | hasvar_spawn : forall t,
      HasVar x t ->
      HasVar x <{ spawn t }>
  .

Ltac inversion_hv :=
  match goal with
  | H : HasVar _ <{ unit         }> |- _ => inversion H; subst
  | H : HasVar _ <{ N _          }> |- _ => inversion H; subst
  | H : HasVar _ <{ & _ :: _     }> |- _ => inversion H; subst
  | H : HasVar _ <{ new _ _      }> |- _ => inversion H; subst
  | H : HasVar _ <{ * _          }> |- _ => inversion H; subst
  | H : HasVar _ <{ _ = _        }> |- _ => inversion H; subst
  | H : HasVar _ <{ var _        }> |- _ => inversion H; subst
  | H : HasVar _ <{ fn _ _ --> _ }> |- _ => inversion H; subst
  | H : HasVar _ <{ call _ _     }> |- _ => inversion H; subst
  | H : HasVar _ <{ _ ; _        }> |- _ => inversion H; subst
  | H : HasVar _ <{ spawn _      }> |- _ => inversion H; subst
  end.

Ltac inversion_clear_hv :=
  match goal with
  | H : HasVar _ <{ unit         }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ N _          }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ & _ :: _     }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ new _ _      }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ * _          }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ _ = _        }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ var _        }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ fn _ _ --> _ }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ call _ _     }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ _ ; _        }> |- _ => inversion_subst_clear H
  | H : HasVar _ <{ spawn _      }> |- _ => inversion_subst_clear H
  end.

Lemma hasvar_dec : forall x t,
  Decidable.decidable (HasVar x t).
Proof.
  unfold Decidable.decidable. intros. induction t;
  try (destruct IHt); try (destruct IHt1); try (destruct IHt2);
  try match goal with
    | x : id, x' : id |- _ =>
      destruct (String.string_dec x x'); subst
  end;
  solve
    [ left; eauto using HasVar
    | right; intros F; inversion_subst_clear F; eauto; contradiction
    ].
Qed.

Local Ltac solve_not_hasvar :=
  intros; match goal with
  | |- (~ HasVar _ ?t) => induction t; eauto using HasVar
  end.

Lemma not_hv_new : forall x t T,
  ~ HasVar x <{ new T t }> -> ~ HasVar x t.
Proof. solve_not_hasvar. Qed.

Lemma not_hv_load : forall x t,
  ~ HasVar x <{ *t }> -> ~ HasVar x t.
Proof. solve_not_hasvar. Qed.

Lemma not_hv_asg1 : forall x t1 t2,
  ~ HasVar x <{ t1 = t2 }> -> ~ HasVar x t1.
Proof. solve_not_hasvar. Qed.

Lemma not_hv_asg2 : forall x t1 t2,
  ~ HasVar x <{ t1 = t2 }> -> ~ HasVar x t2.
Proof. solve_not_hasvar. Qed.

Lemma not_hv_fun : forall x x' t Tx,
  x <> x' -> ~ HasVar x <{ fn x' Tx --> t }> -> ~ HasVar x t.
Proof. solve_not_hasvar. Qed.

Lemma not_hv_call1 : forall x t1 t2,
  ~ HasVar x <{ call t1 t2 }> -> ~ HasVar x t1.
Proof. solve_not_hasvar. Qed.

Lemma not_hv_call2 : forall x t1 t2,
  ~ HasVar x <{ call t1 t2 }> -> ~ HasVar x t2.
Proof. solve_not_hasvar. Qed.

Lemma not_hv_seq1 : forall x t1 t2,
  ~ HasVar x <{ t1; t2 }> -> ~ HasVar x t1.
Proof. solve_not_hasvar. Qed.

Lemma not_hv_seq2 : forall x t1 t2,
  ~ HasVar x <{ t1; t2 }> -> ~ HasVar x t2.
Proof. solve_not_hasvar. Qed.

Lemma not_hv_spawn : forall x t,
  ~ HasVar x <{ spawn t }> -> ~ HasVar x t.
Proof. solve_not_hasvar. Qed.

Lemma hasvar_subst : forall x t tx,
  ~ (HasVar x t) -> ([x := tx] t) = t.
Proof.
  intros. induction t; simpl; trivial;
  try (destruct String.string_dec; subst; trivial);
  solve
    [ rewrite IHt; eauto using not_hv_new, not_hv_load, not_hv_spawn, not_hv_fun
    | rewrite IHt1; eauto using not_hv_asg1, not_hv_call1, not_hv_seq1;
      rewrite IHt2; eauto using not_hv_asg2, not_hv_call2, not_hv_seq2
    | exfalso; eauto using HasVar
    ].
Qed.

Lemma hasvar_typing : forall Gamma x t T,
  HasVar x t ->
  Gamma x = None ->
  ~ (Gamma |-- t is T).
Proof.
  assert (forall Gamma x, Gamma x = None -> (safe Gamma) x = None).
  { unfold safe. intros * H. rewrite H. reflexivity. }
  intros * ? HGamma F. induction_type; inversion_hv; eauto.
  - rewrite HGamma in *. discriminate.
  - rewrite lookup_update_neq in IHF; eauto.
Qed.

(* ------------------------------------------------------------------------- *)
(* Equivalence                                                               *)
(* ------------------------------------------------------------------------- *)

Local Lemma equivalence_safe : forall Gamma1 Gamma2,
  Gamma1 === Gamma2 ->
  safe Gamma1 === safe Gamma2.
Proof.
  unfold map_equivalence, safe. intros * Heq k.
  specialize (Heq k). rewrite Heq. trivial.
Qed.

Local Lemma equivalence_typing : forall Gamma1 Gamma2 t T,
  Gamma1 === Gamma2 ->
  Gamma1 |-- t is T ->
  Gamma2 |-- t is T.
Proof.
  intros. generalize dependent Gamma2. induction_type; intros;
  eauto using well_typed_term, equivalence_safe,
    MapEquivalence.lookup, MapEquivalence.update_equivalence.
Qed.

(* ------------------------------------------------------------------------- *)
(* SafeSpawns mstep term preservation                                        *)
(* ------------------------------------------------------------------------- *)

Local Lemma safe_spawns_subst : forall Gamma x t v T Tx,
  value v ->
  empty |-- v is Tx ->
  Gamma[x <== Tx] |-- t is T ->
  SafeSpawns v ->
  SafeSpawns t ->
  SafeSpawns ([x := v] t).
Proof.
  assert (H1 : forall Gamma x T,
    (safe Gamma[x <== <{{ &T }}>]) x = None);
  assert (H2 : forall Gamma x T T',
    (safe Gamma[x <== <{{ T --> T' }}>]) x = None);
  try solve [unfold safe; intros; rewrite lookup_update_eq; reflexivity].
  (* main proof *)
  intros * Hvalue HtypeV HtypeT Hssv Hsst.
  generalize dependent Gamma. generalize dependent T. generalize dependent Tx.
  induction Hsst; intros; inversion_type;
  simpl; try (destruct String.string_dec);
  eauto using SafeSpawns, equivalence_typing, MapEquivalence.update_permutation.
  eapply safe_spawns_spawn. destruct (hasvar_dec x t).
  - eapply nomut_subst; trivial.
    inversion Hvalue; subst; eauto using NoMut.
    + inversion HtypeV; subst; eauto using NoMut.
      exfalso. eapply hasvar_typing; eauto using H1.
    + inversion_clear Hvalue. inversion HtypeV; subst.
      exfalso. eapply hasvar_typing; eauto using H2.
  - erewrite hasvar_subst; eauto.
Qed.

Local Lemma mstep_tm_safe_spawns_preservation : forall m m' t t' eff T,
  empty |-- t is T ->
  forall_memory m SafeSpawns ->
  SafeSpawns t ->
  m / t ==[eff]==> m' / t' ->
  SafeSpawns t'.
Proof.
  intros. generalize dependent T.
  inversion_clear_mstep; induction_step; intros;
  try solve [inversion_type; inversion_ss; eauto using SafeSpawns].
  do 2 (inversion_ss; inversion_type).
  eauto using safe_spawns_subst.
Qed.

(* ------------------------------------------------------------------------- *)
(* SafeSpawns mstep memory preservation                                      *)
(* ------------------------------------------------------------------------- *)

Local Lemma mem_safe_spawns_alloc : forall m t t' v V,
  forall_memory m SafeSpawns ->
  SafeSpawns t ->
  t --[EF_Alloc (length m) v V]--> t' ->
  forall_memory (m +++ (v, V)) SafeSpawns.
Proof.
  intros. assert (SafeSpawns v) by (induction_step; inversion_ss; eauto).
  unfold forall_memory. eauto using forall_array_add, SafeSpawns.
Qed.

Local Lemma mem_safe_spawns_store : forall m t t' ad v V,
  forall_memory m SafeSpawns ->
  SafeSpawns t ->
  t --[EF_Write ad v V]--> t' ->
  forall_memory m[ad <- (v, V)] SafeSpawns.
Proof.
  intros. assert (SafeSpawns v) by (induction_step; inversion_ss; eauto).
  unfold forall_memory. eauto using forall_array_set, SafeSpawns.
Qed.

Local Lemma mstep_mem_safe_spawns_preservation : forall m m' t t' eff,
  forall_memory m SafeSpawns ->
  SafeSpawns t ->
  m / t ==[eff]==> m' / t' ->
  forall_memory m' SafeSpawns.
Proof.
  intros. inversion_mstep;
  eauto using mem_safe_spawns_alloc, mem_safe_spawns_store.
Qed.

(* ------------------------------------------------------------------------- *)
(* SafeSpawns cstep preservation                                             *)
(* ------------------------------------------------------------------------- *)

Local Lemma nomut_then_safe_spawns : forall t,
  NoMut t ->
  SafeSpawns t.
Proof.
  intros * H. induction t; induction H; eauto using SafeSpawns.
Qed.

Local Lemma safe_spawns_for_block : forall t t' block,
  SafeSpawns t ->
  t --[EF_Spawn block]--> t' ->
  SafeSpawns block.
Proof.
  intros. induction_step; inversion_ss;
  eauto using SafeSpawns, nomut_then_safe_spawns.
Qed.

Local Lemma step_safe_spawns_preservation : forall t t' block,
  SafeSpawns t ->
  t --[EF_Spawn block]--> t' ->
  SafeSpawns t'.
Proof.
  intros. induction_step; inversion_ss;
  eauto using SafeSpawns, nomut_then_safe_spawns.
Qed.

Theorem safe_spawns_preservation : forall m m' ths ths' tid eff,
  forall_threads ths well_typed ->
  forall_program m ths SafeSpawns ->
  m / ths ~~[tid, eff]~~> m' / ths' ->
  forall_program m' ths' SafeSpawns.
Proof.
  intros * Htype [? ?]. split; inversion_cstep;
  eauto using mstep_mem_safe_spawns_preservation.
  - eapply forall_array_set;
    eauto using SafeSpawns. specialize (Htype tid) as [? ?].
    eauto using mstep_tm_safe_spawns_preservation. (* performance *)
  - eapply forall_array_add; eauto using SafeSpawns, safe_spawns_for_block.
    eapply forall_array_set;
    eauto using SafeSpawns, step_safe_spawns_preservation.
Qed.

(* ------------------------------------------------------------------------- *)
(*                                                                           *)
(* ------------------------------------------------------------------------- *)

Lemma nomut_block : forall t t' block,
  SafeSpawns t ->
  t --[EF_Spawn block]--> t' ->
  NoMut block.
Proof.
  intros. induction_step; inversion_ss; eauto.
Qed.

Lemma nomut_then_nuacc: forall m t ad,
  NoMut t ->
  UnsafeAccess m t ad ->
  False.
Proof.
  intros * Hnm Huacc. induction Hnm; inversion_uacc; eauto.
Qed.


(*! Inversion lemmata for ETT *)

From Coq Require Import Bool String List BinPos Compare_dec Lia.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From Translation
Require Import util Sorts SAst SLiftSubst SCommon ITyping ITypingLemmata
               XTyping.

Open Scope x_scope.

(* We prove these lemmata in the context of Type in Type
   as they will only be used for examples.
 *)
Existing Instance Sorts.type_in_type.

Notation Ty := (@sSort Sorts.type_in_type tt).

Lemma inversionProd :
  forall {Σ Γ n A B T},
    Σ ;;; Γ |-x sProd n A B : T ->
    (Σ ;;; Γ |-x A : Ty) *
    (Σ ;;; Γ ,, A |-x B : Ty) *
    (Σ ;;; Γ |-x Ty ≡ T : Ty).
Proof.
  intros Σ Γ n A B T h.
  dependent induction h.
  - destruct s1, s2.
    split ; [ split | ..] ; try assumption.
    apply eq_reflexivity. econstructor.
  - destruct IHh1 as [[? ?] ?].
    destruct s.
    split ; [ split | ..] ; try assumption.
    eapply eq_transitivity ; eassumption.
Defined.


Require Import Mem.
Require Import Pred.
Require Import Prog.
Require Import ListPred.
Require Import List.
Require Import SepAuto.
Require Import Array.
Require Import Omega.
Require Import AsyncDisk PredCrash.
Require Import FunctionalExtensionality.

Set Implicit Arguments.
Set Default Proof Using "Type".

Section MemPred.

  Variable LowAT : Type.
  Variable LowAEQ : EqDec LowAT.
  Variable LowV : Type.

  Variable HighAT : Type.
  Variable HighAEQ : EqDec HighAT.
  Variable HighV : Type.

  Definition low_mem := @mem LowAT LowAEQ LowV.
  Definition high_mem := @mem HighAT HighAEQ HighV.

  Definition low_pred := @pred LowAT LowAEQ LowV.
  Definition high_pred := @pred HighAT HighAEQ HighV.

  Fixpoint avs2mem_iter (avs : list (HighAT * HighV)) (m : @mem HighAT HighAEQ HighV) :=
    match avs with
    | nil => m
    | (a, v) :: rest =>
      upd (avs2mem_iter rest m) a v
    end.

  Definition avs2mem avs :=
    avs2mem_iter avs empty_mem.

  Fixpoint avs_except avs victim : @list (HighAT * HighV) :=
    match avs with
    | nil => nil
    | (a, v) :: rest =>
      if HighAEQ a victim then avs_except rest victim else (a, v) :: avs_except rest victim
    end.

  Theorem avs_except_notin_eq : forall avs a,
    ~ In a (map fst avs) -> avs_except avs a = avs.
  Proof.
    induction avs; simpl; intros; auto.
    destruct a; intuition.
    destruct (HighAEQ h a0); subst. intuition.
    f_equal; eauto.
  Qed.

  Theorem avs_except_cons : forall avs a v,
    NoDup (map fst ((a, v) :: avs)) ->
    avs_except ((a, v) :: avs) a = avs.
  Proof.
    intros; simpl.
    destruct (HighAEQ a a); try congruence.
    apply avs_except_notin_eq.
    inversion H; auto.
  Qed.

  Theorem avs2mem_ne : forall avs a v a',
    a <> a' ->
    avs2mem ((a, v) :: avs) a' = avs2mem avs a'.
  Proof.
    unfold avs2mem; simpl; intros.
    rewrite upd_ne; auto.
  Qed.

  Theorem listpred_avs_except : forall avs (lp : _ -> low_pred) a v,
    NoDup (map fst avs) ->
    avs2mem avs a = Some v ->
    listpred lp avs =p=> listpred lp (avs_except avs a) * lp (a, v).
  Proof.
    induction avs; simpl; intros.
    - inversion H0.
    - destruct a.
      destruct (HighAEQ h a0); subst.
      + unfold avs2mem in H0; simpl in H0. rewrite upd_eq in H0 by auto. inversion H0; subst.
        inversion H.
        rewrite avs_except_notin_eq by auto. cancel.
      + inversion H.
        rewrite avs2mem_ne in H0 by auto.
        rewrite IHavs by eauto.
        cancel.
  Qed.

  Theorem avs_except_notin : forall avs a a',
    ~ In a' (map fst avs) -> ~ In a' (map fst (avs_except avs a)).
  Proof.
    induction avs; simpl; intros; eauto.
    destruct a.
    destruct (HighAEQ h a0); subst; eauto.
    simpl in *; intuition; eauto.
  Qed.

  Hint Resolve avs_except_notin.

  Lemma avs2mem_notindomain : forall l a,
    ~ In a (map fst l) ->
    notindomain a (avs2mem l).
  Proof.
    unfold avs2mem, notindomain; induction l; simpl; intros.
    cbv; auto.
    destruct a; simpl in *; intuition.
    rewrite upd_ne; auto.
  Qed.

  Theorem avs_except_nodup : forall avs a,
    NoDup (map fst avs) -> NoDup (map fst (avs_except avs a)).
  Proof.
    induction avs; simpl; intros; eauto.
    destruct a.
    inversion H; subst.
    destruct (HighAEQ h a0); subst; eauto.
    simpl; constructor; eauto.
  Qed.

  Hint Resolve avs_except_nodup.

  Lemma avs2mem_except_eq : forall avs a,
    avs2mem (avs_except avs a) a = None.
  Proof.
    induction avs; simpl; intros; eauto.
    destruct a.
    destruct (HighAEQ h a0); subst; eauto.
    rewrite avs2mem_ne by auto; auto.
  Qed.

  Lemma avs2mem_except_ne : forall avs a a',
    a <> a' ->
    avs2mem (avs_except avs a) a' = avs2mem avs a'.
  Proof.
    induction avs; simpl; intros; eauto.
    destruct a.
    destruct (HighAEQ h a0); subst.
    - rewrite avs2mem_ne; auto.
    - unfold avs2mem in *; simpl.
      destruct (HighAEQ h a'); subst.
      + repeat rewrite upd_eq; auto.
      + repeat rewrite upd_ne; auto.
  Qed.

  Theorem mem_except_avs_except : forall avs a,
    mem_except (avs2mem avs) a = avs2mem (avs_except avs a).
  Proof.
    intros; apply functional_extensionality; intros.
    destruct (HighAEQ a x); subst.
    - rewrite mem_except_eq. rewrite avs2mem_except_eq. auto.
    - rewrite mem_except_ne by auto.
      rewrite avs2mem_except_ne by auto.
      auto.
  Qed.

  Hint Resolve mem_except_avs_except.

  Lemma avs2mem_none_notin : forall avs a,
    avs2mem avs a = None -> ~ In a (map fst avs).
  Proof.
    unfold avs2mem; induction avs; simpl; intros; auto.
    destruct a; intuition; simpl in *; subst.
    rewrite upd_eq in * by auto; congruence.
    destruct (HighAEQ h a0); subst.
    rewrite upd_eq in * by auto; congruence.
    rewrite upd_ne in * by auto; eauto.
  Qed.

  Variable Pred : HighAT -> HighV -> low_pred.

  Definition mem_pred_one (av : HighAT * HighV) : low_pred :=
    Pred (fst av) (snd av).

  Definition mem_pred (hm : high_mem) : low_pred :=
    (exists hm_avs,
     [[ NoDup (map fst hm_avs) ]] *
     [[ hm = avs2mem hm_avs ]] *
     listpred mem_pred_one hm_avs)%pred.

  Theorem mem_pred_extract' : forall hm a v,
    hm a = Some v ->
    mem_pred hm =p=> mem_pred (mem_except hm a) * mem_pred_one (a, v).
  Proof.
    unfold mem_pred; intros.
    cancel.
    eapply listpred_avs_except; subst; eauto.
    eauto.
  Qed.

  Theorem mem_pred_extract : forall hm a v,
    hm a = Some v ->
    mem_pred hm =p=> mem_pred (mem_except hm a) * Pred a v.
  Proof.
    apply mem_pred_extract'.
  Qed.

  Theorem mem_pred_absorb' : forall hm a v,
    mem_pred (mem_except hm a) * mem_pred_one (a, v) =p=> mem_pred (upd hm a v).
  Proof.
    unfold mem_pred; intros.
    norml.
    exists ((a, v) :: hm_avs).
    pred_apply.
    cancel.
    simpl; constructor; auto.
    apply avs2mem_none_notin.
    rewrite <- H3. apply mem_except_eq.
    unfold avs2mem in *; simpl.
    rewrite <- H3.
    rewrite upd_mem_except.
    auto.
  Qed.

  Theorem mem_pred_absorb : forall hm a v,
    mem_pred (mem_except hm a) * Pred a v =p=> mem_pred (upd hm a v).
  Proof.
    apply mem_pred_absorb'.
  Qed.

  Theorem mem_pred_absorb_nop' : forall hm a v,
    hm a = Some v ->
    mem_pred (mem_except hm a) * mem_pred_one (a, v) =p=> mem_pred hm.
  Proof.
    unfold mem_pred; intros.
    norml.
    exists ( (a, v) :: hm_avs).
    pred_apply.
    cancel.
    simpl; constructor; auto.
    apply avs2mem_none_notin.
    rewrite <- H4. apply mem_except_eq.
    unfold avs2mem in *; simpl.
    rewrite <- H4.
    rewrite upd_mem_except.
    rewrite upd_nop; auto.
  Qed.

  Theorem mem_pred_absorb_nop : forall hm a v,
    hm a = Some v ->
    mem_pred (mem_except hm a) * Pred a v =p=> mem_pred hm.
  Proof.
    apply mem_pred_absorb_nop'.
  Qed.

  Theorem mem_pred_empty_mem :
    mem_pred empty_mem <=p=> emp.
  Proof.
    unfold mem_pred, mem_pred_one, avs2mem; split; norm; auto.
    destruct hm_avs; try cancel.
    eapply equal_f with (x := p_1) in H2.
    rewrite upd_eq in H2 by auto.
    unfold empty_mem in H2; congruence.
    instantiate (1 := nil); cancel.
    intuition; constructor.
  Qed.

End MemPred.

Theorem mem_pred_pimpl : forall LA LEQ LV HA HEQ HV hm p1 p2,
  (forall a v, p1 a v =p=> p2 a v) ->
  @mem_pred LA LEQ LV HA HEQ HV p1 hm =p=> mem_pred p2 hm.
Proof.
  unfold mem_pred; intros.
  cancel; eauto.
  subst.
  induction hm_avs; simpl; intros; auto.
  unfold mem_pred_one at 1 3; simpl. rewrite H. cancel.
  eapply IHhm_avs.
  inversion H0; eauto.
Qed.

Theorem mem_pred_pimpl_except : forall LA LEQ LV HA HEQ HV hm p1 p2 a',
  (forall a v, a <> a' -> p1 a v =p=> p2 a v) ->
  @mem_pred LA LEQ LV HA HEQ HV p1 (mem_except hm a') =p=> mem_pred p2 (mem_except hm a').
Proof.
  unfold mem_pred; intros.
  cancel; eauto.
  assert (~ In a' (map fst hm_avs)).
  eapply avs2mem_none_notin. rewrite <- H3. rewrite mem_except_eq. auto.
  clear H3 hm.
  induction hm_avs; simpl; intros; auto.
  unfold mem_pred_one at 1 3; simpl. rewrite H. cancel.
  eapply IHhm_avs; eauto.
  inversion H0; eauto.
  destruct a; firstorder.
Qed.

Theorem mem_pred_absent_hm :
  forall A AEQ LV HV p hm m a,
  m a = None ->
  (forall a v, p a v =p=> exists v', a |-> v') ->
  @mem_pred A AEQ LV A AEQ HV p hm m ->
  hm a = None.
Proof.
  intros.
  case_eq (hm a); intros; auto.
  eapply mem_pred_extract in H1; eauto.
  rewrite H0 in H1; destruct_lift H1.
  apply ptsto_valid' in H1; congruence.
Qed.

Theorem mem_pred_absent_lm :
  forall A AEQ LV HV p hm m a,
  hm a = None ->
  (forall a v, p a v =p=> exists v', a |-> v') ->
  @mem_pred A AEQ LV A AEQ HV p hm m ->
  m a = None.
Proof.
  intros.
  unfold mem_pred, mem_pred_one in H1. destruct_lift H1.
  apply avs2mem_none_notin in H.
  generalize dependent m.
  induction dummy; simpl in *; intros.
  - apply emp_empty_mem_only in H1; subst.
    firstorder.
  - destruct a0; simpl in *.
    rewrite H0 in H1.
    destruct (AEQ a0 a); try solve [ exfalso; eauto ].
    destruct_lift H1.
    generalize dependent H1.
    unfold_sep_star; intros; repeat safedeex.
    inversion H3.
    unfold ptsto, mem_union in H1.
    intuition; subst.
    match goal with
    | [ H : forall _, _ -> m1 _ = None |- _ ] => rewrite H
    end; eauto.
Qed.

Theorem xform_mem_pred : forall prd (hm : rawdisk),
  crash_xform (@mem_pred _ addr_eq_dec _ _ addr_eq_dec _ prd hm) <=p=>
  @mem_pred _ addr_eq_dec _ _ addr_eq_dec _ (fun a v => crash_xform (prd a v)) hm.
Proof.
  unfold mem_pred; intros; split.
  xform_norm; subst.
  rewrite xform_listpred.
  cancel.

  cancel; subst.
  xform_normr; cancel.
  rewrite xform_listpred.
  cancel.
  eauto.
Qed.

Theorem sync_xform_mem_pred : forall prd (hm : rawdisk),
  sync_xform (@mem_pred _ addr_eq_dec _ _ addr_eq_dec _ prd hm) <=p=>
  @mem_pred _ addr_eq_dec _ _ addr_eq_dec _ (fun a v => sync_xform (prd a v)) hm.
Proof.
  unfold mem_pred; intros; split.
  rewrite sync_xform_exists_comm; apply pimpl_exists_l; intros.
  repeat (rewrite sync_xform_sep_star_dist || rewrite sync_xform_lift_empty).
  rewrite sync_xform_listpred; cancel.

  rewrite sync_xform_exists_comm; apply pimpl_exists_l; intros.
  apply pimpl_exists_r; eexists.
  repeat (rewrite sync_xform_sep_star_dist || rewrite sync_xform_lift_empty).
  rewrite sync_xform_listpred; cancel.
Qed.

Theorem sync_invariant_mem_pred : forall HighAT HighAEQ HighV (prd : HighAT -> HighV -> _) hm,
  (forall a v, sync_invariant (prd a v)) ->
  sync_invariant (@mem_pred _ _ _ _ HighAEQ _ prd hm).
Proof.
  unfold mem_pred; eauto.
Qed.

Hint Resolve sync_invariant_mem_pred.

Section MEM_MATCH.

  Variable AT V : Type.
  Variable AEQ : EqDec AT.

  Implicit Types m ma mb : @Mem.mem AT AEQ V.

  Definition mem_match ma mb :=
    forall a, ma a = None <-> mb a = None.

  Lemma mem_match_refl : forall m,
    mem_match m m.
  Proof.
    firstorder.
  Qed.

  Lemma mem_match_trans : forall m ma mb,
    mem_match m ma ->
    mem_match ma mb ->
    mem_match m mb.
  Proof.
    firstorder.
  Qed.

  Lemma mem_match_sym : forall ma mb,
    mem_match ma mb ->
    mem_match mb ma.
  Proof.
    firstorder.
  Qed.

  Lemma mem_match_except : forall ma mb a,
    mem_match ma mb ->
    mem_match (mem_except ma a) (mem_except mb a).
  Proof.
    unfold mem_match; intros.
    unfold mem_except.
    destruct (AEQ a0 a); firstorder.
  Qed.

  Lemma mem_match_upd : forall ma mb a va vb,
    mem_match ma mb ->
    mem_match (upd ma a va) (upd mb a vb).
  Proof.
    unfold mem_match; intros.
    destruct (AEQ a0 a); subst.
    repeat rewrite upd_eq by auto.
    split; congruence.
    repeat rewrite upd_ne by auto.
    firstorder.
  Qed.

  Lemma mem_match_upd_l : forall ma mb a va vb,
    mem_match ma mb ->
    mb a = Some vb ->
    mem_match (upd ma a va) mb.
  Proof.
    unfold mem_match; intros.
    destruct (AEQ a0 a); subst.
    repeat rewrite upd_eq by auto.
    split; congruence.
    repeat rewrite upd_ne by auto.
    firstorder.
  Qed.

  Lemma mem_match_upd_r : forall ma mb a va vb,
    mem_match ma mb ->
    ma a = Some va ->
    mem_match ma (upd mb a vb).
  Proof.
    unfold mem_match; intros.
    destruct (AEQ a0 a); subst.
    repeat rewrite upd_eq by auto.
    split; congruence.
    repeat rewrite upd_ne by auto.
    firstorder.
  Qed.

  Lemma mem_match_cases : forall ma mb a,
    mem_match ma mb ->
    (ma a = None /\ mb a = None) \/
    exists va vb, (ma a = Some va /\ mb a = Some vb).
  Proof.
    intros.
    specialize (H a); destruct H.
    destruct (ma a); destruct (mb a).
    right. eexists; eauto.
    contradict H0; intuition; congruence.
    contradict H; intuition; congruence.
    intuition.
  Qed.

End MEM_MATCH.

Section MEM_REGION.

  Variable V : Type.
  Implicit Types m ma mb : @Mem.mem _ addr_eq_dec V.

  Definition region_filled m st n :=
    forall a, a >= st -> a < st + n -> m a <> None.

  Lemma region_filled_sel : forall m st n a,
    region_filled m st n ->
    a >= st -> a < st + n ->
    exists v, m a = Some v.
  Proof.
    intros.
    specialize (H a H0 H1).
    destruct (m a); try congruence.
    eexists; eauto.
  Qed.

  Lemma listupd_region_filled : forall l m a,
    region_filled (listupd m a l) a (length l).
  Proof.
    unfold region_filled; destruct l; simpl; intros.
    omega.
    destruct (addr_eq_dec a a0); subst.
    rewrite listupd_sel_oob by omega.
    rewrite upd_eq; congruence.
    erewrite listupd_sel_inb with (def := v) by omega.
    congruence.
  Qed.

(*
  Lemma arrayN_region_filled : forall l m a F,
    (F * arrayN a l)%pred m ->
    region_filled m a (length l).
  Proof.
    unfold region_filled; induction l; simpl; intros.
    omega.
    destruct (addr_eq_dec a1 a0); subst.
    apply sep_star_comm in H; apply sep_star_assoc in H.
    apply ptsto_valid in H; congruence.
    apply sep_star_assoc in H.
    eapply IHl; eauto; omega.
  Qed.
*)

  Lemma mem_match_listupd_l : forall l ma mb a,
    mem_match ma mb ->
    region_filled mb a (length l) ->
    mem_match (listupd ma a l) mb.
  Proof.
    induction l; simpl; auto; intros.
    apply IHl.
    eapply region_filled_sel in H0; eauto.
    destruct H0.
    eapply mem_match_upd_l; eauto.
    omega.
    unfold region_filled in *; intuition.
    eapply H0 with (a := a1); try omega; auto.
  Qed.

End MEM_REGION.

Section MEM_INCL.

  Implicit Types m ma mb : rawdisk.

  Definition mem_incl ma mb := forall a,
    (ma a = None /\ mb a = None) \/
    exists va vb, ma a = Some va /\ mb a = Some vb /\
    incl (vsmerge va) (vsmerge vb).

  Lemma mem_incl_refl : forall m,
    mem_incl m m.
  Proof.
    unfold mem_incl; intros.
    destruct (m a) eqn: Heq; intuition.
    right; do 2 eexists; intuition.
  Qed.

  Lemma mem_incl_trans : forall m ma mb,
    mem_incl ma m ->
    mem_incl m mb ->
    mem_incl ma mb.
  Proof.
    unfold mem_incl; intuition.
    specialize (H a); specialize (H0 a).
    intuition; repeat deex; try congruence.
    right.
    rewrite H1 in H0; inversion H0; subst.
    do 2 eexists; intuition eauto.
    eapply incl_tran; eauto.
  Qed.

  Lemma possible_crash_incl_trans : forall m ma mb,
    possible_crash ma m ->
    mem_incl ma mb ->
    possible_crash mb m.
  Proof.
    unfold possible_crash, mem_incl; intros.
    specialize (H a); specialize (H0 a).
    intuition; repeat deex; try congruence.
    right.
    rewrite H2 in H0; inversion H0; subst.
    do 2 eexists; intuition eauto.
  Qed.

  Lemma mem_incl_upd : forall a va vb ma mb,
    mem_incl ma mb ->
    incl (vsmerge va) (vsmerge vb) ->
    mem_incl (upd ma a va) (upd mb a vb).
  Proof.
    unfold mem_incl; intros.
    specialize (H a0).
    destruct (addr_eq_dec a a0); subst.
    repeat rewrite upd_eq by auto.
    intuition; repeat deex; intuition.
    right; do 2 eexists; eauto.
    right; do 2 eexists; eauto.
    repeat rewrite upd_ne by auto.
    intuition.
  Qed.

  Lemma mem_incl_listupd : forall la lb,
    Forall2 (fun va vb => incl (vsmerge va) (vsmerge vb)) la lb ->
    forall ma mb st,
    mem_incl ma mb ->
    mem_incl (listupd ma st la) (listupd mb st lb).
  Proof.
    induction 1; simpl; intros; auto.
    apply IHForall2.
    apply mem_incl_upd; auto.
  Qed.

  Lemma mem_incl_listupd_same : forall la lb,
    Forall2 (fun va vb => incl (vsmerge va) (vsmerge vb)) la lb ->
    forall m st,
    mem_incl (listupd m st la) (listupd m st lb).
  Proof.
    intros.
    apply mem_incl_listupd; auto.
    apply mem_incl_refl.
  Qed.

End MEM_INCL.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype seq.
Require Import ZArith_ext String_ext ssrnat_ext seq_ext.
Require Import machine_int.
Import MachineInt.
Require Import C_types C_types_fp C_value C_expr C_expr_ground C_seplog C_pp.

Local Open Scope C_types_scope.
Local Open Scope string_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope machine_int_scope.

Module C_swap_env <: CENV.
Definition g := \wfctxt{ \O \}.
Definition sigma : g.-env := ("x", :* (ityp: uint)) :: ("y", :* (ityp: uint)) ::
                             ("z", g.-ityp: uint) :: ("v", g.-ityp: uint) :: nil.
Definition uniq_vars : uniq (unzip1 sigma) := Logic.eq_refl.
End C_swap_env.

Definition g := C_swap_env.g.
Definition sigma := C_swap_env.sigma.

Module Import C_Seplog_m := C_Pp_f C_swap_env.

Local Open Scope C_cmd_scope.

Definition swap :=
  "z" <-* %"x" ;
  "v" <-* %"y" ;
  %"x" *<- %"v" ;
  %"y" *<- %"z".

Definition mk_cell := log_of_uint (g.-ityp: uint) Logic.eq_refl.

Local Notation "a |~> b" := (a |le~> mk_cell b) (at level 77).

Lemma swap_correct (a b : int 32) :
  {{ %"x" |~> a ** %"y" |~> b }}
              swap
  {{ %"x" |~> b ** %"y" |~> a }}.
Proof.
rewrite /swap.
pose za := `! \b %"z" \= [ a ]pc.
Hoare_seq_ext za.
  Hoare_frame_idx_tmp (O :: nil) (O :: 1%nat :: nil).
  eapply hoare_stren; last by apply hoare_lookup_stren, ent_id.
  apply ent_R_lookup_trans with ([ a ]p) (mk_cell a).
    by rewrite /phylog_conv /=.
    by apply ent_R_con_T.
  Ent_R_subst_con_distr.
  do 2 Ent_R_subst_apply => /=.
  by Ent_monotony0.

pose vb := `! \b %"v" \= [ b ]pc.
  Hoare_seq_ext vb.
  Hoare_frame_idx_tmp (2%nat :: nil) (O :: 3%nat :: nil).
  eapply hoare_stren; last by apply hoare_lookup_stren, ent_id.
  apply ent_R_lookup_trans with ([ b ]p) (mk_cell b).
    by rewrite /phylog_conv /=.
    by apply ent_R_con_T.
  Ent_R_subst_con_distr.
  do 2 Ent_R_subst_apply => /=.
  by rewrite bbang_eq_exx coneP.

set Hx_old := %"x" |le~> mk_cell a.
pose Hx_new := %"x" |le~> mk_cell b.
Hoare_seq_replace1 Hx_old Hx_new.
  Hoare_frame_idx_tmp (O :: 2%nat :: nil) (O :: 2%nat :: nil).
  apply hoare_mutation_subst_btyp with (str := "v") (Hstr := Logic.eq_refl) (e' := [ b ]pc).
    rewrite /vb.
    Ent_R_rewrite_eq_e O.
    Ent_R_subst_con_distr.
    do 2 Ent_R_subst_apply.
   rewrite /Hx_old.
   rewrite bbang_eq_exx coneP; by apply ent_R_T.
  rewrite /=.
  Hoare_frame_idx_tmp (1%nat :: nil) (1%nat :: nil).
  rewrite /Hx_old /Hx_new.
  set bpc := [ b ]pc.
  have He2 : vars bpc = nil by done.
  apply hoare_mutation_local_forward_ground_le with (He2 := He2); by rewrite/phylog_conv /=.

rewrite -/Hx_new.
set Hy_old := %"y" |le~> _.
set Hy_new := %"y" |le~> _.
Hoare_frame (vb :: za :: Hy_old :: nil) (Hy_new :: nil).
apply hoare_mutation_subst_btyp with (str := "z") (Hstr := Logic.eq_refl) (e' := [ a ]pc).
  rewrite /za.
  Ent_R_rewrite_eq_e O.
  Ent_R_subst_con_distr.
  do 2 Ent_R_subst_apply.
  rewrite bbang_eq_exx coneP; by apply ent_R_T.
rewrite /=.
Hoare_L_contract_bbang vb.
Hoare_L_contract_bbang za.
set apc := [ a ]pc.
have He2 : vars apc = nil by done.
apply hoare_mutation_local_forward_ground_le with (He2 := He2); by rewrite/phylog_conv /=.
Qed.

Eval compute in pp_ctxt.
Eval compute in (foldl
  (fun s p => s ++ typ_to_string (Ctyp.ty _ (snd p)) (fst p) (line ";"))
  "" sigma).
Eval compute in (pp_cmd 0 swap "").


From stdpp Require Export binders strings countable gmap.
From iris.algebra Require Export ofe.
From iris.heap_lang Require Export locations.
From iris.prelude Require Import options.

Declare Scope c_val_scope.
Delimit Scope c_val_scope with CV.

Module C_intf.

(** C values *)

Inductive base_lit : Set :=
  | LitInt (n : Z) | LitLoc (l : loc) | LitNull | LitFunPtr (x : string).
Inductive val :=
  | LitV (l : base_lit).

Bind Scope c_val_scope with C_intf.val.

Global Instance base_lit_eq_dec : EqDecision base_lit.
Proof. solve_decision. Defined.
Global Instance val_eq_dec : EqDecision val.
Proof. solve_decision. Defined.

Global Instance base_lit_countable : Countable base_lit.
Proof.
 refine (inj_countable' (λ l, match l with
  | LitInt n => (inl (inl n))
  | LitLoc l => (inl (inr l))
  | LitFunPtr p => (inr (inl p))
  | LitNull => inr (inr ())
  end) (λ l, match l with
  | inl (inl n) => LitInt n
  | inl (inr l) => LitLoc l
  | inr (inl p) => LitFunPtr p
  | inr (inr _) => LitNull
  end) _); by intros [].
Qed.
Global Instance val_countable : Countable val.
Proof.
  set (enc := fun e => match e with LitV l => l end).
  set (dec := LitV).
  refine (inj_countable' enc dec _).
  by intros [].
Qed.

Global Instance val_inhabited : Inhabited val := populate (LitV (LitInt 0)).
Canonical Structure valO {SI:indexT} := leibnizO val.

Definition LitBool (b : bool) : base_lit := LitInt (if b then 1%Z else 0%Z).
Definition LitUnit : base_lit := LitInt 0.

(** C state *)

Notation heap_cell := (option (option val)).
Notation Deallocated := (None : heap_cell).
Notation Uninitialized := (Some None : heap_cell).
Notation Storing v := (Some (Some v) : heap_cell).

(** The state: heaps of heap_cells. *)
Notation c_state := (gmap loc (option (option val))).

Global Instance state_inhabited : Inhabited c_state :=
  populate inhabitant.

Canonical Structure stateO {SI:indexT} := leibnizO c_state.

(* Contiguous regions in the heap, i.e. arrays *)

Definition state_upd_heap (f: gmap loc heap_cell → gmap loc heap_cell) (σ: c_state) : c_state :=
  f σ.
Global Arguments state_upd_heap _ !_ /.

Fixpoint heap_array (l : loc) (vs : list heap_cell) : gmap loc heap_cell :=
  match vs with
  | [] => ∅
  | v :: vs' => {[l := v]} ∪ heap_array (l +ₗ 1) vs'
  end.

Lemma heap_array_singleton l v : heap_array l [v] = {[l := v]}.
Proof. by rewrite /heap_array right_id. Qed.

Lemma heap_array_lookup l vs ow k :
  heap_array l vs !! k = Some ow ↔
  ∃ j, (0 ≤ j)%Z ∧ k = l +ₗ j ∧ vs !! (Z.to_nat j) = Some ow.
Proof.
  revert k l; induction vs as [|v' vs IH]=> l' l /=.
  { rewrite lookup_empty. naive_solver lia. }
  rewrite -insert_union_singleton_l lookup_insert_Some IH. split.
  - intros [[-> ?] | (Hl & j  & ? & -> & ?)].
    { eexists 0. rewrite loc_add_0. naive_solver lia. }
    eexists (1 + j)%Z. rewrite loc_add_assoc !Z.add_1_l Z2Nat.inj_succ; auto with lia.
  - intros (j & w & -> & Hil). destruct (decide (j = 0)); simplify_eq/=.
    { rewrite loc_add_0; eauto. }
    right. split.
    { rewrite -{1}(loc_add_0 l). intros ?%(inj (loc_add _)); lia. }
    assert (Z.to_nat j = S (Z.to_nat (j - 1))) as Hj.
    { rewrite -Z2Nat.inj_succ; last lia. f_equal; lia. }
    rewrite Hj /= in Hil.
    eexists (j - 1)%Z. rewrite loc_add_assoc Z.add_sub_assoc Z.add_simpl_l.
    auto with lia.
Qed.

Lemma heap_array_map_disjoint (h : gmap loc heap_cell) (l : loc) (vs : list _) :
  (∀ i, (0 ≤ i)%Z → (i < length vs)%Z → h !! (l +ₗ i) = None) →
  (heap_array l vs) ##ₘ h.
Proof.
  intros Hdisj. apply map_disjoint_spec=> l' v1 v2.
  intros (j&w&->&Hj%lookup_lt_Some%inj_lt)%heap_array_lookup.
  move: Hj. rewrite Z2Nat.id // => ?. by rewrite Hdisj.
Qed.

End C_intf.

Export C_intf.


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

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

  Ltac option_locate_r_once_reg r reg :=
  match goal with
  | H : r !! reg = Some ?w |- _ => let Htmp := fresh in
                                rename H into Htmp ;
                                let Ha := fresh "H" r reg in
                                pose proof (regs_lookup_eq _ _ _ Htmp) as Ha; clear Htmp
  end.

  Lemma step_Load Ep K pc_p pc_g pc_b pc_e pc_a r1 r2 w mem regs :
    decodeInstrW w = Load r1 r2 →
    isCorrectPC (inr (pc_p, pc_g, pc_b, pc_e, pc_a)) →
    regs !! PC = Some (inr (pc_p, pc_g, pc_b, pc_e, pc_a)) →
    regs_of (Load r1 r2) ⊆ dom _ regs →
    mem !! pc_a = Some w →
    allow_load_map_or_true r2 regs mem →

    nclose specN ⊆ Ep →

    spec_ctx ∗ ⤇ fill K (Instr Executable) ∗ (▷ [∗ map] a↦w ∈ mem, a ↣ₐ w) ∗ (▷ [∗ map] k↦y ∈ regs, k ↣ᵣ y)
    ={Ep}=∗ ∃ retv regs', ⤇ fill K (of_val retv) ∗ ⌜ Load_spec regs r1 r2 regs' mem retv ⌝ ∗ ([∗ map] a↦w ∈ mem, a ↣ₐ w)∗ ([∗ map] k↦y ∈ regs', k ↣ᵣ y).
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs Hmem_pc HaLoad Hnclose) "(#Hinv & Hj & >Hmem & >Hmap)".
    iDestruct "Hinv" as (ρ) "Hinv". rewrite /spec_inv.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e [σr σm]) "[Hown %] /=".
    iDestruct (regspec_heap_valid_inclSepM with "Hown Hmap") as %Hregs.
    iDestruct (spec_expr_valid with "[$Hown $Hj]") as %Heq; subst e.

    (* Derive necessary register values in r *)
     pose proof (lookup_weaken _ _ _ _ HPC Hregs).
     specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri. unfold regs_of in Hri.
     feed destruct (Hri r2) as [r2v [Hr'2 Hr2]]. by set_solver+.
     feed destruct (Hri r1) as [r1v [Hr'1 _]]. by set_solver+. clear Hri.
     pose proof (regs_lookup_eq _ _ _ Hr'1) as Hr''1.
     pose proof (regs_lookup_eq _ _ _ Hr'2) as Hr''2.
     (* Derive the PC in memory *)
     iDestruct (memspec_heap_valid_inSepM _ _ _ _ pc_a with "Hown Hmem") as %Hma; eauto.

     specialize (normal_always_step (σr,σm)) as [c [ σ2 Hstep]].
     eapply step_exec_inv in Hstep; eauto. simpl in H3,Hr2,Hma.

     option_locate_r_once_reg σr r2. assert (Hstep':=Hstep).
     cbn in Hstep. rewrite Hσrr2 in Hstep.

     (* Now we start splitting on the different cases in the Load spec, and prove them one at a time *)
     destruct r2v as  [| (([[p g] b] & e) & a) ] eqn:Hr2v.
     { (* Failure: r2 is not a capability *)
       symmetry in Hstep; inversion Hstep; clear Hstep. subst c σ2.
       iMod (exprspec_mapsto_update _ _ (fill K (Instr Failed)) with "Hown Hj") as "[Hown Hj]".
       iMod ("Hclose" with "[Hown]") as "_".
       { iNext. iExists _,_;iFrame.
         iPureIntro. eapply rtc_r;eauto. prim_step_from_exec. }
       iExists (FailedV),_; iFrame. iModIntro. iFailCore Load_fail_const.
     }

     destruct (readAllowed p && withinBounds (p,g, b, e, a)) eqn:HRA; rewrite HRA in Hstep.
     2 : { (* Failure: r2 is either not within bounds or doesnt allow reading *)
       symmetry in Hstep; inversion Hstep; clear Hstep. subst c σ2.
       apply andb_false_iff in HRA.
       iMod (exprspec_mapsto_update _ _ (fill K (Instr Failed)) with "Hown Hj") as "[Hown Hj]".
       iMod ("Hclose" with "[Hown]") as "_".
       { iNext. iExists _,_;iFrame.
         iPureIntro. eapply rtc_r;eauto. prim_step_from_exec. }
       iExists (FailedV),_; iFrame. iModIntro. iFailCore Load_fail_bounds.
     }
     apply andb_true_iff in HRA; destruct HRA as (Hra & Hwb).

     (* Prove that a is in the memory map now, otherwise we cannot continue *)
     pose proof (allow_load_implies_loadv r2 mem regs p g b e a) as (loadv & Hmema); auto.

     iDestruct (memspec_v_implies_m_v mem (σr,σm) _ b e a loadv with "Hmem Hown" ) as %Hma' ; auto.

     rewrite Hma' in Hstep.
     destruct (incrementPC (<[ r1 := loadv ]> regs)) as  [ regs' |] eqn:Hregs'.
     2: { (* Failure: the PC could not be incremented correctly *)
       assert (incrementPC (<[ r1 := loadv]> σr) = None).
       { eapply incrementPC_overflow_mono; first eapply Hregs'.
         by rewrite lookup_insert_is_Some'; eauto.
         by apply insert_mono; eauto. }

       rewrite incrementPC_fail_updatePC /= in Hstep; auto.
       symmetry in Hstep; inversion Hstep; clear Hstep. subst c σ2.
       (* Update the heap resource, using the resource for r2 *)
       iMod (exprspec_mapsto_update _ _ (fill K (Instr Failed)) with "Hown Hj") as "[Hown Hj]".
       iMod ((regspec_heap_update_inSepM _ _ _ r1 loadv) with "Hown Hmap") as "[Hown Hmap]"; eauto.
       iMod ("Hclose" with "[Hown]") as "_".
       { iNext. iExists _,_;iFrame.
         iPureIntro. eapply rtc_r;eauto. prim_step_from_exec. }
       iExists (FailedV),_; iFrame. iModIntro. iFailCore Load_fail_invalid_PC.
     }

     (* Success *)
     rewrite /update_reg /= in Hstep.
     eapply (incrementPC_success_updatePC _ σm) in Hregs'
       as (p1 & g1 & b1 & e1 & a1 & a_pc1 & HPC'' & Ha_pc' & HuPC & -> & ?).
     eapply updatePC_success_incl in HuPC. 2: by eapply insert_mono.
     rewrite HuPC in Hstep; clear HuPC; inversion Hstep; clear Hstep; subst c σ2. cbn.
     iFrame.
     iMod ((regspec_heap_update_inSepM _ _ _ r1 loadv) with "Hown Hmap") as "[Hown Hmap]"; eauto.
     iMod ((regspec_heap_update_inSepM _ _ _ PC (inr (p1, g1, b1, e1, a_pc1))) with "Hown Hmap") as "[Hown Hmap]"; eauto.
     iMod (exprspec_mapsto_update _ _ (fill K (Instr NextI)) with "Hown Hj") as "[Hown Hj]".
     iExists NextIV,_. iFrame.
     iMod ("Hclose" with "[Hown]") as "_".
     { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
      prim_step_from_exec. }
     iModIntro. iPureIntro. eapply Load_spec_success; auto.
    * split; auto. apply (regs_lookup_inr_eq regs r2).
      exact Hr''2.
      auto.
    * exact Hmema.
    * unfold incrementPC. rewrite HPC'' Ha_pc'.
      destruct p1; naive_solver.
      Unshelve. all: auto.
  Qed.

  Lemma step_load_success_same E K r1 pc_p pc_g pc_b pc_e pc_a w w' w'' p g b e a pc_a' :
    decodeInstrW w = Load r1 r1 →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) →
    readAllowed p = true ∧ withinBounds (p, g, b, e, a) = true →
    (pc_a + 1)%a = Some pc_a' →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ ▷ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a)
             ∗ ▷ pc_a ↣ₐ w
             ∗ ▷ r1 ↣ᵣ inr (p,g,b,e,a)
             ∗ (if (a =? pc_a)%a then emp else ▷ a ↣ₐ w')
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
        ∗ r1 ↣ᵣ (if (a =? pc_a)%a then w else w')
        ∗ pc_a ↣ₐ w
        ∗ (if (a =? pc_a)%a then emp else a ↣ₐ w').
  Proof.
    iIntros (Hinstr Hvpc [Hra Hwb] Hpca' Hnclose)
            "(Hown & Hj & >HPC & >Hi & >Hr1 & Hr1a)".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iDestruct (memMap_resource_2gen_clater _ _ _ _ (λ a w, a ↣ₐ w)%I with "Hi Hr1a") as (mem) "[>Hmem Hmem']".
    iDestruct "Hmem'" as %Hmem.

    iMod (step_Load with "[$Hown $Hj $Hmap $Hmem]") as (retv regs') "(Hj & #Hspec & Hmem & Hmap)"; eauto; simplify_map_eq; eauto.
    { by rewrite !dom_insert; set_solver+. }
    { destruct (a =? pc_a)%a; by simplify_map_eq. }
    { eapply mem_implies_allow_load_map; eauto. rewrite lookup_insert_ne// lookup_insert;eauto. }
    iDestruct "Hspec" as %Hspec.

    destruct Hspec as [ | * Hfail ].
     { (* Success *)
       destruct H3 as [Hrr2 _].
       rewrite lookup_insert_ne// lookup_insert in Hrr2. simplify_eq.
       incrementPC_inv. rewrite lookup_insert_ne// lookup_insert in H3. simplify_eq.
       iDestruct (memMap_resource_2gen_d with "[Hmem]") as "[Hpc_a Ha]".
       {iExists mem; iSplitL; auto. }
       pose proof (mem_implies_loadv _ _ _ _ _ _ Hmem H4) as Hloadv; eauto.
       rewrite (insert_commute _ PC r1) // insert_insert (insert_commute _ r1 PC) // insert_insert.
       iDestruct (regs_of_map_2 with "[$Hmap]") as "[HPC Hr1]"; eauto. rewrite Hloadv. by iFrame. }
     { (* Failure (contradiction) *)
       destruct Hfail; try (incrementPC_inv;[|rewrite lookup_insert_ne//]);simplify_map_eq;eauto.
       destruct o. all: try congruence.
       destruct e3; try congruence. inv Hvpc; naive_solver.
     }
  Qed.

  Lemma step_load_success_same_alt E K r1 pc_p pc_g pc_b pc_e pc_a w w' w'' p g b e a pc_a' :
    decodeInstrW w = Load r1 r1 →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) →
    readAllowed p = true ∧ withinBounds (p, g, b, e, a) = true →
    (pc_a + 1)%a = Some pc_a' →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ ▷ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a)
             ∗ ▷ pc_a ↣ₐ w
             ∗ ▷ r1 ↣ᵣ inr (p,g,b,e,a)
             ∗ ▷ a ↣ₐ w'
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
        ∗ r1 ↣ᵣ w'
        ∗ pc_a ↣ₐ w
        ∗ a ↣ₐ w'.
  Proof.
    iIntros (Hinstr Hvpc [Hra Hwb] Hpca' Hnclose) "(Hown & Hj & >HPC & >Hpc_a & >Hr1 & >Ha)".
    iAssert (⌜(a =? pc_a)%a = false⌝)%I as %Hfalse.
    { rewrite Z.eqb_neq. iIntros (->%z_of_eq). iDestruct (memspec_mapsto_valid_2 with "Ha Hpc_a") as %Hneq. done. }
    iMod (step_load_success_same with "[$HPC $Hpc_a $Hr1 $Hown $Hj Ha]") as "(?&?&?&?&?)";eauto;try rewrite Hfalse;by iFrame.
  Qed.

  Lemma step_load_success E K r1 r2 pc_p pc_g pc_b pc_e pc_a w w' w'' p g b e a pc_a' :
    decodeInstrW w = Load r1 r2 →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) →
    readAllowed p = true ∧ withinBounds (p, g, b, e, a) = true →
    (pc_a + 1)%a = Some pc_a' →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ ▷ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a)
             ∗ ▷ pc_a ↣ₐ w
             ∗ ▷ r1 ↣ᵣ w''
             ∗ ▷ r2 ↣ᵣ inr (p,g,b,e,a)
             ∗ (if (eqb_addr a pc_a) then emp else ▷ a ↣ₐ w')
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
        ∗ r1 ↣ᵣ (if (eqb_addr a pc_a) then w else w')
        ∗ pc_a ↣ₐ w
        ∗ r2 ↣ᵣ inr (p,g,b,e,a)
        ∗ (if (eqb_addr a pc_a) then emp else a ↣ₐ w').
  Proof.
    iIntros (Hinstr Hvpc [Hra Hwb] Hpca' Hnclose)
            "(Hown & Hj & >HPC & >Hi & >Hr1 & >Hr2 & Hr2a)".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hr2") as "[Hmap (%&%&%)]".
    iDestruct (memMap_resource_2gen_clater _ _ _ _ (λ a w, a ↣ₐ w)%I with "Hi Hr2a") as (mem) "[>Hmem Hmem']".
    iDestruct "Hmem'" as %Hmem.

    iMod (step_Load with "[$Hown $Hj $Hmap $Hmem]") as (retv regs') "(Hj & #Hspec & Hmem & Hmap)"; eauto.
    { rewrite lookup_insert;eauto. }
    { by rewrite !dom_insert; set_solver+. }
    { destruct (a =? pc_a)%a; by simplify_map_eq. }
    { eapply mem_implies_allow_load_map; eauto. rewrite lookup_insert_ne// lookup_insert_ne// lookup_insert. eauto. }
    iDestruct "Hspec" as %Hspec.

    destruct Hspec as [ | * Hfail ].
     { (* Success *)
       (* FIXME: fragile *)
       destruct H5 as [Hrr2 _]. simplify_map_eq_alt.
       iDestruct (memMap_resource_2gen_d with "[Hmem]") as "[Hpc_a Ha]".
       {iExists mem; iSplitL; auto. }
       incrementPC_inv.
       pose proof (mem_implies_loadv _ _ _ _ _ _ Hmem H6) as Hloadv; eauto.
       simplify_map_eq_alt.
       rewrite (insert_commute _ PC r1) // insert_insert (insert_commute _ r1 PC) // insert_insert.
       iDestruct (regs_of_map_3 with "[$Hmap]") as "[HPC [Hr1 Hr2] ]"; eauto.
       by iFrame. }
     { (* Failure (contradiction) *)
       destruct Hfail; simplify_map_eq_alt.
       destruct o;congruence.
       incrementPC_inv;[|rewrite lookup_insert_ne// lookup_insert;eauto].
       destruct e3; try congruence. inv Hvpc; naive_solver. }
  Qed.

  Lemma step_load_success_alt E K r1 r2 pc_p pc_g pc_b pc_e pc_a w w' w'' p g b e a pc_a' :
    decodeInstrW w = Load r1 r2 →
    isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) →
    readAllowed p = true ∧ withinBounds (p, g, b, e, a) = true →
    (pc_a + 1)%a = Some pc_a' →
    nclose specN ⊆ E →

    spec_ctx ∗ ⤇ fill K (Instr Executable)
             ∗ ▷ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a)
             ∗ ▷ pc_a ↣ₐ w
             ∗ ▷ r1 ↣ᵣ w''
             ∗ ▷ r2 ↣ᵣ inr (p,g,b,e,a)
             ∗ ▷ a ↣ₐ w'
    ={E}=∗ ⤇ fill K (Instr NextI)
        ∗ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
        ∗ r1 ↣ᵣ w'
        ∗ pc_a ↣ₐ w
        ∗ r2 ↣ᵣ inr (p,g,b,e,a)
        ∗ a ↣ₐ w'.
  Proof.
    iIntros (Hinstr Hvpc [Hra Hwb] Hpca' Hnclose)
            "(Hown & Hj & >HPC & >Hi & >Hr1 & >Hr2 & >Hr2a)".
    iAssert (⌜(a =? pc_a)%a = false⌝)%I as %Hfalse.
    { rewrite Z.eqb_neq. iIntros (->%z_of_eq). iDestruct (memspec_mapsto_valid_2 with "Hr2a Hi") as %Hneq. done. }
    iMod (step_load_success with "[$Hown $Hj $HPC $Hi $Hr1 $Hr2 Hr2a]");eauto;rewrite Hfalse;by iFrame.
  Qed.

End cap_lang_spec_rules.


Require Import FunctionalExtensionality.
Require Import List.
Import ListNotations.
From Coq Require Import ZArith.
Require Import Basics.
Require Import Automation.
Require Import Monads.
Require Import Blockchain.
Require Import Extras.
Require Import Containers.

Require Import Serializable.
From RecordUpdate Require Import RecordUpdate.
Import RecordSetNotations.
Require Import CLIPrelude.
Require Import CLITranslate.

Open Scope Z.

Set Nonrecursive Elimination Schemes.

Section Interp.
  Context `{Base : ChainBase}.

  (** Defines setup, state and message records for the contract *)
  Record Setup :=
    build_setup {
        setup_contract : list CInstruction;
      }.

  Record State :=
    build_state {
        contract : list CInstruction;
        currentTime : nat;
        result : option TraceM;
      }.

  Inductive Msg :=
  | update : ExtMap -> nat -> Msg.

  (** Automatically prove that our required datatypes and records are serializable, needs to be in this file for some reason *)
(*  Instance party_serializable : Serializable Party :=
    Derive Serializable Party_rect<PartyN>. *)
  Instance Obs_serializable : Serializable ObsLabel :=
    Derive Serializable ObsLabel_rect<LabZ, LabB>.
  Instance Val_Serializable : Serializable Val :=
    Derive Serializable Val_rect<BVal, ZVal>.
  Instance ExtMapSerializable : Serializable ExtMap := _.
(*  Instance asset_serializable : Serializable Asset :=
    Derive Serializable Asset_rect<DKK, USD>. *)
  Instance TransSerial : Serializable TransM := _.
  Instance TraceSerial : Serializable TraceM := _.
  Instance Op_serializable : Serializable Op :=
    Derive Serializable Op_rect <Add, Sub, Mult, Div, And, Or, Less, Leq, Equal, Not, Neg, BLit, ZLit, Cond>.
  Instance instruction_serializable : Serializable instruction :=
    Derive Serializable instruction_rect<IPushZ, IPushB, IObs, IOp, IAccStart1,
    IAccStart2, IAccStep, IAccEnd, IVar>.
   Instance Env_Serializable : Serializable Env := _.
  Instance CInstruction_serializable : Serializable CInstruction :=
    Derive Serializable CInstruction_rect< CIZero, CITransfer, CIScale, CIBoth, CITranslate,
    CITranslateEnd, CILet, CILetEnd, CIIf, CIThen, CIIfEnd>.
  Instance SetupSerial : Serializable Setup :=
    Derive Serializable Setup_rect<build_setup>.
  Instance StateSerial : Serializable State :=
    Derive Serializable State_rect<build_state>.
  Instance MsgSerial : Serializable Msg :=
    Derive Serializable Msg_rect<update>.
  Global Instance State_settable : Settable _ :=
    settable! build_state <contract; currentTime; result>.

  (** init funtion for the contract, sets the current time to zero, and the currently computed transactions to None
   note that we meassure time realitvely, so 0 means 0 time units since initialization *)
  Definition init (chain : Chain) (ctx: ContractCallContext) (setup: Setup) : option State :=
    let contract := setup_contract setup in
    Some (build_state contract 0 None).

  Definition extract_element (trace : TraceM) (index : nat) : TraceM :=
    match FMap.find index trace with
    | Some trans => FMap.add index trans empty_traceM
    | None => empty_traceM
    end.

  Fixpoint cutTrace (trace : TraceM) (startTime idx: nat) : TraceM :=
    match idx with
    | 0%nat => empty_traceM
    | S n => add_traceM (extract_element trace (startTime + idx)%nat) (cutTrace trace startTime n)
    end.

  (**
      The receive method of the contract.
      When an environment and a time is received, if the new time is greater that what
      has previously been evaluated, then the contract is evluated according to the
      environment. The section of the trace between is then evaluation and the last
      is recorded for use by the ContractManager.
   *)

  Definition receive
             (chain : Chain) (ctx : ContractCallContext)
             (state : State) (msg : option Msg)
    : option (State * list ActionBody) :=
    match msg with
    | Some (update ext t) => if (Nat.ltb (currentTime state) t) then
                              Some (state<|result := do trace <- (vmC (contract state) [] ext);
                                                     Some (cutTrace trace (currentTime state) t)|>
                                                     <|currentTime := t |>, [])
                            else
                              None
    | None => Some (state,[])
    end.
End Interp.


Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Ipdl.Tacs Lib.Dist Ipdl.Big Pars Lib.Set Lib.OrdLems.
Require Import CoinFlip CFold.

Lemma eq_EqRxn {chan} {t} (r1 r2 : rxn t) :
  r1 = r2 ->
  @EqRxn chan _ r1 r2.
  move => -> //=.
Qed.

Definition CFRealParty_honest_external {chan : Type -> Type} (k : nat) {n} (committed : (n.+1).-tuple (chan unit)) (opened : (n.+1).-tuple (chan k.-bv)) (commit : chan k.-bv) (open : chan unit)  :=
  committed_sum <- newvec n.+1 @ unit ;;
  opened_sum' <- newvec n.+1 @ k.-bv ;;
  pars [::
          commit ::= (Samp (Unif ));
          read_all committed committed_sum;
          Out open (copy (tnth committed_sum ord_max));
          @cfold chan _ k.-bv k.-bv opened xort id opened_sum'
       ].

Lemma CFRealParty_honest_externalE {chan : Type -> Type} (k : nat) {n} (committed : (n.+1).-tuple (chan unit)) (opened : (n.+1).-tuple (chan k.-bv)) (commit : chan k.-bv) (open : chan unit) (out : chan k.-bv) (opened_sum : (n.+1).-tuple (chan k.-bv)) :
  pars [::
          CFRealParty_honest k _ committed opened commit open out;
          @cfold chan _ k.-bv k.-bv opened xort id opened_sum ] =p
  pars [::
          CFRealParty_honest_external k committed opened commit open ;
          Out out (copy (tnth opened_sum ord_max));
       @cfold chan _ k.-bv k.-bv opened xort id opened_sum ].
  rewrite newPars.
  rewrite newPars.
  setoid_rewrite newPars.
  apply EqCongNew_vec => committed_sum.
  apply EqCongNew_vec => opened_sum'.
  rewrite pars_pars; simpl.

  rewrite pars_pars; simpl.
  swap_tac 0 5.
  swap_tac 1 3.
  rewrite (pars_split 2) //=.
  rewrite cfold2_det_copy.
  rewrite -pars_cat //=.
  swap_tac 0 4.
  rewrite pars_inline_from_big //=.
  swap_tac 0 4.
  rewrite (pars_split 2) //=.
  rewrite -cfold2_det_copy.
  rewrite -pars_cat //=.
  align.
  rewrite /copy; apply EqCongReact; simp_rxn; done.
  apply _.
  apply _.
Qed.

Lemma CFRealPartyE {chan : Type -> Type} (k : nat) {n} (honest : pred 'I_(n.+1)) advCommit advOpen advCommitted advOpened i committed opened commit open out opened_sum :
  pars [::
          CFParty k _ honest advCommit advOpen advCommitted advOpened i committed opened commit open out;
          @cfold chan _ k.-bv k.-bv opened xort id opened_sum ] =p
  pars [::
          if honest i then pars [::
                                   CFRealParty_honest_external k committed opened commit open; Out out (copy (tnth opened_sum ord_max))] else CFRealParty_corr k _ advCommit advOpen advCommitted advOpened i committed opened commit open;
       @cfold chan _ k.-bv k.-bv opened xort id opened_sum ].
  rewrite /CFParty.
  destruct (honest i).
  rewrite pars_pars.
  apply CFRealParty_honest_externalE.
  done.
Qed.

Lemma CFRealParty_compE {chan : Type -> Type} (k : nat) {n} (honest : pred 'I_(n.+1)) advCommit advOpen advCommitted advOpened committed opened commit open out opened_sum :
  pars [::
         \||_(i < n.+1) CFParty k _ honest advCommit advOpen advCommitted advOpened i committed opened (tnth commit i) (tnth open i) (tnth out i) ;
          @cfold chan _ k.-bv k.-bv opened xort id opened_sum ] =p
  pars [::
          \||_(i < n.+1 | honest i) CFRealParty_honest_external k committed opened (tnth commit i) (tnth open i);
          \||_(i < n.+1 | honest i) Out (tnth out i) (copy (tnth opened_sum ord_max));
       \||_(i < n.+1 | ~~ honest i) CFRealParty_corr k _ advCommit advOpen advCommitted advOpened i committed opened (tnth commit i) (tnth open i);
          @cfold chan _ k.-bv k.-bv opened xort id opened_sum ].
  etransitivity.
  apply pars_big_replace.
  intros.
  apply CFRealPartyE.
  simpl.
  symmetry.
  rewrite bigpar_mkcond.
  swap_tac 0 1.
  rewrite bigpar_mkcond.
  swap_tac 0 2.
  rewrite bigpar_mkcond.
  simpl.
  rewrite -par_in_pars.
  rewrite -bigpar_par.
  rewrite -par_in_pars.
  rewrite -bigpar_par.
  apply pars_big_replace; intros.
  rewrite !par_in_pars.
  destruct (honest i); simpl.
  rewrite pars_prot0.
  rewrite pars_pars //=.
  swap_tac 0 1; rewrite pars_prot0.
  swap_tac 0 1; rewrite pars_prot0.
  done.
Qed.

Lemma opened_sumE {chan : Type -> Type} (k : nat) {n} (commits : (n.+1).-tuple (chan k.-bv)) (opens : (n.+1).-tuple (chan unit)) (committed : (n.+1).-tuple (chan unit)) (opened : (n.+1).-tuple (chan k.-bv)) (opened_sum : (n.+1).-tuple (chan k.-bv))
      (opens_sum : (n.+1).-tuple (chan unit))
      (commits_sum : (n.+1).-tuple (chan k.-bv))
  :
  pars [::
          @cfold _ _ k.-bv k.-bv commits xort id commits_sum;
          read_all opens opens_sum;
          @cfold _ _ k.-bv k.-bv opened xort id opened_sum;
          \||_(i < n.+1) FComm k (tnth commits i)  (tnth committed i) (tnth opens i) (tnth opened i)]  =p

  pars [::
          @cfold _ _ k.-bv k.-bv commits xort id commits_sum;
          read_all opens opens_sum;
       \||_(i < n.+1) Out (tnth opened_sum i) (
                                            _ <-- Read (tnth opens_sum i) ;;
                                            x <-- Read (tnth commits_sum i) ;;
                                            Ret x);
          \||_(i < n.+1)
          FComm k (tnth commits i) (tnth committed i) (tnth opens i)  (tnth opened i)].
  swap_tac 0 3.
  rewrite big_pars2 pars_pars //=.
  swap_tac 0 3.
  symmetry.
  swap_tac 0 3.
  rewrite pars_pars //=.
  swap_tac 0 3.

  apply pars_big_hybrid2.
  intros.
  symmetry.
  rewrite /cfold_body.
  destruct (ordP k0); subst.
  swap_tac 0 1.
  swap_tac 1 2.
  rewrite pars_inline_from_big //=.
  simp_at 0.
  symmetry.
  swap_tac 0 1.
  swap_tac 1 3.
  rewrite pars_inline_from_big //=.
  rewrite {1}/cfold_body //=.
  simp_at 0.
  swap_at 0 0 1.
  swap_tac 1 5.
  rewrite pars_inline_from_big //=.
  rewrite {1}/cfold_body //=.
  apply pars_cons_cong.
  apply EqCongReact.
  simp_rxn.
  rewrite /copy.
  r_swap 0 1; done.

  swap_tac 0 1.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 1.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.

  swap_tac 0 1.
  swap_tac 1 2.
  rewrite pars_inline_from_big; rewrite //=.
  simp_at 0.
  swap_at 0 0 2.
  swap_tac 1 2.
  rewrite pars_inline_from_big; rewrite //=.
  simp_at 0.
  symmetry.
  swap_tac 0 1.

  swap_tac 1 3.
  rewrite pars_inline_from_big; rewrite //=.

  rewrite {1}/cfold_body //=.
  simp_at 0.
  swap_at 0 0 2.
  swap_tac 1 5.
  rewrite pars_inline_from_big; rewrite //=.
  apply pars_cons_cong.
  rewrite /cfold_body //=.
  apply EqCongReact.
  simp_rxn.
  r_swap 0 3.
  apply EqRxnBind.
  apply eq_EqRxn.
  congr (_ _).
  congr (_ _ _).
  apply/eqP; rewrite eqE //=.
  intros.

  r_swap 0 1.
  apply EqRxnBind.
  apply eq_EqRxn.
  congr (_ _).
  congr (_ _ _).
  apply/eqP; rewrite eqE //=.
  intros.

  r_swap 0 1.
  apply EqBind_r; intro.
  rewrite /copy.
  symmetry; simp_rxn.
  apply EqBind_r; intro.
  done.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
Qed.

Definition CFRealSimpl {chan : Type -> Type} (k : nat) {n}
           (honest : pred 'I_(n.+1))
           (out advCommit : (n.+1).-tuple (chan k.-bv))
           (advOpen : (n.+1).-tuple (chan unit))
           (advCommitted : (n.+1).-tuple ((n.+1).-tuple (chan unit)))
           (advOpened : (n.+1).-tuple ((n.+1).-tuple (chan k.-bv))) :=
  commit <- newvec n.+1 @ k.-bv ;;
  committed <- newvec n.+1 @ unit ;;
  open <- newvec n.+1 @ unit ;;
  opened <- newvec n.+1 @ k.-bv ;;
  commits_sum <- newvec n.+1 @ k.-bv ;;
  opens_sum <- newvec n.+1 @ unit ;;
  pars [::
          \||_(i < n.+1) FComm k (tnth commit i) (tnth committed i) (tnth open i) (tnth opened i);
          \||_(i < n.+1 | honest i) CFRealParty_honest_external k committed opened (tnth commit i) (tnth open i);
       \||_(i < n.+1 | honest i) Out (tnth out i)
          (
            _ <-- Read (tnth opens_sum ord_max) ;;
            x <-- Read (tnth commits_sum ord_max) ;;
            Ret x);
       \||_(i < n.+1 | ~~ honest i) CFRealParty_corr k _ advCommit advOpen advCommitted advOpened i committed opened (tnth commit i) (tnth open i);
          @cfold _ _ k.-bv k.-bv commit xort id commits_sum;
          read_all open opens_sum
].

Lemma CFRealSimplE {chan : Type -> Type} (k : nat) {n}
           (honest : pred 'I_(n.+1))
           (out advCommit : (n.+1).-tuple (chan k.-bv))
           (advOpen : (n.+1).-tuple (chan unit))
           (advCommitted : (n.+1).-tuple ((n.+1).-tuple (chan unit)))
           (advOpened : (n.+1).-tuple ((n.+1).-tuple (chan k.-bv))) :
  CFReal k _ honest out advCommit advOpen advCommitted advOpened =p
  CFRealSimpl k honest out advCommit advOpen advCommitted advOpened.
  rewrite /CFReal.
  etransitivity.
  apply EqCongNew_vec => commit .
  apply EqCongNew_vec => committed .
  apply EqCongNew_vec => open .
  apply EqCongNew_vec => opened .
  rewrite -(@new_cfold_remove chan _ k.-bv k.-bv commit xort id).
  apply EqCongNew_vec => commits_sum .
  rewrite -(@new_cfold_remove chan _ unit unit open (fun _ _ => tt) (fun _ => tt)).
  apply EqCongNew_vec => opens_sum .
  rewrite -(@new_cfold_remove chan _ k.-bv k.-bv opened xort id).
  apply EqCongNew_vec => opened_sum.
  swap_tac 0 4.
  swap_tac 1 4.
  rewrite (pars_split 2); simpl.
  rewrite CFRealParty_compE.
  rewrite -pars_cat //=.
  swap_tac 0 4.
  swap_tac 1 6.
  swap_tac 2 3.
  swap_tac 3 5.
  rewrite (pars_split 4); simpl.
  rewrite opened_sumE.
  rewrite -pars_cat; simpl.
  swap_tac 0 6.
  swap_tac 1 2.
  etransitivity.
  apply pars_big_replace; intros.
  rewrite pars_inline_from_big.
  edit_tac 0.
  simp_rxn.
  done.
  apply EqRefl.
  done.
  done.
  apply EqRefl.

  rewrite /CFRealSimpl.

  apply EqCongNew_vec => commit .
  apply EqCongNew_vec => committed .
  apply EqCongNew_vec => open .
  apply EqCongNew_vec => opened .

  apply EqCongNew_vec => commits_sum .
  apply EqCongNew_vec => opens_sum .

  etransitivity.
  etransitivity.
  apply EqCongNew_vec => x; swap_tac 0 1.
  apply EqRefl.
  rewrite pars_big_remove.
  apply EqRefl.

  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 2.
  apply pars_cons_cong; rewrite //=.
  apply pars_cons_cong; rewrite //=.
  swap_tac 0 1.
  apply pars_cons_cong; rewrite //=.
  align.
Qed.