Require Import RamifyCoq.msl_ext.log_normalize.
Require Import RamifyCoq.msl_ext.iter_sepcon.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.EnumEnsembles.
Require Import RamifyCoq.lib.List_ext.
Require Import VST.msl.base.
Require Import VST.msl.simple_CCC.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.msl.Coqlib2.
Require Import VST.msl.ramification_lemmas.

Local Open Scope logic.

Section Ramification_P.

Context {A Env : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.
Context {CoSL: CorableSepLog A}.

Variable M: Env -> Env -> Prop.
Context {EqM: Equivalence M}.

(* Definition EnvironBox (P: Env -> A) : Env -> A := *)
(*   fun rho: Env => (ALL rho': Env, !! M rho rho' --> P rho'). *)

Definition EnvironStable (P: Env -> A) : Prop :=
  forall rho rho', M rho rho' -> P rho = P rho'.

Lemma EnvironStable_sepcon: forall P Q,
  EnvironStable P ->
  EnvironStable Q ->
  EnvironStable (P * Q).
Proof.
  unfold EnvironStable.
  intros.
  specialize (H _ _ H1).
  specialize (H0 _ _ H1).
  simpl.
  f_equal; auto.
Qed.

(*
Lemma EnvironBox_EnvironStable: forall P, EnvironStable (EnvironBox P).
(* This lemma is the reason why EqM is required. *)
Proof.
  intros.
  unfold EnvironBox, EnvironStable; intros.
  apply pred_ext; apply allp_right; intro rho''; apply (allp_left _ rho'');
  apply imp_andp_adjoint; normalize; rewrite prop_imp; auto.
  + rewrite H; auto.
  + rewrite <- H; auto.
Qed.

Lemma EnvironBox_T: forall P, EnvironBox P |-- P.
Proof.
  intros P rho.
  apply (allp_left _ rho).
  rewrite prop_imp by reflexivity.
  auto.
Qed.

Lemma EnvironBox_derives: forall P Q, P |-- Q -> EnvironBox P |-- EnvironBox Q.
Proof.
  intros P Q ? rho.
  apply allp_right; intro rho'.
  apply (allp_left _ rho').
  apply imp_andp_adjoint.
  apply derives_extract_prop'; intro.
  rewrite prop_imp by auto.
  auto.
Qed.

Lemma EnvironBox_sepcon: forall P Q, EnvironBox P * EnvironBox Q |-- EnvironBox (P * Q).
Proof.
  intros.
  unfold EnvironBox; simpl; intro rho.
  apply allp_right; intro rho'.
  apply imp_andp_adjoint; normalize.
  apply sepcon_derives; apply (allp_left _ rho');
  rewrite prop_imp by auto; auto.
Qed.

Lemma EnvironBox_andp: forall P Q, EnvironBox (P && Q) = EnvironBox P && EnvironBox Q.
Proof.
  intros.
  unfold EnvironBox; apply pred_ext; simpl; intro rho.
  + apply andp_right.
    - apply allp_right; intro rho'.
      apply -> imp_andp_adjoint; normalize.
      apply (allp_left _ rho');
      rewrite prop_imp by auto.
      apply andp_left1; auto.
    - apply allp_right; intro rho'.
      apply -> imp_andp_adjoint; normalize.
      apply (allp_left _ rho');
      rewrite prop_imp by auto.
      apply andp_left2; auto.
  + apply allp_right; intro rho'.
    apply -> imp_andp_adjoint; normalize.
    apply andp_derives; apply (allp_left _ rho');
    rewrite prop_imp by auto; auto.
Qed.

Lemma EnvironStable_allp: forall {T} P, (forall a: T, EnvironStable (P a)) -> EnvironStable (allp P).
Proof.
  intros.
  unfold EnvironStable in *.
  intros.
  simpl.
  apply allp_congr; intro a.
  apply H; auto.
Qed.

Lemma EnvironBox_TT: EnvironBox TT = TT.
Proof.
  intros.
  apply pred_ext.
  + apply TT_right.
  + unfold EnvironBox; intro rho.
    apply allp_right; intro rho'.
    apply imp_andp_adjoint.
    simpl; apply TT_right.
Qed.

Lemma EnvironStable_EnvironBox: forall P, EnvironStable P -> EnvironBox P = P.
Proof.
  intros.
  apply pred_ext; [apply EnvironBox_T |].
  unfold EnvironBox; intro rho.
  apply allp_right; intro rho'.
  apply imp_andp_adjoint; normalize.
  rewrite (H _ _ H0).
  auto.
Qed.

Lemma sepcon_EnvironBox_weaken: forall P Q R R', R |-- R' -> P |-- Q * EnvironBox R -> P |-- Q * EnvironBox R'.
Proof.
  intros.
  eapply derives_trans; [apply H0 |].
  apply sepcon_derives; auto.
  apply EnvironBox_derives; auto.
Qed.

Lemma EnvironBox_corable: forall P, corable P -> corable (EnvironBox P).
Proof.
  intros.
  simpl in H |- *.
  intro.
  unfold EnvironBox.
  auto.
Qed.

Lemma solve_ramify_P: forall (g l g' l' F: Env -> A),
  EnvironStable F ->
  g |-- l * F ->
  F * l' |-- g' ->
  g |-- l * EnvironBox (l' -* g').
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  unfold EnvironBox; simpl; intros rho.
  apply allp_right; intro rho'.
  apply imp_andp_adjoint.
  normalize.
  rewrite (H rho rho' H2).
  apply wand_sepcon_adjoint.
  apply H1.
Qed.

Lemma ramify_P_frame: forall g l g' l' F,
  EnvironStable F ->
  g |-- l * EnvironBox (l' -* g') ->
  g * F |-- l * EnvironBox (l' -* g' * F).
Proof.
  intros.
  apply solve_ramify_P with (EnvironBox (l' -* g') * F).
  + apply EnvironStable_sepcon; auto.
    apply EnvironBox_EnvironStable.
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; auto.
  + rewrite (sepcon_comm _ l'), <- sepcon_assoc.
    apply sepcon_derives; [| auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    apply EnvironBox_T.
Qed.

Lemma split_ramify_P: forall g1 g2 l1 l2 g1' g2' l1' l2',
  g1 |-- l1 * EnvironBox (l1' -* g1') ->
  g2 |-- l2 * EnvironBox (l2' -* g2') ->
  g1 * g2 |-- (l1 * l2) * EnvironBox (l1' * l2' -* g1' * g2').
Proof.
  intros.
  apply solve_ramify_P with (EnvironBox (l1' -* g1') * EnvironBox (l2' -* g2')).
  + apply EnvironStable_sepcon;
    apply EnvironBox_EnvironStable.
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + apply wand_sepcon_adjoint.
    eapply derives_trans; [apply EnvironBox_sepcon |].
    eapply derives_trans; [apply EnvironBox_T |].
    apply wand_sepcon_wand.
Qed.

Lemma go_lower_ramify_P: forall (g l g' l': A),
  g |-- l * (l' -* g') ->
  @Basics.const A Env g |-- Basics.const l * EnvironBox (Basics.const l' -* Basics.const g').
Proof.
  intros.
  intro rho; unfold EnvironBox, Basics.const; simpl.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply allp_right; intro rho'.
  apply imp_andp_adjoint.
  apply andp_left1.
  auto.
Qed.

Lemma ramify_PQ_reduce0: forall {B} g l (g' l': B -> Env -> A),
  g |-- l * EnvironBox (allp (l' -* g')) ->
  g |-- l * EnvironBox (exp l' -* exp g').
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply EnvironBox_derives.
  apply wand_sepcon_adjoint.
  rewrite exp_sepcon2.
  apply exp_left; intro x; apply (exp_right x).
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  auto.
Qed.

Lemma ramify_PQ_reduce1: forall {B} g l g0 l0 (g' l': B -> Env -> A),
  corable l0 ->
  g0 |-- l0 ->
  g |-- l * EnvironBox (allp (l' -* g')) ->
  g0 && g |-- (l0 && l) * EnvironBox (allp (l' -* g')).
Proof.
  intros.
  rewrite corable_andp_sepcon1 by auto.
  apply andp_derives; auto.
Qed.

Lemma ramify_PQ_reduce2: forall {B} g l g0 g' l' g0',
  corable g0 ->
  EnvironStable g0 ->
  (forall x: B, g0 |-- g0' x) ->
  g |-- l * EnvironBox (allp (l' -* g')) ->
  g0 && g |-- l * EnvironBox (allp (l' -* g0' && g')).
Proof.
  intros.
  eapply derives_trans; [apply andp_derives; [apply derives_refl | apply H2] |].
  rewrite <- corable_sepcon_andp1 by auto.
  apply sepcon_derives; [auto |].
  rewrite <- (EnvironStable_EnvironBox g0) at 1 by auto.
  rewrite <- EnvironBox_andp.
  apply EnvironBox_derives.
  apply allp_right; intro x.
  rewrite (andp_comm g0).
  apply imp_andp_adjoint.
  apply (allp_left _ x).
  apply imp_andp_adjoint.
  apply wand_sepcon_adjoint.
  rewrite corable_andp_sepcon2 by auto.
  change ((g0' && g') x) with (g0' x && g' x).
  change ((l' -* g') x) with (l' x -* g' x).
  apply andp_derives; auto.
  apply wand_sepcon_adjoint.
  auto.
Qed.

Lemma ramify_PQ_reduce3: forall {B} g l g' l' g0 l0 p,
  (forall x: B, corable (l0 x)) ->
  (forall x: B, l0 x |-- g0 x) ->
  (forall x: B, l0 x |-- p x) ->
  g |-- l * EnvironBox (allp (p --> (l' -* g'))) ->
  g |-- l * EnvironBox (allp (l0 && l' -* g0 && g')).
Proof.
  intros.
  apply derives_trans with (l * EnvironBox (allp (p --> (l' -* g')))).
  + auto.
  + apply sepcon_derives; auto.
    apply EnvironBox_derives.
    apply allp_right; intro x.
    apply (allp_left _ x).
    change ((l0 && l' -* g0 && g') x) with (l0 x && l' x -* g0 x && g' x).
    change ((p --> (l' -* g')) x) with (p x --> (l' x -* g' x)).
    apply wand_sepcon_adjoint.
    rewrite sepcon_comm, corable_andp_sepcon1, <- corable_sepcon_andp1 by auto.
    eapply derives_trans; [apply sepcon_derives; [apply derives_refl |] |].
    - apply andp_right; [apply andp_left1; apply derives_refl |].
      eapply derives_trans; [apply andp_derives; [apply H1 | apply derives_refl] |].
      apply modus_ponens.
    - rewrite corable_sepcon_andp1 by auto.
      apply andp_derives; auto.
      apply modus_ponens_wand.
Qed.

Lemma solve_ramify_PQ: forall {B} g l p g' l' F,
  EnvironStable F ->
  (forall x: B, corable (p x)) ->
  g |-- l * F ->
  (forall x: B, p x && (F * l' x) |-- g' x) ->
  g |-- l * EnvironBox (allp (p --> (l' -* g'))).
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  unfold EnvironBox; simpl; intros rho.
  apply allp_right; intro rho'.
  apply imp_andp_adjoint.
  normalize.
  rewrite (H rho rho' H3).
  clear rho H3; rename rho' into rho.
  apply allp_right; intro x.
  apply imp_andp_adjoint, wand_sepcon_adjoint.
  rewrite corable_andp_sepcon2 by apply (H0 x rho).
  apply (H2 x rho).
Qed.

Lemma ramify_PQ_frame: forall {B} g l p g' l' F,
  EnvironStable F ->
  (forall x: B, corable (p x)) ->
  g |-- l * EnvironBox (allp (p --> (l' -* g'))) ->
  g * F |-- l * EnvironBox (allp (p --> (l' -* g' * Basics.const F))).
Proof.
  intros.
  eapply derives_trans with (l * EnvironBox (allp (p --> (l' -* g'))) * F).
  + apply sepcon_derives; auto.
  + rewrite sepcon_assoc.
    apply sepcon_derives; auto.
    rewrite <- (EnvironStable_EnvironBox F) at 1 by auto.
    eapply derives_trans; [apply EnvironBox_sepcon |].
    apply EnvironBox_derives.
    apply allp_right; intro x.
    apply wand_sepcon_adjoint.
    apply (allp_left _ x).
    apply wand_sepcon_adjoint.
    change ((p --> (l' -* g' * Basics.const F)) x) with (p x --> (l' x -* g' x * F)).
    change ((p --> (l' -* g')) x) with (p x --> (l' x -* g' x)).
    apply imp_andp_adjoint.
    rewrite andp_comm, <- corable_andp_sepcon1 by auto.
    apply wand_sepcon_adjoint.
    eapply derives_trans; [apply modus_ponens |].
    rewrite wand_wand_comm.
    apply wand_derives; auto.
    apply wand_sepcon_adjoint; auto.
Qed.

Lemma split_ramify_PQ: forall {B} g1 g2 l1 l2 p g1' g2' l1' l2',
  (forall x: B, corable (p x)) ->
  g1 |-- l1 * EnvironBox (allp (p --> (l1' -* g1'))) ->
  g2 |-- l2 * EnvironBox (allp (p --> (l2' -* g2'))) ->
  g1 * g2 |-- (l1 * l2) * EnvironBox (allp (p --> (l1' * l2' -* g1' * g2'))).
Proof.
  intros.
  apply solve_ramify_PQ with (EnvironBox (allp (p --> (l1' -* g1'))) * EnvironBox (allp (p --> (l2' -* g2')))).
  + apply EnvironStable_sepcon;
    apply EnvironBox_EnvironStable.
  + auto.
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + intros x.
    change ((l1' * l2') x) with (l1' x * l2' x).
    rewrite <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l1' x)), (sepcon_comm _ (l1' x)), <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l2' x)).
    rewrite <- (andp_dup (p x)), andp_assoc.
    rewrite <- corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
    rewrite <- !corable_sepcon_andp1 by auto.
    apply sepcon_derives.
    - apply wand_sepcon_adjoint; (eapply derives_trans; [apply EnvironBox_T |]).
      apply (allp_left _ x).
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      (eapply derives_trans; [apply sepcon_derives; [simpl; intros; apply modus_ponens | apply derives_refl] |]).
      apply wand_sepcon_adjoint; apply derives_refl.
    - apply wand_sepcon_adjoint; (eapply derives_trans; [apply EnvironBox_T |]).
      apply (allp_left _ x).
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      (eapply derives_trans; [apply sepcon_derives; [simpl; intros; apply modus_ponens | apply derives_refl] |]).
      apply wand_sepcon_adjoint; apply derives_refl.
Qed.

Lemma go_lower_ramify_PQ: forall {B} g l (p g' l': B -> A),
  g |-- l * (allp (p --> (l' -* g'))) ->
  Basics.const g |-- Basics.const l *
    EnvironBox (allp ((fun (x: B) (rho: Env) => p x) -->
      ((fun x _ => l' x) -* (fun x _ => g' x)))).
Proof.
  intros.
  intro rho; unfold EnvironBox, Basics.const; simpl.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply allp_right; intro rho'.
  apply imp_andp_adjoint.
  apply andp_left1.
  auto.
Qed.

Lemma reduce_frame_from_ramification: forall F Q, EnvironStable F -> F |-- EnvironBox (Q -* Q * F).
Proof.
  intros.
  unfold EnvironBox.
  simpl; intros rho.
  apply allp_right; intros rho'.
  apply imp_andp_adjoint.
  normalize.
  apply wand_sepcon_adjoint.
  rewrite sepcon_comm.
  specialize (H _ _ H0).
  rewrite H.
  auto.
Qed.
*)
End Ramification_P.

(*

Lemma EnvironBox_allp: forall {A B Env : Type} {ND : NatDed A} (M: Env -> Env -> Prop) P, EnvironBox M (@allp _ _ B P) = ALL x: B, (EnvironBox M (P x)).
Proof.
  intros.
  unfold EnvironBox; apply pred_ext; simpl; intro rho.
  + apply allp_right; intro b.
    apply allp_right; intro rho'.
    apply imp_andp_adjoint; normalize.
    apply (allp_left _ rho').
    rewrite prop_imp by auto.
    apply (allp_left _ b).
    auto.
  + apply allp_right; intro rho'.
    apply imp_andp_adjoint; normalize.
    apply allp_right; intro b.
    apply (allp_left _ b).
    apply (allp_left _ rho').
    rewrite prop_imp by auto.
    auto.
Qed.

Lemma EnvironBox_weaken: forall {A Env : Type} {ND : NatDed A} (M1 M2: Env -> Env -> Prop) P, inclusion _ M1 M2 -> EnvironBox M2 P |-- EnvironBox M1 P.
Proof.
  intros.
  unfold EnvironBox.
  intro rho.
  apply allp_right; intro rho'.
  apply (allp_left _ rho').
  apply imp_andp_adjoint.
  apply derives_extract_prop'; intro.
  rewrite prop_imp by auto.
  auto.
Qed.

Lemma EnvironBox_EnvironStable_weaken: forall {A Env : Type} {ND : NatDed A} (M1 M2: Env -> Env -> Prop) {EqM2: Equivalence M2} P, inclusion _ M1 M2 -> EnvironStable M1 (EnvironBox M2 P).
(* This lemma is the reason why EqM is required. *)
Proof.
  intros.
  unfold EnvironBox, EnvironStable; intros.
  apply pred_ext; apply allp_right; intro rho''; apply (allp_left _ rho'');
  apply imp_andp_adjoint; normalize; rewrite prop_imp; auto.
  + apply H in H0.
    rewrite H0; auto.
  + apply H in H0.
    rewrite <- H0; auto.
Qed.

*)

Ltac solve_ramify_Q_with Fr :=
  match goal with
  | |- @derives ?Pred _ ?g (?l * @allp ?Pred _ ?T ?Func) =>
      let p := fresh "p" in evar (p: T -> Pred);
      let g' := fresh "g'" in evar (g': T -> Pred);
      let l' := fresh "l'" in evar (l': T -> Pred);
      let x := fresh "x" in
      let H := fresh "H" in
      assert (Func = p --> (l' -* g'));
      [
        extensionality x; cbv beta;
        match goal with
        | |- ?P --> (?L' -* ?G') = _ =>
             super_pattern P x; super_pattern L' x; super_pattern G' x
        end;
        match goal with
        | |- ?P _ --> (?L' _ -* ?G' _) = _ =>
             instantiate (1 := P) in (Value of p);
             instantiate (1 := L') in (Value of l');
             instantiate (1 := G') in (Value of g')
        end;
        subst p g' l';
        reflexivity
      | subst p g' l'; rewrite H; clear H]
  end;
  apply RAMIF_Q'.solve with Fr.

Section Ramification_PredSepCon.

(******************************************

The purpose of these lemmas are specifying ramification premises, such that
spatial predicates and items (or pure predicates) can be modified from the
left side to the right side.

However, the frame part should be part-wise equivalent, i.e. spatial predicates
must be equivalent and items (or pure predicates) must be equivalent. E.g.
F = G and a = b is acceptable but only F a = G b is not. To prove a ramification
premise of latter situation should use iter_sepcon_map/pred_sepcon_map first.

******************************************)

Context {A : Type}.
Context {B : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.
Context {ClS: ClassicalSep A}.
Context {CoSL: CorableSepLog A}.

(******************************************

Ramification Premises with iter_sepcon

******************************************)

Lemma iter_sepcon_ramif_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (P': T -> B -> A) (g: list B) (g': T -> list B) (x: B) (x': T -> B),
  (exists f,
    Permutation g (x :: f) /\
    (forall a, Pure a -> Permutation (g' a) (x' a :: f)) /\
    (forall a, Pure a -> forall x, In x f -> P x = (P' a) x)) ->
  iter_sepcon g P |-- P x *
    (ALL a: T, !! Pure a -->
      ((P' a) (x' a) -* iter_sepcon (g' a) (P' a))).
Proof.
  intros.
  destruct H as [f [? [? ?]]].
  RAMIF_Q'.formalize.
  apply RAMIF_Q'.solve with (iter_sepcon f P).
  + simpl; auto.
  + rewrite H; simpl; auto.
  + intros a; normalize.
    specialize (H0 _ H2).
    specialize (H1 _ H2).
    rewrite H0.
    rewrite sepcon_comm.
    apply derives_refl'; simpl; f_equal.
    apply iter_sepcon_func_strong; auto.
Qed.

Lemma iter_sepcon_ramif_xQ: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (P': T -> B -> A) (g l: list B) (g' l': T -> list B),
  (exists f,
    Permutation g (l ++ f) /\
    (forall a, Pure a -> Permutation (g' a) (l' a ++ f)) /\
    (forall a, Pure a -> forall x, In x f -> P x = (P' a) x)) ->
  iter_sepcon g P |-- iter_sepcon l P *
    (ALL a: T, !! Pure a -->
      (iter_sepcon (l' a) (P' a) -* iter_sepcon (g' a) (P' a))).
Proof.
  intros.
  destruct H as [f [? [? ?]]].
  RAMIF_Q'.formalize.
  apply RAMIF_Q'.solve with (iter_sepcon f P).
  + simpl; auto.
  + rewrite H.
    apply derives_refl'.
    apply iter_sepcon_app_sepcon.
  + intros a; normalize.
    specialize (H0 _ H2).
    specialize (H1 _ H2).
    rewrite H0.
    rewrite sepcon_comm.
    apply derives_refl'.
    rewrite iter_sepcon_app_sepcon; f_equal.
    apply iter_sepcon_func_strong; auto.
Qed.

Lemma iter_sepcon_ramif_item_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (g: list B) (g': T -> list B) (x: B) (x': T -> B),
  (exists f,
    Permutation g (x :: f) /\
    (forall a, Pure a -> Permutation (g' a) (x' a :: f))) ->
  iter_sepcon g P |-- P x *
    (ALL a: T, !! Pure a -->
      (P (x' a) -* iter_sepcon (g' a) P)).
Proof.
  intros.
  apply (iter_sepcon_ramif_1Q Pure P (fun _ => P)).
  destruct H as [f [? ?]].
  exists f; split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_item_xQ: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (g l: list B) (g' l': T -> list B),
  (exists f,
    Permutation g (l ++ f) /\
    (forall a, Pure a -> Permutation (g' a) (l' a ++ f))) ->
  iter_sepcon g P |-- iter_sepcon l P *
    (ALL a: T, !! Pure a -->
      (iter_sepcon (l' a) P -* iter_sepcon (g' a) P)).
Proof.
  intros.
  apply (iter_sepcon_ramif_xQ Pure P (fun _ => P)).
  destruct H as [f [? ?]].
  exists f; split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_pred_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (P': T -> B -> A) (g: list B) (x: B),
  (exists f,
    Permutation g (x :: f) /\
    (forall a, Pure a -> forall x, In x f -> P x = (P' a) x)) ->
  iter_sepcon g P |-- P x *
    (ALL a: T, !! Pure a -->
      ((P' a) x -* iter_sepcon g (P' a))).
Proof.
  intros.
  apply (iter_sepcon_ramif_1Q _ _ _ g (fun _ => g) x (fun _ => x)).
  destruct H as [f [? ?]].
  exists f; split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_pred_xQ: forall {T: Type} (Pure: T -> Prop) (P: B -> A) (P': T -> B -> A) (g l: list B),
  (exists f,
    Permutation g (l ++ f) /\
    (forall a, Pure a -> forall x, In x f -> P x = (P' a) x)) ->
  iter_sepcon g P |-- iter_sepcon l P *
    (ALL a: T, !! Pure a -->
      (iter_sepcon l (P' a) -* iter_sepcon g (P' a))).
Proof.
  intros.
  apply (iter_sepcon_ramif_xQ _ _ _ g l (fun _ => g) (fun _ => l)).
  destruct H as [f [? ?]].
  exists f; split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_1: forall P P' (g g': list B) (x x': B),
  (exists f,
    Permutation g (x :: f) /\
    Permutation g' (x' :: f) /\
    (forall x, In x f -> P x = P' x)) ->
  iter_sepcon g P |-- P x * (P' x' -* iter_sepcon g' P').
Proof.
  intros.
  pose proof iter_sepcon_ramif_1Q (fun x: unit => True) P (fun _ => P') g (fun _ => g') x (fun _ => x').
  rewrite allp_unit in H0.
  rewrite prop_imp in H0 by auto.
  apply H0.
  destruct H as [f [? [? ?]]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_x: forall P P' (g g' l l': list B),
  (exists f,
    Permutation g (l ++ f) /\
    Permutation g' (l' ++ f) /\
    (forall x, In x f -> P x = P' x)) ->
  iter_sepcon g P |-- iter_sepcon l P * (iter_sepcon l' P' -* iter_sepcon g' P').
Proof.
  intros.
  pose proof iter_sepcon_ramif_xQ (fun x: unit => True) P (fun _ => P') g l (fun _ => g') (fun _ => l').
  rewrite allp_unit in H0.
  rewrite prop_imp in H0 by auto.
  apply H0.
  destruct H as [f [? [? ?]]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_item_1: forall P (g g': list B) (x x': B),
  (exists f,
    Permutation g (x :: f) /\
    Permutation g' (x' :: f)) ->
  iter_sepcon g P |-- P x * (P x' -* iter_sepcon g' P).
Proof.
  intros.
  apply iter_sepcon_ramif_1.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_item_x: forall P (g g' l l': list B),
  (exists f,
    Permutation g (l ++ f) /\
    Permutation g' (l' ++ f)) ->
  iter_sepcon g P |-- iter_sepcon l P * (iter_sepcon l' P -* iter_sepcon g' P).
Proof.
  intros.
  apply iter_sepcon_ramif_x.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_pred_1: forall P P' (g: list B) (x: B),
  (exists f,
    Permutation g (x :: f) /\
    (forall x, In x f -> P x = P' x)) ->
  iter_sepcon g P |-- P x * (P' x -* iter_sepcon g P').
Proof.
  intros.
  apply iter_sepcon_ramif_1.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; intros; auto.
Qed.

Lemma iter_sepcon_ramif_stable_1: forall P (g: list B) (x: B),
    In x g -> iter_sepcon g P |-- P x * (P x -* iter_sepcon g P).
Proof.
  intros. apply In_Permutation_cons in H. destruct H as [f ?].
  apply iter_sepcon_ramif_pred_1. exists f. split; [assumption|intros; reflexivity].
Qed.

Lemma iter_sepcon_ramif_pred_x: forall P P' (g l: list B),
  (exists f,
    Permutation g (l ++ f) /\
    (forall x, In x f -> P x = P' x)) ->
  iter_sepcon g P |-- iter_sepcon l P * (iter_sepcon l P' -* iter_sepcon g P').
Proof.
  intros.
  apply iter_sepcon_ramif_x.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; intros; auto.
Qed.

(******************************************

Ramification Premises with pred_sepcon

******************************************)

(* A better way to prove it is using RAMIF_Q'.solve and sepcon properties of pred_sepcon.
Unfolding into iter_sepcon needs handling quatifiers, which is in convenient. The following
proof script only shows that it is doable. *)
Lemma pred_sepcon_ramif_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> Prop) (P': T -> B -> Prop) (p: B -> A) (p': T -> B -> A) (x: B) (x' : T -> B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    (forall a, Pure a -> Prop_join (eq (x' a)) Pf (P' a)) /\
    (forall a, Pure a -> (forall y, Pf y -> p y = (p' a) y))) ->
  pred_sepcon P p |-- p x *
    (ALL a: T, !! Pure a -->
      ((p' a) (x' a) -* pred_sepcon (P' a) (p' a))).
Proof.
  intros.
  unfold pred_sepcon.
  normalize; intros; normalize; rename x0 into g.
  destruct H as [Pf [? [? ?]]].
  destruct (Permutation_spec_Prop_join g P Pf x H (conj H0 H1)) as [f [? [? ?]]].
  evar (pp : T -> A). evar (ll: T -> A). evar (gg: list B -> T -> A).
  assert ((fun a : T =>
   !! Pure a -->
   (p' a (x' a) -*
    (EX l : list B,
            !! (forall x0 : B, In x0 l <-> P' a x0) && !! NoDup l && iter_sepcon l (p' a)))) = (pp --> (ll -* exp gg))). {
    extensionality x0.
    super_pattern (!! Pure x0) x0. super_pattern (p' x0 (x' x0)) x0.
    super_pattern (fun l => !! (forall x1 : B, In x1 l <-> P' x0 x1) && !! NoDup l && iter_sepcon l (p' x0)) x0.
    instantiate (1 := (fun t : T => !! Pure t)) in (Value of pp).
    instantiate (1 := (fun t : T => p' t (x' t))) in (Value of ll).
    instantiate (1 := (fun (l : list B) (t : T) => !! (forall x1 : B, In x1 l <-> P' t x1) && !! NoDup l && iter_sepcon l (p' t))) in (Value of gg).
    subst pp gg ll. reflexivity.
  }
  subst pp gg ll. rewrite H7. clear H7.
  apply (RAMIF_Q'.exp_right (fun a => x' a :: f)); [simpl; auto |].
  pose proof iter_sepcon_ramif_1Q Pure p p' g (fun a => x' a :: f) x x'.
  spec H7; [clear H7 |].
  + exists f.
    split; auto.
    split; intros.
    - reflexivity.
    - apply (H3 _ H7).
      rewrite <- H5; auto.
  + eapply derives_trans; [exact H7 |]; clear H7.
    apply sepcon_derives; auto.
    apply allp_right; intros a.
    apply (allp_left _ a).
    simpl.
    apply imp_andp_adjoint; normalize.
    unfold TT; rewrite prop_imp by auto.
    apply wand_derives; auto.
    apply andp_right; auto.
    specialize (H2 _ H7).
    specialize (H3 _ H7).
    apply andp_right; apply prop_right.
    - intro y.
      rewrite H5.
      destruct H2 as [? _].
      symmetry; apply H2.
    - apply NoDup_cons; auto.
      destruct H2 as [_ ?].
      specialize (H2 (x' a) eq_refl).
      rewrite H5; auto.
Qed.

Lemma pred_sepcon_ramif_xQ: forall {T: Type} (Pure: T -> Prop) (G L: B -> Prop) (L' G': T -> B -> Prop) (p: B -> A) (p': T -> B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    (forall a, Pure a -> Prop_join (L' a) Pf (G' a)) /\
    (forall a, Pure a -> (forall y, Pf y -> p y = (p' a) y))) ->
  pred_sepcon G p |-- pred_sepcon L p *
    (ALL a: T, !! Pure a -->
      (pred_sepcon (L' a) (p' a) -* pred_sepcon (G' a) (p' a))).
Proof.
  intros.
  destruct H as [Pf [? [? ?]]].
  RAMIF_Q'.formalize.
  apply RAMIF_Q'.solve with (pred_sepcon Pf p).
  + simpl; auto.
  + apply derives_refl'; symmetry.
    apply pred_sepcon_sepcon; auto.
  + intros.
    normalize.
    specialize (H0 _ H2).
    specialize (H1 _ H2).
    apply derives_refl'.
    rewrite (pred_sepcon_strong_proper Pf Pf p (p' x)) by (auto; intros; tauto).
    rewrite sepcon_comm; apply pred_sepcon_sepcon; auto.
Qed.

Lemma pred_sepcon_ramif_pred_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> Prop) (p: B -> A) (p': T -> B -> A) (x: B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    (forall a, Pure a -> (forall y, Pf y -> p y = (p' a) y))) ->
  pred_sepcon P p |-- p x *
    (ALL a: T, !! Pure a -->
      ((p' a) x -* pred_sepcon P (p' a))).
Proof.
  intros.
  apply pred_sepcon_ramif_1Q.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_pred_xQ: forall {T: Type} (Pure: T -> Prop) (G L: B -> Prop) (p: B -> A) (p': T -> B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    (forall a, Pure a -> (forall y, Pf y -> p y = (p' a) y))) ->
  pred_sepcon G p |-- pred_sepcon L p *
    (ALL a: T, !! Pure a -->
      (pred_sepcon L (p' a) -* pred_sepcon G (p' a))).
Proof.
  intros.
  apply pred_sepcon_ramif_xQ.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_item_1Q: forall {T: Type} (Pure: T -> Prop) (P: B -> Prop) (P': T -> B -> Prop) (p: B -> A) (x: B) (x' : T -> B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    (forall a, Pure a -> Prop_join (eq (x' a)) Pf (P' a))) ->
  pred_sepcon P p |-- p x *
    (ALL a: T, !! Pure a -->
      (p (x' a) -* pred_sepcon (P' a) p)).
Proof.
  intros.
  apply pred_sepcon_ramif_1Q.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_item_xQ: forall {T: Type} (Pure: T -> Prop) (G L: B -> Prop) (L' G': T -> B -> Prop) (p: B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    (forall a, Pure a -> Prop_join (L' a) Pf (G' a))) ->
  pred_sepcon G p |-- pred_sepcon L p *
    (ALL a: T, !! Pure a -->
      (pred_sepcon (L' a) p -* pred_sepcon (G' a) p)).
Proof.
  intros.
  apply pred_sepcon_ramif_xQ.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_1: forall (P P': B -> Prop) (p p': B -> A) (x x': B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    Prop_join (eq x') Pf P' /\
    (forall y, Pf y -> p y = p' y)) ->
  pred_sepcon P p |-- p x * (p' x' -* pred_sepcon P' p').
Proof.
  intros.
  pose proof pred_sepcon_ramif_1Q (fun _: unit => True) P (fun _ => P') p (fun _ => p') x (fun _ => x').
  rewrite allp_unit in H0.
  rewrite prop_imp in H0 by auto.
  apply H0.
  destruct H as [f [? [? ?]]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_x: forall (G L L' G': B -> Prop) (p p': B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    Prop_join L' Pf G' /\
    (forall y, Pf y -> p y = p' y)) ->
  pred_sepcon G p |-- pred_sepcon L p * (pred_sepcon L' p' -* pred_sepcon G' p').
Proof.
  intros.
  pose proof pred_sepcon_ramif_xQ (fun _: unit => True) G L (fun _ => L') (fun _ => G') p (fun _ => p').
  rewrite allp_unit in H0.
  rewrite prop_imp in H0 by auto.
  apply H0.
  destruct H as [f [? [? ?]]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_pred_1: forall (P: B -> Prop) (p p': B -> A) (x: B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    (forall y, Pf y -> p y = p' y)) ->
  pred_sepcon P p |-- p x * (p' x -* pred_sepcon P p').
Proof.
  intros.
  apply pred_sepcon_ramif_1.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_pred_x: forall (G L: B -> Prop) (p p': B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    (forall y, Pf y -> p y = p' y)) ->
  pred_sepcon G p |-- pred_sepcon L p * (pred_sepcon L p' -* pred_sepcon G p').
Proof.
  intros.
  apply pred_sepcon_ramif_x.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_item_1: forall (P P': B -> Prop) (p: B -> A) (x x': B),
  (exists Pf,
    Prop_join (eq x) Pf P /\
    Prop_join (eq x') Pf P') ->
  pred_sepcon P p |-- p x * (p x' -* pred_sepcon P' p).
Proof.
  intros.
  apply pred_sepcon_ramif_1.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

Lemma pred_sepcon_ramif_item_x: forall (G L L' G': B -> Prop) (p: B -> A),
  (exists Pf,
    Prop_join L Pf G /\
    Prop_join L' Pf G') ->
  pred_sepcon G p |-- pred_sepcon L p * (pred_sepcon L' p -* pred_sepcon G' p).
Proof.
  intros.
  apply pred_sepcon_ramif_x.
  destruct H as [f [? ?]]; exists f.
  split; [| split]; auto.
Qed.

End Ramification_PredSepCon.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^379 - 19
Base: 25 + 4/15
***)

Definition curve : CurveParameters :=
  {|
    sz := 15%nat;
    base := 25 + 4/15;
    bitwidth := 32;
    s := 2^379;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 15); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From iris.algebra Require Import frac agree csum.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Export weakestpre.
From iris.deprecated.program_logic Require Import hoare.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import assert proofmode notation adequacy.
From iris.heap_lang.lib Require Import par.
Set Default Proof Using "Type".

(** This is the introductory example from Ralf's PhD thesis.
The difference to [one_shot] is that [set] asserts to be called only once. *)

Definition one_shot_example : val := λ: <>,
  let: "x" := ref NONE in (
  (* set *) (λ: "n",
    assert: CAS "x" NONE (SOME "n")),
  (* check  *) (λ: <>,
    let: "y" := !"x" in λ: <>,
      let: "y'" := !"x" in
      match: "y" with
        NONE => #()
      | SOME <> => assert: "y" = "y'"
      end)).

Definition one_shotR := csumR fracR (agreeR ZO).
Definition Pending (q : Qp) : one_shotR := Cinl q.
Definition Shot (n : Z) : one_shotR := Cinr (to_agree n).

Class one_shotG Σ := { one_shot_inG :> inG Σ one_shotR }.
Definition one_shotΣ : gFunctors := #[GFunctor one_shotR].
Global Instance subG_one_shotΣ {Σ} : subG one_shotΣ Σ → one_shotG Σ.
Proof. solve_inG. Qed.

Section proof.
Local Set Default Proof Using "Type*".
Context `{!heapG Σ, !one_shotG Σ}.

Definition one_shot_inv (γ : gname) (l : loc) : iProp Σ :=
  (l ↦ NONEV ∗ own γ (Pending (1/2)%Qp) ∨
   ∃ n : Z, l ↦ SOMEV #n ∗ own γ (Shot n))%I.

Local Hint Extern 0 (environments.envs_entails _ (one_shot_inv _ _)) =>
  unfold one_shot_inv : core.

Lemma pending_split γ q :
  own γ (Pending q) ⊣⊢ own γ (Pending (q/2)) ∗ own γ (Pending (q/2)).
Proof.
  rewrite /Pending. rewrite -own_op -Cinl_op. rewrite frac_op Qp_div_2 //.
Qed.

Lemma pending_shoot γ n :
  own γ (Pending 1%Qp) ==∗ own γ (Shot n).
Proof.
  iIntros "Hγ". iMod (own_update with "Hγ") as "$"; last done.
  by apply cmra_update_exclusive with (y:=Shot n).
Qed.

Lemma wp_one_shot (Φ : val → iProp Σ) :
  (∀ (f1 f2 : val) (T : iProp Σ), T ∗
    □ (∀ n : Z, T -∗ WP f1 #n {{ w, True }}) ∗
    □ WP f2 #() {{ g, □ WP g #() {{ _, True }} }} -∗ Φ (f1,f2)%V)
  ⊢ WP one_shot_example #() {{ Φ }}.
Proof.
  iIntros "Hf /=". pose proof (nroot .@ "N") as N.
  wp_lam. wp_alloc l as "Hl".
  iMod (own_alloc (Pending 1%Qp)) as (γ) "Hγ"; first done.
  iDestruct (pending_split with "Hγ") as "[Hγ1 Hγ2]".
  iMod (inv_alloc N _ (one_shot_inv γ l) with "[Hl Hγ2]") as "#HN".
  { iNext. iLeft. by iFrame. }
  wp_pures. iModIntro. iApply ("Hf" $! _ _ (own γ (Pending (1/2)%Qp))).
  iSplitL; first done. iSplit.
  - iIntros (n) "!> Hγ1". wp_pures.
    iApply wp_assert. wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as ">[[Hl Hγ2]|H]"; last iDestruct "H" as (m) "[Hl Hγ']".
    + iDestruct (pending_split with "[$Hγ1 $Hγ2]") as "Hγ".
      iMod (pending_shoot _ n with "Hγ") as "Hγ".
      wp_cmpxchg_suc. iModIntro. iSplitL; last (wp_pures; by eauto).
      iNext; iRight; iExists n; by iFrame.
    + by iDestruct (own_valid_2 with "Hγ1 Hγ'") as %?.
  - iIntros "!> /=". wp_lam. wp_bind (! _)%E.
    iInv N as ">Hγ".
    iAssert (∃ v, l ↦ v ∗ (⌜v = NONEV⌝ ∗ own γ (Pending (1/2)%Qp) ∨
       ∃ n : Z, ⌜v = SOMEV #n⌝ ∗ own γ (Shot n)))%I with "[Hγ]" as "Hv".
    { iDestruct "Hγ" as "[[Hl Hγ]|Hl]"; last iDestruct "Hl" as (m) "[Hl Hγ]".
      + iExists NONEV. iFrame. eauto.
      + iExists (SOMEV #m). iFrame. eauto. }
    iDestruct "Hv" as (v) "[Hl Hv]". wp_load.
    iAssert (one_shot_inv γ l ∗ (⌜v = NONEV⌝ ∨ ∃ n : Z,
      ⌜v = SOMEV #n⌝ ∗ own γ (Shot n)))%I with "[Hl Hv]" as "[Hinv #Hv]".
    { iDestruct "Hv" as "[[% ?]|Hv]"; last iDestruct "Hv" as (m) "[% ?]"; subst.
      + Show. iSplit. iLeft; by iSplitL "Hl". eauto.
      + iSplit. iRight; iExists m; by iSplitL "Hl". eauto. }
    iSplitL "Hinv"; first by eauto.
    iModIntro. wp_pures. iIntros "!> !>". wp_lam. wp_bind (! _)%E.
    iInv N as "Hinv".
    iDestruct "Hv" as "[%|Hv]"; last iDestruct "Hv" as (m) "[% Hγ']"; subst.
    + iDestruct "Hinv" as "[[Hl >Hγ]|H]"; last iDestruct "H" as (m') "[Hl Hγ]";
      wp_load; iModIntro; (iSplitL "Hl Hγ"; first by eauto with iFrame);
      wp_pures; done.
    + iDestruct "Hinv" as "[[Hl >Hγ]|H]"; last iDestruct "H" as (m') "[Hl Hγ]".
      { by iDestruct (own_valid_2 with "Hγ Hγ'") as %?. }
      wp_load. Show.
      iDestruct (own_valid_2 with "Hγ Hγ'") as %?%to_agree_op_inv_L; subst.
      iModIntro. iSplitL "Hl Hγ"; first by eauto with iFrame.
      wp_pures. iApply wp_assert. wp_op. by case_bool_decide.
Qed.

Lemma ht_one_shot (Φ : val → iProp Σ) :
  ⊢ {{ True }} one_shot_example #()
    {{ ff, ∃ T, T ∗
      (∀ n : Z, {{ T }} Fst ff #n {{ _, True }}) ∗
      {{ True }} Snd ff #() {{ g, {{ True }} g #() {{ _, True }} }}
    }}.
Proof.
  iIntros "!> _". iApply wp_one_shot. iIntros (f1 f2 T) "(HT & #Hf1 & #Hf2)".
  iExists T. iFrame "HT". iSplit.
  - iIntros (n) "!> HT". wp_smart_apply "Hf1". done.
  - iIntros "!> _". wp_smart_apply (wp_wand with "Hf2"). by iIntros (v) "#? !> _".
Qed.
End proof.

(* Have a client with a closed proof. *)
Definition client : expr :=
  let: "ff" := one_shot_example #() in
  (Fst "ff" #5 ||| let: "check" := Snd "ff" #() in "check" #()).

Section client.
  Context `{!heapG Σ, !one_shotG Σ, !spawnG Σ}.

  Lemma client_safe : ⊢ WP client {{ _, True }}.
  Proof using Type*.
    rewrite /client. wp_apply wp_one_shot. iIntros (f1 f2 T) "(HT & #Hf1 & #Hf2)".
    wp_let. wp_smart_apply (wp_par with "[HT]").
    - wp_smart_apply "Hf1". done.
    - wp_proj. wp_bind (f2 _)%E. iApply wp_wand; first by iExact "Hf2".
      iIntros (check) "Hcheck". wp_pures. iApply "Hcheck".
    - auto.
  Qed.
End client.

(** Put together all library functors. *)
Definition clientΣ : gFunctors := #[ heapΣ; one_shotΣ; spawnΣ ].
(** This lemma implicitly shows that these functors are enough to meet
all library assumptions. *)
Lemma client_adequate σ : adequate NotStuck client σ (λ _ _, True).
Proof. apply (heap_adequacy clientΣ)=> ?. iIntros "_". iApply client_safe. Qed.


From Perennial.Helpers Require Import List.

From Goose.github_com.tchajed Require Import marshal.
From Perennial.goose_lang.lib Require Import encoding.

From Perennial.program_proof Require Import proof_prelude.
From Perennial.goose_lang.lib Require Import slice.typed_slice.

Inductive encodable :=
| EncUInt64 (x:u64)
| EncUInt32 (x:u32)
| EncBytes (bs:list u8)
| EncBool (b:bool)
.

Definition Rec := list encodable.

Local Definition encode1 (e:encodable) : list u8 :=
  match e with
  | EncUInt64 x => u64_le x
  | EncUInt32 x => u32_le x
  | EncBytes bs => bs
  | EncBool b => [U8 (if b then 1 else 0)%Z]
  end.

Lemma encode1_u64_inj : Inj (=) (=) (encode1 ∘ EncUInt64).
Proof.
  move=>x y /= Heq.
  rewrite -(u64_le_to_word x).
  rewrite -(u64_le_to_word y).
  rewrite Heq //.
Qed.
Lemma encode1_u32_inj : Inj (=) (=) (encode1 ∘ EncUInt32).
Proof.
  move=>x y /= Heq.
  rewrite -(u32_le_to_word x).
  rewrite -(u32_le_to_word y).
  rewrite Heq //.
Qed.
Lemma encode1_bytes_inj : Inj (=) (=) (encode1 ∘ EncBytes).
Proof. move=>x y /= Heq //. Qed.
Lemma encode1_bool_inj : Inj (=) (=) (encode1 ∘ EncBool).
Proof.
  move=>x y /= Heq.
  by destruct x, y.
Qed.

Lemma encode1_bytes_len bs : length (encode1 (EncBytes bs)) = length bs.
Proof. done. Qed.

Local Definition encode (es:Rec): list u8 := concat (encode1 <$> es).

Notation encoded_length r := (length (encode r)).

Theorem encode_app es1 es2 :
  encode (es1 ++ es2) = encode es1 ++ encode es2.
Proof.
  rewrite /encode.
  rewrite fmap_app.
  rewrite concat_app //.
Qed.

Theorem encode_singleton x :
  encode [x] = encode1 x.
Proof.
  rewrite /encode /=.
  rewrite app_nil_r //.
Qed.

Theorem encode_cons x xs :
  encode (x::xs) = encode1 x ++ encode xs.
Proof.
  change (?x::?xs) with ([x] ++ xs).
  rewrite encode_app encode_singleton //.
Qed.

Theorem encoded_length_singleton x :
  encoded_length [x] = length (encode1 x).
Proof. rewrite encode_singleton //. Qed.

Theorem encoded_length_app (r1 r2:Rec) :
  encoded_length (r1 ++ r2) = (encoded_length r1 + encoded_length r2)%nat.
Proof. rewrite encode_app; len. Qed.

Theorem encoded_length_app1 (r:Rec) (x:encodable) :
  encoded_length (r ++ [x]) = (encoded_length r + length (encode1 x))%nat.
Proof. rewrite encoded_length_app encoded_length_singleton //. Qed.

(** has_encoding is an opaque connection between data and a typed record

    It is generated by encoding [r] with an [Enc] and calling [Enc__Finish], and
    is subsequently used while decoding to reconstruct [r]. *)
Definition has_encoding (data: list u8) (r:Rec) :=
  take (encoded_length r) data = encode r.

Typeclasses Opaque has_encoding.

Lemma has_encoding_length {data r} :
  has_encoding data r →
  (encoded_length r ≤ length data)%nat.
Proof.
  intros H%(f_equal length).
  move: H; len.
Qed.

Lemma has_encoding_app_characterization data r :
  has_encoding data r ↔
  ∃ extra, data = encode r ++ extra.
Proof.
  split; intros.
  - rewrite /has_encoding in H.
    exists (drop (encoded_length r) data).
    rewrite -[data in data = _](take_drop (encoded_length r)) H //.
  - destruct H as [extra ->].
    rewrite /has_encoding.
    rewrite take_app_le //.
    rewrite take_ge //.
Qed.

Lemma has_encoding_inv data r :
  has_encoding data r →
  ∃ extra, data = encode r ++ extra ∧
           (encoded_length r + length extra = length data)%nat.
Proof.
  intros [extra ->]%has_encoding_app_characterization.
  exists extra; intuition.
  len.
Qed.

Lemma has_encoding_from_app data extra r :
  data = encode r ++ extra →
  has_encoding data r.
Proof.
  intros ->.
  apply has_encoding_app_characterization; eauto.
Qed.

Section goose_lang.
Context `{hG: heapGS Σ, !ffi_semantics _ _, !ext_types _}.

Implicit Types (v:val).

Definition is_enc (enc_v:val) (sz:Z) (r: Rec) (remaining: Z) : iProp Σ :=
  ∃ (s: Slice.t) (off_l: loc) (data: list u8),
    let off := encoded_length r in
    "->" ∷ ⌜enc_v = (slice_val s, (#off_l, #()))%V⌝ ∗
    "Hs" ∷ is_slice_small s byteT 1 data ∗
    "Hs_cap" ∷ is_slice_cap s byteT ∗
    "%Hsz" ∷ ⌜length data = Z.to_nat sz⌝ ∗
    "%Hremaining" ∷ ⌜(off + remaining)%Z = sz⌝ ∗
    "Hoff" ∷ off_l ↦[uint64T] #off ∗
    "%Hoff" ∷ ⌜0 ≤ off ≤ length data⌝ ∗
    "%Hencoded" ∷ ⌜has_encoding data r⌝
.

Theorem wp_new_enc_from_slice stk E s (data: list u8) :
  {{{ is_slice s byteT 1 data }}}
    NewEncFromSlice (slice_val s) @ stk; E
  {{{ (enc_v:val), RET enc_v; is_enc enc_v (length data) [] (length data) }}}.
Proof.
  iIntros (Φ) "Hs HΦ".
  iDestruct (is_slice_split with "Hs") as "[Hs Hcap]".
  wp_call.
  wp_apply (typed_mem.wp_AllocAt uint64T); eauto.
  iIntros (off_l) "Hoff".
  wp_pures.
  iModIntro.
  iApply "HΦ".
  iExists _, _, _; iFrame.
  iPureIntro.
  split_and!; auto; len.
  rewrite /has_encoding //.
Qed.

Theorem wp_new_enc stk E (sz: u64) :
  {{{ True }}}
    NewEnc #sz @ stk; E
  {{{ (enc_v:val), RET enc_v; is_enc enc_v (int.Z sz) [] (int.Z sz) }}}.
Proof.
  iIntros (Φ) "_ HΦ".
  wp_call.
  wp_apply (wp_NewSlice (V:=u8)).
  iIntros (s) "Hs".
  wp_apply (wp_new_enc_from_slice with "Hs").
  rewrite replicate_length. word_cleanup.
  iIntros (enc_v) "Henc".
  iApply ("HΦ" with "Henc").
Qed.

Lemma has_encoding_app data r data' r' :
  has_encoding data r →
  has_encoding data' r' →
  has_encoding (take (encoded_length r) data ++ data')
                (r ++ r').
Proof.
  intros Hdata Hdata'.
  rewrite Hdata.
  apply has_encoding_inv in Hdata' as [extra' [-> _]].
  rewrite app_assoc.
  eapply has_encoding_from_app.
  rewrite encode_app -!app_assoc //.
Qed.

Theorem wp_Enc__PutInt stk E enc_v sz r (x:u64) remaining :
  8 ≤ remaining →
  {{{ is_enc enc_v sz r remaining }}}
    Enc__PutInt enc_v #x @ stk; E
  {{{ RET #(); is_enc enc_v sz (r ++ [EncUInt64 x]) (remaining - 8) }}}.
Proof.
  iIntros (Hspace Φ) "Hpre HΦ"; iNamed "Hpre".
  set (off:=encoded_length r) in *.
  wp_call.
  wp_load.
  wp_pures.
  iDestruct (is_slice_small_sz with "Hs") as %Hslice_len.
  wp_apply wp_SliceSkip.
  { word. }
  iDestruct (is_slice_small_take_drop _ _ _ (U64 off) with "Hs") as "[Hs2 Hs1]".
  { word. }
  replace (int.nat (U64 off)) with off by word.
  wp_apply (wp_UInt64Put with "Hs2").
  { len. }
  iIntros "Hs2".
  iDestruct (slice.is_slice_combine with "Hs1 Hs2") as "Hs"; first len.
  wp_pures.
  wp_load; wp_store.
  rewrite -fmap_drop drop_drop.
  iApply "HΦ".
  iExists _, _, _; iFrame.
  change (u64_le_bytes x) with (into_val.to_val (V:=u8) <$> u64_le x).
  rewrite -!fmap_app.
  iSplitR; first eauto.
  iFrame "Hs". iModIntro.
  rewrite encoded_length_app1.
  change (length (encode1 (EncUInt64 x))) with 8%nat.
  iSplitR; first by iPureIntro; len.
  iSplitR; first by iPureIntro; len.
  iSplitL "Hoff".
  { iExactEq "Hoff".
    rewrite /named.
    repeat (f_equal; try word). }
  iPureIntro; split.
  - len.
  - subst off.
    apply has_encoding_app; auto.
    eapply has_encoding_from_app; eauto.
Qed.

Theorem wp_Enc__PutInt32 stk E enc_v sz r (x:u32) remaining :
  4 ≤ remaining →
  {{{ is_enc enc_v sz r remaining }}}
    Enc__PutInt32 enc_v #x @ stk; E
  {{{ RET #(); is_enc enc_v sz (r ++ [EncUInt32 x]) (remaining - 4) }}}.
Proof.
  iIntros (Hspace Φ) "Hpre HΦ"; iNamed "Hpre".
  set (off:=encoded_length r) in *.
  wp_call.
  wp_load.
  wp_pures.
  iDestruct (is_slice_small_sz with "Hs") as %Hslice_len.
  wp_apply wp_SliceSkip.
  { word. }
  iDestruct (is_slice_small_take_drop _ _ _ (U64 off) with "Hs") as "[Hs2 Hs1]".
  { word. }
  replace (int.nat (U64 off)) with off by word.
  wp_apply (wp_UInt32Put with "Hs2").
  { len. }
  iIntros "Hs2".
  iDestruct (slice.is_slice_combine with "Hs1 Hs2") as "Hs"; first len.
  wp_pures.
  wp_load; wp_store.
  rewrite -fmap_drop drop_drop.
  iApply "HΦ".
  iExists _, _, _; iFrame.
  change (u32_le_bytes x) with (into_val.to_val <$> u32_le x).
  rewrite -!fmap_app.
  iSplitR; first eauto.
  iFrame "Hs". iModIntro.
  rewrite encoded_length_app1.
  change (length (encode1 _)) with 4%nat.
  iSplitR; first by iPureIntro; len.
  iSplitR; first by iPureIntro; len.
  iSplitL "Hoff".
  { iExactEq "Hoff".
    rewrite /named.
    repeat (f_equal; try word). }
  iPureIntro; split.
  - len.
  - subst off.
    apply has_encoding_app; auto.
    eapply has_encoding_from_app; eauto.
Qed.

Local Lemma wp_bool2byte stk E (x:bool) :
  {{{ True }}}
    bool2byte #x @ stk; E
  {{{ RET #(U8 (if x then 1 else 0))%Z; True }}}.
Proof.
  iIntros (Φ) "_ HΦ". wp_lam.
  destruct x; wp_pures; by iApply "HΦ".
Qed.

Theorem wp_Enc__PutBool stk E enc_v sz r (x:bool) remaining :
  1 ≤ remaining →
  {{{ is_enc enc_v sz r remaining }}}
    Enc__PutBool enc_v #x @ stk; E
  {{{ RET #(); is_enc enc_v sz (r ++ [EncBool x]) (remaining - 1) }}}.
Proof.
  iIntros (Hspace Φ) "Hpre HΦ"; iNamed "Hpre".
  set (off:=encoded_length r) in *.
  wp_call.
  wp_load.
  wp_pures.
  iDestruct (is_slice_small_sz with "Hs") as %Hslice_len.
  wp_pures.
  wp_apply wp_bool2byte.
  set (u:=U8 (if x then 1 else 0)%Z).
  wp_pures.
  wp_apply (wp_SliceSet (V:=byte) with "[$Hs]").
  { iPureIntro. apply lookup_lt_is_Some_2. word. }
  iIntros "Hs".
  wp_pures.
  wp_load. wp_store.
  iApply "HΦ". iModIntro.
  iExists _, _, _. iFrame.
  iSplit; eauto.
  rewrite insert_length.
  iSplit; eauto.
  rewrite encoded_length_app1. simpl.
  iSplit.
  { iPureIntro. word. }
  iSplit.
  { iExactEq "Hoff". rewrite /named. do 3 f_equal. word. }
  iPureIntro.
  split; first word.
  replace (<[int.nat off:=u]> data) with
      (take off data ++ [u] ++ drop (off + 1) data); last first.
  { rewrite insert_take_drop. 2:word.
    repeat f_equal; word. }
  apply has_encoding_app; eauto.
  eapply has_encoding_from_app; eauto.
Qed.

Theorem wp_Enc__PutInts stk E enc_v sz r (x_s: Slice.t) q (xs:list u64) remaining :
  8*(Z.of_nat $ length xs) ≤ remaining →
  {{{ is_enc enc_v sz r remaining ∗ is_slice_small x_s uint64T q xs }}}
    Enc__PutInts enc_v (slice_val x_s) @ stk; E
  {{{ RET #(); is_enc enc_v sz (r ++ (EncUInt64 <$> xs)) (remaining - 8*(Z.of_nat $ length xs)) ∗
               is_slice_small x_s uint64T q xs }}}.
Proof.
  iIntros (Hbound Φ) "[Henc Hxs] HΦ".
  wp_rec; wp_pures.
  wp_apply (wp_forSlicePrefix
              (λ done todo,
                "Henc" ∷ is_enc enc_v sz
                        (r ++ (EncUInt64 <$> done))
                        (remaining - 8*(Z.of_nat $ length done)))%I
           with "[] [$Hxs Henc]").
  - clear Φ.
    iIntros (???? Hdonetodo) "!>".
    iIntros (Φ) "HI HΦ"; iNamed "HI".
    wp_pures.
    wp_apply (wp_Enc__PutInt with "Henc").
    { apply (f_equal length) in Hdonetodo; move: Hdonetodo; len. }
    iIntros "Henc".
    iApply "HΦ".
    iExactEq "Henc".
    rewrite /named; f_equal; len.
    rewrite fmap_app.
    rewrite -!app_assoc.
    reflexivity.
  - iExactEq "Henc".
    rewrite /named; f_equal; len.
    rewrite app_nil_r //.
  - iIntros "(Hs&HI)"; iNamed "HI".
    wp_pures. iApply "HΦ"; by iFrame.
Qed.

Hint Rewrite encoded_length_app1 : len.

Theorem wp_Enc__PutBytes stk E enc_v r sz remaining b_s q bs :
  Z.of_nat (length bs) ≤ remaining →
  {{{ is_enc enc_v sz r remaining ∗ is_slice_small b_s byteT q bs }}}
    Enc__PutBytes enc_v (slice_val b_s) @ stk; E
  {{{ RET #(); is_enc enc_v sz (r ++ [EncBytes bs]) (remaining - Z.of_nat (length bs)) ∗
               is_slice_small b_s byteT q bs }}}.
Proof.
  iIntros (Hbound Φ) "[Henc Hbs] HΦ"; iNamed "Henc".
  wp_call.
  wp_load; wp_pures.
  iDestruct (is_slice_small_sz with "Hs") as %Hs_sz.
  wp_apply wp_SliceSkip.
  { len. }
  iDestruct (slice_small_split _ (U64 (encoded_length r)) with "Hs") as "[Hs1 Hs2]"; first by len.
  wp_apply (wp_SliceCopy (V:=byte) with "[$Hbs $Hs2]"); first by len.
  iIntros "[Hbs Hs2]".
  iDestruct (is_slice_combine with "Hs1 Hs2") as "Hs"; first by len.
  wp_pures.
  wp_load; wp_store.
  iApply "HΦ".
  iFrame. iModIntro.
  iExists _, _, _; iFrame.
  iSplitR; first by eauto.
  iSplitR.
  { iPureIntro; len. }
  iSplitR.
  { iPureIntro; len. simpl; len. }
  iSplitL "Hoff".
  { iExactEq "Hoff".
    rewrite /named.
    f_equal.
    f_equal.
    f_equal.
    len.
    simpl.
    word.
  }
  iPureIntro.
  split_and.
  - len.
    simpl; len.
  - replace (int.nat (U64 (encoded_length r))) with (encoded_length r) by word.
    rewrite Hencoded.
    rewrite app_assoc.
    eapply has_encoding_from_app.
    rewrite encode_app encode_singleton //=.
Qed.

Theorem wp_Enc__Finish stk E enc_v r sz remaining :
  {{{ is_enc enc_v sz r remaining }}}
    Enc__Finish enc_v @ stk; E
  {{{ s data, RET slice_val s; ⌜has_encoding data r⌝ ∗
                               ⌜length data = Z.to_nat sz⌝ ∗
                               is_slice s byteT 1 data }}}.
Proof.
  iIntros (Φ) "Henc HΦ"; iNamed "Henc"; subst.
  wp_call.
  iApply "HΦ"; by iFrame "∗ %".
Qed.

Definition is_dec (dec_v:val) (r:Rec) (s:Slice.t) (q:Qp) (data: list u8): iProp Σ :=
  ∃ (off_l:loc) (off: u64),
    "->" ∷ ⌜dec_v = (slice_val s, (#off_l, #()))%V⌝ ∗
    "Hoff" ∷ off_l ↦[uint64T] #off ∗
    "%Hoff" ∷ ⌜int.nat off ≤ length data⌝ ∗
    "Hs" ∷ is_slice_small s byteT q data ∗
    "%Henc" ∷ ⌜has_encoding (drop (int.nat off) data) r⌝.

Lemma is_dec_to_is_slice_small dec_v r s q data :
  is_dec dec_v r s q data -∗
  is_slice_small s byteT q data.
Proof.
  iIntros "H". iNamed "H". iFrame.
Qed.

Theorem wp_new_dec stk E s q data r :
  has_encoding data r →
  {{{ is_slice_small s byteT q data }}}
    NewDec (slice_val s) @ stk; E
  {{{ dec_v, RET dec_v; is_dec dec_v r s q data }}}.
Proof.
  iIntros (Henc Φ) "Hs HΦ".
  wp_call.
  wp_apply (typed_mem.wp_AllocAt uint64T); eauto.
  iIntros (off_l) "Hoff".
  wp_pures.
  iApply "HΦ".
  iExists _, _; iFrame.
  iPureIntro.
  split_and!; auto; len.
Qed.

Hint Rewrite encoded_length_singleton : len.

Lemma encoded_length_cons x r :
  encoded_length (x::r) = (length (encode1 x) + encoded_length r)%nat.
Proof. rewrite encode_cons; len. Qed.

Theorem wp_Dec__GetInt stk E dec_v (x: u64) r s q data :
  {{{ is_dec dec_v (EncUInt64 x :: r) s q data }}}
    Dec__GetInt dec_v @ stk; E
  {{{ RET #x; is_dec dec_v r s q data }}}.
Proof.
  iIntros (Φ) "Hdec HΦ"; iNamed "Hdec".
  wp_call.
  wp_load; wp_pures.
  wp_load; wp_store.
  iDestruct (is_slice_small_sz with "Hs") as %Hsz.
  wp_apply wp_SliceSkip.
  { word. }
  iDestruct (slice.slice_small_split _ off with "Hs") as "[Hs1 Hs2]".
  { len. }
  wp_apply (wp_UInt64Get_unchanged with "Hs2").
  { eapply has_encoding_inv in Henc as [extra [Henc ?]].
    rewrite -fmap_drop -fmap_take.
    rewrite Henc.
    reflexivity. }
  iIntros "Hs2".
  iDestruct (slice.is_slice_small_take_drop_1 with "[$Hs1 $Hs2]") as "Hs"; first by word.
  iApply "HΦ".
  iExists _, _; iFrame.
  iSplitR; first by auto.
  pose proof (has_encoding_length Henc).
  autorewrite with len in H.
  rewrite encoded_length_cons in H.
  change (length (encode1 _)) with 8%nat in H.
  iSplitR; first iPureIntro.
  { word. }
  iPureIntro.
  replace (int.nat (word.add off 8)) with (int.nat off + 8)%nat by word.
  rewrite -drop_drop.
  apply has_encoding_inv in Henc as [extra [Henc ?]].
  rewrite Henc.
  rewrite encode_cons.
  eapply has_encoding_from_app.
  rewrite -app_assoc.
  rewrite drop_app_ge //.
Qed.

Theorem wp_Dec__GetInt32 stk E dec_v (x: u32) r s q data :
  {{{ is_dec dec_v (EncUInt32 x :: r) s q data }}}
    Dec__GetInt32 dec_v @ stk; E
  {{{ RET #x; is_dec dec_v r s q data }}}.
Proof.
  iIntros (Φ) "Hdec HΦ"; iNamed "Hdec".
  wp_call.
  wp_load; wp_pures.
  wp_load; wp_store.
  iDestruct (is_slice_small_sz with "Hs") as %Hsz.
  wp_apply wp_SliceSkip.
  { word. }
  iDestruct (slice.slice_small_split _ off with "Hs") as "[Hs1 Hs2]".
  { len. }
  wp_apply (wp_UInt32Get_unchanged with "Hs2").
  { eapply has_encoding_inv in Henc as [extra [Henc ?]].
    rewrite -fmap_drop -fmap_take.
    rewrite Henc.
    reflexivity. }
  iIntros "Hs2".
  iDestruct (slice.is_slice_small_take_drop_1 with "[$Hs1 $Hs2]") as "Hs"; first by word.
  iApply "HΦ".
  iExists _, _; iFrame.
  iSplitR; first by auto.
  pose proof (has_encoding_length Henc).
  autorewrite with len in H.
  rewrite encoded_length_cons in H.
  change (length (encode1 _)) with 4%nat in H.
  iSplitR; first iPureIntro.
  { word. }
  iPureIntro.
  replace (int.nat (word.add off 4)) with (int.nat off + 4)%nat by word.
  rewrite -drop_drop.
  apply has_encoding_inv in Henc as [extra [Henc ?]].
  rewrite Henc.
  rewrite encode_cons.
  eapply has_encoding_from_app.
  rewrite -app_assoc.
  rewrite drop_app_ge //.
Qed.

Theorem wp_Dec__GetBool stk E dec_v (x: bool) r s q data :
  {{{ is_dec dec_v (EncBool x :: r) s q data }}}
    Dec__GetBool dec_v @ stk; E
  {{{ RET #x; is_dec dec_v r s q data }}}.
Proof.
  iIntros (Φ) "Hdec HΦ"; iNamed "Hdec".
  wp_call.
  wp_load; wp_pures.
  wp_load; wp_store.
  iDestruct (is_slice_small_sz with "Hs") as %Hsz.
  pose proof (has_encoding_length Henc).
  autorewrite with len in H.
  rewrite encoded_length_cons in H.
  change (length (encode1 _)) with 1%nat in H.
  apply has_encoding_inv in Henc as [extra [Henc ?]].
  rewrite encode_cons in Henc.
  assert (drop (int.nat off) data !! 0%nat = Some $ U8 (if x then 1 else 0)) as Hx.
  { rewrite Henc. done. }
  rewrite lookup_drop Nat.add_0_r in Hx.
  wp_apply (wp_SliceGet (V:=byte) with "[$Hs]").
  { done. }
  iIntros "Hl". wp_pures.
  destruct x; wp_pures; iApply "HΦ";
    iExists _, _; iFrame; iPureIntro.
  - split; first done.
    split; first word.
    eapply has_encoding_from_app.
    replace (int.nat (word.add off 1)) with (int.nat off + 1)%nat by word.
    rewrite -drop_drop.
    rewrite Henc /= drop_0 //.
  - split; first done.
    split; first word.
    eapply has_encoding_from_app.
    replace (int.nat (word.add off 1)) with (int.nat off + 1)%nat by word.
    rewrite -drop_drop.
    rewrite Henc /= drop_0 //.
Qed.

(* This version of GetBytes consumes full ownership of the decoder to be able to
   give the full fraction to the returned slice *)
Theorem wp_Dec__GetBytes' stk E dec_v bs (n: u64) r s data :
  n = U64 (length bs) →
  {{{ is_dec dec_v (EncBytes bs :: r) s 1 data ∗
      (∀ vs' : list u8, is_slice_small s byteT 1 vs' -∗ is_slice s byteT 1 vs') }}}
    Dec__GetBytes dec_v #n @ stk; E
  {{{ s', RET slice_val s'; is_slice s' byteT 1 bs }}}.
Proof.
  iIntros (-> Φ) "(Hdec&Hclo) HΦ"; iNamed "Hdec".
  pose proof (has_encoding_length Henc).
  autorewrite with len in H.
  rewrite encoded_length_cons /= in H.
  wp_call.
  wp_load.
  iDestruct (is_slice_small_sz with "Hs") as %Hsz.
  wp_pures.
  iDestruct ("Hclo" with "[$]") as "Hs".
  wp_apply (wp_SliceSubslice_full with "Hs"); first by word.
  iIntros (s') "Hbs".
  wp_pures.
  wp_load; wp_store.
  iApply "HΦ". iModIntro.
  apply has_encoding_inv in Henc as [extra [Hdataeq _]].
  rewrite encode_cons /= -app_assoc in Hdataeq.
  iExactEq "Hbs".
  f_equal.
  rewrite -> subslice_drop_take by word.
  replace (int.nat (word.add off (length bs)) - int.nat off)%nat with (length bs) by word.
  rewrite Hdataeq.
  rewrite take_app_alt //; lia.
Qed.

Theorem wp_Dec__GetBytes stk E dec_v bs (n: u64) r s q data :
  n = U64 (length bs) →
  {{{ is_dec dec_v (EncBytes bs :: r) s q data }}}
    Dec__GetBytes dec_v #n @ stk; E
  {{{ q' s', RET slice_val s'; is_slice_small s' byteT q' bs ∗ is_dec dec_v r s q' data }}}.
Proof.
  iIntros (-> Φ) "Hdec HΦ"; iNamed "Hdec".
  pose proof (has_encoding_length Henc).
  autorewrite with len in H.
  rewrite encoded_length_cons /= in H.
  wp_call.
  wp_load.
  iDestruct (is_slice_small_sz with "Hs") as %Hsz.
  (* we split the decoder state into one half used to serve the client and one
     half to reconstruct the decoder (now with half the fraction) *)
  iDestruct (fractional.fractional_half with "Hs") as "[Hs1 Hs2]".
  wp_pures.
  wp_apply (wp_SliceSubslice_small with "Hs1"); first by word.
  iIntros (s') "Hbs".
  wp_pures.
  wp_load; wp_store.
  iApply "HΦ". iModIntro.
  apply has_encoding_inv in Henc as [extra [Hdataeq _]].
  rewrite encode_cons /= -app_assoc in Hdataeq.
  iSplitL "Hbs".
  { iExactEq "Hbs".
    f_equal.
    rewrite -> subslice_drop_take by word.
    replace (int.nat (word.add off (length bs)) - int.nat off)%nat with (length bs) by word.
    rewrite Hdataeq.
    rewrite take_app_alt //; lia.
  }
  iExists _, _; iFrame.
  iPureIntro.
  split_and!; auto; try len.
  replace (int.nat (word.add off (length bs))) with (int.nat off + int.nat (length bs))%nat by word.
  rewrite -drop_drop.
  eapply has_encoding_from_app.
  rewrite Hdataeq.
  rewrite drop_app_alt //; word.
Qed.

Theorem wp_Dec__GetBytes_ro stk E dec_v bs (n: u64) r s q data :
  n = U64 (length bs) →
  {{{ is_dec dec_v (EncBytes bs :: r) s q data }}}
    Dec__GetBytes dec_v #n @ stk; E
  {{{ q' s', RET slice_val s'; readonly (is_slice_small s' byteT 1 bs) ∗ is_dec dec_v r s q' data }}}.
Proof.
  iIntros (-> Φ) "Hdec HΦ".
  iApply wp_ncfupd.
  iApply (wp_Dec__GetBytes with "Hdec"); first done.
  iIntros "!>" (q' s') "[Hsl Hdec]".
  iApply "HΦ". iFrame "Hdec".
  iMod (readonly_alloc with "[Hsl]") as "$"; by iFrame.
Qed.

(* TODO: use this to replace list_lookup_lt (it's much easier to remember) *)
Local Tactic Notation "list_elem" constr(l) constr(i) "as" simple_intropattern(x) :=
  let H := fresh "H" x "_lookup" in
  let i := lazymatch type of i with
           | nat => i
           | Z => constr:(Z.to_nat i)
           | u64 => constr:(int.nat i)
           end in
  destruct (list_lookup_lt _ l i) as [x H];
  [ try solve [ len ]
  | ].

Theorem wp_Dec__GetInts stk E dec_v (xs: list u64) r (n: u64) s q data :
  length xs = int.nat n →
  {{{ is_dec dec_v ((EncUInt64 <$> xs) ++ r) s q data }}}
    Dec__GetInts dec_v #n @ stk; E
  {{{ (s':Slice.t), RET slice_val s'; is_dec dec_v r s q data ∗ is_slice s' uint64T 1 xs }}}.
Proof.
  iIntros (Hlen Φ) "Hdec HΦ".
  wp_rec; wp_pures.
  wp_apply (typed_mem.wp_AllocAt (slice.T uint64T)).
  { apply zero_val_ty', has_zero_slice_T. }
  iIntros (s_l) "Hsptr".
  wp_pures.
  wp_apply wp_ref_to; auto.
  iIntros (i_l) "Hi".
  wp_pures.
  wp_apply (wp_forUpto (λ i,
                        let done := take (int.nat i) xs in
                        let todo := drop (int.nat i) xs in
                        "Hdec" ∷ is_dec dec_v ((EncUInt64 <$> todo) ++ r) s q data ∗
                        "*" ∷ ∃ s, "Hsptr" ∷ s_l ↦[slice.T uint64T] (slice_val s) ∗
                                   "Hdone" ∷ is_slice s uint64T 1 done
           )%I with "[] [$Hi Hsptr Hdec]").
  - word.
  - clear Φ.
    iIntros (?) "!>".
    iIntros (Φ) "(HI&Hi&%Hlt) HΦ"; iNamed "HI".
    wp_pures.
    list_elem xs i as x.
    rewrite (drop_S _ _ _ Hx_lookup) /=.
    wp_apply (wp_Dec__GetInt with "Hdec"); iIntros "Hdec".
    wp_load.
    wp_apply (wp_SliceAppend with "Hdone"); iIntros (s') "Hdone".
    wp_store.
    iApply "HΦ"; iFrame.
    replace (int.nat (word.add i 1)) with (S (int.nat i)) by word.
    iFrame "Hdec".
    iExists _; iFrame.
    erewrite take_S_r; eauto.
  - rewrite drop_0; iFrame "Hdec".
    iExists Slice.nil.
    iFrame.
    rewrite take_0.
    iApply is_slice_nil; auto.
  - iIntros "(HI&Hi)"; iNamed "HI".
    wp_load.
    iApply "HΦ"; iFrame.
    rewrite -> take_ge, drop_ge by len.
    by iFrame.
Qed.

(* special case where GetInts is the last thing and there are no more remaining
items to decode *)
Theorem wp_Dec__GetInts_complete stk E dec_v (xs: list u64) (n: u64) s q data :
  length xs = int.nat n →
  {{{ is_dec dec_v (EncUInt64 <$> xs) s q data }}}
    Dec__GetInts dec_v #n @ stk; E
  {{{ (s':Slice.t), RET slice_val s'; is_dec dec_v [] s q data ∗ is_slice s' uint64T 1 xs }}}.
Proof.
  iIntros (? Φ) "Hpre HΦ".
  wp_apply (wp_Dec__GetInts _ _ _ _ [] with "[Hpre]"); first by eauto.
  - rewrite app_nil_r //.
  - auto.
Qed.

End goose_lang.

Typeclasses Opaque has_encoding.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 lv0)).
Admitted.
QuickChick conj5synthconj6.