Require Import stdpp.namespaces.
Require Import VST.veric.invariants.
Require Import VST.msl.ghost_seplog.
Require Import VST.msl.sepalg_generators.
Require Import VST.veric.compcert_rmaps.
Require Import VST.concurrency.conclib.
Require Export VST.concurrency.ghostsI.
Require Import VST.veric.bi.
Require Import VST.msl.sepalg.
Require Import List.
Import Ensembles.

#[export] Notation iname := iname.

Lemma coPset_to_Ensemble_minus : forall E1 E2, coPset_to_Ensemble (E1 ∖ E2) = Setminus (coPset_to_Ensemble E1) (coPset_to_Ensemble E2).
Proof.
  intros; unfold coPset_to_Ensemble.
  apply Extensionality_Ensembles; split; intros ? Hin; unfold In in *.
  - apply elem_of_difference in Hin as []; constructor; auto.
  - inv Hin. apply elem_of_difference; auto.
Qed.

Lemma coPset_to_Ensemble_single : forall x, coPset_to_Ensemble {[Pos.of_nat (S x)]} = Singleton x.
Proof.
  intros; unfold coPset_to_Ensemble.
  apply Extensionality_Ensembles; split; intros ? Hin; unfold In in *.
  - apply elem_of_singleton in Hin.
    apply (f_equal Pos.to_nat) in Hin.
    rewrite -> !Nat2Pos.id in Hin by auto; inv Hin; constructor.
  - inv Hin.
    apply elem_of_singleton; auto.
Qed.

(* recapitulating Iris "semantic invariants" so we can use custom namespaces. *)
Definition inv (N : namespace) (P : mpred) : mpred :=
  □ ∀ E, ⌜↑N ⊆ E⌝ → |={E,E ∖ ↑N}=> ▷ P ∗ (▷ P ={E ∖ ↑N,E}=∗ emp).

Definition own_inv (N : namespace) (P : mpred) :=
    ∃ i, ⌜Pos.of_nat (S i) ∈ (↑N:coPset)⌝ ∧ invariant i P.

Lemma own_inv_acc E N P :
  ↑N ⊆ E → own_inv N P |-- |={E,E∖↑N}=> ▷ P ∗ (▷ P ={E∖↑N,E}=∗ emp).
Proof.
  intros.
  iDestruct 1 as (i) "[% HiP]".
  iPoseProof (inv_open (coPset_to_Ensemble E) with "HiP") as "H".
  { unfold Ensembles.In, coPset_to_Ensemble; set_solver. }
  iAssert (|={E,E ∖ {[Pos.of_nat (S i)]}}=> |> P * (|> P -* |={E ∖ {[Pos.of_nat (S i)]},E}=> emp)) with "[H]" as "H".
  { unfold fupd, bi_fupd_fupd; simpl.
    rewrite coPset_to_Ensemble_minus coPset_to_Ensemble_single; auto. }
  iMod "H"; iApply fupd_mask_intro; first by set_solver.
  iIntros "mask".
  iDestruct "H" as "[$ H]"; iIntros "?".
  iMod "mask"; iMod ("H" with "[$]"); auto.
Qed.

Lemma fresh_inv_name n N : ∃ i, (n <= i)%nat /\ Pos.of_nat (S i) ∈ (↑N:coPset).
Proof.
  pose proof (coPpick_elem_of (↑ N ∖ gset_to_coPset (list_to_set (map (fun i => Z.to_pos (i + 1)) (upto n))))).
  rewrite elem_of_difference in H; destruct H as [HN H].
  { apply coPset_infinite_finite, difference_infinite, gset_to_coPset_finite.
    apply coPset_infinite_finite, nclose_infinite. }
  exists (Pos.to_nat (coPpick (↑ N ∖ gset_to_coPset (list_to_set (map (fun i => Z.to_pos (i + 1)) (upto n))))) - 1)%nat; split.
  - match goal with |-(?a <= ?b)%nat => destruct (le_lt_dec a b); auto; exfalso end.
    apply H, elem_of_gset_to_coPset, elem_of_list_to_set, elem_of_list_In, in_map_iff.
    apply Nat2Z.inj_lt in l.
    setoid_rewrite In_upto; eexists; split; [|split; [|apply l]]; lia.
  - destruct (eq_dec (coPpick (↑N ∖ gset_to_coPset (list_to_set (map (λ i : Z, Z.to_pos (i + 1)) (upto n))))) 1%positive).
    + rewrite e in HN |- *; auto.
    + rewrite -> Nat2Pos.inj_succ, Nat2Pos.inj_sub, Pos2Nat.id, Positive_as_OT.sub_1_r, Pos.succ_pred; auto; lia.
Qed.

Lemma own_inv_alloc N E P : ▷ P |-- |={E}=> own_inv N P.
Proof.
  iIntros "HP".
  iPoseProof (inv_alloc_strong _ _ (fun i => Pos.of_nat (S i) ∈ (↑N : coPset)) with "HP") as "H";
    auto using fresh_inv_name.
Qed.

Global Instance agree_persistent g P : Persistent (agree g P : mpred).
Proof.
  apply core_persistent; auto.
Qed.

Lemma own_inv_to_inv M P: own_inv M P |-- inv M P.
Proof.
  iIntros "#I !>". iIntros (E H).
  iPoseProof (own_inv_acc with "I") as "H"; eauto.
Qed.

Global Instance inv_persistent N P : Persistent (inv N P).
Proof.
  apply _.
Qed.

Global Instance inv_affine N P : Affine (inv N P).
Proof.
  apply _.
Qed.

Lemma invariant_dup : forall N P, inv N P = (inv N P * inv N P)%logic.
Proof.
  intros; apply pred_ext; rewrite <- (bi.persistent_sep_dup (inv N P)); auto.
Qed.

Lemma agree_join : forall g P1 P2, agree g P1 * agree g P2 |-- (|> P1 -* |> P2) * agree g P1.
Proof.
  constructor; apply agree_join.
Qed.

Lemma agree_join2 : forall g P1 P2, agree g P1 * agree g P2 |-- (|> P1 -* |> P2) * agree g P2.
Proof.
  constructor; apply agree_join2.
Qed.

Lemma inv_alloc : forall N E P, |> P |-- |={E}=> inv N P.
Proof.
  intros; iIntros "?"; iApply own_inv_to_inv; iApply own_inv_alloc; auto.
Qed.

Lemma make_inv : forall N E P Q, (P |-- Q) -> P |-- |={E}=> inv N Q.
Proof.
  intros.
  eapply derives_trans, inv_alloc; auto.
  eapply derives_trans, now_later; auto.
Qed.

Global Instance into_inv_inv N P : IntoInv (inv N P) N := {}.

#[export] Instance into_acc_inv N P E:
  IntoAcc (X := unit) (inv N P)
          (↑N ⊆ E) emp (updates.fupd E (E ∖ ↑N)) (updates.fupd (E ∖ ↑N) E)
          (λ _ : (), (▷ P)%I) (λ _ : (), (▷ P)%I) (λ _ : (), None).
Proof.
  rewrite /inv /IntoAcc /accessor bi.exist_unit.
  intros; iIntros "#I _".
  iMod ("I" with "[%]"); auto.
Qed.

(* up *)
Lemma persistently_nonexpansive : nonexpansive persistently.
Proof.
  intros; unfold nonexpansive, persistently.
  intros; split; intros ?????; simpl in *; eapply (H (core a'')); eauto;
    rewrite level_core; apply necR_level in H1; apply ext_level in H2; lia.
Qed.

Lemma persistently_nonexpansive2 : forall f, nonexpansive f ->
  nonexpansive (fun a => persistently (f a)).
Proof.
  intros; unfold nonexpansive.
  intros; eapply predicates_hered.derives_trans; [apply H|].
  apply persistently_nonexpansive.
Qed.

Lemma bupd_nonexpansive : nonexpansive own.bupd.
Proof.
  unfold nonexpansive, own.bupd; split; simpl; intros;
    apply H3 in H4 as (? & ? & ? & ? & ? & ? & ?); do 2 eexists; eauto; do 2 eexists; eauto;
    repeat (split; auto); eapply (H x0); eauto; apply necR_level in H1; apply ext_level in H2; lia.
Qed.

Lemma bupd_nonexpansive2 : forall f, nonexpansive f ->
  nonexpansive (fun a => own.bupd (f a)).
Proof.
  intros; unfold nonexpansive.
  intros; eapply predicates_hered.derives_trans; [apply H|].
  apply bupd_nonexpansive.
Qed.

Lemma fupd_nonexpansive1 : forall E1 E2, nonexpansive (fupd.fupd E1 E2).
Proof.
  unfold fupd.fupd, nonexpansive; intros.
  apply (contractive.wand_nonexpansive (fun _ => wsat * ghost_set g_en E1)%pred
    (fun P => (|==> |> predicates_hered.FF || wsat * ghost_set g_en E2 * P)%pred)
    (const_nonexpansive _)).
  apply bupd_nonexpansive2, @disj_nonexpansive, sepcon_nonexpansive, identity_nonexpansive; apply const_nonexpansive.
Qed.

Lemma fupd_nonexpansive2 : forall E1 E2 f, nonexpansive f ->
  nonexpansive (fun a => fupd.fupd E1 E2 (f a)).
Proof.
  intros; unfold nonexpansive.
  intros; eapply predicates_hered.derives_trans; [apply H|].
  apply fupd_nonexpansive1.
Qed.

Lemma later_nonexpansive1 : nonexpansive (box laterM).
Proof.
  apply contractive_nonexpansive, later_contractive, identity_nonexpansive.
Qed.

Lemma inv_nonexpansive : forall N, nonexpansive (inv N).
Proof.
  intros; unfold inv.
  unfold bi_intuitionistically, bi_affinely, bi_persistently; simpl.
  apply @conj_nonexpansive, persistently_nonexpansive2, @forall_nonexpansive; intros.
  { apply const_nonexpansive. }
  apply @impl_nonexpansive, fupd_nonexpansive2, sepcon_nonexpansive, contractive.wand_nonexpansive, fupd_nonexpansive2;
    try apply later_nonexpansive1; apply const_nonexpansive.
Qed.

Lemma inv_nonexpansive2 : forall N f, nonexpansive f ->
  nonexpansive (fun a => inv N (f a)).
Proof.
  intros; unfold nonexpansive.
  intros; eapply predicates_hered.derives_trans; [apply H|].
  apply inv_nonexpansive.
Qed.

Global Opaque inv.


Require Export generic synt_and_sos main_defs prog_reductions guarantees.

Lemma stengthening :
  forall R R' G G' P P' Q Q' c,
    assrtImp P P' ->
    assrtImp Q' Q ->
    rstImp R R' ->
    rstImp G' G ->
    [|R',G'|] |= [|P'|] c [|Q'|] ->
    HG_val' R G P c Q.
Proof.
  intros *.
  intros Hp Hq Hr Hg.
  intro.
  red.
  intros .
  split.
  intros.
  dependent induction H1.
  apply Hp in H0.
  pose proof H _ H0.
  destruct H1.
  apply Hq.
  apply H1.
  constructor.
  apply Hp in H0.
  apply H in H0.
  destruct H0.
  apply Hq.
  apply H0.
  destruct H2.

  constructor 2 with y.
  left;auto.
  eapply star_n_impl.
  apply Hr.
  assumption.
  destruct H2.
  simpl in *.
  subst.
  destruct y;simpl in *.
  constructor 2 with (s,s0).
  right;split;auto.
  eapply star_n_impl.
  apply Hr.
  assumption.

  red;intros.
  apply Hg.
  apply Hp in H0.
  pose proof H _ H0.
  destruct H4.
  eapply H5.
  eapply star_n_impl.
  apply Hr.
  apply H2.
  apply H3.
Qed.

Lemma aver :
  forall P c G Q,
    triple G P c Q -> G_val P c G Q.
Proof.
  induction 1;intros.
  red;intros.
  apply star_skip_means_R_star in H0.
  apply reflexive_ID_eq in H0.
  subst.
  split;auto.

  red;intros.
  inv H1.
  destruct2 y H2.
  inv H2.
  apply star_skip_means_R_star in H3.
  apply reflexive_ID_eq in H3.
  subst.
  split;eauto.

  destruct H2.
  simpl in *.
  subst.
  red in H4.
  subst.
  apply reflexive_assg_G_val in H3.
  subst.
  split;eauto.

  assert(stable ID ([T]b)).
  red.
  intros.
  destruct H1.
  red in H2.
  subst.
  assumption.

  red;intros.
  destruct(b2assrt_dec b x).
  assert((([T]b)[/\]P) x).
  split;auto.
  pose proof IHtriple1 _ H4.
  apply H5.

  pose proof star_if_inv_true ID b c1 c2 x s' H1 H3 b0.
  assumption.

  assert(stable ID ([F]b)).
  red.
  intros.
  destruct H4.
  red in H5.
  subst.
  assumption.

  assert((([F]b)[/\]P) x) by (split;auto).
  pose proof IHtriple2 _ H5.
  apply H6.
  pose proof star_if_inv_false ID b c1 c2 x s' H4 H3 n.
  assumption.

  red;intros.
  pose proof IHtriple1 _ H1.
  apply sequence_reduces_in_parts_3 in H2.
  destruct H2.
  destruct H2.
  pose proof H3 _ H2.
  destruct H5.
  pose proof IHtriple2 _ H5 _ H4.
  destruct H7.
  split;eauto.
  eapply star_trans.
  apply H6.
  assumption.
  red;intros.
  apply H in H3.
  apply IHtriple in H3.
  apply H3 in H4.
  destruct H4.
  apply H0 in H4.
  split;auto.
  eapply star_R_star_incl.
  apply H1.
  assumption.

  red;intros.
  eapply hoare_while_ID;eauto.
Qed.

Section Sequential_Hoare_soundness.

(** End Sequential_Hoare_soundness. *)

Lemma auxy :
  forall Rl Gl Rr Gr s0 s',
    star st (rstAnd Rl Rr) s0 s' ->
    star _ (rstAnd (rstOr Rl Gl) (rstOr Rr Gr)) s0 s'.
Proof.
  intros *.
  induction 1;auto.
  destruct H0.
  econstructor 2 with x0.
  destruct H.
  split.
  left;auto.
  left;auto.
  constructor.
  destruct H.
  destruct H0.
  constructor 2 with x0.
  split;auto.
  left;auto.
  left;auto.
  assumption.
Qed.

(* Lemma soundness_rg_skip : *)
(*   forall R : Env, forall G : relation st, forall P : assrt, *)
(*     forall H : Reflexive G, forall H0 : stable R P, forall x : st, forall H1 : P x, *)
(*       (∀s' : st, star (stmt * st) (prog_red R) (skip, x) (skip, s') → P s') *)
(*         ∧ << R, G, skip, x >>. *)
(* Proof. *)
(*   split;intros. *)
(*   apply star_skip_means_R_star in H2. *)
(*   pose proof stable_star _ _ H0. *)
(*   eapply H3;eauto. *)

(*   apply guarantee_SKIP. *)
(* Qed. *)

(* Lemma soundness_rg_assg : *)
(*   forall (v : id)(a : aexp)(P : assrt)(R : Env)(Q : assrt)(G : Env), *)
(*     forall (H : stable R P)(H0 : stable R Q)(H1 : ∀s : st, G s (s) [v <== aeval s a]), *)
(*       forall (H2 : ∀s : st, P s → Q (s) [v <== aeval s a])(x : st)(H3 : P x), *)
(*    (∀s' : st, star (stmt * st) (prog_red R) (v ::= a, x) (skip, s') → Q s') *)
(*    ∧ << R, G, v ::= a, x >>. *)
(* Proof. *)
(*   split;intros. *)

(*   do_star2starn H4. *)
(*   revert n x H3 s' H4. *)
(*   induction n;intros. *)
(*   inv H4. *)
(*   inv H4. *)
(*   destruct2 y H6. *)
(*   inv H5. *)
(*   do_starn2star H7. *)
(*   apply star_skip_means_R_star in H6. *)
(*   pose proof stable_star _ _ H0. *)
(*   eapply H7. *)
(*   split. *)
(*   2:apply H6. *)
(*   apply H2. *)
(*   assumption. *)
(*   destruct H5. *)
(*   simpl in *. *)
(*   rewrite <- H5 in H7. *)
(*   assert(P s0). *)
(*   eapply H. *)
(*   split;eauto. *)
(*   pose proof IHn s0 H8 s' H7. *)
(*   assumption. *)

(*   red;intros. *)
(*   do_star2starn H4. *)
(*   revert n x H3 y c' c'' z H5 H4. *)
(*   induction n;intros. *)
(*   inv H4. *)
(*   inv H5. *)
(*   apply H1. *)
(*   inv H4. *)
(*   destruct2 y0 H7. *)
(*   inv H6. *)
(*   apply starn_skip_skip in H8. *)
(*   subst. *)
(*   inv H5. *)
(*   destruct H6. *)
(*   simpl in *. *)
(*   rewrite <- H6 in H8. *)
(*   assert(P s0). *)
(*   eapply H. *)
(*   split;eauto. *)
(*   pose proof IHn _ H9 _ _ _ _ H5 H8. *)
(*   assumption. *)
(* Qed. *)

(* Lemma soundness_rg_atom : *)
(*   forall (R : Env)(G : Env)(P : assrt)(Q : assrt)(c : stmt)(H : Reflexive G), *)
(*     forall (H0 : ∀x y : st, star st G x y → G x y)(H1 : stable R P)(H2 : stable R Q), *)
(*       forall (H3 : G_val P c G Q)(x : st)(H4 : P x), *)
(*    (∀s' : st, star (stmt * st) (prog_red R) (atomic(c), x) (skip, s') → Q s') *)
(*    ∧ << R, G, atomic(c), x >>. *)
(* Proof. *)
(*   split; *)
(*   intros. *)
(*   apply star_does_atomic_inv in H5. *)
(*   destruct H5 as [s1 [s2 [H6 [H7 H8]]]]. *)
(*   pose proof stable_star _ _ H2. *)
(*   eapply H5. *)
(*   split. *)
(*   2:apply H8. *)
(*   assert(P s1).  *)
(*   pose proof stable_star _ _ H1. *)
(*   eapply H9;eauto. *)
(*   pose proof H3 _ H9 s2 H7. *)
(*   destruct H10. *)
(*   assumption. *)

(*   red;intros. *)
(*   pose proof H5. *)
(*   apply atomic_implies_skip in H5. *)
(*   destruct H5. *)
(*   subst. *)
(*   pose proof red_atomic_imp_skip _ _ _ _ H6. *)
(*   subst. *)
(*   apply red_atomic_implies_cstep in H6. *)
(*   pose proof star_does_atomic R c z y H6. *)
(*   pose proof atomic_atomic_implies_Rstar _ _ _ _ H7. *)
(*   clear H5. *)
(*   assert(P y). *)
(*   pose proof stable_star _ _ H1. *)
(*   eapply H5. *)
(*   split;eauto. *)
(*   pose proof H3 _ H5 _ H6. *)
(*   destruct H9. *)
(*   apply H0 in H10. *)
(*   assumption. *)
(*   subst. *)
(*   inv H6. *)
(* Qed. *)

(* Lemma soundness_rg_if : *)
(*   forall (R : Env)(G : Env)(P : assrt)(c1 : stmt)(c2 : stmt)(Q : assrt)(b : bexp), *)
(*     forall (H : Reflexive G)(H0 : stable R ([T]b))(H1 : stable R ([F]b))(H2 : stable R P), *)
(*       forall (H3 : [| R , G |] |- [| ([T]b)[/\]P |] c1 [| Q |]), *)
(*         forall (H4 : [| R , G |] |- [| ([F]b)[/\]P |] c2 [| Q |]), *)
(*           forall (IHtriple_rg1 : [| R , G |] |= [| ([T]b)[/\]P |] c1 [| Q |]), *)
(*             forall (IHtriple_rg2 : [| R , G |] |= [| ([F]b)[/\]P |] c2 [| Q |])(x : st)(H5 : P x), *)
(*    (∀s' : st, *)
(*     star (stmt * st) (prog_red R) (ifb b then c1 else c2 fi, x) (skip, s') *)
(*     → Q s') ∧ << R, G, ifb b then c1 else c2 fi, x >>. *)
(* Proof. *)
(*   split;intros. *)
(*   dependent induction H6. *)
(*   destruct2 y H7. *)
(*   inv H7. *)
(*   assert((([F]b)[/\]P) s0). *)
(*   split;auto. *)
(*   pose proof IHtriple_rg2 s0 H8. *)
(*   destruct H10. *)
(*   pose proof H10 _ H6. *)
(*   assumption. *)

(*   assert((([T]b)[/\]P) s0). *)
(*   split;auto. *)
(*   pose proof IHtriple_rg1 s0 H8. *)
(*   destruct H10. *)
(*   apply H10;auto. *)
(*   destruct H7;simpl in *. *)
(*   symmetry in H7;subst. *)
(*   assert(P s0). *)
(*   eapply H2;split;eauto. *)
(*   pose proof IHstar c1 c2 b H H0 H1 H2 H3 H4  *)
(*              IHtriple_rg1 IHtriple_rg2 s0 H7 s' refl_equal refl_equal. *)
(*   assumption. *)

(*   destruct(b2assrt_dec b x) as [Bt | Bf]; *)
(*              [ assert((assrtT b[/\]P) x) by (split;auto) |  *)
(*                assert((assrtF b[/\]P) x) by (split;auto)]; *)
(*              [ pose proof (IHtriple_rg1 _ H6) as H7 |  *)
(*                pose proof (IHtriple_rg2 _ H6) as H7 ];destruct H7. *)
(*   eapply within_if_true;auto. *)
(*   eapply within_if_false;auto. *)
(* Qed. *)

(* Lemma soundness_rg_seq : *)
(*   forall (R : Env)(G : Env)(c1 : stmt)(c2 : stmt)(P : assrt)(K : assrt)(Q : assrt), *)
(*     forall (H : Reflexive G)(H0 : [| R , G |] |- [| P |] c1 [| K |]), *)
(*       forall (H1 : [| R , G |] |- [| K |] c2 [| Q |]), *)
(*         forall (IHtriple_rg1 : [| R , G |] |= [| P |] c1 [| K |]), *)
(*           forall (IHtriple_rg2 : [| R , G |] |= [| K |] c2 [| Q |])(x : st)(H2 : P x), *)
(*    (∀s' : st, star (stmt * st) (prog_red R) (c1; c2, x) (skip, s') → Q s') *)
(*    ∧ << R, G, c1; c2, x >>. *)
(* Proof. *)
(*   split;intros. *)

(*   apply sequence_reduces_in_parts_3 in H3. *)
(*   destruct H3 as [s [H4 H5]]. *)
(*   pose proof IHtriple_rg1 _ H2. *)
(*   destruct H3. *)
(*   apply H3 in H4. *)
(*   pose proof IHtriple_rg2 _ H4. *)
(*   destruct H7. *)
(*   apply H7;auto. *)

(*   eapply within_seq. *)
(*   apply H. *)
(*   pose proof IHtriple_rg1 _ H2. *)
(*   destruct H3. *)
(*   assumption. *)
(*   pose proof IHtriple_rg1 _ H2. *)
(*   destruct H3. *)
(*   intros. *)
(*   do_starn2star H5. *)
(*   apply H3 in H6. *)
(*   pose proof IHtriple_rg2 _ H6. *)
(*   destruct H5. *)
(*   assumption. *)
(* Qed. *)

(* Lemma soundness_rg_conseq : *)
(*   forall (R : Env)(R' : Env)(G : Env)(G' : Env)(P : assrt)(P' : assrt)(Q : assrt)(Q' : assrt), *)
(*     forall (c : stmt)(H : [| R' , G' |] |- [| P' |] c [| Q' |])(H0 : P[->]P')(H1 : Q'[->]Q), *)
(*       forall (H2 : rstImp R R')(H3 : rstImp G' G), *)
(*       forall (IHtriple_rg : [| R' , G' |] |= [| P' |] c [| Q' |])(x : st)(H4 : P x), *)
(*    (∀s' : st, star (stmt * st) (prog_red R) (c, x) (skip, s') → Q s') *)
(*    ∧ << R, G, c, x >>. *)
(* Proof. *)
(*   split; *)
(*   pose proof stengthening R R' G G' P P' Q Q' c H0 H1 H2 H3 IHtriple_rg. *)
(*   apply H5 in H4. *)
(*   destruct H4. *)
(*   assumption. *)

(*   pose proof stengthening R R' G G' P P' Q Q' c H0 H1 H2 H3 IHtriple_rg. *)
(*   apply H5 in H4. *)
(*   destruct H4. *)
(*   assumption. *)
(* Qed. *)

(* Lemma soundness_rg_while : *)
(*   forall (R : Env)(G : Env)(P : assrt)(b : bexp)(c : stmt), *)
(*     forall (H : Reflexive G)(H0 : stable R ([T]b))(H1 : stable R ([F]b))(H2 : stable R P), *)
(*       forall (H3 : [| R , G |] |- [| ([T]b)[/\]P |] c [| P |]), *)
(*         forall (IHtriple_rg : [| R , G |] |= [| ([T]b)[/\]P |] c [| P |])(x : st)(H4 : P x), *)
(*    (∀s' : st, *)
(*     star (stmt * st) (prog_red R) (while b do c end, x) (skip, s') *)
(*     → (([F]b)[/\]P) s') ∧ << R, G, while b do c end, x >>. *)
(* Proof. *)
(*   split. eapply hoare_while;eauto.  admit. *)
(* Qed. *)

(* Lemma soundness_rg_par : *)
(*   forall (R : Env)(Rl : Env)(Rr : Env)(Gl : Env)(Gr : Env)(G : Env)(P : assrt)(Q1 : assrt), *)
(*     forall (Q2 : assrt)(cr : stmt)(cl : stmt)(H : Reflexive Gl)(H0 : Reflexive Gr), *)
(*       forall (H1 : rstImp (rstOr Gl Gr) G)(H2 : rstImp (rstOr Rl Gl) Rr), *)
(*       forall (H3 : rstImp (rstOr Rr Gr) Rl)(H4 : stable (rstOr Rr Gr) Q1), *)
(*         forall (H5 : stable (rstOr Rl Gl) Q2)(H6 : stable (rstOr Rr Gr) P), *)
(*           forall (H7 : stable (rstOr Rl Gl) P)(H8 : [| Rl , Gl |] |- [| P |] cl [| Q1 |]), *)
(*             forall (H9 : [| Rr , Gr |] |- [| P |] cr [| Q2 |]), *)
(*               forall (IHtriple_rg1 : [| Rl , Gl |] |= [| P |] cl [| Q1 |]), *)
(*                 forall (IHtriple_rg2 : [| Rr , Gr |] |= [| P |] cr [| Q2 |]), *)
(*                   forall (x : st)(H10 : P x), *)
(*    (∀s' : st, *)
(*     star (stmt * st) (prog_red (rstAnd Rl Rr)) (par cl with cr end, x) *)
(*       (skip, s') → (Q1[/\]Q2) s') *)
(*    ∧ << rstAnd Rl Rr, G, par cl with cr end, x >>. *)
(* Proof. *)
(* split. *)
(*   intros. *)
(*   pose proof IHtriple_rg1 _ H10. *)
(*   pose proof IHtriple_rg2 _ H10. *)
(*   destruct H12. *)
(*   destruct H13. *)
(*   pose proof par_reduces_to_skip_left Rl Rr Gl Gr cl cr x s' H2 H3 H14 H15 H11. *)
(*   destruct H16. *)
(*   destruct H16. *)
(*   destruct H16. *)
(*   destruct H17. *)
(*   assert(<<Rr,Gr,x0,x1>>). *)
(*   eapply within_prog_red_star. *)
(*   apply H18. *)
(*   assumption. *)
(*   pose proof within_par_skip_left _ _ _ _ H0 H19. *)
(*   pose proof rstAnd_split _ _ _ _ H17. *)
(*   destruct H21. *)
(*   split. *)

(*   pose proof correct_reduction_wrt_rely_and_guarante _ _ _ _ _ _ H16 H14. *)
(*   clear H21. *)
(*   pose proof correct_reduction_wrt_rely_and_guarante _ _ _ _ _ _ H22 H20. *)
(*   pose proof stable_star _ _ H4. *)
(*   eapply H24. *)
(*   split;eauto. *)

(*   pose proof par_reduces_to_skip_right Rl Rr Gl Gr cl cr x s' H2 H3 H14 H15 H11. *)
(*   destruct H23. *)
(*   destruct H23. *)
(*   destruct H23. *)
(*   destruct H24. *)
(*   assert(<<Rl,Gl,x2,x3>>). *)
(*   eapply within_prog_red_star. *)
(*   apply H25. *)
(*   assumption. *)
(*   pose proof within_par_skip_right _ _ _ _ H H26. *)
(*   pose proof rstAnd_split _ _ _ _ H24. *)
(*   destruct H28. *)

(*   pose proof correct_reduction_wrt_rely_and_guarante _ _ _ _ _ _ H23 H15. *)
(*   clear H21. *)
(*   pose proof correct_reduction_wrt_rely_and_guarante _ _ _ _ _ _ H28 H27. *)
(*   pose proof stable_star _ _ H5. *)
(*   eapply H31. *)
(*   split;eauto. *)

(*   (** Guarantee parallel. *) *)
(*   eapply within_par_both. *)
(*   eapply(rstOr_refl Gl Gr);eauto. *)
(*   3:apply H1. *)
(*   pose proof IHtriple_rg1 _ H10. *)
(*   destruct H11. *)
(*   clear H11. *)
(*   eapply guarantee_impl with Rl. *)
(*   red;intros. *)
(*   destruct H11. *)
(*   destruct H11. *)
(*   apply H11. *)
(*   assert((rstOr Rr Gr) s s'). *)
(*   right. *)
(*   assumption. *)
(*   apply H3 in H13. *)
(*   assumption. *)
(*   assumption. *)
(*   pose proof IHtriple_rg2 _ H10. *)
(*   destruct H11. *)
(*   clear H11. *)
(*   eapply guarantee_impl with Rr. *)
(*   red;intros. *)
(*   destruct H11. *)
(*   destruct H11. *)
(*   apply H13. *)
(*   assert((rstOr Rl Gl) s s'). *)
(*   right. *)
(*   assumption. *)
(*   apply H2 in H13. *)
(*   assumption. *)
(*   assumption. *)
(* Qed. *)

Theorem soundness_rg :
  forall R G P Q c,
    [|  R  , G  |]  |- [|  P  |]  c [|  Q  |] ->
    HG_val' R G  |= [|  P  |]  c [|  Q  |].
Proof.
  induction 1;red;intros(*;split*).

  (* SKIP *)
  apply soundness_rg_skip;auto.

  (* Assignment *)
  eapply soundness_rg_assg with P;auto.

  (* Atomic execution. *)
  apply soundness_rg_atom with P;auto.

  (* Conditional *)
  apply soundness_rg_if with P;auto.

  (* Sequence *)
  apply soundness_rg_seq with P K;auto.

  (* Consequence *)
  eapply soundness_rg_conseq;eauto.

  (** While loop *)
  eapply soundness_rg_while;eauto.

  (** Parallel computation rule *)
  pose proof soundness_rg_par R Rl Rr Gl Gr G P.
  apply H11;auto.
Qed.

End Sequential_Hoare_soundness.


(*
 * Copyright (c) 2009-2016, Andrew Appel, Robert Dockins,
    Aquinas Hobor and Le Xuan Bach
 *
 *)

Require Import msl.base.
Require Import msl.sepalg.
Require Import msl.psepalg.
Require Import msl.sepalg_generators.
Require Import msl.boolean_alg.
Require Import msl.eq_dec.

Require msl.tree_shares.

Module Share : SHARE_MODEL := tree_shares.Share.
Import Share.

Definition share : Type := Share.t.

Instance pa_share : Perm_alg share := Share.pa.
Instance sa_share : Sep_alg share := Share.sa.
Instance ca_share : Canc_alg share := Share.ca.
Definition emptyshare : share := Share.bot.
Definition fullshare : share := Share.top.

Theorem leq_join_sub : forall s1 s2:Share.t,
  s1 <= s2 <-> join_sub s1 s2.
Proof.
  split; intros.
  pose (s' := glb s2 (comp s1)).
  exists s'.
  simpl; split.
  subst s'.
  rewrite glb_commute.
  rewrite glb_assoc.
  rewrite (glb_commute (comp s1) s1).
  rewrite comp2.
  apply glb_bot.
  subst s'.
  rewrite distrib2.
  rewrite comp1.
  rewrite glb_top.
  rewrite <- ord_spec2; auto.

  destruct H as [s' H].
  destruct H.
  rewrite ord_spec2.
  rewrite <- H0.
  rewrite <- lub_assoc.
  rewrite lub_idem; auto.
Qed.

Lemma top_correct' : forall x:t, join_sub x top.
Proof.
  intros; rewrite <- leq_join_sub; auto with ba.
Qed.

Lemma bot_identity : identity bot.
Proof.
  hnf; intros.
  destruct H.
  rewrite lub_commute in H0.
  rewrite lub_bot in H0.
  auto.
Qed.

Hint Resolve bot_identity.

Lemma identity_share_bot : forall s,
  identity s -> s = bot.
Proof.
  intros.
  apply identities_unique; auto.
  exists s.
  apply join_comm.

  destruct (top_correct' s).
  assert (x = top).
  apply H; auto.
  subst x; auto.
  destruct (top_correct' bot).
  assert (x = top).
  apply bot_identity; auto.
  subst x; auto.
  apply join_comm in H1.
  destruct (join_assoc H0 H1); intuition.
  assert (x = top).
  apply H; auto.
  subst x.
  replace bot with s.
  rewrite identity_unit_equiv in H.
  trivial.
  eapply joins_units_eq; try apply H0. exists top; eauto.
  simpl. split. apply glb_bot. apply lub_bot.
Qed.

Lemma factoryOverlap' : forall f1 f2 n1 n2,
  isTokenFactory f1 n1 -> isTokenFactory f2 n2 -> joins f1 f2 -> False.
Proof.
  intros.
  destruct H1.
  destruct H1.
  apply (factoryOverlap f1 f2 n1 n2 H H0 H1).
Qed.

Lemma identityToken' : forall x, isToken x 0 <-> identity x.
Proof.
  intro x; destruct (identityToken x); split; intros.
  hnf; intros.
  rewrite H in H2; auto.
  apply H0.
  apply identity_share_bot; auto.
Qed.

Lemma nonidentityToken' : forall x n, (n > 0)%nat -> isToken x n -> nonidentity x.
Proof.
  intros.
  generalize (nonidentityToken x n H H0).
  repeat intro.
  apply H1.
  apply identity_share_bot; auto.
Qed.

Lemma nonidentityFactory' : forall x n, isTokenFactory x n -> nonidentity x.
Proof.
  intros.
  generalize (nonidentityFactory x n H); repeat intro.
  apply H0.
  apply identity_share_bot; auto.
Qed.

Lemma split_join : forall x1 x2 x,
  split x = (x1,x2) -> join x1 x2 x.
Proof.
  intros; split.
  apply split_disjoint with x; auto.
  apply split_together; auto.
Qed.

Lemma split_nontrivial' : forall x1 x2 x,
  split x = (x1, x2) ->
    (identity x1 \/ identity x2) ->
    identity x.
Proof.
  intros.
  rewrite (split_nontrivial x1 x2 x H).
  apply bot_identity.
  destruct H0.
  left; apply identity_share_bot; auto.
  right; apply identity_share_bot; auto.
Qed.

Lemma rel_leq : forall a x, join_sub (rel a x) a.
Proof.
  intros.
  rewrite <- leq_join_sub.

  intros.
  rewrite ord_spec1.
  pattern a at 3.
  replace a with (rel a top).
  rewrite <- rel_preserves_glb.
  rewrite glb_top.
  auto.
  apply rel_top1.
Qed.

Lemma rel_join : forall a x y z,
  join x y z ->
  join (rel a x) (rel a y) (rel a z).
Proof.
  simpl; intuition. inv H.
  constructor.
  rewrite <- rel_preserves_glb.
  replace bot with (rel a bot).
  replace (glb x y) with bot; auto.
  apply rel_bot1.
  rewrite <- rel_preserves_lub. auto.
Qed.

Lemma rel_join2 : forall a x y s,
  nonidentity a ->
  join (rel a x) (rel a y) s ->
  exists z, s = rel a z /\ join x y z.
Proof.
  simpl; intros.
  destruct H0.
  exists (lub x y).
  split.
  rewrite <- H1.
  symmetry.
  apply rel_preserves_lub.
  split; auto.
  rewrite <- rel_preserves_glb in H0.
  replace bot with (rel a bot) in H0.
  apply rel_inj_l with a; auto.
  hnf; intros; apply H.
  subst a; apply bot_identity.
  apply rel_bot1.
Qed.

Lemma rel_nontrivial : forall a x,
  identity (rel a x) ->
  (identity a \/ identity x).
Proof.
  intros a x H.
  destruct (eq_dec a bot); auto.
  subst a.
  left. apply bot_identity.

  right.
  assert (rel a x = bot).
  apply identity_share_bot; auto.
  assert (x = bot).
  replace bot with (rel a bot) in H0.
  apply rel_inj_l with a; auto.
  apply rel_bot1.
  subst x; apply bot_identity.
Qed.

Instance share_cross_split : Cross_alg t.
Proof.
  hnf; simpl; intuition. destruct H as [H1 H2]. destruct H0 as [H H3].
  exists (glb a c, glb a d, glb b c, glb b d); intuition; constructor.
  rewrite (glb_commute a d).
  rewrite glb_assoc.
  rewrite <- (glb_assoc c d a).
  rewrite H.
  rewrite (glb_commute bot a).
  rewrite glb_bot.
  rewrite glb_bot.
  auto.
  rewrite <- distrib1;  rewrite H3; rewrite <- H2; auto with ba.
  rewrite (glb_commute b d).
  rewrite glb_assoc.
  rewrite <- (glb_assoc c d b).
  rewrite H.
  rewrite (glb_commute bot b).
  rewrite glb_bot.
  rewrite glb_bot.
  auto.
  rewrite <- distrib1;  rewrite H3; rewrite <- H2; auto with ba.
  rewrite (glb_commute a c).
  rewrite glb_assoc.
  rewrite <- (glb_assoc a b c).
  rewrite H1.
  rewrite (glb_commute bot c).
  rewrite glb_bot.
  rewrite glb_bot.
  auto.
  rewrite (glb_commute a c).
  rewrite (glb_commute b c).
  rewrite <- distrib1; rewrite H2; rewrite <- H3; auto with ba.
  rewrite (glb_commute a d).
  rewrite glb_assoc.
  rewrite <- (glb_assoc a b d).
  rewrite H1.
  rewrite (glb_commute bot d).
  rewrite glb_bot.
  rewrite glb_bot.
  auto.
  rewrite (glb_commute a d).
  rewrite (glb_commute b d).
  rewrite <- distrib1; rewrite H2; rewrite <- H3; auto with ba.
Qed.

Lemma bot_correct' : forall x, join_sub bot x.
Proof.
  intros s.
  destruct (top_correct' s).
  exists s.
  destruct (top_correct' bot).
  assert (x0 = top).
  apply bot_identity; auto.
  subst x0.
  apply join_comm in H0.
  destruct (join_assoc H H0); intuition.
  apply join_comm in H2.
  destruct (join_assoc H1 H2); intuition.
  assert (s = x1).
  apply bot_identity; auto.
  subst x1; auto.
Qed.

Lemma top_share_nonidentity : nonidentity top.
Proof.
  hnf; intros.
  assert (top = bot).
  apply identity_share_bot; auto.
  apply nontrivial; auto.
Qed.

Lemma top_share_nonunit: nonunit top.
Proof.
  repeat intro. unfold unit_for in H.
  destruct H. rewrite glb_commute in H. rewrite glb_top in H. subst.
  rewrite lub_bot in H0. apply nontrivial; auto.
Qed.

Lemma bot_join_eq : forall x, join bot x x.
Proof.
  intros.
  destruct (join_ex_identities x); intuition.
  destruct H0.
  generalize (H _ _ H0).
  intros; subst; auto.
  replace bot with x0; auto.
  apply identity_share_bot; auto.
Qed.

Lemma join_bot_eq : forall x, join x bot x.
Proof.
  intros.
  apply join_comm, bot_join_eq.
Qed.

Lemma bot_joins : forall x, joins bot x.
Proof.
  intro x; exists x; apply bot_join_eq.
Qed.

Lemma dec_share_identity : forall x:t, { identity x } + { ~identity x }.
Proof.
  intro x.
  destruct (eq_dec x bot); subst.
  left; apply bot_identity.
  right; intro; elim n.
  apply identity_share_bot; auto.
Qed.

Lemma dec_share_nonunit : forall x:t, { nonunit x } + { ~ nonunit x }.
Proof.
  intro x.
  destruct (dec_share_identity x) as [H | H]; [right | left].
  + intro; revert H. apply nonunit_nonidentity; auto.
  + apply nonidentity_nonunit; auto.
Qed.

Lemma fullshare_full : full fullshare.
Proof.
  unfold full.
  intros.
  generalize (Share.top_correct);intros.
  destruct H as [sigma'' ?].
  spec H0 sigma''.
  rewrite leq_join_sub in H0.
  destruct H0.
  destruct (join_assoc H H0) as [s [H1 H2]].
  apply join_comm in H2. apply unit_identity in H2.
  eapply split_identity; eauto.
Qed.

Lemma join_sub_fullshare : forall sh,
  join_sub fullshare sh -> sh = fullshare.
Proof.
  intros.
  generalize fullshare_full; intro.
  apply full_maximal in H0.
  spec H0 sh H.
  auto.
Qed.

Lemma dec_share_full : forall (sh : Share.t),
  {full sh} + {~full sh}.
Proof with auto.
  intro sh.
  destruct (eq_dec sh top); subst.
  left. apply fullshare_full.
  right. intro. apply n.
  generalize (Share.top_correct sh);intro.
  apply leq_join_sub in H0.
  destruct H0.
  spec H x. spec H. exists top...
  spec H sh top (join_comm H0)...
Qed.

Lemma rel_congruence : forall a x1 x2,
  join_sub x1 x2 ->
  join_sub (rel a x1) (rel a x2).
Proof.
  intros.
  destruct H.
  exists (rel a x).
  apply rel_join; auto.
Qed.

Lemma share_split_injective:
  forall sh1 sh2, Share.split sh1 = Share.split sh2 -> sh1=sh2.
Proof.
  intros sh1 sh2;
    case_eq (Share.split sh1); case_eq (Share.split sh2); intros.
  generalize (split_join _ _ _ H); intro.
  generalize (split_join _ _ _ H0); intro.
  inv H1.
  eapply join_eq; eauto.
Qed.

Lemma share_joins_constructive:
  forall sh1 sh2 : t , joins sh1 sh2 ->  {sh3 | join sh1 sh2 sh3}.
Proof.
  intros.
  exists (lub sh1 sh2).
  destruct H.
  destruct H; split; auto.
Qed.

Lemma share_join_sub_constructive:
  forall sh1 sh3 : t , join_sub sh1 sh3 ->  {sh2 | join sh1 sh2 sh3}.
Proof.
  intros.
  exists (glb sh3 (comp sh1)).
  destruct H.
  destruct H.
  split.
  rewrite (glb_commute sh3 (comp sh1)).
  rewrite <- glb_assoc.
  rewrite comp2.
  rewrite glb_commute.
  rewrite glb_bot.
  auto.
  rewrite distrib2.
  rewrite comp1.
  rewrite glb_top.
  rewrite <- ord_spec2.
  rewrite <- H0.
  apply lub_upper1.
Qed.

Lemma triple_join_exists_share : Trip_alg t.
Proof.
  repeat intro.
  destruct H; destruct H0; destruct H1.
  exists (lub a (lub b c)).
  split.
  rewrite <- H2.
  rewrite glb_commute.
  rewrite distrib1.
  rewrite glb_commute.
  rewrite H1.
  rewrite glb_commute.
  rewrite H0.
  rewrite lub_bot; auto.
  rewrite <- H2.
  apply lub_assoc.
Qed.

Lemma nonemp_split_neq1: forall sh sh1 sh2, nonidentity sh -> split sh = (sh1, sh2) -> sh1 <> sh.
Proof with auto.
  intros until sh2; intros H H0.
  destruct (dec_share_identity sh2).
  generalize (split_nontrivial' _ _ _ H0); intro.
  spec H1...
  destruct (eq_dec sh1 sh)...
  subst sh1.
  generalize (split_join _ _ _ H0); intro.
  apply join_comm in H1.
  apply unit_identity in H1...
Qed.

Lemma nonemp_split_neq2: forall sh sh1 sh2, nonidentity sh -> split sh = (sh1, sh2) -> sh2 <> sh.
Proof with auto.
  intros until sh2; intros H H0.
  destruct (dec_share_identity sh1).
  generalize (split_nontrivial' _ _ _ H0); intro.
  spec H1...
  destruct (eq_dec sh2 sh)...
  subst sh2.
  generalize (split_join _ _ _ H0); intro.
  apply unit_identity in H1...
Qed.

Lemma bot_unit: forall sh,
  join emptyshare sh sh.
Proof.
  intro sh.
  generalize (bot_joins sh); generalize bot_identity; intros.
  destruct H0.
  spec H sh x H0. subst.
  trivial.
Qed.

Hint Resolve bot_unit.

Lemma join_bot: join emptyshare emptyshare emptyshare.
Proof.
  apply bot_unit.
Qed.

Lemma share_rel_nonidentity:
  forall {sh1 sh2}, nonidentity sh1 -> nonidentity sh2 -> nonidentity (Share.rel sh1 sh2).
Proof.
intros.
unfold nonidentity in *.
generalize (rel_nontrivial sh1 sh2); intro. intuition.
Qed.

Lemma share_rel_nonunit: forall {sh1 sh2: Share.t},
       nonunit sh1 -> nonunit sh2 -> nonunit (Share.rel sh1 sh2).
Proof. intros. apply nonidentity_nonunit. apply share_rel_nonidentity.
intro. apply (@identity_unit _ _ _ sh1 Share.bot) in H1. apply H in H1; auto.
apply joins_comm. apply bot_joins.
intro. apply (@identity_unit _ _ _ sh2 Share.bot) in H1. apply H0 in H1; auto.
apply joins_comm. apply bot_joins.
Qed.

Lemma decompose_bijection: forall sh1 sh2,
 sh1 = sh2 <-> decompose sh1 = decompose sh2.
Proof.
 intros.
 split;intros. subst;trivial.
 generalize (recompose_decompose sh1);intro.
 generalize (recompose_decompose sh2);intro.
 congruence.
Qed.

Module ShareMap.
Section SM.
  Variable A:Type.
  Variable EqDec_A : EqDec A.

  Variable B:Type.
  Variable JB: Join B.
  Variable paB : Perm_alg B.
  Variable saB : Sep_alg B.

  Definition map := fpm A (lifted Share.Join_ba * B).
  Instance Join_map : Join map := Join_fpm _.
  Instance pa_map : Perm_alg map := Perm_fpm _ _.
  Instance sa_map : Sep_alg map := Sep_fpm _ _.
  Instance ca_map {CA: Canc_alg B} : Canc_alg map := Canc_fpm _.
  Instance da_map {DA: Disj_alg B} : Disj_alg map := @Disj_fpm _ _ _ _.

  Definition map_share (a:A) (m:map) : share :=
    match lookup_fpm m a with
    | Some (sh,_) => lifted_obj sh
    | None => Share.bot
    end.

  Definition map_val (a:A) (m:map) : option B :=
    match lookup_fpm m a with
    | Some (_,b) => Some b
    | None => None
    end.

  Definition empty_map : map := empty_fpm _ _.

  Definition map_upd (a:A) (b:B) (m:map) : option map :=
    match lookup_fpm m a with
    | Some (sh,_) =>
        if eq_dec (lifted_obj sh) fullshare
           then Some (insert_fpm _ a (sh,b) m)
           else None
    | None => None
    end.

Lemma join_lifted {t} {J: Join t}:
    forall (a b c: lifted J), join a b c -> join (lifted_obj a) (lifted_obj b) (lifted_obj c).
Proof. destruct a; destruct b; destruct c; simpl; intros. apply H.
Qed.

  Lemma map_join_char : forall m1 m2 m3,
    join m1 m2 m3 <->
    (forall a,
       join (map_share a m1) (map_share a m2) (map_share a m3) /\
       join (map_val a m1) (map_val a m2) (map_val a m3)).
  Proof with auto.
    split; intros.
    hnf in H. spec H a.
    unfold map_val, map_share, lookup_fpm.
    destruct (proj1_sig m1 a) as [[sh1 a1] ?| ];
    destruct (proj1_sig m2 a) as [[sh2 a2] ?| ];
    destruct (proj1_sig m3 a) as [[sh3 a3] ?| ]; inv H; try solve [inv H0]; simpl; auto.
    destruct H3; simpl in *; auto.
    split. apply join_lifted; auto. constructor; auto.
    split; apply join_unit2; auto.
    split; apply join_unit1; auto.
    split; apply join_unit1; auto.
    split; apply join_unit1; auto.

    intro a. spec H a. destruct H.
        unfold map_val, map_share, lookup_fpm in *.
    destruct (proj1_sig m1 a) as [[sh1 a1] ?| ];
    destruct (proj1_sig m2 a) as [[sh2 a2] ?| ];
    destruct (proj1_sig m3 a) as [[sh3 a3] ?| ]; inv H0; try solve [inv H1]; auto.
    constructor. split; auto.
    apply join_unit2_e in H; auto. apply join_unit2; auto.
    repeat f_equal. destruct sh1; destruct sh3; simpl in *; subst.
    rewrite (proof_irr n n0); auto.
    apply join_unit1_e in H; auto. apply join_unit1; auto.
    repeat f_equal. destruct sh2; destruct sh3; simpl in *; subst.
    rewrite (proof_irr n n0); auto.
    constructor. constructor.
 Qed.

  Lemma empty_map_identity {CAB: Canc_alg B}: identity empty_map.
  Proof.
    rewrite identity_unit_equiv.
    intro x. simpl. auto. constructor.
  Qed.

  Lemma map_identity_unique {CAB: Canc_alg B}: forall m1 m2:map,
    identity m1 -> identity m2 -> m1 = m2.
  Proof.
    intros.
    destruct m1; destruct m2; simpl in *.
    cut (x = x0). intros. subst x0.
    replace f0 with f; auto.
    apply proof_irr; auto.
    rewrite identity_unit_equiv in H, H0.
    extensionality a.
    spec H a; spec H0 a.
    apply lower_inv in H.
    apply lower_inv in H0.
    destruct H; destruct H0; simpl in *.
    intuition; congruence.
    destruct s0 as [? [? [? [? [? [? ?]]]]]].
    rewrite H in H1. inv H1. rewrite H0 in H; inv H.
    destruct x3. destruct H2. simpl in *. apply no_units in H. contradiction.
    destruct s as [? [? [? [? [? [? ?]]]]]].
    rewrite H in H0; inv H0. rewrite H1 in H; inv H.
    destruct x2. destruct H2. simpl in *. apply no_units in H. contradiction.
    destruct s as [? [? [? [? [? [? ?]]]]]].
    rewrite H in H0; inv H0. rewrite H1 in H; inv H.
    destruct x2. destruct H2. simpl in *. apply no_units in H. contradiction.
  Qed.

  Lemma map_identity_is_empty  {CAB: Canc_alg B} : forall m,
    identity m -> m = empty_map.
  Proof.
    intros; apply map_identity_unique; auto.
    apply empty_map_identity.
  Qed.

  Lemma empty_map_join {CAB: Canc_alg B} : forall m,
    join empty_map m m.
  Proof.
    intro m. destruct (join_ex_units m).
    replace empty_map with x; auto.
    apply map_identity_is_empty.
    eapply unit_identity; eauto.
  Qed.

  Lemma map_val_bot  : forall a m,
    map_val a m = None <-> map_share a m = Share.bot.
  Proof.
    do 2 intro.
    unfold map_val, map_share, lookup_fpm.
    destruct (proj1_sig m a); intuition.
    disc.
    contradiction (no_units a0 a0). destruct a0. simpl in *. subst.
    contradiction (n bot). auto.
  Qed.

  Lemma map_upd_success : forall a v m,
    map_share a m = Share.top ->
    exists m', map_upd a v m = Some m'.
  Proof.
    intros.
    unfold map_upd. simpl.
    unfold map_share, lookup_fpm in*.
    destruct (proj1_sig  m a).
    destruct p.
    rewrite H.
    unfold fullshare.
    destruct (eq_dec top top).
    eauto.
    elim n; auto.
    elim Share.nontrivial; auto.
  Qed.

  Lemma map_set_share1 : forall a v m m',
    map_upd a v m = Some m' ->
    map_share a m = Share.top.
  Proof.
    unfold map_upd, map_share.
    intros.
    destruct (lookup_fpm m a); disc.
    destruct p.
    destruct (eq_dec (lifted_obj l) fullshare); disc; auto.
  Qed.

  Lemma map_set_share2 : forall a v m m',
    map_upd a v m = Some m' ->
    map_share a m' = Share.top.
  Proof.
    unfold map_upd, map_share.
    intros. destruct (lookup_fpm m a); disc.
    destruct p. destruct (eq_dec (lifted_obj l) fullshare); disc.
    inv H.
    rewrite fpm_gss. auto.
  Qed.

  Lemma map_set_share3 : forall a v m m',
    map_upd a v m = Some m' ->
    forall a',
      map_share a' m = map_share a' m'.
  Proof.
    unfold map_upd, map_share.
    intros a v m m'.
    case_eq (lookup_fpm m a); intros; disc.
    destruct p.
    destruct (eq_dec (lifted_obj l) fullshare); disc.
    inv H0.
    destruct (eq_dec a a'). subst.
    rewrite H.
    rewrite fpm_gss. auto.
    rewrite fpm_gso; auto.
  Qed.

  Lemma map_gss_val: forall a v m m',
        map_upd a v m = Some m' ->
        map_val a m' = Some v.
  Proof.
    unfold map_upd, map_val.
    intros a v m m'.
    case_eq (lookup_fpm m a); intros; disc.
    destruct p.
    destruct (eq_dec (lifted_obj l) fullshare); disc.
    inv H0.
    rewrite fpm_gss. auto.
  Qed.

  Lemma map_gso_val : forall i j v m m',
       i <> j ->
       map_upd j v m = Some m' ->
       map_val i m = map_val i m'.
  Proof.
    unfold map_upd, map_val.
    intros i j v m m'.
    case_eq (lookup_fpm m j); intros; disc.
    destruct p.
    destruct (eq_dec (lifted_obj l) fullshare); disc.
    inv H1.
    rewrite fpm_gso; auto.
  Qed.

  Lemma map_gso_share : forall i j v m m',
    i <> j ->
    map_upd j v m = Some m' ->
    map_share i m = map_share i m'.
  Proof.
    unfold map_upd, map_share.
    intros i j v m m'.
    case_eq (lookup_fpm m j); intros; disc.
    destruct p.
    destruct (eq_dec (lifted_obj l) fullshare); disc.
    inv H1.
    rewrite fpm_gso; auto.
  Qed.

  Lemma map_upd_join : forall m1 m2 m3 a v m1',
    map_upd a v m1 = Some m1' ->
    join m1 m2 m3 ->
    exists m3', map_upd a v m3 = Some m3' /\
      join m1' m2 m3'.
  Proof.
    intros.
    rewrite map_join_char in H0.
    destruct (H0 a).
    generalize H; intros.
    apply map_set_share1 in H.
    rewrite H in H1.
    destruct H1.
    rewrite glb_commute in H1.
    rewrite glb_top in H1.
    rewrite H1 in H4.
    rewrite lub_bot in H4.
    symmetry in H4.
    destruct (map_upd_success a v _ H4).
    exists x; split; auto.
    clear H2.
    rewrite map_join_char.
    intro a'.
    destruct (eq_dec a a').
    subst a'. split.
    apply map_set_share2 in H3. rewrite H3.
    apply map_set_share2 in H5. rewrite H5.
    rewrite H1. apply join_unit2; auto.
    erewrite map_gss_val; eauto.
    apply map_val_bot in H1. rewrite H1.
    erewrite map_gss_val; eauto. constructor.
    destruct (H0 a'). split.
    rewrite <- (map_gso_share a' a v m1 m1'); auto.
    rewrite <- (map_gso_share a' a v m3 x); auto.
    rewrite <- (map_gso_val a' a v m1 m1'); auto.
    rewrite <- (map_gso_val a' a v m3 x); auto.
  Qed.

  Definition build_map (l:list (A * B)) : map :=
     fold_right
      (fun (ab:A * B) m =>
        insert_fpm EqDec_A
           (fst ab)
           (mk_lifted fullshare top_share_nonunit,snd ab) m)
      empty_map l.

  Lemma build_map_results : forall (l:list (A*B)) a b,
    NoDup (List.map (@fst _ _) l) ->
    (In (a,b) l <->
    (map_val a (build_map l) = Some b /\
     map_share a (build_map l) = Share.top)).
  Proof.
    induction l; simpl.
    split; intros. elim H0.
    destruct H0.
    unfold build_map in H0. simpl in H0.
    unfold map_val in H0.
    simpl in H0. discriminate.
    intros. split; intros.
    destruct H0; subst.
    unfold build_map.
    simpl fold_right.
    split.
    unfold map_val.
    rewrite fpm_gss. simpl; auto.
    unfold map_share.
    rewrite fpm_gss. simpl; auto.
    generalize H0; intro H1.
    rewrite IHl in H0.
    inv H.
    assert (fst a <> a0).
    intro. subst a0.
    elim H4.
    clear -H1. induction l; simpl in *; intuition; subst; auto.
    destruct H0.
    unfold build_map. simpl fold_right.
    split.
    unfold map_val.
    rewrite fpm_gso; auto.
    unfold map_share.
    rewrite fpm_gso; auto.
    inv H. auto.
    inv H.
    destruct H0.
    destruct a.
    destruct (eq_dec a a0).
    subst a0.
    left. f_equal.
    unfold build_map in H.
    unfold map_val in H.
    simpl fold_right in H.
    rewrite fpm_gss in H.
    inv H. auto.
    right.
    rewrite IHl; auto.
    split.
    revert H.
    unfold build_map, map_val.
    simpl fold_right.
    rewrite fpm_gso; auto.
    revert H0.
    unfold build_map, map_share.
    simpl fold_right.
    rewrite fpm_gso; auto.
  Qed.

  Lemma build_map_join : forall (l1 l2:list (A * B)),
    NoDup (List.map (@fst _ _) (l1++l2)) ->
    join  (build_map l1)
          (build_map l2)
          (build_map (l1++l2)).
  Proof.
    induction l1; intros.
    simpl app.
    unfold build_map at 1.
    simpl fold_right.
    apply empty_fpm_join; auto with typeclass_instances.
    inv H.
    simpl app.
    unfold build_map.
    simpl fold_right.
    apply insert_fpm_join. auto with typeclass_instances.
    2: apply (IHl1 l2); auto.
    assert (~In (fst a) (List.map (@fst _ _) l2)).
    intro.
    elim H2.
    rewrite map_app.
    apply in_or_app.
    auto.
    clear -H.
    induction l2; simpl in *.
    auto.
    rewrite fpm_gso; auto.
  Qed.

End SM.
End ShareMap.


From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv.tutorial.objectstore Require Export chunk dir client.
From Perennial.base_logic.lib Require Import ghost_map.

(*
  map keyname → chunkhandle

  global monotonic map: chunkhandle → chunkdata.
  All points-tos are persistent (related to hashing plan).

  { True }
    PrepareWrite()
  { writeId, RET #writeId; ownership of writeId }
  ownership of writeId is:
    for each index, a points-to with value chunkhandle. Initially points-to nil.

  Just before the client sends a chunk for a particular index to a chunk server,
  it updates the points-to for that index to a frozen points-to with value equal
  to that chunk server+content hash.
  This persistent points-to is precondition of dir.RecordChunk().

  Client-side ghost state is map from string to (list u8).

  PrepareWrite returns ownership of the ongoing write value.
  AppendChunk changes this value.
  Done takes ownership of the ongoing value, and (logically) atomically updates
  the "real" value of that keyname to be the ongoing value.

  Key invariant about top-level ghost state:
    auth_map (1/2) m ∗
    if m !! k = Some v →
      ∃ chunkhandles,
      k ↦[γdir] chunkhandles ∗
      (there's a way to split up v into chunks such that
       chunk_handle[j].content_hash ↦[γhash]□ v_chunks[j]

 *)

(* Hashing plan:
   1. Real Go code does hashing.
   2. GooseLang model is a Go hashing service, which checks for duplicates.
   3. Spec is monotonic map:
      { True }
       Hash(content)
      { content_hash:string, RET #content_hash; content_hash ↦[γhash]□ content }
*)

Module PreparedWrite.
Record t := mk
  {
    Id: u64;
    ChunkAddrs: list chan;
  }.

End PreparedWrite.

Module RecordChunkArgs.
  Record t := mk
    {
      WriteId: u64;
      Index: u64;
      Server: chan;
      ContentHash: string;
    }.
End RecordChunkArgs.

Module FinishWriteArgs.
  Record t := mk
    {
      WriteId: u64;
      Keyname: string;
    }.
End FinishWriteArgs.

Section proof.

Context `{!heapGS Σ}.
Context `{ghost_mapG Σ nat (chan * list u8)}.
Context `{ghost_mapG Σ (u64 * nat) unit}.

Record dir_names :=
  {
    writeId_gn:gname; (* ghost_map writeId → gname *)
    recorded_gn:gname; (* ghost_map (writeId:u64, index:nat) → unit *)
  }
.

Definition own_PreparedWrite (v:val) (x:PreparedWrite.t) : iProp Σ :=
  ∃ (addrs_sl:Slice.t),
  ⌜v = (#x.(PreparedWrite.Id), (slice_val addrs_sl, #() ))%V⌝ ∗
  readonly (is_slice_small addrs_sl uint64T 1%Qp x.(PreparedWrite.ChunkAddrs))
  (* [∗ list] index ↦ '(addr, _) ∈ chunkhandles, is_chunk_host γchunk? addr *)
.

Implicit Type γd : dir_names.

(* This owned by the client, and is used to decide what the data for this WriteID will be *)
Definition own_WriteId γd (id:u64) (chunkhandles:list (chan * (list u8) )) : iProp Σ :=
  (* id + γ should determine the γid *)
  ∃ γid, ghost_map_auth γid 1 (map_seq 0 chunkhandles)
  (* [∗ list] index ↦ v ∈ chunkhandles, index ↪[γ] v *)
  (* [∗ list] index ↦ '(addr, _) ∈ chunkhandles, is_chunk_host γchunk? addr *)
.

Definition is_Clerk (ck:loc) γd : iProp Σ := True.

Lemma wp_Clerk__PrepareWrite (ck:loc) γd :
  {{{
        is_Clerk ck γd
  }}}
    Clerk__PrepareWrite #ck
  {{{
        v x, RET v; own_PreparedWrite v x ∗
                     own_WriteId γd x.(PreparedWrite.Id) []
  }}}
.
Proof.
Admitted.

(* This is a witness that the client has decided on the data/server at an index for a writeId *)
Definition is_client_writeId_index γd (id:u64) (index:nat) (chunkhandle:chan * list u8) : iProp Σ :=
  ∃ γid, (* id + γ should determine the γid *)
  index ↪[γid]□ chunkhandle
.

Lemma decide_writeId_index γd (id:u64) chunkhandles newchunkhandle :
  own_WriteId γd id chunkhandles ==∗
  own_WriteId γd id (chunkhandles ++ [newchunkhandle]) ∗
  is_client_writeId_index γd id (length chunkhandles) newchunkhandle.
Proof.
Admitted.

Definition is_dir_writeId_index_recorded γd (id:u64) (index:nat) : iProp Σ :=
  (id, index) ↪[γd.(recorded_gn)]□ ()
.

Lemma wp_Clerk__RecordChunk γd (ck:loc) args data :
  {{{
        is_Clerk ck γd ∗
        is_client_writeId_index γd args.(RecordChunkArgs.WriteId) (int.nat args.(RecordChunkArgs.Index))
                           (args.(RecordChunkArgs.Server), data)
        (* own args *)
        (* witness that args.(RecordChunkArgs.Server) stores data with args.(RecordChunkArgs.ContentHash) *)
  }}}
    Clerk__RecordChunk #ck (* #args *)
  {{{
        RET #(); is_dir_writeId_index_recorded γd args.(RecordChunkArgs.WriteId)
                                                         (int.nat args.(RecordChunkArgs.Index))
  }}}
.
Proof.
Admitted.

Definition is_finished_writeId γd (id:u64) chunkhandles : iProp Σ :=
  (* XXX: should be able to to have DfracDiscarded in place of (1:Qp) *)
  ∃ γid, readonly (ghost_map_auth γid 1 (map_seq 0 chunkhandles))
.

Definition object_ptsto γd (key:string) (data:list (list u8)) : iProp Σ :=
 True
.

(* The code is not exactly-once because FinishWrite might run many times. The
   spec cannot take and return ownership of the object_ptsto. *)
Lemma wp_Clerk__FinishWrite γd (ck:loc) args chunkhandles (data newdata : list (list u8)) :
  {{{
        is_Clerk ck γd ∗
        is_finished_writeId γd args.(FinishWriteArgs.WriteId) chunkhandles ∗
        ([∗ list] index ↦ _ ∈ chunkhandles,
          is_dir_writeId_index_recorded γd args.(FinishWriteArgs.WriteId) index) ∗
        ⌜chunkhandles.*2 = newdata⌝ ∗
        object_ptsto γd args.(FinishWriteArgs.Keyname) data
  }}}
    Clerk__FinishWrite #ck (* #args *)
  {{{
        RET #(); object_ptsto γd args.(FinishWriteArgs.Keyname) newdata
  }}}
.
Proof.
Admitted.

End proof.


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

Section cap_lang_rules.
  Context `{memG Σ, regG Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Inductive IsPtr_spec (regs: Reg) (dst src: RegName) (regs': Reg): cap_lang.val -> Prop :=
  | IsPtr_spec_success (w: Word):
      regs !! src = Some w →
      incrementPC (<[ dst := WInt (if is_cap w then 1%Z else 0%Z) ]> regs) = Some regs' ->
      IsPtr_spec regs dst src regs' NextIV
  | IsPtr_spec_failure (w: Word):
      regs !! src = Some w →
      incrementPC (<[ dst := WInt (if is_cap w then 1%Z else 0%Z) ]> regs) = None ->
      IsPtr_spec regs dst src regs' FailedV.

  Lemma wp_IsPtr Ep pc_p pc_b pc_e pc_a w dst src regs :
    decodeInstrW w = IsPtr dst src ->
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    regs !! PC = Some (WCap pc_p pc_b pc_e pc_a) →
    regs_of (IsPtr dst src) ⊆ dom regs →

    {{{ ▷ pc_a ↦ₐ w ∗
        ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
      Instr Executable @ Ep
    {{{ regs' retv, RET retv;
        ⌜ IsPtr_spec regs dst src regs' retv ⌝ ∗
          pc_a ↦ₐ w ∗
          [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs φ) "(>Hpc_a & >Hmap) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ns l1 l2 nt) "Hσ1 /=". destruct σ1; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %Hpc_a; auto.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iIntros "_".
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.
    rewrite /exec in Hstep.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri. unfold regs_of in Hri.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.
    destruct (Hri src) as [wsrc [H'src Hsrc]]. by set_solver+.

    assert (exec_opt (IsPtr dst src) (r, m) = updatePC (update_reg (r, m) dst (WInt (if is_cap wsrc then 1%Z else 0%Z)))) as HH.
    {  rewrite /= Hsrc. unfold is_cap; destruct_word wsrc; auto. }
    rewrite HH in Hstep. rewrite /update_reg /= in Hstep.

    destruct (incrementPC (<[ dst := WInt (if is_cap wsrc then 1%Z else 0%Z) ]> regs))
      as [regs'|] eqn:Hregs'; pose proof Hregs' as H'regs'; cycle 1.
    { apply incrementPC_fail_updatePC with (m:=m) in Hregs'.
      eapply updatePC_fail_incl with (m':=m) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      simplify_pair_eq.
      rewrite Hregs' in Hstep. inversion Hstep.
      iFrame. iApply "Hφ"; iFrame. iPureIntro. econstructor; eauto. }

    (* Success *)

    eapply (incrementPC_success_updatePC _ m) in Hregs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & HuPC & ->).
    eapply updatePC_success_incl with (m':=m) in HuPC. 2: by eapply insert_mono; eauto. rewrite HuPC in Hstep.

    simplify_pair_eq. iFrame.
    iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iFrame. iModIntro. iApply "Hφ". iFrame. iPureIntro. econstructor; eauto.
  Qed.

  Lemma wp_IsPtr_successPC E pc_p pc_b pc_e pc_a pc_a' w dst w' :
    decodeInstrW w = IsPtr dst PC →
    isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ dst ↦ᵣ w'
    }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
          ∗ pc_a ↦ₐ w
          ∗ dst ↦ᵣ WInt 1%Z }}}.
   Proof.
     iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hdst) Hφ".
     iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
     iApply (wp_IsPtr with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
     by rewrite !dom_insert; set_solver+.
     iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

     destruct Hspec as [|].
     { iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
       rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
       iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
     { incrementPC_inv; simplify_map_eq; eauto. congruence. }
   Qed.

   Lemma wp_IsPtr_success E pc_p pc_b pc_e pc_a pc_a' w dst r wr w' :
     decodeInstrW w = IsPtr dst r →
     isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
     (pc_a + 1)%a = Some pc_a' →

       {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
             ∗ ▷ pc_a ↦ₐ w
             ∗ ▷ r ↦ᵣ wr
             ∗ ▷ dst ↦ᵣ w'
       }}}
         Instr Executable @ E
       {{{ RET NextIV;
           PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
           ∗ pc_a ↦ₐ w
           ∗ r ↦ᵣ wr
           ∗ dst ↦ᵣ WInt (if is_cap wr then 1%Z else 0%Z) }}}.
   Proof.
    iIntros (Hinstr Hvpc Hpc_a ϕ) "(>HPC & >Hpc_a & >Hr & >Hdst) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr Hdst") as "[Hmap (%&%&%)]".
    iApply (wp_IsPtr with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC dst) // insert_insert (insert_commute _ r dst) //
              (insert_commute _ dst PC) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto. congruence. }
   Qed.

   Lemma wp_IsPtr_success_dst E pc_p pc_b pc_e pc_a pc_a' w dst w' :
     decodeInstrW w = IsPtr dst dst →
     isCorrectPC (WCap pc_p pc_b pc_e pc_a) →
     (pc_a + 1)%a = Some pc_a' →

       {{{ ▷ PC ↦ᵣ WCap pc_p pc_b pc_e pc_a
             ∗ ▷ pc_a ↦ₐ w
             ∗ ▷ dst ↦ᵣ w'
       }}}
         Instr Executable @ E
       {{{ RET NextIV;
           PC ↦ᵣ WCap pc_p pc_b pc_e pc_a'
           ∗ pc_a ↦ₐ w
           ∗ dst ↦ᵣ WInt (if is_cap w' then 1%Z else 0%Z) }}}.
   Proof.
     iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hdst) Hφ".
     iDestruct (map_of_regs_2 with "HPC Hdst") as "[Hmap %]".
     iApply (wp_IsPtr with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
     by rewrite !dom_insert; set_solver+.
     iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

     destruct Hspec as [|].
     { iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
       rewrite (insert_commute _ PC dst) // insert_insert insert_commute // insert_insert.
       iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
     { incrementPC_inv; simplify_map_eq; eauto. congruence. }
   Qed.

End cap_lang_rules.


Require Import Platform.tests.Thread0 Platform.tests.Connect Platform.Bootstrap.

Module Type S.
  Parameter heapSize : nat.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := ((heapSize + 50) * 4)%nat.

  Definition inbuf_size := 40.

  Theorem inbuf_size_lower : (inbuf_size >= 2)%nat.
    unfold inbuf_size; auto.
  Qed.

  Theorem inbuf_size_upper : (N_of_nat (inbuf_size * 4) < Npow2 32)%N.
    reflexivity.
  Qed.
End M'.

Import M'.

Module E := Connect.Make(M').
Import E.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 1.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 1.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "connect"!"main" @ [E.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREmain[_] globalSched =?> 1 * 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSched =?> 1 * mallocHeap 0];;

        Goto "connect"!"main"
      end
    }}.

  Ltac t := unfold globalSched, localsInvariantMain, M'.globalSched; genesis.

  Theorem ok0 : moduleOk boot.
    vcgen; abstract t.
  Qed.

  Definition m1 := link Buffers.m boot.
  Definition m2 := link E.m m1.
  Definition m := link m2 E.T.T.m.

  Lemma ok1 : moduleOk m1.
    link Buffers.ok ok0.
  Qed.

  Lemma ok2 : moduleOk m2.
    link E.ok ok1.
  Qed.

  Theorem ok : moduleOk m.
    link ok2 E.T.T.ok.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $ (size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok.
  Qed.
End boot.

End Make.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import plotkin.
Require Import embed.
Require Import joinable.
Require Import approx_rels.
Require Import profinite.
Require Import profinite_adj.
Require Import cont_functors.

(**  * Continuous adjoint functors

     Here we lift the lifting and forgetful adjoint functors into the
     category of embeddings and prove that they are continuous.
  *)

Definition forgetEMBED_map (A B:ob PLT) (f:A ⇀ B) : forgetPLT_ob A ⇀ forgetPLT_ob B :=
  Embedding true (forgetPLT_ob A) (forgetPLT_ob B)
    (@embed_map false A B f)
    (@embed_mono false A B f)
    (@embed_reflects false A B f)
    (fun _ => I)
    (@embed_directed2 false A B f).

Program Definition forgetEMBED : functor (EMBED false) (EMBED true) :=
  Functor (EMBED false) (EMBED true) forgetPLT_ob forgetEMBED_map _ _ _.
Solve Obligations of forgetEMBED with auto.

Program Definition liftEMBED_map (A B:ob ∂PLT) (f:A ⇀ B) : liftPPLT_ob A ⇀ liftPPLT_ob B :=
  Embedding false (liftPPLT_ob A) (liftPPLT_ob B)
    (fun x => match x with None => None | Some a => Some (f a) end)
    _ _ _ _.
Next Obligation.
  simpl. intros.
  destruct a; destruct a'; simpl; auto.
  apply embed_mono. auto.
Qed.
Next Obligation.
  simpl. intros.
  destruct a; destruct a'; simpl; auto.
  apply embed_reflects with B f; auto.
Qed.
Next Obligation.
  intros. exists None. hnf. auto.
Qed.
Next Obligation.
  simpl. intros.
  destruct a; destruct b.
  - destruct y.
    + destruct embed_directed2 with true A B f c1 c c0 as [q [?[??]]]; auto.
      exists (Some q); auto.
    + elim H.
  - exists (Some c). auto.
  - exists (Some c). auto.
  - exists None. auto.
Qed.

Program Definition liftEMBED : functor (EMBED true) (EMBED false) :=
  Functor (EMBED true) (EMBED false) liftPPLT_ob liftEMBED_map _ _ _.
Next Obligation.
  intros. split; hnf; simpl; intros.
  - destruct x; simpl; auto.
    destruct H. apply H.
  - destruct x; simpl; auto.
    destruct H. apply H0.
Qed.
Next Obligation.
  intros. split; hnf; simpl; intros.
  - destruct x; auto. destruct H. apply H.
  - destruct x; auto. destruct H. apply H0.
Qed.
Next Obligation.
  intros. split; hnf; simpl; intros.
  - destruct x; auto. destruct H. apply H.
  - destruct x; auto. destruct H. apply H0.
Qed.

Require Import bilimit.

Lemma forgetEMBED_continuous : continuous_functor forgetEMBED.
Proof.
  hnf; intros.
  apply decompose_is_colimit; simpl.
  intros.
  destruct (colimit_decompose _ I DS CC X x) as [i [s H]].
  exists i. exists s. auto.
Qed.

Lemma liftEMBED_continuous : continuous_functor liftEMBED.
Proof.
  hnf; intros.
  apply decompose_is_colimit; simpl.
  intros.
  destruct x.
  - destruct (colimit_decompose _ I DS CC X c) as [i [s H]].
    exists i. exists (Some s). auto.
  - destruct (directed.choose_ub_set I nil) as [i0 ?].
    exists i0. exists None. auto.
Qed.


Require Import Coqlib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.

Set Implicit Arguments.

Section CANNON.
  Definition div (n m: Z): option Z :=
    if Z_zerop m then None else Some (Z.div n m).

  Definition fire_body {E} `{callE -< E} `{pE -< E} `{eventE -< E}
    : list val -> itree E Z :=
    fun args =>
      powder <- trigger PGet;; powder <- powder↓?;;
      r <- (div 1 powder)?;;
      _ <- trigger (Syscall "print" [r]↑ top1);;
      _ <- trigger (PPut (powder - 1)%Z↑);;
      Ret r
  .

  Definition CannonSem: ModSem.t := {|
    ModSem.fnsems := [("fire", cfunU fire_body)];
    ModSem.mn := "Cannon";
    ModSem.initial_st := (1: Z)%Z↑;
  |}
  .

  Definition Cannon: Mod.t := {|
    Mod.get_modsem := fun _ => CannonSem;
    Mod.sk := [("fire", Sk.Gfun)];
  |}
  .
End CANNON.


Require Import StlcIso.SpecTyping.
Require Import StlcIso.SpecEquivalent.
Require Import StlcIso.LemmasEvaluation.
Require Import StlcIso.LemmasTyping.
Require Import StlcEqui.SpecEquivalent.
Require Import StlcEqui.LemmasEvaluation.

Require Import CompilerIE.Compiler.

Require Import UValIE.UVal.

Require Import LogRelIE.PseudoType.
Require Import LogRelIE.LemmasPseudoType.
Require Import LogRelIE.LR.
Require Import LogRelIE.LemmasLR.

Require Import BacktransIE.Emulate.
Require Import BacktransIE.InjectExtract.
Require Import BacktransIE.UpgradeDowngrade.
Require Import BacktransIE.Backtrans.

Lemma equivalencePreservation {t₁ t₂ τ} :
  ValidTy τ ->
  ⟪ I.empty i⊢ t₁ : τ ⟫ →
  ⟪ I.empty i⊢ t₂ : τ ⟫ →
  ⟪ I.empty i⊢ t₁ ≃ t₂ : τ ⟫ →
  ⟪ E.empty e⊢ compie t₁ ≃ compie t₂ : τ ⟫.
Proof.
  (* sufficient to prove one direction of equi-termination *)
  revert t₁ t₂ τ.
  enough (∀ {t₁ t₂ τ τ'},
             ValidTy τ ->
             ValidTy τ' ->
            ⟪ I.empty i⊢ t₁ : τ ⟫ →
            ⟪ I.empty i⊢ t₂ : τ ⟫ →
            ⟪ I.empty i⊢ t₁ ≃ t₂ : τ ⟫ →
            ∀ {C}, ⟪ ea⊢ C : E.empty , τ → E.empty , τ' ⟫ →
                 E.Terminating (E.pctx_app (compie t₁) (eraseAnnot_pctx C)) → E.Terminating (E.pctx_app (compie t₂) (eraseAnnot_pctx C))) as Hltor.
  { intros t₁ t₂ τ vτ ty1 ty2 ceq.
    assert (⟪ I.empty i⊢ t₂ ≃ t₁ : τ ⟫) as ceq'
            by (apply I.pctx_equiv_symm; assumption).
    split;
      refine (Hltor _ _ _ _ _ _ _ _ _ _ H0); crushValidTy.
  }

  intros t₁ t₂ τ τ' vτ vτ' ty₁ ty₂ ceq Cu tCu term.
  destruct (E.Terminating_TermHor term) as [n termN]; clear term.

  assert (⟪ pempty ⊩ t₁ ⟦ dir_gt , S n ⟧ compie t₁ : embed τ ⟫) as lre₁.
  { change pempty with (embedCtx (repEmulCtx pempty)).
      eapply compie_correct; crushValidTy_with_UVal.
      cbn; eauto using ValidEnv_nil. }

  unshelve epose proof (lrfull₁ := backtranslateCtx_works vτ' vτ (dwp_precise _) tCu lre₁).
  exact (S (S n)).
  eauto.

  unfold backtranslateCtx in lrfull₁.
  rewrite I.eraseAnnot_pctx_cat, I.pctx_cat_app in lrfull₁.

  assert (I.Terminating (I.pctx_app (I.app (inject (S (S n)) τ) t₁)
                                    (I.eraseAnnot_pctx (emulate_pctx (S (S n)) Cu)))) as termI
    by (eapply (adequacy_gt lrfull₁ termN); eauto with arith).

  change (I.app (inject (S (S n)) τ) t₁) with (I.pctx_app t₁ (I.eraseAnnot_pctx (I.ia_papp₂ τ (UValIE (S (S n)) τ) (injectA (S (S n)) τ) I.ia_phole))) in termI.
  rewrite <- I.pctx_cat_app in termI.
  rewrite <- I.eraseAnnot_pctx_cat in termI.

  assert (⟪ i⊢ I.eraseAnnot_pctx (emulate_pctx (S (S n)) Cu) : I.empty, UValIE (S (S n)) τ → I.empty, UValIE (S (S n)) τ' ⟫) by
    (change I.empty with (toUVals (S (S n)) E.empty);
        eapply I.eraseAnnot_pctxT, emulate_pctx_T; eauto with tyvalid).

  assert (vε : ValidEnv E.empty) by eauto with tyvalid.
  assert (vuvalτ : ValidTy (UValIE (S (S n)) τ')) by crushValidTy_with_UVal.
  pose proof (tEmCu := emulate_pctx_T (n := S (S n)) vε vτ' tCu).
  assert (I.Terminating (I.pctx_app t₂ (backtranslateCtx (S (S n)) τ Cu))) as termS'.
  { eapply ceq.
    exact vuvalτ.
    repeat (I.crushTypingMatchIAH + I.crushTypingMatchIAH2);
    crushValidTy_with_UVal; eauto using I.pctxtyping_cat_annot, injectAT, emulate_pctx_T, I.PCtxTypingAnnot.
    assumption.
  }
  unfold backtranslateCtx in termS'.

  destruct (I.Terminating_TermHor termS') as [m termSm']; clear termS'.

  assert (⟪ pempty ⊩ t₂ ⟦ dir_lt , S m ⟧ compie t₂ : embed τ ⟫) as lre₂
      by (change pempty with (embedCtx (repEmulCtx pempty));
          eapply compie_correct;
          cbn; assumption).

  epose proof (lrfull₂ := backtranslateCtx_works vτ' vτ dwp_imprecise tCu lre₂).

  eapply (adequacy_lt lrfull₂ termSm'); eauto with arith.
Qed.

Definition FullAbstraction (t₁ : I.Tm) (t₂ : I.Tm) (τ : Ty) : Prop :=
  ⟪ I.empty i⊢ t₁ : τ ⟫ →
  ⟪ I.empty i⊢ t₂ : τ ⟫ →
  ⟪ I.empty i⊢ t₁ ≃ t₂ : τ ⟫ ↔
  ⟪ E.empty e⊢ compie t₁ ≃ compie t₂ : τ ⟫.

Lemma fullAbstraction {t₁ t₂ τ} : FullAbstraction t₁ t₂ τ.
Proof.
  unfold FullAbstraction.
  intros.
  pose proof I.typed_terms_are_valid t₁ τ ValidEnv_nil H as vτ.
  split;
  eauto using equivalenceReflectionEmpty, equivalencePreservation.
Qed.

Print Assumptions fullAbstraction.


Require Import Coq.Lists.List Coq.Setoids.Setoid Coq.Classes.Morphisms.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.Refinement.BinOpBrackets.ParenBalanced.
Require Import Fiat.Parsers.Reachable.ParenBalanced.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.FoldGrammar.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.
Require Import Fiat.Common.Enumerable.
Require Import Fiat.Common.FixedPoints.

Local Open Scope bool_scope.
Local Open Scope string_like_scope.

Set Implicit Arguments.

Local Notation eta x := (fst x, snd x) (only parsing).
Local Notation eta2 x := (fst x, (fst (snd x), snd (snd x))) (only parsing).

Local Opaque rdp_list_predata.

Section specific.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
          {CharE : Enumerable Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.
  Context (G : pregrammar Char).
  Let predata := (@rdp_list_predata _ G).
  Local Existing Instance predata.

  Section assume_lists.
    Context (pb_nts pbh_nts : nonterminals_listT).

    Definition paren_balanced''_production_step
               (hiding : bool)
      := fun (it : item Char) (rest_balanced : nat -> bool) level
         => let predata := @rdp_list_predata _ G in
            match it with
              | Terminal P
                => ((pb_check_level_fun hiding P level)
                      && match pb_new_level_fun P level with
                           | new_level::nil => rest_balanced new_level
                           | _ => false
                         end)%bool
              | NonTerminal nt
                => (*(is_valid_nonterminal initial_nonterminals_data nt)
                   &&*)
                (if (hiding && Compare_dec.zerop level)
                 then is_valid_nonterminal pbh_nts (of_nonterminal nt)
                 else is_valid_nonterminal pb_nts (of_nonterminal nt))
                  && rest_balanced level
            end.

    Definition paren_balanced''_production
               (hiding : bool)
               (level : nat)
               (pat : production Char)
    : bool
      := fold_right
           (paren_balanced''_production_step hiding)
           Compare_dec.zerop
           pat
           level.

    Definition paren_balanced''_productions
               (hiding : bool)
               (level : nat)
               (pats : productions Char)
    : bool
      := fold_right
           andb
           true
           (map (paren_balanced''_production hiding level) pats).

    Definition paren_balanced''_nt
               (hiding : bool)
               (nt : nonterminal_carrierT)
    : bool
      := let predata := @rdp_list_predata _ G in
         (paren_balanced''_productions
            hiding
            0
            (Lookup_idx G nt)).

    Section correct.
      Context (H_pb : forall nt, is_valid_nonterminal pb_nts nt
                                 -> paren_balanced''_nt false nt)
              (H_pbh : forall nt, is_valid_nonterminal pbh_nts nt
                                  -> paren_balanced''_nt true nt).

      Fixpoint paren_balanced_productions_correct
               (hiding : bool)
               (level : nat)
               (pats : productions Char)
               (H_p : paren_balanced''_productions hiding level pats)
               (str : String)
               (p : parse_of G str pats)
      : if hiding
        then paren_balanced_hiding' str level
        else paren_balanced' str level
      with paren_balanced_production_correct
             (hiding : bool)
             (level : nat)
             (pat : production Char)
             (H_p : paren_balanced''_production hiding level pat)
             (str : String)
             (p : parse_of_production G str pat)
           : if hiding
             then paren_balanced_hiding' str level
             else paren_balanced' str level.
      Proof.
        { destruct p as [?? p | ?? p ];
          [ apply (fun hiding level H_p => paren_balanced_production_correct hiding level _ H_p _ p)
          | apply (fun hiding level H_p => paren_balanced_productions_correct hiding level _ H_p _ p) ];
          clear paren_balanced_production_correct paren_balanced_productions_correct;
          unfold paren_balanced''_productions in *;
          simpl in *;
          apply Bool.andb_true_iff in H_p;
          destruct H_p as [H_p0 H_p1];
          assumption. }
        { destruct p as [| ??? p0 p1 ].
          { clear paren_balanced_productions_correct paren_balanced_production_correct.
            unfold paren_balanced''_production in *.
            simpl in *.
            edestruct Compare_dec.zerop; subst; simpl in *; try congruence; [].
            destruct hiding.
            { rewrite paren_balanced_hiding'_nil by assumption; reflexivity. }
            { rewrite paren_balanced'_nil by assumption; reflexivity. } }
          { specialize (fun hiding level H_p => paren_balanced_production_correct hiding level _ H_p _ p1); clear p1.
            unfold paren_balanced''_production in *.
            simpl in *.
            destruct p0 as [| ? ? p0 ].
            { clear paren_balanced_productions_correct.
              unfold paren_balanced''_production_step at 1 in H_p.
              destruct (pb_new_level_fun P level) as [|? [|]] eqn:Heq;
                simpl in *;
                try rewrite Bool.andb_false_r in *; try congruence;
                [].
              apply Bool.andb_true_iff in H_p;
                destruct H_p as [H_p0 H_p1].
              specialize (paren_balanced_production_correct _ _ H_p1).
              clear H_p1.
              rewrite paren_balanced_hiding'_recr.
              rewrite paren_balanced'_recr.
              repeat match goal with
                       | [ H : is_true (_ ~= [ _ ]) |- _ ]
                         => pose proof (length_singleton _ _ H);
                           progress apply take_n_1_singleton in H
                       | [ H : context[length (StringLike.take _ _)] |- _ ]
                         => rewrite take_length in H
                     end.
              erewrite !(proj1 (get_0 _ _)) by eassumption.
              assert (H' : StringLike.drop n str =s StringLike.drop 1 str).
              { destruct n as [|[|n]]; simpl in *; try congruence; try reflexivity.
                destruct (length str) as [|[|]] eqn:?; try congruence.
                apply bool_eq_empty; rewrite ?drop_length; omega. }
              rewrite !H' in paren_balanced_production_correct; clear H'.
              repeat match goal with
                       | [ H : _ |- _ ] => setoid_rewrite pb_check_level_fun_correct in H
                       | [ H : _ |- _ ] => setoid_rewrite pb_new_level_fun_correct in H
                     end.
              unfold paren_balanced_hiding'_step, paren_balanced'_step, pb_check_level_fun, pb_new_level_fun, pb_check_level, pb_new_level in *.
              repeat match goal with
                       | _ => assumption
                       | _ => progress subst
                       | [ H : filter _ _ = _::nil |- _ ] => eapply filter_enumerate in H
                       | _ => progress split_iff
                       | _ => specialize_by eassumption; progress subst
                       | [ H : context[fold_right andb true (map _ _)] |- _ ]
                         => rewrite fold_right_andb_map_in_iff in H
                       | [ H : context[In _ (filter _ _)] |- _ ]
                         => setoid_rewrite filter_In in H
                       | [ H : forall x, _ /\ _ -> _ |- _ ] => specialize (fun x A B => H x (conj A B))
                       | [ H : forall x, In _ (enumerate _) -> _ |- _ ]
                           => specialize (fun x => H x (enumerate_correct _))
                       | [ H : ?x = true, H' : context[?x] |- _ ] => rewrite H in H'
                       | [ H : ?x = false, H' : context[?x] |- _ ] => rewrite H in H'
                       | [ H : ?x = ?y::nil |- _ ]
                         => assert (forall n, In n x <-> n = y)
                           by (intro; rewrite H; simpl; intuition);
                           clear H
                       | [ H : forall x, _ = x -> _ |- _ ] => specialize (H _ eq_refl)
                       | [ H : forall x, x = _ -> _ |- _ ] => specialize (H _ eq_refl)
                       | [ H : context[In _ (uniquize _ _)] |- _ ]
                         => setoid_rewrite <- (ListFacts.uniquize_In_refl_iff _ EqNat.beq_nat _ (lb eq_refl) bl) in H
                       | [ H : context[In _ (map _ _)] |- _ ]
                         => setoid_rewrite in_map_iff in H
                       | _ => progress destruct_head ex
                       | _ => progress destruct_head and
                       | [ H : forall x, ex _ -> _ |- _ ]
                         => specialize (fun x a b => H x (ex_intro _ a b))
                       | _ => progress cbv beta in *
                       | _ => progress split_and
                       | [ |- context[bool_of_sumbool ?e] ] => destruct e; simpl
                       | [ |- appcontext[if ?e then _ else _] ]
                         => destruct e eqn:?
                       | [ H : forall ch, is_true (?P ch) -> _ |- _ ]
                         => repeat match goal with
                                     | [ H' : is_true (P ?ch') |- _ ]
                                       => unique pose proof (H _ H')
                                     | [ H' : P ?ch' = true |- _ ]
                                       => unique pose proof (H _ H')
                                   end;
                           clear H
                     end. }
            { specialize (fun hiding level H_p => paren_balanced_productions_correct hiding level _ H_p _ p0); clear p0.
              unfold paren_balanced''_production_step at 1 in H_p.
              apply Bool.andb_true_iff in H_p;
                destruct H_p as [H_p0 H_p1].
              specialize (paren_balanced_production_correct _ _ H_p1); clear H_p1.
              destruct hiding.
              { simpl in *.
                rewrite paren_balanced_hiding'_split_0; [ reflexivity | | eassumption ].
                destruct level as [|level]; simpl in *.
                { specialize (H_pbh _ H_p0); clear H_p0.
                  unfold paren_balanced''_nt in *.
                  (*apply Bool.andb_true_iff in H_pbh;
                  destruct H_pbh as [H_pbh0 H_pbh1]; clear H_pbh.*)
                  rewrite <- Carriers.list_to_productions_to_nonterminal in H_pbh.
                  change Carriers.default_to_nonterminal with to_nonterminal in H_pbh.
                  rewrite to_of_nonterminal in H_pbh by assumption.
                  specialize (paren_balanced_productions_correct _ _ H_pbh).
                  simpl in *.
                  assumption. }
                { specialize (H_pb _ H_p0); clear H_p0.
                  unfold paren_balanced''_nt in *.
                  (*apply Bool.andb_true_iff in H_pb;
                  destruct H_pb as [H_pb0 H_pb1]; clear H_pb.*)
                  rewrite <- Carriers.list_to_productions_to_nonterminal in H_pb.
                  change Carriers.default_to_nonterminal with to_nonterminal in H_pb.
                  rewrite to_of_nonterminal in H_pb by assumption.
                  specialize (paren_balanced_productions_correct _ _ H_pb).
                  simpl in *.
                  assumption. } }
              { simpl in *.
                rewrite paren_balanced'_split_0; [ reflexivity | | eassumption ].
                specialize (H_pb _ H_p0); clear H_p0.
                unfold paren_balanced''_nt in *.
                (*apply Bool.andb_true_iff in H_pb;
                destruct H_pb as [H_pb0 H_pb1]; clear H_pb.*)
                rewrite <- Carriers.list_to_productions_to_nonterminal in H_pb.
                change Carriers.default_to_nonterminal with to_nonterminal in H_pb.
                rewrite to_of_nonterminal in H_pb by assumption.
                specialize (paren_balanced_productions_correct _ _ H_pb).
                simpl in *.
                assumption. } } } }
      Defined.

      Lemma paren_balanced_nt''_correct
            (hiding : bool)
            nt
            (H_p : paren_balanced''_nt hiding (of_nonterminal nt))
            (str : String)
            (p : parse_of_item G str (NonTerminal nt))
      : if hiding
        then paren_balanced_hiding str
        else paren_balanced str.
      Proof.
        dependent destruction p.
        eapply paren_balanced_productions_correct;
          try eassumption; instantiate;
            rewrite <- Carriers.list_to_productions_to_nonterminal;
            change Carriers.default_to_nonterminal with to_nonterminal;
            rewrite ?to_of_nonterminal; eassumption.
      Qed.
    End correct.

    Section correct_reflective.
      Local Transparent rdp_list_predata.

      Context (H_pb : fold_right andb true (map (paren_balanced''_nt false) pb_nts))
              (H_pbh : fold_right andb true (map (paren_balanced''_nt true) pbh_nts)).

      Local Ltac t :=
        repeat match goal with
                 | _ => progress simpl in *
                 | _ => progress specialize_by assumption
                 | _ => progress intros
                 | _ => progress unfold rdp_list_is_valid_nonterminal in *
                 | _ => progress subst
                 | _ => congruence
                 | [ H : string_beq _ _ = true |- _ ] => apply string_bl in H
                 | [ H : EqNat.beq_nat _ _ = true |- _ ] => apply EqNat.beq_nat_true in H
                 | [ H : is_true (_ || _) |- _ ] => apply Bool.orb_true_iff in H
                 | [ H : is_true (_ && _) |- _ ] => apply Bool.andb_true_iff in H
                 | [ H : _ /\ _ |- _ ] => let H1 := fresh in
                                          let H2 := fresh in
                                          destruct H as [H1 H2]; try clear H
                 | [ H : _ \/ _ |- _ ] => destruct H
                 | _ => solve [ eauto with nocore ]
               end.

      Lemma paren_balanced_nt'_correct
            (hiding : bool)
            nt
            (H_p : paren_balanced''_nt hiding (of_nonterminal nt))
            (str : String)
            (p : parse_of_item G str (NonTerminal nt))
      : if hiding
        then paren_balanced_hiding str
        else paren_balanced str.
      Proof.
        eapply paren_balanced_nt''_correct; try eassumption.
        { clear -H_pb.
          induction pb_nts; t. }
        { clear -H_pbh.
          induction pbh_nts; t. }
      Qed.
    End correct_reflective.
  End assume_lists.
End specific.

Section paren_balanced_nonterminals.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}.
  Context {HEC : Enumerable Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}
          (G : pregrammar Char)
          (hiding : bool).
  Let predata := (@rdp_list_predata _ G).
  Local Existing Instance predata.

  Definition paren_balanced_nonterminals (nt : String.string) : list nonterminal_carrierT * list nonterminal_carrierT
    := greatest_fixpoint_of_lists
         (fun pb_nts pbh_nts => paren_balanced''_nt (G := G) pb_nts pbh_nts false)
         (fun pb_nts pbh_nts => paren_balanced''_nt (G := G) pb_nts pbh_nts true)
         initial_nonterminals_data
         initial_nonterminals_data.
End paren_balanced_nonterminals.

Local Transparent rdp_list_predata.

Section with_lists.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.
  Context {HEC : Enumerable Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.
  Context (G : pregrammar Char).
  Let predata := (@rdp_list_predata _ G).
  Local Existing Instance predata.

  Section pre.
    Context (hiding : bool)
            (nt : String.string).

    Let pb_nts : nonterminals_listT
      := fst (paren_balanced_nonterminals G nt).
    Let pbh_nts : nonterminals_listT
      := snd (paren_balanced_nonterminals G nt).

    Let H_pb : fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts false) pb_nts).
    Proof.
      rapply @greatest_fixpoint_of_lists_correct_1.
    Qed.
    Let H_pbh : fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts true) pbh_nts).
    Proof.
      rapply @greatest_fixpoint_of_lists_correct_2.
    Qed.

    Lemma paren_balanced_nt_correct
          (H_p : paren_balanced''_nt pb_nts pbh_nts hiding (of_nonterminal nt))
          (str : String)
          (p : parse_of_item G str (NonTerminal nt))
    : if hiding
      then paren_balanced_hiding str
      else paren_balanced str.
    Proof.
      eapply paren_balanced_nt'_correct; eassumption.
    Qed.
  End pre.

  Section rule.
    Context (nt : String.string).

    Let pb_nts : nonterminals_listT
      := fst (paren_balanced_nonterminals G nt).
    Let pbh_nts : nonterminals_listT
      := snd (paren_balanced_nonterminals G nt).

    Definition paren_balanced_hiding_correctness_type
      := (*(fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts false) pb_nts))
           && (fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts true) pbh_nts))
           && *)(paren_balanced''_nt pb_nts pbh_nts true (of_nonterminal nt)).

    Global Arguments paren_balanced_hiding_correctness_type / .

    (** Just check for paren-balanced-ness, not for that it hides the binary operation. *)
    Definition paren_balanced_correctness_type
      := (*(fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts false) pb_nts))
           && (fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts false) pbh_nts))
           &&*) (paren_balanced''_nt pb_nts pbh_nts false (of_nonterminal nt)).

    Global Arguments paren_balanced_hiding_correctness_type / .

    Lemma paren_balanced_hiding_nt_correct
          (Hvalid : paren_balanced_hiding_correctness_type)
    : forall str', parse_of_item G str' (NonTerminal nt)
                   -> paren_balanced_hiding str'.
    Proof.
      simpl in Hvalid.
      apply (paren_balanced_nt_correct true);
      assumption.
    Qed.
  End rule.
End with_lists.


Require Import Coq.Lists.List.
Require Import Poulet4.P4light.Syntax.Typed.
Require Import Poulet4.P4light.Syntax.Syntax.
Require Import Poulet4.P4light.Syntax.Value.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.core.Coqlib.
Require Import ProD3.core.Hoare.
Require ProD3.core.AssertionLang.
Require Import ProD3.core.AssertionNotations.
Require Import ProD3.core.ConcreteHoare.
Require Import ProD3.core.Modifies.
Require Import ProD3.core.ExtPred.
Require Import ProD3.core.Result.
Require Import Hammer.Plugin.Hammer.

Section FuncSpec.

Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).
Notation Lval := ValueLvalue.

Notation ident := (String.string).
Notation path := (list ident).

Context `{target : @Target tags_t (@Expression tags_t)}.

(* A func spec contains two levels binders. A func spec is like
  WITH (p : path) ... ,
    PATH p
    MOD [...] [...]
    WITH (x : X) ... ,
      PRE ...
      POST ...
*)

Inductive func_spec_hoare : Type :=
  | fsh_base : arg_assertion -> arg_ret_assertion -> func_spec_hoare
  | fsh_bind {A} : (A -> func_spec_hoare) -> func_spec_hoare.

Record func_spec_aux : Type := mk_func_spec {
  func_spec_p : path;
  func_spec_body : func_spec_hoare;
  func_spec_mod_vars : option (list path); (* None means anything can be modified. *)
  func_spec_mod_exts : list path
}.

Inductive func_spec : Type :=
  | fs_base : func_spec_aux -> func_spec
  | fs_bind {A} : (A -> func_spec) -> func_spec.

Fixpoint fundef_satisfies_hoare (ge : genv) (p : path) (func : fundef) (targs : list (P4Type)) (fs : func_spec_hoare) :=
  match fs with
  | fsh_base pre post =>
       hoare_func ge p pre func targs post
  | @fsh_bind A fs =>
      (* How can we keep binder names? They are preserved when intro-ing them
        through our tactic. *)
      forall (x : A), fundef_satisfies_hoare ge p func targs (fs x)
  end.

Definition func_sound_aux (ge : genv) (func : fundef) (targs : list (P4Type)) (fs : func_spec_aux) :=
  let '(mk_func_spec p body vars exts) := fs in
  fundef_satisfies_hoare ge p func targs body
    /\ func_modifies ge p func vars exts.

Fixpoint func_sound (ge : genv) (func : fundef) (targs : list (P4Type)) (fs : func_spec) :=
  match fs with
  | fs_base fs =>
      func_sound_aux ge func targs fs
  | @fs_bind A fs =>
      (* How can we keep binder names? *)
      forall (x : A), func_sound ge func targs (fs x)
  end.

Definition path_eq_dec : forall (p p' : path), {p = p'} + {p <> p'}.
Proof.
  apply list_eq_dec, String.string_dec.
Defined.

Definition exclude {A} (mods : list path) (l : list (path * A)) :=
  filter (fun '(p, _) => negb (In_dec path_eq_dec p mods)) l.

Fixpoint disjoint (p1 p2 : path) : bool :=
  match p1 with
  | [] => false
  | n :: p1 =>
      match p2 with
      | [] => false
      | m :: p2 =>
          if String.eqb n m then disjoint p1 p2 else true
      end
  end.

(* This is an iff, but we only prove one direction. *)
Lemma disjoint_spec : forall p1 p2,
  disjoint p1 p2 ->
  forall q, negb (is_prefix p1 q && is_prefix p2 q).
Proof.
  induction p1 as [ | s1 p1]; destruct p2 as [ | s2 p2]; intros; inv H.
  destruct q as [ | t q].
  - auto.
  - simpl.
    destruct (String.eqb s1 s2) eqn:H_eqb_s1_s2;
      destruct (String.eqb s1 t) eqn:H_eqb_s1_t;
      destruct (String.eqb s2 t) eqn:H_eqb_s2_t;
      try auto.
    + hfcrush use: String.eqb_eq.
    + hfcrush use: String.eqb_eq.
    + hauto b: on.
Qed.

(* For symbolic paths, we cannot decide whether two paths are disjoint. So we define a weaker
  version: we use a tactic to generate a result for each test, which is either disjoint or
  unknown.
    We want to separate the decision procedure to test disjoint from the filter process,
  so we do not directly define a relation (list ext_pred -> list ext_pred -> Prop). *)

(* Test if modifying in the scopes of mods is disjoint from ep. *)
Definition ext_disjoint (mods : list path) (ep : ext_pred) :=
  forallb (fun q => forallb (disjoint q) ep.(ep_paths)) mods.

Fixpoint ext_exclude (mods : list path) (a_ext : list ext_pred)
    (rs : res_list (ext_disjoint mods) a_ext) : list ext_pred.
Proof.
  inversion rs as [ | ep eps].
  - exact nil.
  - exact (
      if r then ep :: ext_exclude mods eps rs0 else ext_exclude mods eps rs0).
Defined.

Definition hoare_func_frame (ge : genv) (p : path) (pre : arg_assertion) (func : @fundef tags_t) (targs : list P4Type) (post : assertion) :=
  forall st inargs st' outargs sig,
    pre inargs st ->
    exec_func ge read_ndetbit p st func targs inargs st' outargs sig ->
    post st'.

Lemma modifies_exts_disjoint : forall (ep : ext_pred) exts st st',
  modifies_exts exts st st' ->
  ep (snd st) ->
  ext_disjoint exts ep ->
  ep (snd st').
Proof.
  intros.
  eapply ep_wellformed; only 2 : eauto.
  intros; eapply H. clear H.
  induction exts.
  - auto.
  - simpl in H1. rewrite Reflect.andE in H1. destruct H1.
    assert (~(in_scope p a)). {
      remember (ep_paths ep) as ps.
      clear -H H2.
      induction ps.
      - auto.
      - simpl in H. rewrite Reflect.andE in H. destruct H.
        simpl in H2. rewrite Reflect.orE in H2. destruct H2.
        + pose proof disjoint_spec.
          hauto b: on.
        + auto.
    }
    assert (~(in_scopes p exts)). {
      auto.
    }
    clear -H3 H4.
    hauto b: on.
Qed.

Lemma hoare_func_frame_intro : forall ge p a_arg a_mem a_ext func targs vars exts ext_rs a_mem' a_ext',
  func_modifies_vars ge p func vars ->
  func_modifies_exts ge p func exts ->
  force (fun _ => []) (option_map exclude vars) a_mem = a_mem' ->
  ext_exclude exts a_ext ext_rs = a_ext' ->
  hoare_func_frame ge p (ARG a_arg (MEM a_mem (EXT a_ext))) func targs (MEM a_mem' (EXT a_ext')).
Proof.
  unfold func_modifies_vars, func_modifies_exts, hoare_func_frame; intros.
  destruct st; destruct st'.
  split.
  - clear -H H1 H3 H4.
    destruct vars as [vars | ].
    2 : { subst; constructor. }
    specialize (H _ _  _ _ _ _ H4).
    destruct H3 as [_ []].
    generalize dependent a_mem'.
    induction a_mem; intros.
    + subst. constructor.
    + simpl in H1. destruct a as [p' ?]. destruct (in_dec path_eq_dec p' vars) as [H_In | H_In].
      * subst; simpl. apply IHa_mem; auto.
        inv H0; auto.
      * subst; simpl. constructor.
        ++simpl in H; simpl.
          rewrite <- H by auto.
          inv H0; auto.
        ++apply IHa_mem; auto.
          inv H0; auto.
  - clear -H0 H2 H3 H4.
    generalize dependent a_ext'.
    specialize (H0 _ _  _ _ _ _ H4).
    destruct H3 as [_ []].
    induction ext_rs; intros.
    + subst. constructor.
    + simpl in H2. destruct r as [H_disjoint | _].
      * subst; split.
        ++eapply (modifies_exts_disjoint _ _ _ _ H0 (proj1 H1)).
          auto.
        ++apply IHext_rs.
        { apply H1. }
        { reflexivity. }
      * apply IHext_rs.
        { apply H1. }
        { apply H2. }
Qed.

Inductive func_post_combine : assertion -> arg_ret_assertion -> arg_ret_assertion -> Prop :=
  | func_post_combine_base : forall f_mem f_ext a_arg a_ret a_mem a_ext,
      func_post_combine
        (MEM f_mem (EXT f_ext))
        (ARG_RET a_arg a_ret (MEM a_mem (EXT a_ext)))
        (ARG_RET a_arg a_ret (MEM (f_mem ++ a_mem) (EXT (f_ext ++ a_ext))))
  | func_post_combine_ex : forall [A] F (P : A -> arg_ret_assertion) Q,
      (forall (x : A), func_post_combine F (P x) (Q x)) ->
      func_post_combine F (arg_ret_exists P) (arg_ret_exists Q).

Lemma func_post_combine_sound : forall outargs retv st F P Q,
  func_post_combine F P Q ->
  F st ->
  P outargs retv st ->
  Q outargs retv st.
Proof.
  intros. induction H.
  - destruct H1 as [? []].
    split; eauto.
    split; eauto.
    destruct st; split.
    + apply AssertionLang.mem_denote_app. sfirstorder.
    + apply AssertionLang.ext_denote_app. sfirstorder.
  - destruct H1.
    eexists; eauto.
Qed.

Lemma func_spec_combine : forall ge p pre pre' func targs post post' frame,
  arg_implies pre pre' ->
  hoare_func ge p pre' func targs post' ->
  hoare_func_frame ge p pre func targs frame ->
  func_post_combine frame post' post ->
  hoare_func ge p pre func targs post.
Proof.
  unfold hoare_func; intros.
  specialize (H _ _ H3).
  epose proof (H0 _ _ _ _ _ ltac:(eassumption) ltac:(eassumption)).
  destruct sig; only 1, 3, 4 : solve [inv H5].
  eapply (func_post_combine_sound _ _ _ _ _ _ H2); eauto.
Qed.

Lemma func_spec_combine' : forall ge p pre_arg pre_mem pre_ext pre_arg' pre_mem' pre_ext' func targs post vars exts ext_rs post' f_mem f_ext,
  fundef_satisfies_hoare ge p func targs
    (fsh_base (ARG pre_arg' (MEM pre_mem' (EXT pre_ext'))) post')
    /\ func_modifies ge p func vars exts ->
  arg_implies (ARG pre_arg (MEM pre_mem (EXT pre_ext))) (ARG pre_arg' (MEM pre_mem' (EXT pre_ext'))) ->
  force (fun _ => []) (option_map exclude vars) pre_mem = f_mem ->
  ext_exclude exts pre_ext ext_rs = f_ext ->
  func_post_combine (MEM f_mem (EXT f_ext)) post' post ->
  hoare_func ge p (ARG pre_arg (MEM pre_mem (EXT pre_ext))) func targs post.
Proof.
  intros.
  destruct H.
  eapply func_spec_combine; eauto.
  eapply hoare_func_frame_intro; eauto.
  - destruct vars.
    + unfold func_modifies_vars; simpl; intros.
      refine (proj1 (H4 _ _ _ _ _ _ _) _ _); eauto.
    + unfold func_modifies_vars; simpl; auto.
  - unfold func_modifies_exts, modifies_exts; intros.
    refine (proj2 (H4 _ _ _ _ _ _ _) _ _); eauto.
Qed.

End FuncSpec.

Declare Scope func_spec.
Delimit Scope func_spec with func_spec.
Declare Scope func_hoare.
Delimit Scope func_hoare with func_hoare.

Notation "'WITH' , P " :=
  (fs_base P%func_spec) (at level 65, right associativity) : func_spec.

Notation "'WITH' x .. y , P " :=
  (fs_bind (fun x => .. (fs_bind (fun y => fs_base P%func_spec)) ..)) (at level 65, x binder, y binder, right associativity) : func_spec.

Notation "'PATH' p 'MOD' vars exts body" :=
  (mk_func_spec p body%func_hoare vars exts) (at level 64, vars at level 0, exts at level 0) : func_spec.

Notation "'WITH' , 'PRE' pre 'POST' post" :=
  (fsh_base pre post) (at level 63, right associativity) : func_hoare.

Notation "'WITH' x .. y , 'PRE' pre 'POST' post" :=
  (fsh_bind (fun x => .. (fsh_bind (fun y => fsh_base pre post)) ..)) (at level 63, x binder, y binder, right associativity) : func_hoare.