Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs.objectSelfFancy.

(*Version 1 -- leave specs of foo methods unchanged, and require neither funcspec_sub nor
anything else. Just replictae the spec/proof structure of foo in fancy foo and see whether
the client has enough knowledge to call the correct function*)

(*Require Import VST.floyd.Funspec_old_Notation.*)

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope Z.
Local Open Scope logic.

Section FOO.

(*Andrew's definition
Definition object_invariant := list Z -> val -> mpred.*)

(*But the uncurried version is easier for the HOrec construction*)
Definition ObjInv : Type:= (list Z * val).
Definition object_invariant := ObjInv -> mpred.

Definition tobject := tptr (Tstruct _object noattr).

Definition reset_spec (instance: object_invariant) :=
  WITH hs:ObjInv (*modified*)
  PRE [ (*_self OF*) tobject]
          PROP (isptr (snd hs) (*NEW*))
          PARAMS (snd hs) GLOBALS ()
          SEP (instance hs)
  POST [ tvoid ]
          PROP() LOCAL () SEP(instance (nil, snd hs)).

Definition twiddle_spec (instance: object_invariant) :=
  WITH hs: ObjInv, i: Z (*modified*)
  PRE [ (*_self OF*) tobject, (*_i OF*) tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 (fst hs) <= Int.max_signed / 4;
               isptr (snd hs) (*NEW*))
          PARAMS (snd hs; Vint (Int.repr i)) GLOBALS ()
          SEP (instance hs)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 (fst hs) < v <= 2* fold_right Z.add 0 (i::(fst hs)))
          LOCAL (temp ret_temp (Vint (Int.repr v)))
          SEP(instance (i::(fst hs), snd hs)).

Definition object_methods (instance: object_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val, EX twiddleR:val,
  !! readable_share sh &&
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  func_ptr' (twiddle_spec instance) twiddleR *
  data_at sh (Tstruct _methods noattr) (reset,(twiddle, twiddleR)) mtable.

Lemma object_methods_local_facts: forall instance p,
  object_methods instance p |-- !! isptr p.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle twiddleR.
entailer!.
Qed.
Local Hint Resolve object_methods_local_facts : saturate_local.

(*Moved here from further below, and added twiddleR*)
Lemma make_object_methods:
  forall sh instance reset twiddle twiddleR mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  func_ptr' (twiddle_spec instance) twiddleR *
  data_at sh (Tstruct _methods noattr) (reset, (twiddle, twiddleR)) mtable
  |-- object_methods instance mtable.
Proof.
  intros.
  unfold object_methods.
  Exists sh reset twiddle twiddleR.
  entailer!.
Qed.

Lemma make_object_methods_later:
  forall sh instance reset twiddle twiddleR mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  func_ptr' (twiddle_spec instance) twiddleR *
  data_at sh (Tstruct _methods noattr) (reset, (twiddle, twiddleR)) mtable
  |-- |> object_methods instance mtable.
Proof.
intros. eapply derives_trans. apply make_object_methods; trivial. apply now_later.
Qed.

(*Andrew's definition
Definition object_mpred (history: list Z) (self: val) : mpred :=
  EX instance: object_invariant, EX mtable: val,
       (object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self*
     instance history self).*)

Section ObjMpred.
Variable instance: object_invariant.

Definition F (X: ObjInv -> mpred) (hs: ObjInv): mpred :=
   ((EX mtable: val, !!(isptr mtable) (*This has to hold NOW, not ust LATER*)&&
     (|> object_methods X mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   instance hs)%logic.

Definition HOcontractive1 {A: Type}{NA: NatDed A}{IA: Indir A}{RI: RecIndir A}{X: Type}
     (f: (X -> A) -> (X -> A)) :=
 forall P Q : X -> A,
 ALL x : X, |> fash (P x <--> Q x)
 |-- ALL x : X, fash (f P x --> f Q x).

Lemma HOcontractive_i1:
 forall  (A: Type)(NA: NatDed A){IA: Indir A}{RI: RecIndir A}{X: Type}
     (f: (X -> A) -> (X -> A)),
  HOcontractive1 f -> HOcontractive f.
Proof.
intros.
red in H|-*.
intros.
eapply derives_trans.
apply andp_right.
apply H.
specialize (H Q P).
eapply derives_trans.
2: apply H.
apply allp_derives; intros.
apply later_derives.
apply fash_derives.
rewrite andp_comm.
auto.
apply allp_right; intro.
rewrite fash_andp.
apply andp_right.
apply andp_left1.
apply allp_left with v; auto.
apply andp_left2.
apply allp_left with v; auto.
Qed.

Lemma HOcontrF
     (*Need sth like this (HI: HOcontractive (fun (_ : ObjInv -> mpred) (x : ObjInv) => instance x))*):
      HOcontractive F.
Proof.
unfold F.
apply HOcontractive_i1.
red; intros.
apply allp_right; intro oi.
apply subp_sepcon_mpred; [ | apply subp_refl].
apply subp_exp; intro v.
apply subp_sepcon_mpred; [ | apply subp_refl].
clear oi.
apply subp_andp; [ apply subp_refl | ].
rewrite <- subp_later.
rewrite <- later_allp.
apply later_derives.
unfold object_methods.
apply subp_exp; intro sh.
apply subp_exp; intro reset.
apply subp_exp; intro twiddle.
apply subp_exp; intro twiddleR.
apply subp_sepcon_mpred; [ | apply subp_refl].
repeat simple apply subp_sepcon_mpred;
try (simple apply subp_andp; [simple apply subp_refl | ]).
+
unfold func_ptr'.
apply subp_andp; [ | apply subp_refl].
clear - instance.
eapply derives_trans; [ | apply fash_func_ptr_ND].
apply allp_right; intro oi.
apply andp_right.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
rewrite prop_true_andp by tauto.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with oi.
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left2. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with ([], snd oi).
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left1. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
+
unfold func_ptr'.
apply subp_andp; [ | apply subp_refl].
clear - instance.
eapply derives_trans; [ | apply fash_func_ptr_ND].
apply allp_right; intros [hs i].
apply andp_right.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
rewrite prop_true_andp by tauto.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with hs.
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left2. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold PROPx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
subst zz.
apply exp_right with x.
normalize.
rewrite prop_true_andp by tauto.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with (i::fst hs, snd hs).
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left1. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
+
unfold func_ptr'.
apply subp_andp; [ | apply subp_refl].
clear - instance.
eapply derives_trans; [ | apply fash_func_ptr_ND].
apply allp_right; intros [hs i].
apply andp_right.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
rewrite prop_true_andp by tauto.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with hs.
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left2. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold PROPx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
subst zz.
apply exp_right with x.
normalize.
rewrite prop_true_andp by tauto.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with (i::fst hs, snd hs).
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left1. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
Qed.

Definition obj_mpred:ObjInv -> mpred := (HORec F). (*ie same type as Andrew's object_mpred.*)

Lemma ObjMpred_fold_unfold:
HOcontractive (fun (_ : ObjInv -> mpred) (x : ObjInv) => instance x) ->
obj_mpred =
fun hs =>
  ((EX mtable: val,!!(isptr mtable) &&
     (|> object_methods obj_mpred mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   instance hs)%logic.
Proof.
  intros; unfold obj_mpred at 1.
  rewrite HORec_fold_unfold; [ reflexivity | apply HOcontrF]; trivial.
Qed.
Lemma ObjMpred_fold_unfold' hs:
HOcontractive (fun (_ : ObjInv -> mpred) (x : ObjInv) => instance x) ->
obj_mpred hs =
  ((EX mtable: val, !!(isptr mtable) &&
     (|> object_methods obj_mpred mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   instance hs)%logic.
Proof.
  intros. rewrite ObjMpred_fold_unfold, <- ObjMpred_fold_unfold; trivial.
Qed.

Lemma ObjMpred_isptr
   (H: HOcontractive (fun (_ : ObjInv -> mpred) (x : ObjInv) => instance x))
    hs: obj_mpred hs |-- !!(isptr (snd hs)).
Proof. rewrite ObjMpred_fold_unfold' by trivial; Intros m. entailer!. Qed.

End ObjMpred.

Definition object_mpred: object_invariant := fun hs =>
  EX instance, !!(HOcontractive (fun (_ : ObjInv -> mpred) (x : ObjInv) => instance x)) &&
               obj_mpred instance hs.
(*This now plays the role of Andrew's obj_mpred*)

Lemma object_mpred_isptr hs: object_mpred hs |-- !!(isptr (snd hs)).
Proof. unfold object_mpred; Intros inst. apply ObjMpred_isptr; trivial. Qed.

Lemma obj_mpred_entails_object_mpred inst hs
  (H: HOcontractive (fun (_ : ObjInv -> mpred) (x : ObjInv) => inst x)):
  obj_mpred inst hs |-- object_mpred hs.
Proof. unfold object_mpred. Exists inst. entailer!. Qed.

(*Andrew's specs
Definition foo_invariant : object_invariant :=
  (fun (history: list Z) p =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 history)))) p
      *  malloc_token Ews (Tstruct _foo_object noattr) p)
Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_invariant).

Definition foo_twiddleR_spec :=
 DECLARE _foo_twiddleR  (twiddle_spec foo_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () LOCAL (gvars gv)
    SEP (mem_mgr gv; object_methods foo_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () LOCAL (temp ret_temp p)
     SEP (mem_mgr gv; object_mpred (*nil p*)(nil, p); object_methods foo_invariant (gv _foo_methods)).

*)

Section NewSpecs.
Definition foo_data : object_invariant :=
  (fun (x:ObjInv) =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 (fst x))))) (snd x)
      *  malloc_token Ews (Tstruct _foo_object noattr) (snd x)).
Lemma foo_data_HOcontr: HOcontractive (fun (_ : ObjInv -> mpred) (x : ObjInv) => foo_data x).
Proof.
  assert (predicates_rec.HOcontractive (fun (_ : ObjInv -> mpred) (x : ObjInv) => foo_data x)). 2: apply H.
  unfold foo_data.
  unfold withspacer; simpl.
  apply Trashcan.sepcon_HOcontractive.
  apply Trashcan.const_HOcontractive.
  apply Trashcan.const_HOcontractive.
Qed.

Definition foo_obj_invariant :object_invariant := obj_mpred foo_data.

(*New lemma!*)
Lemma foo_obj_invariant_fold_unfold: foo_obj_invariant =
 fun hs =>
  ((EX mtable: val, !!(isptr mtable) &&
     (|>object_methods foo_obj_invariant  mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   foo_data hs)%logic.
Proof.
  unfold foo_obj_invariant.
  rewrite <- ObjMpred_fold_unfold. trivial. apply foo_data_HOcontr.
Qed.

(*Sometimes this variant is preferable, sometimes the one above*)
Lemma foo_obj_invariant_fold_unfold' hs: foo_obj_invariant hs =
  ((EX mtable: val, !!(isptr mtable) &&
     (|>object_methods foo_obj_invariant  mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   foo_data hs)%logic.
Proof. rewrite foo_obj_invariant_fold_unfold. rewrite <- foo_obj_invariant_fold_unfold; trivial. Qed.

Lemma foo_data_isptr hs: foo_data hs = !!(isptr (snd hs)) && foo_data hs.
apply pred_ext; entailer.
unfold foo_data. entailer!. destruct (snd hs); simpl in *; trivial;  contradiction.
Qed.

Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_obj_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_obj_invariant).

Definition foo_twiddleR_spec :=
 DECLARE _foo_twiddleR  (twiddle_spec foo_obj_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () PARAMS () GLOBALS (gv)
    SEP (mem_mgr gv; object_methods foo_obj_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () LOCAL (temp ret_temp p)
     SEP (mem_mgr gv; object_mpred (nil,p); object_methods foo_obj_invariant (gv _foo_methods)).
End NewSpecs.

Definition FooGprog : funspecs :=   ltac:(with_library prog [
    foo_reset_spec; foo_twiddle_spec; foo_twiddleR_spec; make_foo_spec(*; main_spec*)]).

Lemma body_foo_reset: semax_body Vprog FooGprog f_foo_reset foo_reset_spec.
Proof.
start_function.
(*New:*) rewrite foo_obj_invariant_fold_unfold. Intros m; unfold foo_data.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
entailer!.
(*New:*) rewrite foo_obj_invariant_fold_unfold, <- foo_obj_invariant_fold_unfold. Exists m; unfold foo_data.
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_reset_alternativeproof: semax_body Vprog FooGprog f_foo_reset foo_reset_spec.
Proof.
(*New*) unfold foo_reset_spec. rewrite foo_obj_invariant_fold_unfold; unfold reset_spec.
start_function.
(*New:*) Intros m; unfold foo_data.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
entailer!.
(*New:*) Exists m; unfold foo_data.
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_twiddle: semax_body Vprog FooGprog f_foo_twiddle foo_twiddle_spec.
Proof.
(*New*) unfold foo_twiddle_spec. rewrite foo_obj_invariant_fold_unfold; unfold twiddle_spec.
start_function.
(*New:*) Intros m; unfold foo_data.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
{ set (j:= Int.max_signed / 4) in *; compute in j; subst j.
  forget (fold_right Z.add 0 (*history*)(fst hs)) as h.
  entailer!. }
forward.  (* return d+i; *)
{ simpl.
  set (j:= Int.max_signed / 4) in *; compute in j; subst j.
  forget (fold_right Z.add 0 (*history*)(fst hs)) as h.
  entailer!. }
Exists (2 * fold_right Z.add 0 (*history*)(fst hs) + i).
(*New:*) Exists m; unfold foo_data.
simpl;
entailer!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!.
Qed.

Lemma body_foo_twiddleR: semax_body Vprog FooGprog f_foo_twiddleR foo_twiddleR_spec.
Proof.
(*New*) unfold foo_twiddleR_spec. rewrite foo_obj_invariant_fold_unfold; unfold twiddle_spec.
start_function.
(*New:*) Intros m; unfold foo_data.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)

(*The new function call*)
forward.
unfold object_methods. Intros sh r t tR.
forward. (*_s_reset = (_mtable -> _reset);*)
forward_call hs.
{ rewrite foo_obj_invariant_fold_unfold'.
  Exists m. unfold foo_data, withspacer; simpl. entailer!.
  sep_apply make_object_methods_later. cancel. }
(*The spec has folded the object, so need to unfold again*)
deadvars!. clear - H H0.
rewrite foo_obj_invariant_fold_unfold. Intros m. unfold foo_data, withspacer; Intros; simpl.

forward.  (* self -> data = d+2*i; *)
{ set (j:= Int.max_signed / 4) in *; compute in j; subst j.
  forget (fold_right Z.add 0 (*history*)(fst hs)) as h.
  rewrite field_at_isptr; Intros.
  entailer!. }
forward.  (* return d+i; *)
{ simpl.
  set (j:= Int.max_signed / 4) in *; compute in j; subst j.
  forget (fold_right Z.add 0 (*history*)(fst hs)) as h.
  entailer!. }
Exists (2 * fold_right Z.add 0 (*history*)(fst hs) + i).
(*New:*) Exists m; unfold foo_data.
simpl;
entailer!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!.
Qed.

Lemma split_object_methods:
  forall instance m,
    object_methods instance m |-- object_methods instance m * object_methods instance m.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle twiddleR.

Exists (fst (slice.cleave sh)) reset twiddle twiddleR.
Exists (snd (slice.cleave sh)) reset twiddle twiddleR.
rewrite (split_func_ptr' (reset_spec instance) reset) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddle) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddleR) at 1.
entailer!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

(* Isolate a lemma from Andrew's proof of body_make_foo; TODO: simplify the following proof. *)
Lemma MC_FC p (H: malloc_compatible (sizeof (Tstruct _foo_object noattr)) p):
      field_compatible (Tstruct _object noattr) [StructField _mtable] p.
Proof.
destruct p; try contradiction.
destruct H as [AL SZ].
repeat split; auto.
simpl in *.  unfold sizeof in *; simpl in *; lia.
eapply align_compatible_rec_Tstruct; [reflexivity |].
simpl co_members; intros.
simpl in H.
if_tac in H; [| inv H].
inv H. inv H0.
eapply align_compatible_rec_by_value.
reflexivity.
rewrite Z.add_0_r.
simpl.
unfold natural_alignment in AL.
eapply Z.divide_trans; [ | apply AL].
apply prove_Zdivide.
reflexivity.
left; auto.
Qed.

Lemma body_make_foo: semax_body Vprog FooGprog f_make_foo make_foo_spec.
Proof.
unfold make_foo_spec.
start_function.
forward_call (Tstruct _foo_object noattr, gv).
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _foo_object noattr) p;
          data_at_ Ews (Tstruct _foo_object noattr) p;
          object_methods foo_obj_invariant (gv _foo_methods))).
*
change (Memory.EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!.
*
forward_call 1.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &foo_methods; *)
forward. (* p->data = 0; *)
forward. (* return (struct object * ) p; *)
Exists p.
sep_apply (split_object_methods foo_obj_invariant (gv _foo_methods)).
entailer!.
unfold object_mpred.

(*slight variation of Andrew's proof from here on*)
Exists foo_data. entailer!. 1: solve [apply foo_data_HOcontr].
rewrite ObjMpred_fold_unfold by (apply foo_data_HOcontr).
Exists (gv _foo_methods). simpl. normalize.
rewrite ! sepcon_assoc. apply sepcon_derives. apply now_later.
unfold foo_data; simpl. unfold withspacer; simpl.
cancel.
unfold_data_at (field_at _ _ nil _ p).
cancel.
clear -H.
rewrite !field_at_data_at.
simpl.
apply derives_refl'.
rewrite <- ?sepcon_assoc. (* needed if Archi.ptr64=true *)
rewrite !field_compatible_field_address; auto with field_compatible.
apply MC_FC; trivial.
Qed.

End FOO.

Section FancyFoo.

Definition fObjInv : Type:= ((list Z * Z) * val).
Definition fobject_invariant := fObjInv -> mpred.

(*not replcatedDefinition tobject := tptr (Tstruct _object noattr).*)

Definition freset_spec (instance: fobject_invariant) :=
  WITH hs:fObjInv (*modified*)
  PRE [ (*_self OF*) tobject]
          PROP (isptr (snd hs) (*NEW*))
          PARAMS (snd hs) GLOBALS ()
          SEP (instance hs)
  POST [ tvoid ]
          PROP() LOCAL () SEP(instance ((nil, snd(fst hs)), snd hs)).

Definition ftwiddle_spec (instance: fobject_invariant) :=
  WITH hs: fObjInv, i: Z
  PRE [ (*_self OF*) tobject, (*_i OF*) tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 (fst (fst hs)) <= Int.max_signed / 4;
               isptr (snd hs) (*NEW*))
          PARAMS (snd hs; Vint (Int.repr i)) GLOBALS ()
          SEP (instance hs)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 (fst (fst hs)) < v <= 2* fold_right Z.add 0 (i::(fst (fst hs))))
          LOCAL (temp ret_temp (Vint (Int.repr v)))
          SEP(instance ((i::(fst (fst hs)), snd(fst hs)), snd hs)).

Definition fsetcolor_spec (instance: fobject_invariant) :=
  WITH hs:fObjInv, c:Z
  PRE [ (*_self OF*) tobject, (*_c OF*) tint]
          PROP (isptr (snd hs) (*NEW*))
          PARAMS (snd hs; Vint(Int.repr c)) GLOBALS ()
          SEP (instance hs)
  POST [ tvoid ]
          PROP() LOCAL () SEP(instance ((fst(fst hs), c), snd hs)).

Definition fgetcolor_spec (instance: fobject_invariant) :=
  WITH hs: fObjInv
  PRE [ (*_self OF*) tobject]
          PROP (isptr (snd hs) (*NEW*))
          PARAMS (snd hs) GLOBALS ()
          SEP (instance hs)
  POST [ tint ]
          PROP()
          LOCAL (temp ret_temp (Vint (Int.repr (snd(fst hs)))))
          SEP(instance hs).
Check reset_spec. Print ObjInv.

Definition fobject_invariant_of_inv (INV:object_invariant):fobject_invariant.
Proof. intros [[hs c] p]. apply (INV (hs,p)). Defined.

Lemma reset_spec_local_sub INV: funspec_sub (reset_spec INV)
                                            (freset_spec (fobject_invariant_of_inv INV)).
Proof. do_funspec_sub. destruct w as [[hs c] p]; simpl. Exists (hs,p) emp; simpl. entailer!. Qed.

Lemma twiddle_spec_local_sub INV: funspec_sub (twiddle_spec INV)
                                              (ftwiddle_spec (fobject_invariant_of_inv INV)).
Proof. do_funspec_sub. destruct w as [[[hs c] p] i]; simpl.
  Exists ((hs,p),i) emp; entailer!.
  intros. Exists x0. entailer!.
Qed.

Definition fobject_methods (instance: fobject_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val, EX twiddleR:val, EX setcol: val, EX getcol:val,
  !! readable_share sh &&
  func_ptr' (freset_spec instance) reset *
  func_ptr' (ftwiddle_spec instance) twiddle *
  func_ptr' (ftwiddle_spec instance) twiddleR *
  func_ptr' (fsetcolor_spec instance) setcol *
  func_ptr' (fgetcolor_spec instance) getcol *
  data_at sh (Tstruct _fancymethods noattr) (reset,(twiddle, (twiddleR, (setcol, getcol)))) mtable.

Lemma fobject_methods_local_facts: forall instance p,
  fobject_methods instance p |-- !! isptr p.
Proof.
intros.
unfold fobject_methods.
Intros sh reset twiddle twiddleR setcol getcol.
entailer!.
Qed.
Local Hint Resolve fobject_methods_local_facts : saturate_local.

Lemma make_fobject_methods:
  forall sh instance reset twiddle twiddleR setcol getcol mtable,
  readable_share sh ->
  func_ptr' (freset_spec instance) reset *
  func_ptr' (ftwiddle_spec instance) twiddle *
  func_ptr' (ftwiddle_spec instance) twiddleR *
  func_ptr' (fsetcolor_spec instance) setcol *
  func_ptr' (fgetcolor_spec instance) getcol *
  data_at sh (Tstruct _fancymethods noattr) (reset,(twiddle, (twiddleR, (setcol, getcol)))) mtable
  |-- fobject_methods instance mtable.
Proof.
  intros.
  unfold fobject_methods.
  Exists sh reset twiddle twiddleR setcol getcol.
  entailer!.
Qed.

Lemma make_fobject_methods_later:
  forall sh instance reset twiddle twiddleR setcol getcol mtable,
  readable_share sh ->
  func_ptr' (freset_spec instance) reset *
  func_ptr' (ftwiddle_spec instance) twiddle *
  func_ptr' (ftwiddle_spec instance) twiddleR *
  func_ptr' (fsetcolor_spec instance) setcol *
  func_ptr' (fgetcolor_spec instance) getcol *
  data_at sh (Tstruct _fancymethods noattr) (reset,(twiddle, (twiddleR, (setcol, getcol)))) mtable
  |-- |> fobject_methods instance mtable.
Proof.
intros. eapply derives_trans. apply make_fobject_methods; trivial. apply now_later.
Qed.

Section FObjMpred.
Variable instance: fobject_invariant.

Definition G (X: fObjInv -> mpred) (hs: fObjInv): mpred :=
   ((EX mtable: val, !!(isptr mtable) (*This has to hold NOW, not ust LATER*)&&
     (|> fobject_methods X mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   instance hs)%logic.

Lemma HOcontrG
     (*Need sth like this (HI: HOcontractive (fun (_ : ObjInv -> mpred) (x : ObjInv) => instance x))*):
      HOcontractive G.
Proof.
unfold F.
apply HOcontractive_i1.
red; intros.
apply allp_right; intro oi.
apply subp_sepcon_mpred; [ | apply subp_refl].
apply subp_exp; intro v.
apply subp_sepcon_mpred; [ | apply subp_refl].
clear oi.
apply subp_andp; [ apply subp_refl | ].
rewrite <- subp_later.
rewrite <- later_allp.
apply later_derives.
unfold fobject_methods.
apply subp_exp; intro sh.
apply subp_exp; intro reset.
apply subp_exp; intro twiddle.
apply subp_exp; intro twiddleR.
apply subp_exp; intro setCol.
apply subp_exp; intro getCol.
apply subp_sepcon_mpred; [ | apply subp_refl].
repeat simple apply subp_sepcon_mpred;
try (simple apply subp_andp; [simple apply subp_refl | ]).
+
unfold func_ptr'.
apply subp_andp; [ | apply subp_refl].
clear - instance.
eapply derives_trans; [ | apply fash_func_ptr_ND].
apply allp_right; intro oi.
apply andp_right.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
rewrite prop_true_andp by tauto.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with oi.
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left2. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with ([], snd (fst oi), snd oi).
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left1. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
+
unfold func_ptr'.
apply subp_andp; [ | apply subp_refl].
clear - instance.
eapply derives_trans; [ | apply fash_func_ptr_ND].
apply allp_right; intros [hs i].
apply andp_right.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
rewrite prop_true_andp by tauto.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with hs.
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left2. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold PROPx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
subst zz.
apply exp_right with x.
normalize.
rewrite prop_true_andp by tauto.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with (i :: fst (fst hs), snd (fst hs), snd hs).
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left1. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
+
unfold func_ptr'.
apply subp_andp; [ | apply subp_refl].
clear - instance.
eapply derives_trans; [ | apply fash_func_ptr_ND].
apply allp_right; intros [hs i].
apply andp_right.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
rewrite prop_true_andp by tauto.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with hs.
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left2. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold PROPx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
subst zz.
apply exp_right with x.
normalize.
rewrite prop_true_andp by tauto.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with (i :: fst (fst hs), snd (fst hs), snd hs).
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left1. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
+
unfold func_ptr'.
apply subp_andp; [ | apply subp_refl].
clear - instance.
eapply derives_trans; [ | apply fash_func_ptr_ND].
apply allp_right; intros [hs i].
apply andp_right.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
rewrite prop_true_andp by tauto.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with hs.
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left2. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold PROPx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
subst zz. (*
apply exp_right with x.
normalize.
rewrite prop_true_andp by tauto.*)
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with (fst (fst hs), i, snd hs).
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left1. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
+
unfold func_ptr'.
apply subp_andp; [ | apply subp_refl].
clear - instance.
eapply derives_trans; [ | apply fash_func_ptr_ND].
apply allp_right; intros [hs i].
apply andp_right.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold convertPre.
unfold PROPx, PARAMSx, GLOBALSx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
rewrite prop_true_andp by tauto.
subst zz.
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with (hs,i).
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left2. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
*
apply allp_right; intro rho.
apply subp_i1.
rewrite unfash_allp.
set (zz := allp _).
unfold PROPx, LOCALx, SEPx, local, lift1; simpl.
unfold_lift.
normalize.
subst zz. (*
apply exp_right with x.
normalize.
rewrite prop_true_andp by tauto.*)
eapply derives_trans.
apply andp_derives; [ | apply derives_refl].
apply allp_left with (hs,i).
apply unfash_fash.
eapply derives_trans.
apply andp_derives.
apply andp_left1. apply derives_refl. apply derives_refl.
rewrite andp_comm. apply modus_ponens.
Qed.

Definition fobj_mpred:fObjInv -> mpred := (HORec G). (*ie same type as Andrew's object_mpred.*)

Lemma fObjMpred_fold_unfold:
HOcontractive (fun (_ : fObjInv -> mpred) (x : fObjInv) => instance x) ->
fobj_mpred =
fun hs =>
  ((EX mtable: val,!!(isptr mtable) &&
     (|> fobject_methods fobj_mpred mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   instance hs)%logic.
Proof.
  intros; unfold fobj_mpred at 1.
  rewrite HORec_fold_unfold; [ reflexivity | apply HOcontrG]; trivial.
Qed.
Lemma fObjMpred_fold_unfold' hs:
HOcontractive (fun (_ : fObjInv -> mpred) (x : fObjInv) => instance x) ->
fobj_mpred hs =
  ((EX mtable: val, !!(isptr mtable) &&
     (|> fobject_methods fobj_mpred mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   instance hs)%logic.
Proof.
  intros. rewrite fObjMpred_fold_unfold, <- fObjMpred_fold_unfold; trivial.
Qed.

Lemma fObjMpred_isptr
   (H: HOcontractive (fun (_ : fObjInv -> mpred) (x : fObjInv) => instance x))
    hs: fobj_mpred hs |-- !!(isptr (snd hs)).
Proof. rewrite fObjMpred_fold_unfold' by trivial; Intros m. entailer!. Qed.

End FObjMpred.

Definition fobject_mpred: fobject_invariant := fun hs =>
  EX instance, !!(HOcontractive (fun (_ : fObjInv -> mpred) (x : fObjInv) => instance x)) &&
               fobj_mpred instance hs.
(*This now plays the role of Andrew's obj_mpred*)

Lemma fobject_mpred_isptr hs: fobject_mpred hs |-- !!(isptr (snd hs)).
Proof. unfold fobject_mpred; Intros inst. apply fObjMpred_isptr; trivial. Qed.

Lemma fobj_mpred_entails_object_mpred inst hs
  (H: HOcontractive (fun (_ : fObjInv -> mpred) (x : fObjInv) => inst x)):
  fobj_mpred inst hs |-- fobject_mpred hs.
Proof. unfold object_mpred. Exists inst. entailer!. Qed.

Section FancySpecs.

(*We use (Tstruct _foo_object noattr) (superclass) for the field_at for _data
  and (Tstruct _fancyfoo_object noattr) for the field_at for _color*)
Definition fancyfoo_data : fobject_invariant :=
  (fun (x:fObjInv) =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 (fst (fst x)))))) (snd x)
   * withspacer Ews (sizeof size_t + 2*sizeof tint) (3 * sizeof size_t) (field_at Ews (Tstruct _fancyfoo_object noattr)
            [StructField _color] (Vint (Int.repr (snd(fst x))))) (snd x)
      *  malloc_token Ews (Tstruct _fancyfoo_object noattr) (snd x)).
Lemma fancyfoo_data_HOcontr: HOcontractive (fun (_ : fObjInv -> mpred) (x : fObjInv) => fancyfoo_data x).
Proof.
  assert (predicates_rec.HOcontractive (fun (_ : fObjInv -> mpred) (x : fObjInv) => fancyfoo_data x)). 2: apply H.
  unfold fancyfoo_data.
  unfold withspacer; simpl.
  apply Trashcan.sepcon_HOcontractive.
  apply Trashcan.const_HOcontractive.
  apply Trashcan.const_HOcontractive.
Qed.

Definition fancyfoo_obj_invariant :fobject_invariant := fobj_mpred fancyfoo_data.

(*New lemma!*)
Lemma fancyfoo_obj_invariant_fold_unfold: fancyfoo_obj_invariant =
 fun hs =>
  ((EX mtable: val, !!(isptr mtable) &&
     (|>fobject_methods fancyfoo_obj_invariant  mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   fancyfoo_data hs)%logic.
Proof.
  unfold fancyfoo_obj_invariant.
  rewrite <- fObjMpred_fold_unfold. trivial. apply fancyfoo_data_HOcontr.
Qed.

(*Sometimes this variant is preferable, sometimes the one above*)
Lemma fancyfoo_obj_invariant_fold_unfold' hs: fancyfoo_obj_invariant hs =
  ((EX mtable: val, !!(isptr mtable) &&
     (|>fobject_methods fancyfoo_obj_invariant  mtable) *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable (snd hs)) *
   fancyfoo_data hs)%logic.
Proof. rewrite fancyfoo_obj_invariant_fold_unfold. rewrite <- fancyfoo_obj_invariant_fold_unfold; trivial. Qed.

Lemma fancyfoo_data_isptr hs: fancyfoo_data hs = !!(isptr (snd hs)) && fancyfoo_data hs.
apply pred_ext; entailer.
unfold fancyfoo_data. entailer!. destruct (snd hs); simpl in *; trivial;  contradiction.
Qed.

(*The three inherited functions are equipped with fancy specs*)
Definition ffoo_reset_spec :=
 DECLARE _foo_reset (freset_spec fancyfoo_obj_invariant).

Definition ffoo_twiddle_spec :=
 DECLARE _foo_twiddle  (ftwiddle_spec fancyfoo_obj_invariant).

Definition ffoo_twiddleR_spec :=
 DECLARE _foo_twiddleR  (ftwiddle_spec fancyfoo_obj_invariant).

Definition ffoo_setcolor_spec :=
 DECLARE _setcolor  (fsetcolor_spec fancyfoo_obj_invariant).

Definition ffoo_getcolor_spec :=
 DECLARE _getcolor  (fgetcolor_spec fancyfoo_obj_invariant).

Definition make_fancyfoo_spec :=
 DECLARE _make_fancyfoo
 WITH gv: globals, c:Z
 PRE [(*_c OF*) tint ]
    PROP () PARAMS (Vint(Int.repr c)) GLOBALS (gv)
    SEP (mem_mgr gv; fobject_methods fancyfoo_obj_invariant (gv _fancyfoo_methods))
 POST [ tobject ]
    EX p: val, PROP () LOCAL (temp ret_temp p)
     SEP (mem_mgr gv; fobject_mpred ((nil,c),p); fobject_methods fancyfoo_obj_invariant (gv _fancyfoo_methods)).

Definition make_fancyfooTyped_spec :=
 DECLARE _make_fancyfooTyped
 WITH gv: globals, c:Z
 PRE [ (*_c OF*) tint ]
    PROP () PARAMS (Vint(Int.repr c)) GLOBALS (gv)
    SEP (mem_mgr gv; fobject_methods fancyfoo_obj_invariant (gv _fancyfoo_methods))
 POST [ tptr (Tstruct _fancyfoo_object noattr) ]
    EX p: val, PROP () LOCAL (temp ret_temp p)
     SEP (mem_mgr gv; fobject_mpred ((nil,c),p); fobject_methods fancyfoo_obj_invariant (gv _fancyfoo_methods)).

End FancySpecs.

Definition FancyGprog : funspecs :=   ltac:(with_library prog [
    ffoo_reset_spec; ffoo_twiddle_spec; ffoo_twiddleR_spec;
    ffoo_setcolor_spec; ffoo_getcolor_spec;
    make_fancyfoo_spec; make_fancyfooTyped_spec(*; main_spec*)]).

Lemma body_fancyfoo_reset: semax_body Vprog FancyGprog f_foo_reset ffoo_reset_spec.
Proof.
start_function.
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold. Intros m; unfold fancyfoo_data.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
entailer!.
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold, <- fancyfoo_obj_invariant_fold_unfold. Exists m; unfold fancyfoo_data.
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_fancyfoo_twiddle: semax_body Vprog FancyGprog f_foo_twiddle ffoo_twiddle_spec.
Proof.
start_function.
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold. Intros m; unfold fancyfoo_data.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
{ set (j:= Int.max_signed / 4) in *; compute in j; subst j.
  forget (fold_right Z.add 0 (*(fst hs)*)(fst(fst hs))) as h.
  entailer!. }
forward.  (* return d+i; *)
{ simpl.
  set (j:= Int.max_signed / 4) in *; compute in j; subst j.
  forget (fold_right Z.add 0 (*(fst hs)*) (fst(fst hs))) as h.
  entailer!. }
Exists (2 * fold_right Z.add 0 (*(fst hs)*) (fst(fst hs)) + i).
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold, <- fancyfoo_obj_invariant_fold_unfold.
Exists m; unfold fancyfoo_data.
simpl;
entailer!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!.
Qed.

(*A key lemma relating the two classes*)
Lemma FC_fancymethods f m (L: legal_field (nested_field_type (Tstruct _methods noattr) []) (StructField f))
        (FC: field_compatible (Tstruct _fancymethods noattr) [StructField f] m):
        field_compatible (Tstruct _methods noattr) [StructField f] m.
Proof.
  destruct FC as [X1 [X2 [SZ [AL [X5 X6]]]]].
  destruct m; try inv X1. clear - L SZ AL.
  repeat split; auto.
  + simpl in *.  unfold sizeof in *; simpl in *; lia.
  + clear L SZ. inv AL. inv H. inv H1.
    eapply align_compatible_rec_Tstruct; [reflexivity |].
    simpl co_members in *; intros. specialize (H3 i0 t0).
    simpl in H.
    if_tac in H.
    { inv H. specialize (H3 _ (eq_refl _) (eq_refl _)).
      inv H3. inv H0. inv H. simpl in H1.
      eapply align_compatible_rec_by_value.
      reflexivity. apply H1. }
    clear H1.
    if_tac in H.
    { inv H. specialize (H3 _ (eq_refl _) (eq_refl _)).
      inv H3. inv H0. inv H. simpl in H1.
      eapply align_compatible_rec_by_value.
      reflexivity. apply H1. }
    clear H1.
    if_tac in H.
    { inv H. specialize (H3 _ (eq_refl _) (eq_refl _)).
      inv H3. inv H0. inv H. simpl in H1.
      eapply align_compatible_rec_by_value.
      reflexivity. apply H1. }
    inv H.
Qed.

Lemma body_fancyfoo_twiddleR: semax_body Vprog FancyGprog f_foo_twiddleR ffoo_twiddleR_spec.
Proof.
start_function.
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold. Intros m; unfold fancyfoo_data.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)

(*The new function call*)
forward.
unfold fobject_methods. Intros sh r t tR g s.

(*New HERE*)
unfold_data_at (data_at sh (Tstruct _fancymethods noattr) _ _).
rewrite (field_at_compatible' sh (Tstruct _fancymethods noattr) [StructField _reset]); Intros. rename H3 into FCmethod.
replace_SEP 5 (field_at sh (Tstruct _methods noattr) [StructField _reset] r m).
{ clear - FCmethod. entailer!. clear - FCmethod. unfold field_at; simpl; entailer!.
  apply FC_fancymethods; trivial. left; auto. }

forward. (*_s_reset = (_mtable -> _reset);*)
forward_call hs.
{ (*NEW side condition - again a property of subclasses*)
  rewrite fancyfoo_obj_invariant_fold_unfold'.
  Exists m. unfold fancyfoo_data, withspacer; simpl. entailer!.
  eapply derives_trans.
  2:{ apply sepcon_derives.
      apply ( make_fobject_methods_later sh fancyfoo_obj_invariant r t tR g s m); trivial.
      apply derives_refl. }
  cancel. unfold_data_at (data_at sh (Tstruct _fancymethods noattr) _ _ ).
  cancel. unfold field_at; simpl; entailer!. }
(*The spec has folded the object, so need to unfold again*)
deadvars!. clear - H H0.
rewrite fancyfoo_obj_invariant_fold_unfold. Intros m. unfold fancyfoo_data, withspacer; Intros; simpl.

forward.  (* self -> data = d+2*i; *)
{ set (j:= Int.max_signed / 4) in *; compute in j; subst j.
  forget (fold_right Z.add 0 (*(fst hs)*)(fst(fst hs))) as h.
  rewrite field_at_isptr; Intros.
  entailer!. }
forward.  (* return d+i; *)
{ simpl.
  set (j:= Int.max_signed / 4) in *; compute in j; subst j.
  forget (fold_right Z.add 0 (*(fst hs)*)(fst(fst hs))) as h.
  entailer!. }
Exists (2 * fold_right Z.add 0 (*(fst hs)*)(fst(fst hs)) + i).
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold, <- fancyfoo_obj_invariant_fold_unfold.
Exists m; unfold fancyfoo_data.
simpl;
entailer!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!.
Qed.

Lemma body_ffoo_setcolor: semax_body Vprog FancyGprog f_setcolor ffoo_setcolor_spec.
Proof.
start_function.
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold. Intros m; unfold fancyfoo_data.
unfold withspacer; simpl; Intros.
forward.  (* self->color=0; *)
entailer!.
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold, <- fancyfoo_obj_invariant_fold_unfold. Exists m; unfold fancyfoo_data.
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_ffoo_getcolor: semax_body Vprog FancyGprog f_getcolor ffoo_getcolor_spec.
Proof.
start_function.
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold. Intros m; unfold fancyfoo_data.
unfold withspacer; simpl; Intros.
forward.  (* _t'1 = ((tptr (Tstruct _fancyfoo_object noattr)) _self -> _color); *)
forward.
entailer!.
(*New:*) rewrite fancyfoo_obj_invariant_fold_unfold, <- fancyfoo_obj_invariant_fold_unfold. Exists m; unfold fancyfoo_data.
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma split_fobject_methods:
  forall instance m,
    fobject_methods instance m |-- fobject_methods instance m * fobject_methods instance m.
Proof.
intros.
unfold fobject_methods.
Intros sh reset twiddle twiddleR setC getC.

Exists (fst (slice.cleave sh)) reset twiddle twiddleR setC getC.
Exists (snd (slice.cleave sh)) reset twiddle twiddleR setC getC.
rewrite (split_func_ptr' (freset_spec instance) reset) at 1.
rewrite (split_func_ptr' (ftwiddle_spec instance) twiddle) at 1.
rewrite (split_func_ptr' (ftwiddle_spec instance) twiddleR) at 1.
rewrite (split_func_ptr' (fsetcolor_spec instance) setC) at 1.
rewrite (split_func_ptr' (fgetcolor_spec instance) getC) at 1.
entailer!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

Lemma body_make_fancyfoo: semax_body Vprog FancyGprog f_make_fancyfoo make_fancyfoo_spec.
Proof.
unfold make_fancyfoo_spec.
start_function.
forward_call (Tstruct _fancyfoo_object noattr, gv).
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; temp _c (Vint (Int.repr c)); gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _fancyfoo_object noattr) p;
          data_at_ Ews (Tstruct _fancyfoo_object noattr) p;
          fobject_methods fancyfoo_obj_invariant (gv _fancyfoo_methods))).
*
change (Memory.EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!.
*
forward_call 1.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &fancyfoo_methods; *)
forward. (* p->data = 0; *)
forward. (* p->color = c;*)
forward. (* return (struct object * ) p; *)
Exists p.
sep_apply (split_fobject_methods fancyfoo_obj_invariant (gv _fancyfoo_methods)).
entailer!.
unfold fobject_mpred.

(*slight variation of Andrew's proof from here on*)
Exists fancyfoo_data. entailer!. 1: solve [apply fancyfoo_data_HOcontr].
rewrite fObjMpred_fold_unfold by (apply fancyfoo_data_HOcontr).
Exists (gv _fancyfoo_methods). simpl. normalize.
rewrite ! sepcon_assoc. apply sepcon_derives. apply now_later.
unfold fancyfoo_data; simpl. unfold withspacer; simpl.
cancel.
unfold_data_at (field_at _ _ nil _ p).
cancel.
assert_PROP (isptr p) by entailer!. destruct p; inv H2. entailer!.
apply sepcon_derives.
+ clear - H2. unfold field_at; simpl; entailer!.
  - unfold field_compatible. destruct H2 as [_ [_ [SZ [AL _]]]].
    repeat split; trivial.
    ++ red. red in SZ. simpl sizeof in *. lia.
    ++ clear SZ. inv AL. inv H.
       eapply align_compatible_rec_Tstruct; [reflexivity | intros]. specialize (H3 i0).
       simpl co_members in *; intros. inv H.
       if_tac in H4; inv H4.
       inv H0. inv H1. specialize (H3 _ 0 (eq_refl _) (eq_refl _)).
       inv H3. inv H. econstructor. reflexivity. trivial.
    ++ simpl. left; auto.
  - unfold at_offset. entailer!. unfold data_at_rec. simpl.
    unfold mapsto; simpl. if_tac; entailer!.
+ clear - H4. unfold field_at; simpl; entailer!.
  - unfold field_compatible. destruct H4 as [_ [_ [SZ [AL _]]]].
    repeat split; trivial.
    ++ red. red in SZ. simpl sizeof in *. lia.
    ++ clear SZ; inv AL. inv H.
       eapply align_compatible_rec_Tstruct; [reflexivity | intros]. specialize (H3 i0).
       simpl co_members in *; intros. inv H.
       if_tac in H4; inv H4.
       { inv H0. inv H1. specialize (H3 _ 0 (eq_refl _) (eq_refl _)).
          inv H3. inv H. econstructor. reflexivity. trivial. }
       clear H.
       if_tac in H5; inv H5.
       { inv H0. inv H1. specialize (H3 _ 4 (eq_refl _) (eq_refl _)).
          inv H3. inv H. econstructor. reflexivity. trivial. }
    ++ simpl. right; left; auto.
Qed.

(*EXACT SAME PROOF SCRIPT AS Lemma body_make_fancyfoo*)
Lemma body_make_fancyfooTyped: semax_body Vprog FancyGprog f_make_fancyfooTyped make_fancyfooTyped_spec.
Proof.
unfold make_fancyfooTyped_spec.
start_function.
forward_call (Tstruct _fancyfoo_object noattr, gv).
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; temp _c (Vint (Int.repr c)); gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _fancyfoo_object noattr) p;
          data_at_ Ews (Tstruct _fancyfoo_object noattr) p;
          fobject_methods fancyfoo_obj_invariant (gv _fancyfoo_methods))).
*
change (Memory.EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!.
*
forward_call 1.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &fancyfoo_methods; *)
forward. (* p->data = 0; *)
forward. (* p->color = c;*)
forward. (* return (struct object * ) p; *)
Exists p.
sep_apply (split_fobject_methods fancyfoo_obj_invariant (gv _fancyfoo_methods)).
entailer!.
unfold fobject_mpred.

(*slight variation of Andrew's proof from here on*)
Exists fancyfoo_data. entailer!. 1: solve [apply fancyfoo_data_HOcontr].
rewrite fObjMpred_fold_unfold by (apply fancyfoo_data_HOcontr).
Exists (gv _fancyfoo_methods). simpl. normalize.
rewrite ! sepcon_assoc. apply sepcon_derives. apply now_later.
unfold fancyfoo_data; simpl. unfold withspacer; simpl.
cancel.
unfold_data_at (field_at _ _ nil _ p).
cancel.

(*TODO: There's at least one variation of Lemma MC_FC in here...*)
assert_PROP (isptr p) by entailer!. destruct p; inv H2. entailer!.
apply sepcon_derives.
+ clear - H2. unfold field_at; simpl; entailer!.
  - unfold field_compatible. destruct H2 as [_ [_ [SZ [AL _]]]].
    repeat split; trivial.
    ++ red. red in SZ. simpl sizeof in *. lia.
    ++ clear SZ. inv AL. inv H.
       eapply align_compatible_rec_Tstruct; [reflexivity | intros]. specialize (H3 i0).
       simpl co_members in *; intros. inv H.
       if_tac in H4; inv H4.
       inv H0. inv H1. specialize (H3 _ 0 (eq_refl _) (eq_refl _)).
       inv H3. inv H. econstructor. reflexivity. trivial.
    ++ simpl. left; auto.
  - unfold at_offset. entailer!. unfold data_at_rec. simpl.
    unfold mapsto; simpl. if_tac; entailer!.
+ clear (*- H4*). unfold field_at; simpl; entailer!.
  - unfold field_compatible. destruct H as [_ [_ [SZ [AL _]]]].
    repeat split; trivial.
    ++ red. red in SZ. simpl sizeof in *. lia.
    ++ clear SZ; inv AL. inv H.
       eapply align_compatible_rec_Tstruct; [reflexivity | intros]. specialize (H3 i0).
       simpl co_members in *; intros. inv H.
       if_tac in H4; inv H4.
       { inv H0. inv H1. specialize (H3 _ 0 (eq_refl _) (eq_refl _)).
          inv H3. inv H. econstructor. reflexivity. trivial. }
       clear H.
       if_tac in H5; inv H5.
       { inv H0. inv H1. specialize (H3 _ 4 (eq_refl _) (eq_refl _)).
          inv H3. inv H. econstructor. reflexivity. trivial. }
    ++ simpl. right; left; auto.
Qed.

End FancyFoo.

Section Putting_It_All_Together.

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     EX i:Z, PROP(0<=i<=6) LOCAL (temp ret_temp (Vint (Int.repr (i+13)))) SEP(TT).

Definition reset_intersection: funspec.
Proof.
eapply (binary_intersection' (reset_spec foo_obj_invariant) (freset_spec fancyfoo_obj_invariant)); reflexivity.
Defined.
Definition twiddle_intersection: funspec.
Proof.
eapply (binary_intersection' (twiddle_spec foo_obj_invariant) (ftwiddle_spec fancyfoo_obj_invariant)); reflexivity.
Defined.

Lemma reset_sub_foo: funspec_sub reset_intersection (reset_spec foo_obj_invariant).
Proof.
apply (binaryintersection_sub (reset_spec foo_obj_invariant) (freset_spec fancyfoo_obj_invariant)).
apply binary_intersection'_sound.
Qed.
Lemma reset_sub_fancy: funspec_sub reset_intersection (freset_spec fancyfoo_obj_invariant).
Proof.
apply (binaryintersection_sub (reset_spec foo_obj_invariant) (freset_spec fancyfoo_obj_invariant)).
apply binary_intersection'_sound.
Qed.

Lemma twiddle_sub_foo: funspec_sub twiddle_intersection (twiddle_spec foo_obj_invariant).
Proof.
apply (binaryintersection_sub (twiddle_spec foo_obj_invariant) (ftwiddle_spec fancyfoo_obj_invariant)).
apply binary_intersection'_sound.
Qed.
Lemma twiddle_sub_fancy: funspec_sub twiddle_intersection (ftwiddle_spec fancyfoo_obj_invariant).
Proof.
apply (binaryintersection_sub (twiddle_spec foo_obj_invariant) (ftwiddle_spec fancyfoo_obj_invariant)).
apply binary_intersection'_sound.
Qed.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    (_foo_reset, reset_intersection); (_foo_twiddle, twiddle_intersection); (_foo_twiddleR, twiddle_intersection);
    (*foo_reset_spec; foo_twiddle_spec; foo_twiddleR_spec; *)make_foo_spec;
    (*ffoo_reset_spec; ffoo_twiddle_spec; ffoo_twiddleR_spec; *)
    ffoo_setcolor_spec; ffoo_getcolor_spec;
    make_fancyfoo_spec; make_fancyfooTyped_spec; main_spec]).

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
(* assert_gvar _foo_methods. (* TODO: this is needed for a field_compatible later on *) *)
fold noattr cc_default.

(* 0. This part should be handled automatically by start_function *) simpl.
gather_SEP (mapsto _ _ (offset_val 8 (gv _foo_methods)) _)
           (mapsto _ _ (offset_val 4 (gv _foo_methods)) _)
           (data_at _ _ _ (gv _foo_methods));
replace_SEP 0 (data_at Ews (Tstruct _methods noattr)
   (gv _foo_reset, (gv _foo_twiddle, gv _foo_twiddleR)) (gv _foo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _methods _) _ (gv _foo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddleR]) (v:= (gv _foo_twiddleR))
  by  auto with field_compatible.
  rewrite field_at_data_at. rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  cancel.
}
gather_SEP (mapsto _ _ (offset_val 16 (gv _fancyfoo_methods)) _)
           (mapsto _ _ (offset_val 12 (gv _fancyfoo_methods)) _)
           (mapsto _ _ (offset_val 8 (gv _fancyfoo_methods)) _)
           (mapsto _ _ (offset_val 4 (gv _fancyfoo_methods)) _)
           (data_at _ _ _ (gv _fancyfoo_methods));
replace_SEP 0 (data_at Ews (Tstruct _fancymethods noattr)
   (gv _foo_reset, (gv _foo_twiddle, (gv _foo_twiddleR, (gv _setcolor, gv _getcolor)))) (gv _fancyfoo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _fancymethods _) _ (gv _fancyfoo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddleR]) (v:= (gv _foo_twiddleR))
  by  auto with field_compatible.
  rewrite <- mapsto_field_at with (gfs := [StructField _setcolor]) (v:= (gv _setcolor))
  by  auto with field_compatible.
  rewrite <- mapsto_field_at with (gfs := [StructField _getcolor]) (v:= (gv _getcolor))
  by  auto with field_compatible.
  rewrite field_at_data_at. rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  cancel.
}

(* 1a. Prove that [methods] is a proper method table for foo-objects, and that
        fancymethods is a proper method table for fancyfoo-objects *)

make_func_ptr _foo_reset.
replace_SEP 0 (func_ptr' (reset_spec foo_obj_invariant) (gv _foo_reset) *
               func_ptr' (freset_spec fancyfoo_obj_invariant) (gv _foo_reset)).
{ entailer!. rewrite split_func_ptr'. apply sepcon_derives; apply func_ptr'_mono.
  apply reset_sub_foo. apply reset_sub_fancy. }
make_func_ptr _foo_twiddle.
replace_SEP 0 (func_ptr' (twiddle_spec foo_obj_invariant) (gv _foo_twiddle) *
               func_ptr' (ftwiddle_spec fancyfoo_obj_invariant) (gv _foo_twiddle)).
{ entailer!. rewrite split_func_ptr'. apply sepcon_derives; apply func_ptr'_mono.
  apply twiddle_sub_foo. apply twiddle_sub_fancy. }
make_func_ptr _foo_twiddleR.
replace_SEP 0 (func_ptr' (twiddle_spec foo_obj_invariant) (gv _foo_twiddleR) *
               func_ptr' (ftwiddle_spec fancyfoo_obj_invariant) (gv _foo_twiddleR)).
{ entailer!. rewrite split_func_ptr'. apply sepcon_derives; apply func_ptr'_mono.
  apply twiddle_sub_foo. apply twiddle_sub_fancy. }
sep_apply (make_object_methods Ews foo_obj_invariant (gv _foo_reset) (gv _foo_twiddle) (gv _foo_twiddleR) (gv _foo_methods)); auto.

make_func_ptr _setcolor.
make_func_ptr _getcolor.
sep_apply (make_fobject_methods Ews fancyfoo_obj_invariant (gv _foo_reset) (gv _foo_twiddle) (gv _foo_twiddleR) (gv _setcolor) (gv _getcolor)(gv _fancyfoo_methods)); auto.

(* 2. Build an instance of class [foo], called [p] *)
forward_call (* p = make_foo(); *)
        gv.
Intros p.

(* 4. Build an instance of class [fancyfoo], called [q] *)
forward_call (* q = make_fancyfoo(); *)
        (gv,4).
Intros q.
(*New*) freeze [0;2; 4;5 ] FR1. (*Hide the global method tables, memmgr, and the has_ext *)

assert_PROP (p<>Vundef) as pNotVundef by entailer!.
(* Illustration of an alternate method to prove the method calls.
   Method 1:  comment out lines AA and BB and the entire range CC-DD.
   Method 2:  comment out lines AA-BB, inclusive.
*)
(*TODO: Adapt
(* AA *) try (tryif
  (method_call (p, @nil Z) (@nil Z) whatever;
   method_call (p, 3, @nil Z) [3%Z] i;
     [simpl; computable | ])
(* BB *)  then fail else fail 99)
  .*)

(* CC *)
(* 4. first method-call, p.reset *)
(*NEW*) assert_PROP (isptr p) as isptrP by (sep_apply object_mpred_isptr; entailer!).
unfold object_mpred.

(*WAS:Intros instance mtable0.*)
(*Now*) Intros instance. rename H into HOC. rewrite ObjMpred_fold_unfold by trivial. Intros mtable0; simpl.

forward. (*  mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0 tR0.
forward. (* p_reset = mtable->reset; *)
forward_call (* p_reset(p); *)
      (@nil Z,p).
{ (*NEW subgoal*)
   sep_apply make_object_methods_later.
   rewrite ObjMpred_fold_unfold, <- ObjMpred_fold_unfold by trivial.
   Exists mtable0. entailer!. }
(* WAS (*Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).*)

(*Now: folding partially done by forward_call (and the preceding new subgoal*)
sep_apply obj_mpred_entails_object_mpred; simpl.

deadvars!. clear.

(* 5. second method-call, q.reset *)
(*NEW*) assert_PROP (isptr q) as isptrQ by (sep_apply fobject_mpred_isptr; entailer!).
unfold fobject_mpred.

(*WAS:Intros instance mtable0.*)
(*Now*) Intros instance. rename H into HOC. rewrite fObjMpred_fold_unfold by trivial. Intros mtable0; simpl.

forward. (*_t'9 = (_q -> _mtable);*)
forward. (*_mtable = (tptr (Tstruct _fancymethods noattr)) _t'9;*)

unfold fobject_methods at 1.
Intros sh r0 t0 tR0 sC gC.
forward. (* q_reset = qmtable->reset; *)
forward_call (* q_reset(q); *)
      ((@nil Z,4),q).
{ (*NEW subgoal*)
   sep_apply make_fobject_methods_later.
   rewrite fObjMpred_fold_unfold, <- fObjMpred_fold_unfold by trivial.
   Exists mtable0. entailer!. }
(* WAS (*Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).*)

(*Now: folding partially done by forward_call (and the preceding new subgoal*)
sep_apply fobj_mpred_entails_object_mpred; simpl.

deadvars!. clear.

(* 6. second method-call on q, q->getcolor *)
(*NEW*) assert_PROP (isptr q) as isptrQ by (sep_apply fobject_mpred_isptr; entailer!).
unfold fobject_mpred.

(*WAS:Intros instance mtable0.*)
(*Now*) Intros instance. rename H into HOC. rewrite fObjMpred_fold_unfold by trivial. Intros mtable0; simpl.

forward. (*_t'8 = (_q -> _mtable);*)
forward. (*_mtable = (tptr (Tstruct _fancymethods noattr)) _t'8;*)

unfold fobject_methods at 1.
Intros sh r0 t0 tR0 sC gC.
forward. (* q_getcolor = qmtable->getcolor; *)
forward_call (* q_reset(q); *)
      ((@nil Z,4),q).
{ (*NEW subgoal*)
   sep_apply make_fobject_methods_later.
   rewrite fObjMpred_fold_unfold, <- fObjMpred_fold_unfold by trivial.
   Exists mtable0. entailer!. }
(* WAS (*Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).*)

(*Now: folding partially done by forward_call (and the preceding new subgoal*)
sep_apply fobj_mpred_entails_object_mpred; simpl.

deadvars!. clear.

(* 7. second method-call on p, p->twiddleR*)
(*NEW*) assert_PROP (isptr p) as isptrP by (sep_apply object_mpred_isptr; entailer!).
unfold object_mpred.

(*WAS:Intros instance mtable0.*)
(*Now*) Intros instance. rename H into HOC. rewrite ObjMpred_fold_unfold by trivial. Intros mtable0; simpl.

forward.  (* pmtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0 tR0.
forward.   (* p_twiddle = pmtable->twiddleR; *)
(*Now redundant: assert_PROP (p<>Vundef) by entailer!.*)
forward_call (* i = p_twiddle(p,3); *)
      ((@nil Z,p), 3).
{ (*NEW subgoal*)
   sep_apply make_object_methods_later.
   rewrite ObjMpred_fold_unfold, <- ObjMpred_fold_unfold by trivial.
   Exists mtable0. entailer!. }
{ simpl. repeat split; try trivial; computable. }
Intros i.
simpl in H0. (*
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [3] p instance mtable0).*)
sep_apply obj_mpred_entails_object_mpred; simpl.
deadvars!. rename H0 into Hi. clear - Hi.

(* 8. Build an typed instance of class [fancyfoo], called [p] *)
thaw FR1.
forward_call (*t'5 = _make_fancyfooTyped([((9)*)
        (gv, 9).
Intros u. freeze [0; 2; 5;6] FR1. (*Hide the global method tables, the memmgr, and and the has_ext *)
freeze [2;3] PQ. (*Hide the other objects p and q*)

(* 9. first method-call on u, u->reset *)
(*NEW*) assert_PROP (isptr u) as isptrU by (sep_apply fobject_mpred_isptr; entailer!).
unfold fobject_mpred.

(*WAS:Intros instance mtable0.*)
(*Now*) Intros instance. rename H into HOC. rewrite fObjMpred_fold_unfold by trivial. Intros mtable0; simpl.

forward. (*_t'7 = ((tptr (Tstruct _object noattr)) _u -> _mtable);*)
forward. (* _umtable = (tptr (Tstruct _fancymethods noattr)) _t'7;*)

unfold fobject_methods at 1.
Intros sh r0 t0 tR0 sC gC.
forward. (* u_reset = (_umtable -> _reset); *)
forward_call (* u_reset(u); *)
      ((@nil Z,9),u).
{ (*NEW subgoal*)
   sep_apply make_fobject_methods_later.
   rewrite fObjMpred_fold_unfold, <- fObjMpred_fold_unfold by trivial.
   Exists mtable0. entailer!. }
(* WAS (*Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).*)

(*Now: folding partially done by forward_call (and the preceding new subgoal*)
sep_apply fobj_mpred_entails_object_mpred; simpl.

deadvars!. clear -Hi.

(* 10. second method-call on u, u->getcolor *)
(*NEW*) assert_PROP (isptr u) as isptrU by (sep_apply fobject_mpred_isptr; entailer!).
unfold fobject_mpred.

(*WAS:Intros instance mtable0.*)
(*Now*) Intros instance. rename H into HOC. rewrite fObjMpred_fold_unfold by trivial. Intros mtable0; simpl.

forward. (*_t'7 = ((tptr (Tstruct _object noattr)) _u -> _mtable);*)
forward. (* _umtable = (tptr (Tstruct _fancymethods noattr)) _t'7;*)

unfold fobject_methods at 1.
Intros sh r0 t0 tR0 sC gC.
forward. (* u_getcolor = (_umtable -> _getcolor); *)
forward_call (* u_getcolor(u); *)
      ((@nil Z,9),u).
{ (*NEW subgoal*)
   sep_apply make_fobject_methods_later.
   rewrite fObjMpred_fold_unfold, <- fObjMpred_fold_unfold by trivial.
   Exists mtable0. entailer!. }
(* WAS (*Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).*)

(*Now: folding partially done by forward_call (and the preceding new subgoal*)
sep_apply fobj_mpred_entails_object_mpred; simpl.

deadvars!. clear -Hi.

(* 11. return *)
forward.  (* return i; *)
Exists i; entailer!. f_equal. f_equal. lia.
Qed.

End Putting_It_All_Together.
Parameter QQ:mpred.
Lemma funspec_sub_reset_foo_fancy: funspec_sub (reset_spec foo_obj_invariant) (freset_spec fancyfoo_obj_invariant).
Proof. eapply funspec_sub_trans. apply reset_spec_local_sub. unfold fobject_invariant_of_inv.
 do_funspec_sub.
  rewrite fancyfoo_obj_invariant_fold_unfold' at 1. (*foo_obj_invariant_fold_unfold;*) Intros m.
  Exists w QQ. destruct w as [[hs c] p]; simpl in *. entailer!.
 + intros. rewrite foo_obj_invariant_fold_unfold', fancyfoo_obj_invariant_fold_unfold'.
   normalize. Exists mtable. entailer!. unfold fancyfoo_data, foo_data, withspacer; simpl.
   cancel. (*QQ = field_at color, later funspecs for setC, getC*) admit.
 + rewrite foo_obj_invariant_fold_unfold'. Exists m.
   entailer!. unfold fancyfoo_data, foo_data, withspacer; simpl.
   cancel.
Abort. (*same issue as below: method table needs to be co and contravariant*)
(* entailment / "proof-theoretic behavioral subtyping' not suitable"*)

Lemma funspec_sub_reset_foo_fancy: funspec_sub (reset_spec foo_obj_invariant) (freset_spec fancyfoo_obj_invariant).
Proof. do_funspec_sub. simpl in H. inv H. inv H6.
  destruct w as [[hs c] q].
  rewrite fancyfoo_obj_invariant_fold_unfold' at 1. (*foo_obj_invariant_fold_unfold;*) Intros m.
  simpl in H0, H4.
  Exists (hs, q). entailer.
  unfold fancyfoo_data, foo_data, withspacer; simpl. entailer!.
  unfold fobject_methods.
  rewrite later_exp'; normalize. rename x into sh.
  rewrite later_exp'; normalize. rename x into r.
  rewrite later_exp'; normalize. rename x into t.
  rewrite later_exp'; normalize. rename x into tR.
  rewrite later_exp'; normalize. rename x into sC.
  rewrite later_exp'; normalize. rename x into gC.
  Exists ((
     field_at Ews (Tstruct _fancyfoo_object noattr) [StructField _color] (Vint (Int.repr c)) q *
     (|> (func_ptr' (fsetcolor_spec fancyfoo_obj_invariant) sC *
          func_ptr' (fgetcolor_spec fancyfoo_obj_invariant) gC))) *
     ((malloc_token Ews (Tstruct _foo_object noattr) q) -* malloc_token Ews (Tstruct _fancyfoo_object noattr) q)).
  rewrite later_andp. rewrite ! later_sepcon. Intros.
  entailer. apply andp_right.
  + entailer!. intros. rewrite fancyfoo_obj_invariant_fold_unfold'; simpl.
    Exists m. entailer!. (*
    sep_apply wand_frame_elim''. cancel.
(*    eapply derives_trans. apply sepcon_derives. apply now_later. apply derives_refl.*)
    rewrite  <- ! later_sepcon.
    apply later_derives. Exists sh r t tR sC gC. entailer!. admit. (*readable_share*)
    unfold object_methods. admit.
  + entailer!. cancel. normalize.*)
Abort.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Sumbool.
Require Import Arith.
Require Import Bool.
Require Import EquivDec.
Require Import Assoc.
Require Import Bindings.
Require Import SortingAdd.
Require Import CoqLibAdd.
Require Import JSON.

Section JSONNorm.
  Fixpoint normalize_json (d:json) : json :=
    match d with
    | jobject rl => jobject (rec_sort (map (fun x => (fst x, normalize_json (snd x))) rl))
    | jarray l => jarray (map normalize_json l)
    | _ => d
    end.

  Inductive json_normalized : json -> Prop :=
  | jnnull :
      json_normalized jnull
  | jnnumber n :
      json_normalized (jnumber n)
  | jnbool b :
      json_normalized (jbool b)
  | jnstring s :
      json_normalized (jstring s)
  | jnarray dl :
      Forall (fun x => json_normalized x) dl -> json_normalized (jarray dl)
  | jnobject dl :
      Forall (fun d => json_normalized (snd d)) dl ->
      (is_list_sorted ODT_lt_dec (domain dl) = true) ->
      json_normalized (jobject dl).

  Theorem normalize_normalizes :
    forall (d:json), json_normalized (normalize_json d).
  Proof.
    induction d using jsonInd2; simpl.
    - apply jnnull.
    - apply jnnumber.
    - apply jnbool.
    - apply jnstring.
    - apply jnarray.
      apply Forall_forall; intros.
      induction c; elim H0; intros.
      rewrite <- H1.
      apply (H a); left; reflexivity.
      assert (forall x:json, In x c -> json_normalized (normalize_json x))
        by (intros; apply (H x0); right; assumption).
      specialize (IHc H2 H1).
      assumption.
    - apply jnobject.
      + apply Forall_sorted.
        apply Forall_forall; intros.
        induction r.
        contradiction.
        simpl in *.
        elim H0; intros; clear H0.
        rewrite <- H1.
        simpl.
        apply (H (fst a) (snd a)).
        left; destruct a; reflexivity.
        assert (forall (x : string) (y : json),
                   In (x, y) r -> json_normalized (normalize_json y)); intros.
        apply (H x0 y); right; assumption.
        apply (IHr H0).
        assumption.
      + apply (@rec_sort_sorted string ODT_string) with (l1 := (map (fun x : string * json => (fst x, normalize_json (snd x))) r)).
        reflexivity.
  Qed.

  Theorem normalize_normalized_eq {d}:
    json_normalized d ->
    normalize_json d = d.
  Proof.
    induction d using jsonInd2; simpl; trivial.
    - intros.
      rewrite (@map_eq _ _ normalize_json id).
      + rewrite map_id; trivial.
      + inversion H0; simpl; subst.
        revert H2. apply Forall_impl_in.
        auto.
    - intros.
      inversion H0; subst.
      rewrite (@map_eq _ _ (fun x : string * json => (fst x, normalize_json (snd x))) id).
      + rewrite map_id.
        rewrite rec_sorted_id; trivial.
      + revert H2. apply Forall_impl_in.
        destruct a; unfold id; simpl; intros.
        f_equal; eauto.
  Qed.

  Lemma map_normalize_normalized_eq c :
    Forall (fun x => json_normalized (snd x)) c ->
    (map
       (fun x0 : string * json => (fst x0, normalize_json (snd x0)))
       c) = c.
  Proof.
    induction c; simpl; trivial.
    destruct a; inversion 1; simpl in *; subst.
    rewrite normalize_normalized_eq; trivial.
    rewrite IHc; trivial.
  Qed.

  Corollary normalize_idem d :
    normalize_json (normalize_json d) = normalize_json d.
  Proof.
    apply normalize_normalized_eq.
    apply normalize_normalizes.
  Qed.

  Corollary normalize_json_eq_normalized {d} :
    normalize_json d = d -> json_normalized d.
  Proof.
    intros.
    generalize (normalize_normalizes d).
    congruence.
  Qed.

  Theorem normalized_json_dec d : {json_normalized d} + {~ json_normalized d}.
  Proof.
    destruct (normalize_json d == d); unfold equiv, complement in *.
    - left. apply normalize_json_eq_normalized; trivial.
    - right. intro dn; elim c. apply normalize_normalized_eq; trivial.
  Defined.

  Lemma json_normalized_jarray a l :
    (json_normalized a /\ json_normalized (jarray l)) <->
    json_normalized (jarray (a :: l)).
  Proof.
    split.
    - destruct 1 as [d1 d2]. inversion d2; subst.
      constructor; auto.
    - inversion 1; subst. inversion H1; subst.
      split; trivial.
      constructor; auto.
  Qed.

  Lemma json_normalized_rec_sort_app l1 l2 :
    json_normalized (jobject l1) ->
    json_normalized (jobject l2) ->
    json_normalized (jobject (rec_sort (l1 ++ l2))).
  Proof.
    inversion 1; inversion 1; subst.
    constructor; eauto 1 with qcert.
    apply Forall_sorted.
    apply Forall_app; trivial.
  Qed.

  Lemma json_normalized_rec_concat_sort l1 l2 :
    json_normalized (jobject l1) ->
    json_normalized (jobject l2) ->
    json_normalized (jobject (rec_concat_sort l1 l2)).
  Proof.
    apply json_normalized_rec_sort_app.
  Qed.

  Lemma json_normalized_jarray_in x l :
    In x l ->
    json_normalized (jarray l) ->
    json_normalized x.
  Proof.
    inversion 2; subst.
    rewrite Forall_forall in H2.
    eauto.
  Qed.

  Lemma jnobject_nil : json_normalized (jobject nil).
  Proof.
    econstructor; trivial.
  Qed.

  Lemma jnobject_sort_content c :
    Forall (fun d : string * json => json_normalized (snd d)) c ->
    Forall (fun d : string * json => json_normalized (snd d)) (rec_sort c).
  Proof.
    intros F.
    apply Forall_sorted; trivial.
  Qed.

  Lemma jnobject_sort c :
    Forall (fun d : string * json => json_normalized (snd d)) c ->
    json_normalized (jobject (rec_sort c)).
  Proof.
    intros F; econstructor; trivial with qcert.
    apply Forall_sorted; trivial.
  Qed.

  Lemma json_normalized_jarray_Forall l :
    json_normalized (jarray l) <-> Forall json_normalized l.
  Proof.
    split; intros H.
    - invcs H; trivial.
    - constructor; trivial.
  Qed.

End JSONNorm.


Require Import
  Hask.Control.Monad
  Hask.Data.Maybe
  Coq.Lists.List.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Import ListNotations.

Definition Effect := (Type -> Type) -> Type.

Inductive Effects (m : Type -> Type) : list Effect -> Type :=
  | NilE : Effects m []
  | ConsE effects : forall effect : Effect,
      effect m -> Effects m effects -> Effects m (effect :: effects).

Arguments ConsE : default implicits.

Definition combine `(e : effect m) `(xs : Effects m effects) :
  Effects m (effect :: effects) := ConsE _ e xs.

Infix ".:" := combine (at level 48, right associativity).

Class Handles (fs : list Effect) (effect : Effect) := {
  getEffect : forall m, Effects m fs -> effect m
}.

#[export]
Instance Handles_hd {fs : list Effect}  {f : Effect} :
  Handles (f :: fs) f.
Proof.
  constructor; intros.
  inversion X.
  exact X0.
Defined.

#[export]
Instance Handles_tl `{_ : Handles fs f} : Handles (x :: fs) f.
Proof.
  constructor; intros.
  inversion H.
  apply getEffect0.
  inversion X.
  exact X1.
Defined.

Axiom IO : Type -> Type.
Axiom IO_Functor : Functor IO.
Axiom IO_Applicative : Applicative IO.
Axiom IO_Monad : Monad IO.

Definition Kleisli m (A B : Type) := A -> m B.

Arguments Kleisli m A B.

Definition TFree `(xs : list Effect) a :=
  Kleisli IO (Effects IO xs) a.

Definition Eff := TFree.

Arguments Eff xs a.

Definition liftF `{Handles effects effect}
  `(getOp : effect IO -> IO a) : Eff effects a :=
  fun effects => getOp (getEffect IO effects).

Definition interpret `(interpreter : Effects IO effects)
  `(program : Eff effects a) : IO a := program interpreter.

#[export]
Instance Impl_Functor {A} : Functor (fun B => A -> B) := {
  fmap := fun A B f run => fun xs => f (run xs)
}.

#[export]
Instance Impl_Applicative {A} : Applicative (fun B => A -> B) := {
  pure := fun _ x => fun xs => x;
  ap   := fun A B runf runx => fun xs => runf xs (runx xs)
}.

#[export]
Instance Impl_Monad {A} : Monad (fun B => A -> B) := {
  join := fun A run => fun xs => run xs xs
}.

#[export]
Instance Kleisli_Functor `{Monad m} {A} : Functor (Kleisli m A) :=
  Compose_Functor.

#[export]
Instance Kleisli_Applicative `{Applicative m} : Applicative (Kleisli m A) :=
  fun _ => @Compose_Applicative _ _ Impl_Applicative _.

#[export]
Program Instance Kleisli_Monad_Distributes `{Monad m} {A} :
  @Monad_Distributes _ (@Impl_Monad A) m _ := {
  prod := _
}.
Obligation 1.
  exact (join (fmap (fun k => k X0) X)).
Defined.

(* Instance Kleisli_Monad `{Monad m} {A} : Monad (Kleisli m A) := Compose_Monad. *)

#[export]
Instance TFree_Functor `(xs : list Effect) : Functor (TFree xs) := {
  fmap := fun A B f run => fun xs => fmap f (run xs)
}.

#[export]
Instance TFree_Applicative `(xs : list Effect) : Applicative (TFree xs) := {
  pure := fun _ x => fun xs => pure x;
  ap   := fun A B runf runx => fun xs => runf xs <*> runx xs
}.

#[export]
Instance TFree_Monad `(xs : list Effect) : Monad (TFree xs) := {
  join := fun A run => fun xs => run xs >>= fun f => f xs
}.

Record Abortive (m : Type -> Type) := {
  abortE : m unit
}.

Definition abort `{Handles r Abortive} : Eff r unit :=
  liftF abortE.

Record Reader (e : Type) (m : Type -> Type) := {
  askE : m e
}.

Definition ask `{Handles r (Reader e)} : Eff r e :=
  liftF (askE e).

Require Import Arith.

Set Printing Universes.

Definition example1 `{Handles r (Reader nat)} `{Handles r Abortive} :
  Eff r nat :=
  (fun x y => y + 15) <$> abort <*> ask.

Definition maybeInterpreter : Effects Maybe [Reader nat; Abortive] :=
  combine {| askE   := Just 10 |} (combine {| abortE := Nothing |} (NilE _)).

Definition run {a} : Eff [Reader nat; Abortive] a -> Maybe a :=
  interpret maybeInterpreter.

Example run_example1 : run example1 = Nothing.
Proof. reflexivity. Qed.

Definition example2 `{Handles r (Reader nat)} : Eff r nat :=
  fmap (plus 15) ask.

Example run_example2 : run example2 = Just 25.
Proof. reflexivity. Qed.

(*
Definition example3 `{Handles r (Reader nat)} `{Handles r Abortive} :
  Eff r nat :=
  v <- ask;
  if leb v 15
  then abort ;; pure 0
  else pure (v+1).

Example run_example3 : run example3 = None.
Proof. reflexivity. Qed.
*)


From stdpp Require Export namespaces.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import gmap.
From Perennial.base_logic.lib Require Export fancy_updates fupd_level.
From Perennial.base_logic.lib Require Import wsat.
From iris.prelude Require Import options.
Import uPred.

(** Always Enabled Semantic Invariants *)
Definition ae_inv_def `{!invGS Σ} (k : nat) (mj: option nat) (P : iProp Σ) : iProp Σ :=
  □ ∀ Q E, (match mj with
            | None =>
              match k with
              | O => ▷ P ==∗ ◇ (▷ P ∗ Q)
              | S k' => ▷ P -∗ |k',(Some O)={E}=> ▷ P ∗ Q
              end
            | Some j => ▷ P -∗ |k,(Some (S j))={E}=> ▷ P ∗ Q
            end)
             -∗ |k,mj={E}=> Q.
Definition ae_inv_aux : seal (@ae_inv_def). Proof. by eexists. Qed.
Definition ae_inv {Σ i} := ae_inv_aux.(unseal) Σ i.
Definition ae_inv_eq : @ae_inv = @ae_inv_def := ae_inv_aux.(seal_eq).
#[global]
Instance: Params (@ae_inv) 3 := {}.
Typeclasses Opaque ae_inv.

Local Hint Extern 0 (AE _ _ ## MaybeEn1 _) => apply AE_MaybeEn_disj : core.
Local Hint Extern 0 (AlwaysEn ## MaybeEn1 _) => apply coPset_inl_inr_disj : core.

(** * Ae_Invariants *)
Section ae_inv.
  Context `{!invGS Σ}.
  Implicit Types i : positive.
  Implicit Types E : coPset.
  Implicit Types P Q R : iProp Σ.

  (** ** Internal model of ae_invariants *)
  Definition own_ae_inv (k: nat) (mj: option nat) (P : iProp Σ) : iProp Σ :=
    ∃ i, ⌜i ∈ AE_next_diff (S k) mj⌝ ∧ ownI k i (bi_sch_var_fixed O) (list_to_vec [P]).

  Lemma own_ae_inv_acc_k E k mj P Q :
    own_ae_inv k mj P -∗
    (match mj with
     | None =>
       match k with
       | O => ▷ P ==∗ ◇ (▷ P ∗ Q)
       | S k' => ▷ P -∗ |k',(Some O)={E}=> ▷ P ∗ Q
       end
     | Some j => ▷ P -∗ |k,(Some (S j))={E}=> ▷ P ∗ Q
     end) -∗
    |k,mj={E}=> Q.
  Proof.
    rewrite uPred_fupd_split_level_eq /uPred_fupd_split_level_def. iDestruct 1 as (i) "[Hi #HiP]".
    iDestruct "Hi" as % ?%elem_of_subseteq_singleton. iIntros "Hshift".
    rewrite ?(ownE_op (AE _ _)) // ownE_AE_split_current_rest.
    rewrite {1 2}(union_difference_L {[ i ]} (AE_next_diff (S k) mj)) // ownE_op; last set_solver.
    iIntros "(Hw & ((Hi&HAE')&HAE) & HE)".
    iDestruct (ownI_open k i with "[$Hw $Hi $HiP]") as "(Hw & HI & HD)".
    iDestruct "HI" as (? Ps_mut) "(Hinterp&Hmut)".
    iEval (rewrite ?bi_schema_interp_unfold /=) in "Hinterp".
    destruct mj; last first.
    - { destruct k.
        - iMod ("Hshift" with "[$]") as ">(HP&HQ)".
          iDestruct (ownI_close O i _ (list_to_vec [P]) with "[Hw Hmut HD HP]") as "H".
          { iFrame "# ∗". }
          iFrame. eauto.
        - iDestruct (wsat_le_acc (S k) with "Hw") as "(Hw&Hclo)"; first lia.
          rewrite ownE_op //.
          iMod ("Hshift" with "Hinterp [$Hw $HAE $HE]") as ">(Hw&(HAE&HE)&HP&HQ)".
          iDestruct ("Hclo" with "[$]") as "Hw".
          iDestruct (ownI_close (S k) i _ (list_to_vec [P]) with "[Hw Hmut HD HP]") as "H".
          { iFrame "# ∗". }
          iFrame. eauto.
      }
    - rewrite ownE_op //.
      iMod ("Hshift" with "Hinterp [$Hw $HAE $HE]") as ">(Hw&(HAE&HE)&HP&HQ)".
      iDestruct (ownI_close k i _ (list_to_vec [P]) with "[Hw Hmut HD HP]") as "H".
      { iFrame "# ∗". rewrite bi_schema_interp_unfold /=. eauto. }
      iFrame. eauto.
  Qed.

  Lemma own_ae_inv_acc_simple E k mj P Q:
    own_ae_inv k mj P -∗
    (match k with
     | O => ▷ P ==∗ ◇ (▷ P ∗ Q)
     | S k' => ▷ P -∗ |k'={E}=> ▷ P ∗ Q
     end) -∗
    |={E}=> Q.
  Proof.
    iIntros "Hown Hshift". iApply (fupd_split_level_fupd E _ _ k mj).
    iApply (own_ae_inv_acc_k E with "Hown [Hshift]").
    { destruct k; destruct mj.
      - iIntros. iMod ("Hshift" with "[$]") as ">?". iModIntro. eauto.
      - iIntros. iMod ("Hshift" with "[$]") as ">?". iModIntro. eauto.
      - iIntros. iSpecialize ("Hshift" with "[$]").
        iApply (fupd_level_split_level with "Hshift"); lia.
      - iIntros. iSpecialize ("Hshift" with "[$]").
        iApply (fupd_level_split_level with "Hshift"); lia.
    }
  Qed.

  Lemma fresh_ae_inv_name (E : gset positive) k mj : ∃ i, i ∉ E ∧ i ∈ AE_next_diff (S k) mj.
  Proof.
    exists (coPpick (AE_next_diff (S k) mj ∖gset_to_coPset E)).
    rewrite -elem_of_gset_to_coPset (comm and) -elem_of_difference.
    apply coPpick_elem_of=> Hfin.
    eapply AE_next_diff_inf, (difference_finite_inv _ _), Hfin.
    apply gset_to_coPset_finite.
  Qed.

  Lemma own_ae_inv_alloc_k E k mj P : ▷ P -∗ |k,mj={E}=> own_ae_inv k mj P.
  Proof.
    rewrite uPred_fupd_split_level_eq. iIntros "HP [Hw $]".
    iMod (ownI_alloc (.∈ AE_next_diff (S k) mj) (bi_sch_var_fixed O) k (list_to_vec [P]) (list_to_vec [])
            with "[HP $Hw]") as (i ?) "[$ [? ?]]"; auto using fresh_ae_inv_name.
    { rewrite bi_schema_interp_unfold //=. }
    do 2 iModIntro. iExists i. auto.
  Qed.

  Lemma own_ae_inv_alloc k mj E P : ▷ P ={E}=∗ own_ae_inv k mj P.
  Proof. iIntros "HP". iApply (fupd_split_level_fupd). by iApply own_ae_inv_alloc_k. Qed.

  Lemma own_ae_inv_to_ae_inv k mj P: own_ae_inv k mj P -∗ ae_inv k mj P.
  Proof.
    iIntros "#I". rewrite ae_inv_eq. iIntros (E H).
    iPoseProof (own_ae_inv_acc_k with "I") as "H"; eauto.
  Qed.

  (** ** Public API of ae_invariants *)
  Global Instance ae_inv_contractive n mj : Contractive (ae_inv n mj).
  Proof. rewrite ae_inv_eq. solve_contractive. Qed.

  Global Instance ae_inv_ne n mj : NonExpansive (ae_inv n mj).
  Proof. apply contractive_ne, _. Qed.

  Global Instance ae_inv_proper n mj : Proper (equiv ==> equiv) (ae_inv n mj).
  Proof. apply ne_proper, _. Qed.

  Global Instance ae_inv_persistent n mj P : Persistent (ae_inv n mj P).
  Proof. rewrite ae_inv_eq. apply _. Qed.

  Lemma ae_inv_alter n mj P Q : ae_inv n mj P -∗ ▷ □ (P -∗ Q ∗ (Q -∗ P)) -∗ ae_inv n mj Q.
  Proof.
    rewrite ae_inv_eq. iIntros "#HI #HPQ !>" (Q' H). iIntros "Hshift".
    iMod ("HI" $! Q' H with "[Hshift]") as "$"; last done.
    { destruct mj.
      { iIntros.
        iDestruct ("HPQ" with "[$]") as "[HQ HQP]".
        iMod ("Hshift" with "[$]") as "(HQ&$)".
        iModIntro. iModIntro. by iApply ("HQP").
      }
      destruct n.
      - iIntros.
        iDestruct ("HPQ" with "[$]") as "[HQ HQP]".
        iMod ("Hshift" with "[$]") as ">(HQ&$)".
        iModIntro. iModIntro. iNext. by iApply ("HQP").
      - iIntros.
        iDestruct ("HPQ" with "[$]") as "[HQ HQP]".
        iMod ("Hshift" with "[$]") as "(HQ&$)".
        iModIntro. iNext. by iApply ("HQP").
    }
  Qed.

  Lemma ae_inv_iff n mj P Q : ae_inv n mj P -∗ ▷ □ (P ↔ Q) -∗ ae_inv n mj Q.
  Proof.
    iIntros "#HI #HPQ". iApply (ae_inv_alter with "HI").
    iIntros "!> !> HP". iSplitL "HP".
    - by iApply "HPQ".
    - iIntros "HQ". by iApply "HPQ".
  Qed.

  Lemma ae_inv_alloc' k mj E P : ▷ P -∗ |k,mj={E}=> ae_inv k mj P.
  Proof.
    iIntros "HP". iApply own_ae_inv_to_ae_inv.
    iApply (own_ae_inv_alloc_k E k with "HP").
  Qed.

  Lemma ae_inv_alloc k mj E P : ▷ P ={E}=∗ ae_inv k mj P.
  Proof.
    iIntros "HP". iApply own_ae_inv_to_ae_inv.
    iApply (own_ae_inv_alloc k mj E with "HP").
  Qed.

  Lemma ae_inv_acc E k mj P Q :
    ae_inv k mj P -∗
    (match mj with
     | None =>
       match k with
       | O => ▷ P ==∗ ◇ (▷ P ∗ Q)
       | S k' => ▷ P -∗ |k',(Some O)={E}=> ▷ P ∗ Q
       end
     | Some j => ▷ P -∗ |k,(Some (S j))={E}=> ▷ P ∗ Q
     end) -∗
    |k,mj={E}=> Q.
  Proof.
    rewrite ae_inv_eq /ae_inv_def. iIntros "#HI"; by iApply "HI".
  Qed.

  Lemma ae_inv_acc_bupd E k mj P Q :
    ae_inv k mj P -∗
    (▷ P ==∗ ◇ (▷ P ∗ Q)) -∗
    |k,mj={E}=> Q.
  Proof.
    rewrite ae_inv_eq /ae_inv_def. iIntros "#HI Hshift".
    iApply "HI".
    { destruct mj, k; eauto; iIntros; by iMod ("Hshift" with "[$]") as ">$". }
  Qed.

  Lemma ae_inv_accS_simple E k mj P Q :
    ae_inv (S k) mj P -∗
    (▷ P -∗ |k,(Some O)={E}=> ▷ P ∗ Q) -∗
    |(S k),mj={E}=> Q.
  Proof.
    iIntros "H Hshift".
    iApply (ae_inv_acc with "[$] [Hshift]").
    destruct mj; iIntros "HP"; iSpecialize ("Hshift" with "[$]");
      iApply (fupd_split_level_le with "[$]"); naive_solver lia.
  Qed.

  (** ** Proof mode integration *)
  (*
  Global Instance into_ae_inv_ae_inv N P : IntoAe_Inv (ae_inv N P) N := {}.

  Global Instance into_acc_ae_inv_lvl k N P E:
    IntoAcc (X := unit) (ae_inv N P)
            (↑N ⊆ E) True (uPred_fupd_level E (E ∖ ↑N) k) (uPred_fupd_level (E ∖ ↑N) E k)
            (λ _ : (), (▷ P)%I) (λ _ : (), (▷ P)%I) (λ _ : (), None).
  Proof.
    rewrite ae_inv_eq /IntoAcc /accessor bi.exist_unit.
    iIntros (?) "#Hae_inv _". iApply (fupd_level_le _ _ O); first lia.
    iMod ("Hae_inv" $! _ with "[//]") as "($&Hcl)".
    iModIntro. iIntros "H". iSpecialize ("Hcl" with "H").
    iApply (fupd_level_le with "Hcl"); first lia.
  Qed.

  Global Instance into_acc_ae_inv N P E:
    IntoAcc (X := unit) (ae_inv N P)
            (↑N ⊆ E) True (fupd E (E ∖ ↑N)) (fupd (E ∖ ↑N) E)
            (λ _ : (), (▷ P)%I) (λ _ : (), (▷ P)%I) (λ _ : (), None).
  Proof.
    rewrite ae_inv_eq /IntoAcc /accessor bi.exist_unit.
    iIntros (?) "#Hae_inv _". iApply (fupd_level_fupd _ _ _ O).
    iMod ("Hae_inv" $! _ with "[//]") as "($&Hcl)".
    iModIntro. iIntros "H". iSpecialize ("Hcl" with "H").
    iApply (fupd_level_fupd with "Hcl").
  Qed.

  (** ** Derived properties *)
  Lemma ae_inv_acc_strong E N P :
    ↑N ⊆ E → ae_inv N P ={E,E∖↑N}=∗ ▷ P ∗ ∀ E', ▷ P ={E',↑N ∪ E'}=∗ True.
  Proof.
    iIntros (?) "Hae_inv".
    iPoseProof (ae_inv_acc (↑ N) N with "Hae_inv") as "H"; first done.
    rewrite difference_diag_L.
    iPoseProof (fupd_mask_frame_r _ _ (E ∖ ↑ N) with "H") as "H"; first set_solver.
    rewrite left_id_L -union_difference_L //. iMod "H" as "[$ H]"; iModIntro.
    iIntros (E') "HP".
    iPoseProof (fupd_mask_frame_r _ _ E' with "(H HP)") as "H"; first set_solver.
    by rewrite left_id_L.
  Qed.

  Lemma ae_inv_acc_timeless E N P `{!Timeless P} :
    ↑N ⊆ E → ae_inv N P ={E,E∖↑N}=∗ P ∗ (P ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (?) "Hae_inv". iMod (ae_inv_acc with "Hae_inv") as "[>HP Hclose]"; auto.
    iIntros "!> {$HP} HP". iApply "Hclose"; auto.
  Qed.

  Lemma ae_inv_split_l N P Q : ae_inv N (P ∗ Q) -∗ ae_inv N P.
  Proof.
    iIntros "#HI". iApply ae_inv_alter; eauto.
    iIntros "!> !> [$ $] $".
  Qed.
  Lemma ae_inv_split_r N P Q : ae_inv N (P ∗ Q) -∗ ae_inv N Q.
  Proof.
    rewrite (comm _ P Q). eapply ae_inv_split_l.
  Qed.
  Lemma ae_inv_split N P Q : ae_inv N (P ∗ Q) -∗ ae_inv N P ∗ ae_inv N Q.
  Proof.
    iIntros "#H".
    iPoseProof (ae_inv_split_l with "H") as "$".
    iPoseProof (ae_inv_split_r with "H") as "$".
  Qed.
   *)

End ae_inv.


Require Import Lia ZArith List.
Require Import Cdcl.Itauto.
Open Scope Z_scope.

Unset Lia Cache.
Set Itauto Theory Time.

Ltac mp :=  repeat match goal with
         | H :?A , H1 : ?A -> ?B |- _ => specialize (H1 H)
         end.

Ltac sub :=  repeat match goal with
                    | H :?A -> False , H1 : ?A -> ?B |- _ => clear H1
                    end.

Goal  forall (word : Type) (left right : word) (xs : list word)
    (r8 : Z) (v : nat) (x : list word) (x1 x2 : word)
    (r7 q r r6 q0 r0 r2 : Z) (w2z : word -> Z)
    (width q1 r1 q2 r3 q3 r4 r5 q4 q5 q6 q7 q8 : Z),
    r8 = 8 * Z.of_nat (Datatypes.length xs) ->
  r7 = 8 * Z.of_nat (Datatypes.length x) ->
  Datatypes.length x = v ->
  r7 <> 0 ->
  (2 ^ r6 <> 0 -> r7 = 2 ^ r6 * q + r) ->
  (0 < 2 ^ r6 -> 0 <= r < 2 ^ r6) ->
  (2 ^ r6 < 0 -> 2 ^ r6 < r <= 0) ->
  (2 ^ r6 = 0 -> q = 0) ->
  (2 ^ r6 = 0 -> r = 0) ->
  (2 ^ width <> 0 -> r2 - w2z x1 = 2 ^ width * q0 + r0) ->
  (0 < 2 ^ width -> 0 <= r0 < 2 ^ width) ->
  (2 ^ width < 0 -> 2 ^ width < r0 <= 0) ->
  (2 ^ width = 0 -> q0 = 0) ->
  (2 ^ width = 0 -> r0 = 0) ->
  (2 ^ width <> 0 -> 8 = 2 ^ width * q1 + r1) ->
  (0 < 2 ^ width -> 0 <= r1 < 2 ^ width) ->
  (2 ^ width < 0 -> 2 ^ width < r1 <= 0) ->
  (2 ^ width = 0 -> q1 = 0) ->
  (2 ^ width = 0 -> r1 = 0) ->
  (2 ^ width <> 0 -> w2z x1 + r3 = 2 ^ width * q2 + r2) ->
  (0 < 2 ^ width -> 0 <= r2 < 2 ^ width) ->
  (2 ^ width < 0 -> 2 ^ width < r2 <= 0) ->
  (2 ^ width = 0 -> q2 = 0) ->
  (2 ^ width = 0 -> r2 = 0) ->
  (2 ^ width <> 0 -> r4 * 2 ^ r5 = 2 ^ width * q3 + r3) ->
  (0 < 2 ^ width -> 0 <= r3 < 2 ^ width) ->
  (2 ^ width < 0 -> 2 ^ width < r3 <= 0) ->
  (2 ^ width = 0 -> q3 = 0) ->
  (2 ^ width = 0 -> r3 = 0) ->
  (2 ^ width <> 0 -> q = 2 ^ width * q4 + r4) ->
  (0 < 2 ^ width -> 0 <= r4 < 2 ^ width) ->
  (2 ^ width < 0 -> 2 ^ width < r4 <= 0) ->
  (2 ^ width = 0 -> q4 = 0) ->
  (2 ^ width = 0 -> r4 = 0) ->
  (2 ^ width <> 0 -> 3 = 2 ^ width * q5 + r5) ->
  (0 < 2 ^ width -> 0 <= r5 < 2 ^ width) ->
  (2 ^ width < 0 -> 2 ^ width < r5 <= 0) ->
  (2 ^ width = 0 -> q5 = 0) ->
  (2 ^ width = 0 -> r5 = 0) ->
  (2 ^ width <> 0 -> 4 = 2 ^ width * q6 + r6) ->
  (0 < 2 ^ width -> 0 <= r6 < 2 ^ width) ->
  (2 ^ width < 0 -> 2 ^ width < r6 <= 0) ->
  (2 ^ width = 0 -> q6 = 0) ->
  (2 ^ width = 0 -> r6 = 0) ->
  (2 ^ width <> 0 -> w2z x2 - w2z x1 = 2 ^ width * q7 + r7) ->
  (0 < 2 ^ width -> 0 <= r7 < 2 ^ width) ->
  (2 ^ width < 0 -> 2 ^ width < r7 <= 0) ->
  (2 ^ width = 0 -> q7 = 0) ->
  (2 ^ width = 0 -> r7 = 0) ->
  (2 ^ width <> 0 -> w2z right - w2z left = 2 ^ width * q8 + r8) ->
  (0 < 2 ^ width -> 0 <= r8 < 2 ^ width) ->
  (2 ^ width < 0 -> 2 ^ width < r8 <= 0) ->
  (2 ^ width = 0 -> q8 = 0) ->
  (2 ^ width = 0 -> r8 = 0) ->
  r0 < r1 * Z.of_nat (Datatypes.length x).
Proof.
  intros.
  Time Fail itauto lia.
  (* Manual decomposition *)
  assert (CASE : 2 ^ width < 0 \/ 2^width = 0 \/ 0 < 2^width) by lia.
  destruct CASE as [C1 | [C1 | C1]].
  - assert (NZ : 2 ^ width <> 0) by (clear - C1 ; lia).
    mp.
    unfold not in NZ.
    sub.
    lia.
  - mp.
    assert (0 < 2 ^ width -> False) by (clear - C1; lia).
    assert (2 ^ width <> 0 -> False) by (clear - C1; lia).
    assert (0 < 2 ^ width  -> False) by (clear - C1; lia).
    assert (2 ^ width < 0 -> False) by (clear - C1; lia).
    sub.
    lia.
  -
    assert (2 ^ width = 0 -> False) by (clear - C1; lia).
    assert (2 ^ width <> 0) by (clear - C1; lia).
    assert (2 ^ width < 0 -> False) by (clear - C1; lia).
    mp.  sub.
    Fail lia.
Abort.


Goal let x:=O+O in x=x.
intro.
set (y1:=O) in (type of x).
Show.
set (y2:=O) in (value of x) at 1.
Show.
set (y3:=O) in (value of x).
Show.
trivial.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition data_destroy1_spec0 (g_rd: Pointer) (map_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr =>
      rely is_int64 _map_addr;
      when' _t'1, adt == data_destroy_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) adt;
      rely is_int64 _t'1;
      Some (adt, (VZ64 _t'1))
     end
    .

End SpecLow.


Require Import List.

Set Implicit Arguments.

Definition err : Type := unit.

Inductive res (A: Type) : Type :=
| OK: A -> res A
| Error: err -> res A.

Arguments Error [A].

Set Printing Universes.

Section FOO.

Inductive ftyp : Type :=
  | Funit : ftyp
  | Ffun : list ftyp -> ftyp
  | Fref : area -> ftyp
with area : Type :=
  | Stored : ftyp -> area
.

Print ftyp.
(* yields:
Inductive ftyp : Type (* Top.27429 *) :=
    Funit : ftyp | Ffun : list ftyp -> ftyp | Fref : area -> ftyp
  with area : Type (* Set *) :=  Stored : ftyp -> area
*)

Fixpoint tc_wf_type (ftype: ftyp) {struct ftype}: res unit :=
  match ftype with
    | Funit => OK tt
    | Ffun args =>
       ((fix tc_wf_types (ftypes: list ftyp){struct ftypes}: res unit :=
           match ftypes with
             | nil => OK tt
             | t::ts =>
                 match tc_wf_type t with
                   | OK tt => tc_wf_types ts
                   | Error m => Error m
                 end
           end) args)
     | Fref a => tc_wf_area a
   end
with tc_wf_area (ar:area): res unit :=
  match ar with
    | Stored c => tc_wf_type c
  end.

End FOO.

Print ftyp.
(* yields:
Inductive ftyp : Type (* Top.27465 *) :=
    Funit : ftyp | Ffun : list ftyp -> ftyp | Fref : area -> ftyp
  with area : Set :=  Stored : ftyp -> area
*)

Fixpoint tc_wf_type' (ftype: ftyp) {struct ftype}: res unit :=
  match ftype with
    | Funit => OK tt
    | Ffun args =>
       ((fix tc_wf_types (ftypes: list ftyp){struct ftypes}: res unit :=
           match ftypes with
             | nil => OK tt
             | t::ts =>
                 match tc_wf_type' t with
                   | OK tt => tc_wf_types ts
                   | Error m => Error m
                 end
           end) args)
     | Fref a => tc_wf_area' a
   end
with tc_wf_area' (ar:area): res unit :=
  match ar with
    | Stored c => tc_wf_type' c
  end.

(* yields:
Error:
Incorrect elimination of "ar" in the inductive type "area":
the return type has sort "Type (* max(Set, Top.27424) *)" while it
should be "Prop" or "Set".
Elimination of an inductive object of sort Set
is not allowed on a predicate in sort Type
because strong elimination on non-small inductive types leads to paradoxes.
*)


Require Import LambdaBoxLocal.expression.
Require Import Common.Common Common.compM Common.Pipeline_utils.
Require Import LambdaBoxMut.compile.
Require Import LambdaBoxLocal.LambdaBoxMut_to_LambdaBoxLocal.
Require Import LambdaBoxLocal.LambdaBoxMut_to_LambdaBoxLocal_correct.
Require LambdaBoxMut.
Require Import BinNat.

Import Monads.

Import MonadNotation.

Definition LambdaBoxLocalTerm := prod ienv LambdaBoxLocal.expression.exp.

#[global] Instance LambdaBoxLocal_Lang : Lang LambdaBoxLocalTerm :=
  { Value := LambdaBoxLocal.expression.exp ;
    TermWf := fun P => LambdaBoxLocal.expression.exp_wf (0%N) (snd P);
    BigStep := fun P Res => exists n, LambdaBoxLocal.expression.eval_n n (snd P) = Some Res
  }.

Definition compile_LambdaBoxLocal (prims : list (kername * string * bool * nat * positive))
  : CertiCoqTrans (Program LambdaBoxMut.compile.Term) LambdaBoxLocalTerm :=
  fun src =>
    debug_msg "Translating from LambdaBoxMut to LambdaBoxLocal"%bs ;;
    LiftCertiCoqTrans "LambdaBoxLocal" (fun p =>
                              (LambdaBoxMut_to_LambdaBoxLocal.inductive_env (AstCommon.env p),
                               LambdaBoxMut_to_LambdaBoxLocal.translate_program prims (AstCommon.env p)(main p))) src.