(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
Require Import ZArith_ext ssrnat_ext.
Require Import integral_type bipl seplog.
Require Import topsy_hm topsy_hmAlloc_prg.

Require Import expr_b_dp.
Import seplog_Z_m.assert_m.expr_m.
Import seplog_Z_m.assert_m.
Import seplog_Z_m.

Local Close Scope positive_scope.
Local Open Scope heap_scope.
Local Open Scope seplog_expr_scope.
Local Open Scope seplog_assert_scope.
Local Open Scope seplog_cmd_scope.
Local Open Scope seplog_hoare_scope.

(** this file contains:
 - 1. the verification of list traversal (findFree)
 - 2. the verification of compaction (compact, original version and optimization)
 - 3. the verification of splitting (split)
 - 4. the verification of the allocation function (hmAlloc)
*)

Local Close Scope Z_scope.

Definition findFree_specif := forall adr x sizex size,
  size > 0 -> adr > 0 ->
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x, sizex, alloc) adr /\
     [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s }}
  findFree size entry fnd sz stts
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x, sizex, alloc) adr /\
     [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
     ((exists y size'', size'' >= size /\
      In_hl l (y, size'', topsy_hm.free) adr /\
      [ var_e entry \= nat_e y \&& nat_e y \> null ]b_s)
      \/
      [ var_e entry \= null ]b_s) }}.

Lemma findFree_verif : findFree_specif.
Proof.
rewrite /findFree_specif => adr x sizex size H H0.
rewrite /findFree.

(**  entry <- var_e hmStart; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\ [ var_e hmStart \= nat_e adr ]b_s /\
  [ var_e result \= null ]b_s /\ [ var_e entry \= nat_e adr ]b_s ).

move: H1 => [l [Hl [Hl' Hb]]].
exists l.
by Resolve_topsy.

(**  stts <-* (entry -.> status); *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\ [ var_e hmStart \= nat_e adr ]b_s /\
  [ var_e result \= null ]b_s /\ [ var_e entry \= nat_e adr ]b_s /\
  [ var_e stts \= Allocated \|| var_e stts \= Free ]b_s).

move: H1 => [x0 [H1 [H4 [H2 [H6 H5]]]]].
destruct x0 as [|p x0]; first by rewrite //= in H4.
destruct p.
exists (hlstat_bool2expr b).
apply mapsto_strictly_exact; split.
- case: H1 => h1 [h2 [H1 [H7 [H3 H9]]]].
  inversion_clear H3.
  + subst b nxt.
    case_sepcon H13.
    rewrite /= in H13_h31; case_sepcon H13_h31.
    Compose_sepcon h311 (h312 \U h32 \U h4 \U h2); last by done.
    rewrite /status; by Mapsto.
  + subst b nxt.
    rewrite /= in H13; case_sepcon H13.
    Compose_sepcon h31 (h32 \U h4 \U h2); last by done.
    rewrite /status; by Mapsto.
- exists ((n, b) :: x0).
  Resolve_topsy.
  destruct b; rewrite eval_b_upd_subst; by omegab.

(**  fnd <- cst_e 0%Z; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\ [ var_e hmStart \= nat_e adr ]b_s /\
  [ var_e result \= null ]b_s /\ [ var_e entry \= nat_e adr ]b_s /\
  [ var_e stts \= Allocated \|| var_e stts \= Free ]b_s /\
  [ var_e fnd \= nat_e 0 ]b_s).

case: H1 => x0 [H1 [H4 [H2 [H7 [H6 H5]]]]].
exists x0.
by Resolve_topsy.

(**  while ((var_e entry \!= null) \&& (var_e fnd \!= cst_e 1%Z)) ( *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\ [ var_e hmStart \= nat_e adr ]b_s /\
  [ var_e result \= null ]b_s /\
  (exists bloc_adr,
    [ var_e entry \= nat_e bloc_adr ]b_s /\
    ((bloc_adr = 0 /\ [ var_e fnd \= nat_e 0 ]b_s) \/
      (bloc_adr = get_endl l adr  /\
        [ var_e fnd \= nat_e 0 ]b_s /\
        bloc_adr > 0) \/
      (exists bloc_size bloc_status,
        bloc_adr > 0 /\
        In_hl l (bloc_adr, bloc_size, bloc_status) adr /\
        [ var_e fnd \= nat_e 0 ]b_s) \/
      exists bloc_size, bloc_size >= size /\
        In_hl l (bloc_adr, bloc_size, topsy_hm.free) adr /\
        [ var_e fnd \= nat_e 1 ]b_s /\
        bloc_adr > 0))).

rewrite /while.entails => s h [l [H1 [H4 [H2 [H8 [H7 [H6 H5]]]]]]].
exists l; Resolve_topsy.
case : l H1 H4 => [|[n b] tl] H1 H4; first by done.
exists adr; Resolve_topsy.
right; right; left; exists n, b; Resolve_topsy.
by rewrite /= !eqxx.

rewrite /while.entails => s h [[x0 [H2 [H3 [H4 [H5 [x1 [H6 H8]]]]]]] H1].
exists x0; Resolve_topsy.
case: H8.
- case => ? H7; subst x1.
  right; by omegab.
- case.
  + case => H7 [H8 H11].
    move: (get_endl_gt x0 adr) => H9.
    have H10 : [ var_e entry \!= null \&& var_e fnd \!= cst_e 1%Z ]b_s by omegab.
    rewrite /hoare_m.eval_b in H1.
    by rewrite H10 in H1.
  + case.
    * case => x2 [x3 [H8 [H9 H10]]].
      move: (get_endl_gt x0 adr) => H7.
      have H11 : [ var_e entry \!= null \&& var_e fnd \!= cst_e 1%Z ]b_s by omegab.
      rewrite /hoare_m.eval_b in H1.
      by rewrite H11 in H1.
    * move => [x2 [H7 [H10 [H11 H12]]]].
      left; exists x1, x2; by Resolve_topsy.

(**    stts <-* (entry -.> status); *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\ [ var_e hmStart \= nat_e adr ]b_s /\
  [ var_e result \= null ]b_s /\
  (exists bloc_adr, [ var_e entry \= nat_e bloc_adr ]b_s /\
    ((bloc_adr = get_endl l adr /\
      [ var_e fnd \= nat_e O ]b_s /\
      [ var_e stts \= Allocated ]b_s /\
      bloc_adr > O) \/
    exists bloc_size bloc_status,
      In_hl l (bloc_adr, bloc_size, bloc_status) adr /\
      [ var_e fnd \= nat_e O ]b_s /\
      [ var_e stts \= hlstat_bool2expr bloc_status ]b_s /\
      bloc_adr > O))).

move: H1 => [[x0 [H2 [H5 [H3 [H6 [x1 [H4 H8]]]]]]] H9].
case: H8.
- case => H1 H7; subst x1.
  suff : False by done. omegab.
- case.
  + case => H1 [H7 H12].
    subst x1.
    exists Allocated.
    apply mapsto_strictly_exact; split.
    * move/hl_getstat_last : H2 => H2; case_sepcon H2.
      Compose_sepcon h1 h2; [rewrite /status; by Mapsto | done].
    * rewrite /wp_assign; exists x0.
      split; first by Heap_List_equiv.
      split; first by assumption.
      Resolve_topsy.
      exists (get_endl x0 adr).
      Resolve_topsy.
      left; by Resolve_topsy.
  + case.
    * case => x2 [x3 [H8 [H11 H1]]].
      case/In_hl_destruct : (H11) => [x4 [x5 [Hx0 H13]]].
      exists (hlstat_bool2expr x3).
      apply mapsto_strictly_exact; split.
      rewrite Hx0 in H2; move/hl_getstatus : H2 => H10; case_sepcon H10.
      Compose_sepcon h1 h2; [rewrite /status; by Mapsto | done].
      rewrite /wp_assign; exists x0.
      split; first by Heap_List_equiv.
      Resolve_topsy.
      exists (get_endl x4 adr); Resolve_topsy.
      right; exists x2, x3; Resolve_topsy.
      by rewrite H13.
      destruct x3; rewrite eval_b_upd_subst; omegab.
      by rewrite H13.
   * case => x2 [H1 [H11 [H13 H8]]].
     case/In_hl_destruct : (H11) => [x3 [x4 [H12 H14]]].
     exists Free.
     apply mapsto_strictly_exact; split.
     rewrite H12 in H2; move/hl_getstatus : H2 => H2; case_sepcon H2.
     Compose_sepcon h1 h2; [by Mapsto | done].
     rewrite /wp_assign; exists x0.
     split; first by Heap_List_equiv.
     split; first by assumption.
     Resolve_topsy.
     exists (get_endl x3 adr); Resolve_topsy.
     right; exists x2, topsy_hm.free; Resolve_topsy.
     by rewrite H14.
     by rewrite H14.

(**    ENTRYSIZE entry sz; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\ [ var_e hmStart \= nat_e adr ]b_s /\
  [ var_e result \= null ]b_s /\
  (exists bloc_adr,
    [ var_e entry \= nat_e bloc_adr ]b_s /\
    ((bloc_adr = get_endl l adr /\
        [ var_e fnd \= nat_e 0 ]b_s /\
        [ var_e stts \= Allocated ]b_s /\
        bloc_adr > 0 /\
        [ var_e sz \= nat_e 0 ]b_s) \/
      exists bloc_size bloc_status,
        In_hl l (bloc_adr, bloc_size, bloc_status) adr /\
        [ var_e fnd \= nat_e 0 ]b_s /\
        [ var_e stts \= hlstat_bool2expr bloc_status ]b_s /\
        bloc_adr > 0 /\
        [ var_e sz \= nat_e bloc_size ]b_s))).

rewrite /ENTRYSIZE.

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\ [ var_e hmStart \= nat_e adr ]b_s /\
  [ var_e result \= null ]b_s /\
  (exists bloc_adr, [ var_e entry \= nat_e bloc_adr ]b_s /\
    ((bloc_adr = get_endl l adr /\
      [ var_e fnd \= nat_e 0 ]b_s /\
      [ var_e stts \= Allocated ]b_s /\
      bloc_adr > 0 /\
      [ var_e sz \= nat_e 0 ]b_s ) \/
    (exists bloc_size bloc_status,
      In_hl l (bloc_adr, bloc_size, bloc_status) adr /\
      [ var_e fnd \= nat_e 0 ]b_s /\
      [ var_e stts \= hlstat_bool2expr bloc_status ]b_s /\
      bloc_adr > 0 /\
      [ var_e sz \= nat_e (bloc_adr + 2 + bloc_size) ]b_s)))).

move: H1 => [x0 [H1 [H4 [H2 [H5 [x1 [H7 H9]]]]]]].
case: H9.
- case => [H11 [H3 [H8 H10]]].
  exists null.
  apply mapsto_strictly_exact; split.
  move/hl_getnext_last : H1 => H1; case_sepcon H1.
  Compose_sepcon h1 h2; [rewrite /next; by Mapsto | done].
  rewrite /wp_assign; exists x0; Resolve_topsy.
  exists x1; Resolve_topsy.
  left; by Resolve_topsy.
- move => [x2 [x3 [H10 [H11 [H3 H8]]]]].
  move/In_hl_destruct : (H10) => [x4 [x5 [H9 H12]]].
  exists (nat_e (x1 + 2 + x2)).
  apply mapsto_strictly_exact; split.
  rewrite H9 in H1; move/hl_getnext : H1 => H6.
  case_sepcon H6.
  Compose_sepcon h1 h2; last by done.
  rewrite /next; by Mapsto.
  rewrite /wp_assign; exists x0; Resolve_topsy.
  exists (get_endl x4 adr); Resolve_topsy.
  right; exists x2, x3; split.
  by rewrite H12.
  Resolve_topsy.
  destruct x3; rewrite eval_b_upd_subst; by omegab.
  by rewrite H12.

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\ [ var_e hmStart \= nat_e adr ]b_s /\
  [ var_e result \= null ]b_s  /\
  (exists bloc_adr, [ var_e entry \= nat_e bloc_adr ]b_s /\
    ((bloc_adr = get_endl l adr /\
      [ var_e fnd \= nat_e 0 ]b_s /\
      [ var_e stts \= Allocated ]b_s /\
      bloc_adr > 0 /\
      [ var_e sz \= nat_e 0 \- nat_e bloc_adr \- nat_e 2 ]b_s) \/
    exists bloc_size bloc_status,
      In_hl l (bloc_adr, bloc_size, bloc_status) adr /\
      [ var_e fnd \= nat_e 0 ]b_s /\
      [ var_e stts \= hlstat_bool2expr bloc_status ]b_s /\
      bloc_adr > 0 /\
      [ var_e sz \= nat_e bloc_size ]b_s))).

move: H1 => [x0 [H1 [H4 [H2 [H5 [x1 [H7 H3]]]]]]].
case: H3.
- move => [H10 [H3 [H11 [H8 H9]]]].
  exists x0; Resolve_topsy.
  exists (get_endl x0 adr); Resolve_topsy.
  left; Resolve_topsy.
  by omegab.
- move => [x2 [x3 [H9 [H10 [H3 [H11 H8]]]]]].
  exists x0; Resolve_topsy.
  exists x1; Resolve_topsy.
  right; exists x2, x3; Resolve_topsy.
  rewrite eval_b_upd_subst; by destruct x3; omegab.

(**    ifte ((var_e stts \= Free) \&& (var_e sz \>= nat_e size)) thendo *)

Step TT.

Step TT.

move => s h [[x0 [H1 [H2 [H5 [H3 [x1 [H6 H8]]]]]]] H4].
case: H8.
- move => [H8 [H12 [H7 [H13 H10]]]].
  exists x0; Resolve_topsy.
  exists x1; Resolve_topsy.
  left; by Resolve_topsy.
- move => [x2 [x3 [H8 [H11 [H7 [H12 H9]]]]]].
  exists x0; Resolve_topsy.
  exists x1; Resolve_topsy.
  right; exists x2, x3; by Resolve_topsy.

Step TT.

rewrite /while.entails => s h [[x0 [H3 [H2 [H5 [H1 [x1 [H6 H8]]]]]]] H4].
exists x0; Resolve_topsy.
case: H8 => H7.
- move: H7 => [H12 [H7 [H13 [H10 H11]]]].
  have H8 : [ nat_e 0 \> var_e sz ]b_s by omegab.
  by rewrite H8 in H4.
- exists x1; by Resolve_topsy.

Step TT.

(*      (fnd <- cst_e 1%Z) *)

Step TT.

move => s h [[x0 [H2 [H5 [H3 [H6 [x1 [H8 H7]]]]]]] H9].
exists x0; split.
by apply Heap_List_inde_store with s.
Resolve_topsy.
exists x1; Resolve_topsy.
case: H7.
- move => [H4 [H12 [H1 [H13 H10]]]].
  suff : False by done. omegab.
- move => [x2 [[] [H11 [H1 [H12 [H10 H13]]]]]].
  + simpl hlstat_bool2expr in H12.
    right; right; right; exists x2.
    split; first by omegab.
    split; first by assumption.
    rewrite eval_b_upd_subst; by intuition.
  + suff : False by done. omegab.

(**    elsedo
         (entry <-* (entry -.> next))). *)

Step TT.

rewrite /while.entails => s h [[x0 [H2 [H5 [H1 [H6 [x1 [H8 H4]]]]]]] H3].
case: H4.
- move => [H11 [H7 [H12 [H9 H14]]]].
  exists (nat_e 0).
  apply mapsto_strictly_exact; split.
  move/hl_getnext_last : H2 => H2; case_sepcon H2.
  Compose_sepcon h1 h2; [rewrite /next; by Mapsto | done].
  rewrite /wp_assign.
  exists x0; split.
  by apply Heap_List_inde_store with s.
  Resolve_topsy.
  exists 0; Resolve_topsy.
  left; by Resolve_topsy.
- case => [x2 [x3 [H11 [H7 [H12 [H9 H13]]]]]].
  exists (nat_e (x1 + 2 +x2)).
  apply mapsto_strictly_exact; split.
  move/In_hl_destruct : H11 => [x4 [x5 [H15 H14]]].
  rewrite H15 in H2.
  move/hl_getnext : H2 => [h1 [h2 [H4 [H16 [H10 H17]]]]].
  Compose_sepcon h1 h2; last by done.
  rewrite /next; by Mapsto.
  rewrite /wp_assign.
  exists x0; split.
  by apply Heap_List_inde_store with s.
  Resolve_topsy.
  exists (x1 + 2 + x2); Resolve_topsy.
  move/In_hl_destruct : H11 => [x4 [x5 [H15 H14]]].
  case: x5 H15 => [|[n b] x5] H15.
  + right; left; split.
    by rewrite H15 get_endl_app H14.
    split.
    rewrite eval_b_upd_subst; by omegab.
    ssromega.
  + right; right; left; exists n, b.
    split; first by ssromega.
    split.
    rewrite H15; apply In_hl_or_app; right => /=.
    case: ifP => // _.
    by rewrite H14 /= !eqxx.
  by rewrite eval_b_upd_subst; omegab.
Qed.

Definition brk := 10.
Definition tmp := 11.
Definition cstts := 12.
Definition nstts := 13.

Definition compact'_specif:= forall adr size x sizex,
 size > 0 -> adr > 0 ->
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x, sizex, alloc) adr /\
     [ var_e hmStart \= nat_e adr \&& var_e result \= null \&& var_e cptr \= nat_e adr ]b_s }}
  compact' cptr nptr brk tmp cstts nstts
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x, sizex, alloc) adr /\
     [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s }}.

Lemma compact'_verif: compact'_specif.
Proof.
rewrite /compact'_specif /compact' => adr size x sizex H H0.

(**  while (var_e cptr \!= null) ( *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s  /\
  (exists cptr_value, [ var_e cptr \= nat_e cptr_value ]b_s /\
    (cptr_value = 0 \/
      cptr_value = get_endl l adr \/
      exists cptr_size cptr_status, In_hl l (cptr_value, cptr_size, cptr_status) adr))).

rewrite /while.entails => s h [x0 [H2 [H5 H6]]].
exists x0.
split; first by assumption.
split; first by assumption.
split; first by omegab.
exists adr.
split; first by omegab.
case: x0 H2 H5 => [| [n b] x0] H2 H5.
- by rewrite /= in H5.
- right; right; exists n, b => /=.
  by rewrite !eqxx.

rewrite /while.entails => s h [[x0 [H2 [H3 [H4 H5]]]] H6].
exists x0; by Resolve_topsy.

(**    nptr <-* (cptr -.> next); *)

Step (fun s h => exists l, Heap_List l adr s h /\
    In_hl l (x, sizex, alloc) adr /\
    [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
      (exists cptr_value nptr_value,
        [ var_e cptr \= nat_e cptr_value ]b_s /\
        [ var_e nptr \= nat_e nptr_value ]b_s /\
           ((cptr_value = get_endl l adr /\
             nptr_value = 0) \/
            exists cptr_size cptr_status,
               In_hl l (cptr_value, cptr_size, cptr_status) adr /\
               nptr_value = cptr_value + 2 + cptr_size))).

move: H1 => [[l [Hl [Hl' [Hs [cptr [Hs' [Hcptr' | [Hcptr' | [cptr_size [cptr_status Hl'']]]]]]]]]] Hcptr].
- subst cptr; by omegab.
- exists (nat_e 0).
  apply mapsto_strictly_exact; split.
  + move/hl_getnext_last : Hl => Hl; case_sepcon Hl.
    Compose_sepcon h1 h2; [rewrite /next; by Mapsto | done].
  + exists l; Resolve_topsy.
    exists cptr, 0; by Resolve_topsy.
- exists (nat_e (cptr + 2 + cptr_size)).
  apply mapsto_strictly_exact; split.
  move/In_hl_destruct : Hl'' => [x0 [x1 [H5 H6]]].
  rewrite H5 in Hl.
  move/hl_getnext : Hl => H4'.
  case_sepcon H4'.
  Compose_sepcon h1 h2; [rewrite /next; by Mapsto | done].
  exists l; Resolve_topsy.
  exists cptr, (cptr + 2 + cptr_size); Resolve_topsy.
  right; by exists cptr_size, cptr_status.

(*:    brk <- nat_e 1 ; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null \&& var_e brk \= nat_e 1 ]b_s /\
  (exists cptr_value nptr_value,
    [ var_e cptr \= nat_e cptr_value ]b_s /\
    [ var_e nptr \= nat_e nptr_value ]b_s /\
    ((cptr_value = get_endl l adr /\
      nptr_value = 0) \/
    exists cptr_size cptr_status,
      In_hl l (cptr_value,cptr_size,cptr_status) adr /\
      nptr_value = cptr_value + 2 + cptr_size))).

case: H1 => l [Hl [Hl' [Hb [cptr_value [nptr_value [Hcptr [Hnptr Htmp]]]]]]].
rewrite /wp_assign.
exists l; Resolve_topsy.
exists cptr_value, nptr_value; by Resolve_topsy.

(*:    cstts <-* (cptr -.> status); *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null \&& var_e brk \= nat_e 1 ]b_s /\
  (exists cptr_value nptr_value cstts_value,
    [ var_e cptr \= nat_e cptr_value ]b_s /\
    [ var_e nptr \= nat_e nptr_value ]b_s /\
        [ var_e cstts \= cstts_value ]b_s /\
        ((cptr_value = get_endl l adr /\
          nptr_value = 0 /\
          cstts_value = Allocated) \/
        exists cptr_size cptr_status,
          In_hl l (cptr_value,cptr_size,cptr_status) adr /\
          nptr_value = cptr_value + 2 + cptr_size /\
          cstts_value = (hlstat_bool2expr cptr_status)))).

case: H1 => l [Hl [Hl' [Hb [cptr_value [nptr_value [Hcptr [Hnptr []]]]]]]].
- case=> Hcptr_value Hnptr_value.
  exists Allocated.
  apply mapsto_strictly_exact; split.
  move/hl_getstat_last : Hl => Hl; case_sepcon Hl.
  Compose_sepcon h1 h2; [rewrite /status; by Mapsto | done].
  exists l; Resolve_topsy.
  exists cptr_value, nptr_value, Allocated; by Resolve_topsy.
- case=> cptr_size [cptr_status [Hl'' Hnptr_value]].
  exists (hlstat_bool2expr cptr_status).
  apply mapsto_strictly_exact; split.
  move/In_hl_destruct : Hl'' => [l1 [l2 [Hl1l2 Hcptr_value]]].
  rewrite Hl1l2 in Hl; move/hl_getstatus : Hl => Hl; case_sepcon Hl.
  Compose_sepcon h1 h2; [rewrite /status; by Mapsto | done].
  exists l; Resolve_topsy.
  exists cptr_value, nptr_value, (hlstat_bool2expr cptr_status); Resolve_topsy.
  by destruct cptr_status; Resolve_topsy.
  right; exists cptr_size, cptr_status; by Resolve_topsy.

(**    while ((var_e cstts \= Free) \&& (var_e nptr \!= null) \&& (var_e brk \= nat_e 1)) ( *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  ((exists cptr_value cptr_size brk_value,
    [ var_e cptr \= nat_e cptr_value ]b_s /\
    [ var_e nptr \= nat_e (cptr_value + 2 + cptr_size) ]b_s /\
    [ var_e cstts \= Free ]b_s /\
    [ var_e brk \= nat_e brk_value ]b_s /\
    In_hl l (cptr_value,cptr_size,topsy_hm.free) adr /\
    ((cptr_value + 2 + cptr_size = get_endl l adr /\ (brk_value = 0 \/ brk_value = 1)) \/
      (exists  nptr_size nptr_status,
        In_hl l (cptr_value + 2 + cptr_size,nptr_size,nptr_status) adr /\
        ((nptr_status = true /\ brk_value = 1) \/
          (nptr_status = false /\ (brk_value = 1 \/ brk_value = 0)))))) \/
  (exists cptr_value nptr_value cstts_value,
    [ var_e cptr \= nat_e cptr_value ]b_s /\
    [ var_e nptr \= nat_e nptr_value ]b_s /\
    [ var_e cstts \= Allocated ]b_s /\
    [ var_e brk \= nat_e 1 ]b_s /\
    ((cptr_value = get_endl l adr /\
      nptr_value = 0 /\
      cstts_value = Allocated) \/
    (exists cptr_size cptr_status,
      In_hl l (cptr_value,cptr_size,cptr_status) adr /\
      nptr_value = cptr_value + 2 + cptr_size))))).

case : H1 => x0 [H2 [H5 [H7 [x1 [x2 [x3 [H13 [H11 [H12 H10]]]]]]]]].
exists x0; Resolve_topsy.
case: H10.
- case => H4 [H13' Hx3]; subst x3.
  right; exists x1, x2, Allocated; by Resolve_topsy.
- case => x4 [[] [H4 [Hx2 Hx3]]]; subst x2 x3.
  + left; exists x1, x4, 1; Resolve_topsy.
    move/In_hl_destruct : H4 => [x2 [x3 [Hx0 Hx1]]].
    case : x3 Hx0 => [| [n b] x3] Hx0.
    * left; rewrite Hx0 get_endl_app /=; ssromega.
    * right; exists n, b.
      split; last by destruct b; Resolve_topsy.
      rewrite Hx0; apply In_hl_or_app; right => /=.
      have : get_endl x2 adr != x1 + 2 + x4 by apply/eqP; ssromega.
      move/negbTE => -> /=.
      by rewrite Hx1 !eqxx.
  + right; exists x1, (x1 + 2 + x4), Allocated; Resolve_topsy.
    right; by exists x4, false.

(**       nstts <-* (nptr -.> status); *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  (exists cptr_value cptr_size brk_value,
    [ var_e cptr \= nat_e cptr_value ]b_s /\
    [ var_e nptr \= nat_e (cptr_value + 2 + cptr_size) ]b_s /\
    [ var_e cstts \= Free ]b_s /\
    [ var_e brk \= nat_e brk_value ]b_s /\
    In_hl l (cptr_value,cptr_size,topsy_hm.free) adr /\
    ((cptr_value + 2 + cptr_size = get_endl l adr /\ (brk_value = 0 \/ brk_value = 1) /\
        [ var_e nstts \= Allocated ]b_s) \/
      exists  nptr_size nptr_status,
        In_hl l (cptr_value + 2 + cptr_size,nptr_size,nptr_status) adr /\
        ((nptr_status = true /\ brk_value = 1) \/
          (nptr_status = false /\ (brk_value = 1 \/ brk_value = 0))) /\
        [ var_e nstts \= hlstat_bool2expr nptr_status ]b_s))).

case : H1 => [[x0 [H3 [H6 [H7 H8]]]] H2].
case : H8.
- case => cptr_val [cptr_sz [brk_val [H12 [H13 [H14 [H15 [H17 H16]]]]]]].
  case: H16.
  + case => H15' H16.
    exists Allocated.
    rewrite /status.
    apply mapsto_strictly_exact; split.
    * move/hl_getstat_last : H3 => H3; case_sepcon H3.
      Compose_sepcon h1 h2; [by Mapsto | done].
    * rewrite /wp_assign; exists x0.
      Resolve_topsy.
      exists cptr_val, cptr_sz, brk_val; Resolve_topsy.
      left; by Resolve_topsy.
  + case => x4 [x5 [H15' H16]].
    exists (hlstat_bool2expr x5).
    rewrite /status.
    apply mapsto_strictly_exact; split.
    * case/In_hl_destruct : H15' => x6 [x7 [H17' H18]].
      rewrite H17' in H3; move/hl_getstatus : H3 => H3; case_sepcon H3.
      Compose_sepcon h1 h2; [rewrite H18 in H3_h1; by Mapsto | done].
    * rewrite /wp_assign; exists x0.
      Resolve_topsy.
      exists cptr_val, cptr_sz, brk_val; Resolve_topsy.
      right; exists x4, x5; by destruct x5; Resolve_topsy.
- case => cptr_val [nptr_val [cstts_val [H12 [H13 [H14 [H15 H16]]]]]].
  suff : False by done. omegab.

(**       ifte (var_e nstts \!= Free) thendo ( *)

Step TT.

(**          brk <- nat_e 0 *)

Step TT.
move=> s h H2.
case : H2 => [[x0 [H3 [H6 [H7 [x1 [x2 [x3 [H8 [H9 [H10 [H11 [H12 H13]]]]]]]]]]]] H4].
rewrite /wp_assign.
exists x0; Resolve_topsy.
left.
case: H13.
- case => H13 [H15 H16].
  exists x1, x2, 0; by Resolve_topsy.
- case => x4 [x5 [H13 [H15 H16]]].
  exists x1; exists x2, 0; Resolve_topsy.
  right; exists x4, x5; Resolve_topsy.
  destruct x5; omegab.

(**       ) elsedo (
	 tmp <-* nptr -.> next; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  (exists cptr_value cptr_size brk_value,
    [ var_e cptr \= nat_e cptr_value ]b_s /\
    [ var_e nptr \= nat_e (cptr_value + 2 + cptr_size) ]b_s /\
    [ var_e cstts \= Free ]b_s /\
    [ var_e brk \= nat_e brk_value ]b_s /\
    In_hl l (cptr_value, cptr_size, topsy_hm.free) adr /\
    exists nptr_size nptr_status,
      In_hl l (cptr_value + 2 + cptr_size, nptr_size, nptr_status) adr /\
      (nptr_status = true /\ brk_value = 1) /\
      [ var_e tmp \= nat_e (cptr_value + 2 + cptr_size + 2 + nptr_size) ]b_s)).

case : H1 => [[x0 [H3 [H6 [H7 [x1 [x2 [x3 [H8 [H9 [H10 [H11 [H12 H13]]]]]]]]]]]] H4].
case : H13.
- case => H13 [H15 H16].
  suff : False by done. omegab.
- case => x4 [x5 [H13 [H15 H16]]].
  destruct x5.
  + exists (nat_e (x1 + 2 + x2 + 2 + x4)).
    rewrite /next.
    apply mapsto_strictly_exact; split.
    * case/In_hl_destruct : H13 => x5 [x6 [H5 H17]].
      rewrite H5 in H3.
      move/hl_getnext : H3 => H14.
      case_sepcon H14.
      Compose_sepcon h1 h2; last by done.
      rewrite H17 in H14_h1; by Mapsto.
    * exists x0; Resolve_topsy.
      exists x1, x2, 1.
      case: H15 => [ [_ H14] | [] // ].
      subst x3;  Resolve_topsy.
      exists x4, true; by Resolve_topsy.
  + case: H15 => H5.
    * by case: H5.
    * suff : False by done. omegab.

(**         cptr -.> next *<- var_e tmp ; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  (exists cptr_value cptr_size,
    [ var_e cptr \= nat_e cptr_value ]b_s /\
    [ var_e cstts \= Free ]b_s /\
    [ var_e brk \= nat_e 1 ]b_s /\
    In_hl l (cptr_value, cptr_size, topsy_hm.free) adr /\
    [ var_e tmp \= nat_e (cptr_value + 2 + cptr_size) ]b_s)).

case : H1 => x0 [H2 [H5 [H6 [x1 [x2 [x3 [H10 [H11 [H12 [H13 [H14 [x4 [x5 [H15 [[H16 H18] H17]]]]]]]]]]]]]]].

case: (In_hl_next _ _ _ _ _ _ _ H14 H15) => x6 [x7 [H4 Hx1]].
subst x5 x3.
rewrite H4 /topsy_hm.free in H2.
case: (Heap_List_compaction x6 x7 x2 x4 _ s h H2) => x3 mem_s_h.
exists x3.
case_sepcon mem_s_h; Compose_sepcon h1 h2.
by rewrite /next; Mapsto.
move: mem_s_h_h2; apply monotony_imp => h' Hh'.
rewrite /next in Hh'; by Mapsto.
exists (x6 ++ (x2 + x4 + 2, topsy_hm.free) :: x7).
split; first by assumption.
split.
- rewrite H4 in H5.
  case/In_hl_app_or : H5 => H18.
  + by apply In_hl_or_app; left.
  + apply In_hl_or_app; right.
    move: H18.
    rewrite /= /alloc /topsy_hm.free /= -andbA andbC /= -andbA andbC /=.
    rewrite (_ : get_endl x6 adr + 2 + (x2 + x4 + 2) = get_endl x6 adr + 2 + x2 + 2 + x4) //; ssromega.
- Resolve_topsy.
  exists x1, (x2 + 2 + x4); Resolve_topsy.
  apply In_hl_or_app; right => /=.
  rewrite Hx1 (_ : x2 + x4 + 2 = x2 + 2 + x4) //; last by ssromega.
  by rewrite !eqxx.

(**         nptr <- (var_e tmp) *)

Step TT.
move=> s h H2.
rewrite /wp_assign.
case : H2 => x0 [H2 [H5 [H3 [x1 [x2 [H9 [H11 [H7 [H8 H6]]]]]]]]].
exists x0; Resolve_topsy.
left; exists x1, x2, 1; Resolve_topsy.
case/In_hl_destruct : H8 => x3 [x4 [Hx0 H13]].
case : x4 Hx0 => [|[n b] x4] Hx0.
- left; rewrite Hx0 get_endl_app /= H13; tauto.
- right; exists n, b; split.
  rewrite Hx0; apply In_hl_or_app; right => /=.
  case: ifP => // _.
  by rewrite H13 !eqxx.
destruct b; tauto.

(**       )
    );
    cptr <-* (cptr -.> next)
  ). *)

Step TT.
rewrite /while.entails; move=> s h [[x0 [H3 [H6 [H7 H8]]]] H4].
case : H8.
- case => x1 [x2 [x3 [H12 [H5 [H11 [H9 [H10 H14]]]]]]].
  case : H14.
  + case => H13 H14.
    rewrite /next.
    exists (nat_e (x1 + 2 + x2)).
    apply mapsto_strictly_exact; split.
    case/In_hl_destruct : H10 => x4 [x5 [H8 H16]].
    rewrite H8 in H3; move/hl_getnext : H3 => H2'.
    case_sepcon H2'; Compose_sepcon h1 h2; [by Mapsto | done].
    rewrite /wp_assign.
    exists x0; Resolve_topsy.
    exists (x1 + 2 + x2); by Resolve_topsy.
  + case => x4 [x5 [H13 H14]].
    rewrite /next.
    exists (nat_e (x1 + 2 + x2)).
    apply mapsto_strictly_exact; split.
    case/In_hl_destruct : H10 => x6 [x7 [H8 H16]].
    rewrite H8 in H3; move/hl_getnext : H3  => H2'.
    case_sepcon H2'; Compose_sepcon h1 h2; [by Mapsto | done].
    rewrite /wp_assign.
    exists x0; Resolve_topsy.
    exists (x1 + 2 + x2); Resolve_topsy.
    right; right; by exists x4, x5.
- case => x1 [x2 [x3 [H5 [H11 [H9 [H10 H13]]]]]].
  case: H13.
  + case => H12 [H14 H15].
    unfold next.
    exists (nat_e 0).
    apply mapsto_strictly_exact; split.
    move/hl_getnext_last : H3 => H3; case_sepcon H3.
    subst x1 x2 x3.
    Compose_sepcon h1 h2; [by Mapsto | done].
    rewrite /wp_assign.
    exists x0; Resolve_topsy.
    exists 0; by Resolve_topsy.
  + case => x4 [x5 [H12 H13]].
    exists (nat_e (x1 + 2 + x4)).
    unfold next.
    apply mapsto_strictly_exact; split.
    case/In_hl_destruct : H12 => x6 [x7 [H8 H15]].
    rewrite H8 in H3; move/hl_getnext : H3 => H2'.
    case_sepcon H2'; Compose_sepcon h1 h2; [by Mapsto | done].
    rewrite /wp_assign.
    exists x0; Resolve_topsy.
    exists (x1 + 2 + x4); Resolve_topsy.
    right.
    case/In_hl_destruct : H12 => x6 [x7 [H8 H15]].
    case: x7 H8 => [|[n b] x7] H8.
    * left; by rewrite H8 get_endl_app /= H15.
    * right; exists n, b.
      rewrite H8; apply In_hl_or_app; right => /=.
      have : get_endl x6 adr <> x1 + 2 + x4 by ssromega.
      move/eqP/negbTE => -> /=.
      rewrite (_ : get_endl x6 adr + 2 + x4 = x1 + 2 + x4); last by congruence.
      by rewrite !eqxx.
Qed.

Definition compact_specif := forall adr size sizex x,
  size > 0 -> adr > 0 ->
  {{ fun s h => exists l, Heap_List l adr s h /\
    In_hl l (x, sizex, alloc) adr /\
    [ var_e hmStart \= nat_e adr \&& var_e result \= null \&& var_e cptr \= nat_e adr ]b_s }}
  compact cptr nptr stts
  {{ fun s h => exists l, Heap_List l adr s h /\
    In_hl l (x, sizex, alloc) adr /\
    [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s }}.

Lemma compact_verif : compact_specif.
Proof.
unfold compact_specif.
intros.
unfold compact.

(**  while (var_e cptr \!= null) ( *)

Step (fun s h => exists l,
  Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists cur_adr, [ var_e cptr \= nat_e cur_adr ]b_s /\
    (cur_adr = 0 \/
      (cur_adr = get_endl l adr /\
        cur_adr > 0) \/
      (exists cur_size cur_status, In_hl l (cur_adr, cur_size, cur_status) adr /\
        cur_adr > 0))).

rewrite /while.entails => s h [x0 [H1 [H4 H3]]].
exists x0; Resolve_topsy.
exists adr.
split; first by omegab.
case: x0 H1 H4 => [| [n b] x0] H1 H4.
- by rewrite /= in H4.
- right; right; exists n, b; split; last by done.
  by rewrite /= !eqxx.

rewrite /while.entails => s h [[x0 [H2 [H3 [H4 H5]]]] H1].
exists x0; by Resolve_topsy.

(**    stts <-* (cptr -.> status); *)

Step (fun s h => exists l,
  Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists cur_adr, [ var_e cptr \= nat_e cur_adr ]b_s /\
    ((cur_adr = get_endl l adr /\
      cur_adr > 0 /\
      [ var_e stts \= Allocated ]b_s) \/
    (exists cur_size cur_status, In_hl l (cur_adr, cur_size, cur_status) adr /\
      [ var_e stts \= hlstat_bool2expr cur_status ]b_s /\
      cur_adr > 0))).

case : H1 => [[x0 [H2 [H4 [H5 [x1 [H8 H7]]]]]] H3].
case: H7 => [?|].
- subst x1; by omegab.
- case.
  + case => Hx1 H9.
    exists (nat_e 0).
    rewrite /status.
    apply mapsto_strictly_exact; split.
    move/hl_getstat_last : H2 => H2; case_sepcon H2.
    Compose_sepcon h1 h2; [by Mapsto | done].
    rewrite /wp_assign.
    exists x0; Resolve_topsy.
    exists x1; Resolve_topsy.
    left; by Resolve_topsy.
  + case => x2 [x3 [In_hl_x0 H9]].
    case/In_hl_destruct : (In_hl_x0) => x4 [x5 [H10 H11]].
    rewrite /status.
    exists (hlstat_bool2expr x3).
    apply mapsto_strictly_exact; split.
    * rewrite H10 in H2; move/hl_getstatus : H2 => H2; case_sepcon H2.
      Compose_sepcon h1 h2; [by Mapsto | done].
    * rewrite /wp_assign.
      exists x0; Resolve_topsy.
      exists x1; Resolve_topsy.
      right; exists x2, x3; Resolve_topsy.
      by destruct x3; Resolve_topsy.

(**    ifte (var_e stts \=  Free) thendo ( *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists cur_adr, [ var_e cptr \= nat_e cur_adr ]b_s /\
    ((cur_adr = get_endl l adr /\ cur_adr > 0 ) \/
    (exists cur_size cur_status, In_hl l (cur_adr, cur_size, cur_status) adr /\
      cur_adr > 0))).

(**      nptr <-* (cptr -.> next);  *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists cur_adr, [ var_e cptr \= nat_e cur_adr ]b_s /\
    (exists cur_size, In_hl l (cur_adr, cur_size, topsy_hm.free) adr /\
      [ var_e nptr \= nat_e (cur_adr + 2 + cur_size) ]b_s /\
      cur_adr > 0)).

case : H1 => [[x0 [H2 [H4 [H5 [x1 [H6 H7]]]]]] H3].
case : H7.
- case => H7 [H10 H11].
  suff : False by done. omegab.
- case => x2 [[] [H7 [H11 H10]]].
  + exists (nat_e (x1 + 2 + x2)).
    unfold next.
    apply mapsto_strictly_exact; split.
    * case/In_hl_destruct : H7 => x3 [x4 [Hx0 H9]].
      rewrite Hx0 in H2; move/hl_getnext : H2 => H12.
      case_sepcon H12; Compose_sepcon h1 h2; [by Mapsto | done].
    * rewrite /wp_assign.
      exists x0; Resolve_topsy.
      exists x1; Resolve_topsy.
      exists x2; by Resolve_topsy.
  + suff : False by done. omegab.

(**      stts <-* (nptr -.> status); *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists cur_adr, [ var_e cptr \= nat_e cur_adr ]b_s /\
    (exists cur_size, In_hl l (cur_adr, cur_size, topsy_hm.free) adr /\
      [ var_e nptr \= nat_e (cur_adr + 2 + cur_size) ]b_s /\
      cur_adr > 0 /\ (
        (exists next_size next_status,
          In_hl l ((cur_adr + 2 + cur_size), next_size, next_status) adr /\
          [ var_e stts \= hlstat_bool2expr next_status ]b_s) \/
        (cur_adr + 2 + cur_size = get_endl l adr /\
          [ var_e stts \= Allocated ]b_s)))).

case : H1 => x0 [H1 [H4 [H7 [x1 [H5 [x2 [H6 [H8 H9]]]]]]]].
case/In_hl_destruct : (H6) => x3 [x4 [H10 Hx1]].
case: x4 H10 => [|[n b] x4] H10.
- exists Allocated.
  rewrite /status.
  apply mapsto_strictly_exact; split.
  + rewrite H10 in H1; move/hl_getstat_last : H1 => H1; case_sepcon H1.
    Compose_sepcon h1 h2; last by done.
    rewrite get_endl_app in H1_h1; by Mapsto.
  + rewrite /wp_assign.
    exists x0; Resolve_topsy.
    exists x1; Resolve_topsy.
    exists x2; Resolve_topsy.
    right; Resolve_topsy.
    by rewrite -Hx1 H10 get_endl_app.
- exists (hlstat_bool2expr b).
  rewrite /status.
  apply mapsto_strictly_exact; split.
  + rewrite H10 in H1; Hl_getstatus H1 n H2; last by done.
    rewrite get_endl_app [get_endl _]/= in H2_h1; by Mapsto.
  + exists x0; Resolve_topsy.
    exists x1; Resolve_topsy.
    exists x2; Resolve_topsy.
    left; exists n, b; split.
    * rewrite H10; apply In_hl_or_app; right => /=.
      have : get_endl x3 adr <> x1 + 2 + x2 by ssromega.
      move/eqP/negbTE => -> /=.
      by rewrite Hx1 !eqxx.
    * by destruct b; Resolve_topsy.

(*:      while (var_e stts \= Free) ( *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists cur_adr, [ var_e cptr \= nat_e cur_adr ]b_s /\
    exists cur_size, In_hl l (cur_adr, cur_size, topsy_hm.free) adr /\
      [ var_e nptr \= nat_e (cur_adr + 2 + cur_size) ]b_s /\
      cur_adr > 0 /\ (
        (exists next_size next_status,
          In_hl l (cur_adr + 2 + cur_size, next_size, next_status) adr /\
          [ var_e stts \= hlstat_bool2expr next_status ]b_s) \/
        (cur_adr + 2 + cur_size = get_endl l adr /\
          [ var_e stts \= Allocated ]b_s))).

done.

(**        stts <-* (nptr -.> next); *)

rewrite /while.entails => s h [[x0 [H2 [H3 [H4 [x1 [H5 [x2 [H6 [H7 [H8 H9]]]]]]]]]] H1].
exists x0; Resolve_topsy.
exists x1; Resolve_topsy.
right; by exists x2, topsy_hm.free.

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists cur_adr, [ var_e cptr \= nat_e cur_adr ]b_s /\
    exists cur_size,  In_hl l (cur_adr, cur_size, topsy_hm.free) adr /\
      [ var_e nptr \= nat_e (cur_adr + 2 + cur_size) ]b_s /\
      cur_adr > 0 /\
      exists next_size,
        In_hl l (cur_adr + 2 + cur_size, next_size, topsy_hm.free) adr /\
        [ var_e stts \= nat_e (cur_adr + 2 + cur_size + 2 + next_size) ]b_s).

case : H1 => [[x0 [H2 [H4 [H5 [x1 [H6 [x2 [H7 [H8 [H9 H11]]]]]]]]]] H3].
case: H11.
- case => x3 [x4 [H11 H12]].
  destruct x4.
  + case/In_hl_destruct : (H11) => x4 [x5 [Hx0 H14]].
    exists (nat_e (x1 + 2 + x2 + 2 +x3)).
    rewrite /next.
    apply mapsto_strictly_exact; split.
    * rewrite Hx0 in H2; move/hl_getnext : H2 => H2.
      case_sepcon H2; Compose_sepcon h1 h2; [by Mapsto | done].
    * rewrite /wp_assign.
      exists x0; Resolve_topsy.
      exists x1; Resolve_topsy.
      exists x2; Resolve_topsy.
      exists x3; Resolve_topsy.
  + suff : False by done. omegab.
- case => H11 H12.
  suff : False by done. omegab.

(**        (cptr -.> next) *<- var_e stts; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists cur_adr, [ var_e cptr \= nat_e cur_adr ]b_s /\
    exists cur_size,
      In_hl l (cur_adr, cur_size, topsy_hm.free) adr /\
      cur_adr > 0 /\
      [ var_e stts \= nat_e (cur_adr + 2 + cur_size) ]b_s).

case : H1 => x0 [H1 [H4 [H5 [x1 [H6 [x2 [H7 [H8 [H9 [x3 [H10 H11]]]]]]]]]]].
case: (In_hl_next _ _ _ _ _ _ _ H7 H10) => x4 [x7 [H12 H13]].
rewrite /next.
rewrite H12 in H1; case/Heap_List_compaction : H1 => x5 H14.
case_sepcon H14.
exists x5.
Compose_sepcon h1 h2.
- by Mapsto.
- move: H14_h2; apply monotony_imp => h' Hh'; first by Mapsto.
  exists (x4 ++ (x2 + x3 + 2, topsy_hm.free) :: x7).
  split; first by done.
  split.
  * rewrite H12 in H4; case/In_hl_app_or : H4 => H4.
    - apply In_hl_or_app; by left.
    - apply In_hl_or_app; right.
      move: H4.
      rewrite /= /alloc /topsy_hm.free /= -andbA andbC /= -andbA andbC /=.
      rewrite (_ : get_endl _ adr + 2 + (x2 + x3 + 2) = get_endl x4 adr + 2 + x2 + 2 + x3) //; ssromega.
  * Resolve_topsy.
    exists x1; Resolve_topsy.
    exists (x2 + x3 + 2); split.
    - apply In_hl_or_app; right => /=.
      by rewrite -H13 !eqxx.
    - split; [assumption | omegab].

(*:        nptr <- var_e stts; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists cur_adr, [ var_e cptr \= nat_e cur_adr ]b_s /\
    exists cur_size,
      In_hl l (cur_adr, cur_size, topsy_hm.free) adr /\
      cur_adr > 0 /\
      [ var_e nptr \= nat_e (cur_adr + 2 + cur_size) ]b_s).

case : H1 => x0 [H1 [H4 [H5 [x1 [H6 [x2 [H8 [H9 H2]]]]]]]].
rewrite /wp_assign.
exists x0; Resolve_topsy.
exists x1; Resolve_topsy.
exists x2; by Resolve_topsy.

(*:        stts <-* (nptr -.> status))) *)

Step TT.

rewrite /while.entails => s h [x0 [H1 [H4 [H5 [x1 [H6 [x2 [H8 [H9 H2]]]]]]]]].
case/In_hl_destruct : (H8) => x3 [x4 [H10 H11]].
case : x4 H10 => [|[n b] x4] H10.
- exists Allocated.
  rewrite /status.
  apply mapsto_strictly_exact; split.
  + move/hl_getstat_last : H1 => H1; case_sepcon H1.
    rewrite H10 get_endl_app /= H11 in H1_h1.
    Compose_sepcon h1 h2; [by Mapsto | done].
  + rewrite /wp_assign.
    exists x0; Resolve_topsy.
    exists x1; Resolve_topsy.
    exists x2; Resolve_topsy.
    right; Resolve_topsy.
    by rewrite H10 get_endl_app H11.
- exists (hlstat_bool2expr b).
  rewrite /status.
  apply mapsto_strictly_exact; split.
  + rewrite H10 in H1; Hl_getstatus H1 n H3; last by done.
    rewrite get_endl_app [get_endl _]/= in H3_h1; by Mapsto.
  + rewrite /wp_assign.
    exists x0; Resolve_topsy.
    exists x1; Resolve_topsy.
    exists x2; Resolve_topsy.
    left; exists n, b; split.
    * rewrite H10; apply In_hl_or_app; right => /=.
      have : get_endl x3 adr <> x1 + 2 + x2 by ssromega.
      move/eqP/negbTE => -> /=.
      by rewrite H11 !eqxx.
    * by destruct b; Resolve_topsy.

(**    elsedo
      skip; *)

Step TT.
rewrite /while.entails => s h [[x0 [H2 [H5 [H7 [x1 [H6 H8]]]]]] H3].
exists x0; Resolve_topsy.
exists x1; Resolve_topsy.
case: H8.
- left; tauto.
- case => x2 [x3 [H11 [H10 H12]]].
  right; exists x2, x3; by Resolve_topsy.

(**      cptr <-* (cptr -.> next)). *)

Step TT.
rewrite /while.entails => s h [x0 [H1 [H4 [H2 [x1 [H5 H6]]]]]].
rewrite /next.
case: H6.
- case => H6 H8.
  exists (nat_e 0).
  apply mapsto_strictly_exact; split.
  move/hl_getnext_last : H1 => H3; case_sepcon H3.
  Compose_sepcon h1 h2; [by Mapsto | done].
  rewrite /wp_assign.
  exists x0; Resolve_topsy.
  exists 0; by Resolve_topsy.
- case => x2 [x3 [H6 H8]].
  case/In_hl_destruct : H6 => x4 [x5 [H9 Hx1]].
  exists (nat_e (x1 + 2 + x2)).
  apply mapsto_strictly_exact; split.
  + rewrite H9 in H1; move/hl_getnext : H1 => H3.
    case_sepcon H3; Compose_sepcon h1 h2; [by Mapsto | done].
  + rewrite /wp_assign.
    exists x0; Resolve_topsy.
    exists (x1 + 2 + x2); Resolve_topsy.
    case : x5 H9 => [|[n b] x5] H9.
    * right; left.
      rewrite H9 get_endl_app Hx1 /=; ssromega.
    * right; right; exists n, b.
      split; last by ssromega.
      rewrite H9; apply In_hl_or_app; right => /=.
      have : get_endl x4 adr <> x1 + 2 + x2 by ssromega.
      move/eqP/negbTE => -> /=.
      by rewrite Hx1 !eqxx.
Qed.

Definition split_specif := forall adr size sizex x,
  size > 0 -> adr > 0 ->
  {{ fun s h => exists l, Heap_List l adr s h /\
     In_hl l (x, sizex, alloc) adr /\
     [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
     exists y size'', size'' >= size /\
       In_hl l (y, size'', topsy_hm.free) adr /\
       [ var_e entry \= nat_e y ]b_s /\
       y > 0 /\ y <> x }}
  split entry size cptr sz
  {{ fun s h => exists l, In_hl l (x, sizex, alloc) adr /\
     exists y, y > 0 /\ [ var_e entry \= nat_e y ]b_s /\
       exists size'', size'' >= size /\
         (Heap_List l adr ** Array (y + 2) size'') s h /\
         In_hl l (y, size'', alloc) adr /\ y <> x }}.

Lemma split_verif : split_specif.
Proof.
rewrite /split_specif.
intros.
rewrite /split.

(**  ENTRYSIZE entry sz; *)

rewrite /ENTRYSIZE /LEFTOVER.

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists y size'', size'' >= size /\
    In_hl l (y, size'', topsy_hm.free) adr /\
    [ var_e entry \= nat_e y ]b_s /\
    y > 0 /\ y <> x /\
    [ var_e sz \= nat_e size'' ]b_s).

Step (fun s h => exists l, Heap_List l adr s h /\
    In_hl l (x, sizex, alloc) adr /\
    [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
    exists y size'', size'' >= size /\
     In_hl l (y, size'', topsy_hm.free) adr /\
     [ var_e entry \= nat_e y ]b_s /\
     y > 0 /\ y <> x /\
     [ var_e sz \= nat_e (y + 2 + size'') ]b_s).

case : H1 => x0 [H1 [H4 [H2 [x1 [x2 [H7 [H8 [H10 [H6 H5]]]]]]]]].
exists (nat_e (x1 + 2 + x2)).
rewrite /next.
apply mapsto_strictly_exact; split.
case/In_hl_destruct : H8 => x3 [x4 [H11 H12]].
rewrite H11 in H1; move/hl_getnext : H1 => H2'.
case_sepcon H2'; Compose_sepcon h1 h2; [by Mapsto | done].
rewrite /wp_assign.
exists x0; Resolve_topsy.
exists x1, x2; by Resolve_topsy.

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists y size'', size'' >= size /\
     In_hl l (y, size'', topsy_hm.free) adr /\
     [ var_e entry \= nat_e y ]b_s /\
     y > 0 /\ y <> x /\
     [ var_e sz \= nat_e size'' ]b_s).

case : H1 => x0 [H1 [H4 [H2 [x1 [x2 [H7 [H8 [H10 [H6 [H5 H9]]]]]]]]]].
rewrite /wp_assign.
exists x0; Resolve_topsy.
exists x1, x2; by Resolve_topsy.

Step TT.

Step TT.

move=> s h [[x0 [H1 [H4 [H2 [x1 [x2 [H7 [H8 [H10 [H6 [H5 H9]]]]]]]]]]] H1'].
suff : False by done. omegab.

Step TT.

rewrite /while.entails => *; tauto.

(**  ifte (var_e sz \>= (nat_e size \+ nat_e LEFTOVER \+ nat_e 2)) thendo ( *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists y size'', size'' >= size /\
    In_hl l (y, size'', topsy_hm.free) adr /\
    [ var_e entry \= nat_e y ]b_s /\
    y > 0 /\ y <> x).

(**    cptr <- var_e entry \+ nat_e 2 \+ nat_e size; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists y size'', size'' >= size /\
    In_hl l (y, size'', topsy_hm.free) adr /\
    [ var_e entry \= nat_e y ]b_s /\
    y > 0 /\ y <> x /\
    [ var_e sz \= nat_e size'' ]b_s /\
    size'' >= size + LEFTOVER + 2 /\
    [ var_e cptr \= nat_e (y + 2 + size) ]b_s).

unfold LEFTOVER.
case : H1 => [[x0 [H1 [H4 [H2 [x1 [x2 [H7 [H8 [H10 [H6 [H5 H9]]]]]]]]]]] H1'].
rewrite /wp_assign.
exists x0; Resolve_topsy.
exists x1, x2; Resolve_topsy; by omegab.

(*:    sz <-* (entry -.> next); *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  exists y size'', size'' >= size /\
    In_hl l (y, size'', topsy_hm.free) adr /\
    [ var_e entry \= nat_e y ]b_s /\
    y > 0 /\ y <> x /\
    [ var_e sz \= nat_e (y + 2 + size'') ]b_s /\
    size'' >= size + LEFTOVER + 2 /\
    [ var_e cptr \= nat_e (y + 2 + size) ]b_s).

case : H1 => x0 [H1 [H4 [H2 [x1 [x2 [H7 [H8 [H9 [H11 [H12 [H13 [H14 H15]]]]]]]]]]]].
exists (nat_e (x1 + 2 + x2)).
rewrite /next.
apply mapsto_strictly_exact; split.
case/In_hl_destruct : H8 => x3 [x4 [Hx0 Hx1]].
rewrite Hx0 in H1; move/hl_getnext : H1 => H2'.
case_sepcon H2'; Compose_sepcon h1 h2; [by Mapsto | done].
rewrite /wp_assign.
exists x0; Resolve_topsy.
by exists x1, x2; Resolve_topsy.

(**    (cptr -.> next) *<- var_e sz; *)

Step (fun s h => exists e'',
  (cptr -.> status |~> e'' **
    (cptr -.> status |~> Free -*
      (fun s0 h0 => exists e''0,
        (entry -.> next |~> e''0 **
          (entry -.> next |~> var_e cptr -*
            (fun s1 h1 => exists l, Heap_List l adr s h1 /\
              In_hl l (x, sizex, alloc) adr /\
              [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s1 /\
              exists y size'',
                size'' >= size /\
                In_hl l (y, size'', topsy_hm.free) adr /\
                [ var_e entry \= nat_e y ]b_s1 /\
                y > 0 /\ y <> x))) s0 h0))) s h).

case : H1 => x0 [H1 [H2 [H3 [x1 [x2 [H4 [H5 [H6 [H7 [H8 [H9 [H10 H11]]]]]]]]]]]].
rewrite (_ : x2 = size + 2 + (x2 - 2 - size)) in H5; last by ssromega.
case/In_hl_destruct : H5 => x3 [x4 [H3' H15]].
rewrite H3' in H1; case/Heap_List_splitting : H1 => x5 H16.
exists x5.
case_sepcon H16.
rewrite /next.
Compose_sepcon h1 h2.
  rewrite H15 in H16_h1; by Mapsto.
rewrite /status.
move: H16_h2; apply assert_m.monotony_imp.
  move=> h' Hh'; by Mapsto.
move=> h' Hh'.
case: Hh' => x6 H18.
exists x6.
case_sepcon H18.
Compose_sepcon h'1 h'2; first by Mapsto.
move: H18_h'2; apply monotony_imp.
  move=> h'' Hh''; by Mapsto.
move=> h'' Hh''.
case: Hh'' => x7 H21.
exists x7.
case_sepcon H21.
Compose_sepcon h''1 h''2; first by Mapsto.
move: H21_h''2; apply monotony_imp.
  move=> h''' Hh'''; by Mapsto.
move=> h''' Hh'''.
exists (x3 ++ (size, true) :: (x2 - 2 - size, true) :: x4).
split; first by assumption.
Resolve_topsy.
- rewrite H3' in H2; case/In_hl_app_or : H2 => H2.
  - apply In_hl_or_app; by left.
  - apply In_hl_or_app; right.
    move: H2.
    do 2 rewrite /= /alloc /topsy_hm.free /= -andbA andbC /=.
    by rewrite !addnA.
exists x1, size; Resolve_topsy.
apply In_hl_or_app; right => /=.
by rewrite H15 !eqxx.

(*:    (cptr -.> status) *<- Free; *)

Step (fun s0 h0 => exists e'',
  (entry -.> next |~> e'' **
    (entry -.> next |~> var_e cptr -*
      (fun s h => exists l,
        Heap_List l adr s h /\
        In_hl l (x, sizex, alloc) adr /\
        [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
        exists y size'', size'' >= size /\
          In_hl l (y, size'', topsy_hm.free) adr /\
          [ var_e entry \= nat_e y ]b_s /\
          y > 0 /\ y <> x))) s0 h0).

assumption.

(**    (entry -.> next) *<- var_e cptr) *)

Step TT.
by apply hoare_prop_m.entails_id.

(**   elsedo
     skip *)

Step TT.
rewrite /while.entails => s h [[x0 [H1 [H4 [H2 [x1 [x2 [H7 [H8 [H10 [H6 [H5 H9]]]]]]]]]]] H1'].
exists x0; Resolve_topsy.
exists x1, x2; by Resolve_topsy.

(**  (entry -.> status) *<- Allocated. *)

Step TT.
rewrite /while.entails => s h [x0 [H1 [H2 [H3 [x1 [x2 [H4 [H5 [H6 [H7 H8]]]]]]]]]].
case/In_hl_destruct : H5 => x3 [x4 [H11 H12]].
rewrite H11 in H1; case/hl_free2alloc : H1 => x5 H1.
case_sepcon H1.
exists x5.
rewrite /status.
Compose_sepcon h1 h2; first by Mapsto.
move: H1_h2; apply monotony_imp => h' Hh'; first by Mapsto.
case_sepcon Hh'.
exists (x3 ++ (x2,false) :: x4).
Resolve_topsy.
- rewrite H11 in H2; case/In_hl_app_or : H2 => H2.
  - apply In_hl_or_app; by left.
  - rewrite /= /alloc /topsy_hm.free /= -andbA andbC /= in H2.
    apply In_hl_or_app; right => /=.
    have : get_endl x3 adr <> x by lia.
    by move/eqP/negbTE => ->.
- exists x1; Resolve_topsy.
  exists x2; Resolve_topsy.
  Compose_sepcon h'1 h'2; [done | by Array_equiv].
  apply In_hl_or_app; right.
  by rewrite /= H12 !eqxx.
Qed.

Definition hmAlloc_specif := forall adr x sizex size, adr > 0 -> size > 0 ->
  {{ fun s h => exists l, Heap_List l adr s h /\
    In_hl l (x, sizex, alloc) adr /\
    [ var_e hmStart \= nat_e adr ]b_s }}
  hmAlloc result size entry cptr fnd stts nptr sz
  {{ fun s h =>
    (exists l y, y > 0 /\ [ var_e result \= nat_e (y + 2) ]b_s /\
      exists size'', size'' >= size /\
        (Heap_List l adr ** Array (y + 2) size'') s h /\
        In_hl l (x, sizex, alloc) adr /\ In_hl l (y, size'', alloc) adr /\
        x <> y)
    \/
    (exists l, [ var_e result \= nat_e 0 ]b_s /\
      Heap_List l adr s h /\ In_hl l (x, sizex, alloc) adr) }}.

Lemma hmAlloc_verif: hmAlloc_specif.
Proof.
rewrite /hmAlloc_specif /hmAlloc => adr x sizex size H H0.

(**  result <- null; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s).

case : H1 => x0 [H1 [H4 H5]].
rewrite /wp_assign.
exists x0; by Resolve_topsy.

(**  findFree size entry fnd sz stts; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  ((exists y size'',
    size'' >= size /\
    In_hl l (y, size'', topsy_hm.free) adr /\
    [ (var_e entry \= nat_e y) ]b_s /\
    y > 0) \/
  [ var_e entry \= null ]b_s)).

move: (findFree_verif adr x sizex size H0 H) => H1.

Step TT. (* apply hoare_conseq (?) *)
- rewrite /while.entails => s h [x0 [H2 [H4 [H3 H6]]]] {H1}.
  exists x0; Resolve_topsy.
  case : H6 => H1.
  + case : H1 => x1 [x2 [H5 [H7 H1]]].
    left; exists x1, x2; Resolve_topsy.
    omegab.
  + by right.
- by apply hoare_prop_m.entails_id.

(**  ifte (var_e entry \= null) thendo ( *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s /\
  ((exists y size'', size'' >= size /\
    In_hl l (y, size'', topsy_hm.free) adr /\
    [ var_e entry \= nat_e y ]b_s /\
    y > 0) \/ [ var_e entry \= null ]b_s)).

(**    cptr <- var_e hmStart; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr ]b_s /\ [ var_e result \= null ]b_s /\
  [ var_e entry \= null ]b_s /\ [ var_e cptr \= var_e hmStart ]b_s).

case : H1 => [[x0 [H2 [H5 [H4 H7]]]] H6].
case : H7.
- case => x1 [x2 [H7 [H9 [H11 H8]]]].
  suff : False by done. omegab.
- exists x0; by Resolve_topsy.

(**    compact cptr nptr stts; *)

Step (fun s h => exists l, Heap_List l adr s h /\
  In_hl l (x, sizex, alloc) adr /\
  [ var_e hmStart \= nat_e adr \&& var_e result \= null ]b_s).

move: (compact_verif adr size sizex x H0 H) => H1.
Step TT.
- rewrite /while.entails => {H1} s h [x0 [H1 [H4 H2]]].
  exists x0; by Resolve_topsy.
- rewrite /while.entails => s h [x0 [H2 [H5 [H9 [H7 [H6 H4]]]]]].
  exists x0; by Resolve_topsy.

move: (findFree_verif adr x sizex size H0 H) => H1.

(**    findFree size entry fnd sz stts *)

Step TT. (* apply hoare_conseq (?) *)
- rewrite /while.entails => s h [x0 [H2 [H5 [H7 H3]]]].
  exists x0; Resolve_topsy.
  case : H3 => H4.
  + case : H4 => x1 [x2 [H3 [H8 H4]]].
    left; exists x1, x2; Resolve_topsy.
    by omegab.
  + by right.
- done.

(**  ) elsedo
       skip *)

Step TT.
rewrite /while.entails; intros; tauto.

(**  ifte (var_e entry \= null) thendo ( *)

Step TT.

(**    result <- HM_ALLOCFAILED *)

Step TT.
move=> s h H1.
rewrite /wp_assign.
case : H1 => [[x0 [H2 [H5 [H3 H7]]]] H4].
case : H7 => H1.
- case : H1 => x1 [x2 [H7 [H9 [H11 H8]]]].
  suff : False by done. omegab.
- right; exists x0; by Resolve_topsy.

(**  ) elsedo (
    split entry size cptr sz; *)

Step (fun s h => exists l y, y > 0 /\
  [ var_e entry \= nat_e y ]b_s /\
  exists size', size' >= size /\
    (Heap_List l adr ** Array (y + 2) size') s h /\
    In_hl l (x, sizex, alloc) adr /\
    In_hl l (y, size', alloc) adr /\ x <> y).

move: (split_verif adr size sizex x H0 H) => H1.

Step TT. (* apply hoare_conseq (?) *)
- rewrite /while.entails => {H1} s h [x0 [H1 [x1 [H2 [H3 [x2 [H4 [H5 [H6 H7]]]]]]]]].
  exists x0, x1; Resolve_topsy.
  exists x2; by Resolve_topsy.
- rewrite /while.entails => {H1} s h [[x0 [H2 [H5 [H7 H1]]]] H3].
  case : H1 => H4.
  + case: H4 => x1 [x2 [H8 [H9 H11]]].
    exists x0; Resolve_topsy.
    exists x1, x2; Resolve_topsy.
    tauto.
    omegab.
    by apply (In_hl_dif _ _ _ _ _ _ H5 H9).
  + by omegab.

(**    result <- var_e entry \+ nat_e 2
     ). *)

Step TT.
rewrite /wp_assign => s h [x0 [x1 [H2 [H3 [x2 [H4 [H5 [H6 [H7 H8]]]]]]]]].
left; exists x0, x1; Resolve_topsy.
exists x2; Resolve_topsy.
case_sepcon H5.
Compose_sepcon h1 h2.
by Resolve_topsy.
by Array_equiv.
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_atom_tacs.
Require Export rules_struct.

Lemma utok_ren_cseq_thin_hyps {o} :
  forall H J C t wg cg c wfs ct ce D deq fresh
         (f : @utok_ren_cseq
                (set_dset_string o)
                (mk_dset D deq fresh)
                (mk_wcseq ((H ++ J) ||- (mk_concl C t))
                          (ext_wf_cseq (H ++ J) ||- (mk_concl C t) wg cg c))),
    @utok_ren_cseq
      (set_dset_string o)
      (mk_dset D deq fresh)
      (mk_wcseq (H) ||- (mk_concl C t) (wfs, (ct, ce))).
Proof.
  introv f.
  intro p; exrepnd; simpl in p0.
  assert (dset_member
            x
            (get_utokens_cseq
               (mk_wcseq (H ++ J) ||- (mk_concl C t)
                         (ext_wf_cseq (H ++ J) ||- (mk_concl C t) wg cg c)))) as m.
  (* -- begin proof of m *)
  allrw @dset_member_iff.
  allunfold @get_utokens_cseq; allsimpl.
  allunfold @get_utokens_ctseq; allsimpl.
  allunfold @get_utokens_seq; allsimpl.
  allunfold @get_utokens_bseq; allsimpl.
  allrw @get_utokens_bhyps_app; allrw in_app_iff; sp.
  (* -- end proof of m *)
  pose proof (f (existT _ x m)); auto.
Defined.

(* !! MOVE to lsubst_hyps *)
Lemma wf_hyps_proof_irrelevance {o} :
  forall (hs : @barehypotheses o)
         (p1 p2 : wf_hyps hs),
    p1 = p2.
Proof.
  introv.
  allunfold @wf_hyps.
  allunfold @wf_hyp.
  apply functional_extensionality_dep; introv.
  apply functional_extensionality_dep; introv.
  apply wf_term_proof_irrelevance.
Qed.

Lemma rule_thin_hyps_atom_true {o} :
  forall lib (H J : @barehypotheses (s2s o))
         (C t : NTerm),
    rule_atom_true lib (rule_thin_hyps H J C t).
Proof.
  introv.
  unfold rule_atom_true, closed_type_baresequent, closed_extract_baresequent.
  introv cargs hyps; allsimpl.

  clear cargs.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destruct wf1 as [wfs wf1].
  destruct wf1 as [ct ce].
  allsimpl.

  assert (closed_extract (H ++ J) (mk_concl C t))
    as c by (wfseq; apply covered_app_weak_l; auto).
  exists c.

  unfold sequent_atom_true.
  introv kelts; introv.

  pose proof (replace_utokens_cseq_mk_wcseq
                ((H ++ J) ||- (mk_concl C t))
                (ext_wf_cseq (H ++ J) ||- (mk_concl C t) wg cg c)
                f) as e; exrepnd.
  rw e0; clear e0.

  revert w'.
  unfold replace_utokens_bseq; introv; allsimpl.
  foldseq.

  revert w'.
  rw @replace_utokens_bhyps_app; introv.

  destruct w' as [wsr w']; destruct w' as [ctr cer]; allsimpl.

  pose proof (rule_thin_hyps_true
                (replace_utokens_library lib fl)
                (replace_utokens_bhyps
                   H
                   (wf_hyps_app_left H J (wf_sequent_2hyps (H ++ J) ||- (mk_concl C t) wg))
                   (utok_ren_bhyps_app_2bhyps1
                      H J
                      (utok_ren_bseq_2h (H ++ J) ||- (mk_concl C t) f)))
                (replace_utokens_bhyps
                   J
                   (wf_hyps_app_right H J (wf_sequent_2hyps (H ++ J) ||- (mk_concl C t) wg))
                   (utok_ren_bhyps_app_2bhyps2
                      H J
                      (utok_ren_bseq_2h (H ++ J) ||- (mk_concl C t) f)))
                (replace_utokens_t
                   C
                   (wf_concl_ext_2typ C t (wf_sequent_2concl (H ++ J) ||- (mk_concl C t) wg))
                   (utok_ren_concle_2t
                      C t
                      (utok_ren_bseq_2c (H ++ J) ||- (mk_concl C t) f)))
                (replace_utokens_t
                   t
                   (wf_concl_ext_2ext C t (wf_sequent_2concl (H ++ J) ||- (mk_concl C t) wg))
                   (utok_ren_concle_2e
                      C t
                      (utok_ren_bseq_2c (H ++ J) ||- (mk_concl C t) f)))
                wsr
                ctr
                (args_constraints_nil _)) as h; simpl in h.

  repeat (autodimp h hyp).

  - clear cer ctr wsr.
    introv h.
    dorn h; tcsp; subst.
    pose proof (hyp1 k D deq fresh kelts) as h; clear hyp1.

    pose proof (h (utok_ren_cseq_thin_hyps
                     H J C t wg cg c wfs ct ce D deq fresh f)
                  fl) as hh; clear h.

    pose proof (replace_utokens_cseq_mk_wcseq
                  ((H) ||- (mk_concl C t))
                  (wfs,(ct,ce))
                  (utok_ren_cseq_thin_hyps
                     H J C t wg cg c wfs ct ce D deq fresh f)) as e; exrepnd.
    rw e0 in hh; clear e0.
    allunfold @replace_utokens_bseq; allsimpl.
    foldseq.
    rw <- @sequent_true_eq_VR in hh.

    assert (eq_utok_ren_bhyps
              H
              (utok_ren_bseq_2h
                 ((H) ||- (mk_concl C t))
                 (utok_ren_cseq_thin_hyps H J C t wg cg c wfs ct ce D deq fresh f))
              (utok_ren_bhyps_app_2bhyps1
                 H J
                 (utok_ren_bseq_2h (H ++ J) ||- (mk_concl C t) f))) as e1.
    introv; exrepnd; simpl.
    gen_s2s; PI2.

    assert (eq_utok_ren
              C
              (utok_ren_concle_2t
                 C t
                 (utok_ren_bseq_2c (H) ||- (mk_concl C t)
                                   (utok_ren_cseq_thin_hyps H J C t wg cg c wfs ct
                                                            ce D deq fresh f)))
              (utok_ren_concle_2t
                 C t
                 (utok_ren_bseq_2c (H ++ J) ||- (mk_concl C t) f))
           ) as e2.
    introv; exrepnd; simpl.
    gen_s2s; PI2.

    assert (eq_utok_ren
              t
              (utok_ren_concle_2e
                 C t
                 (utok_ren_bseq_2c (H) ||- (mk_concl C t)
                                   (utok_ren_cseq_thin_hyps H J C t wg cg c wfs ct
                                                            ce D deq fresh f)))
              (utok_ren_concle_2e
                 C t
                 (utok_ren_bseq_2c (H ++ J) ||- (mk_concl C t) f))
           ) as e3.
    introv; exrepnd; simpl.
    gen_s2s; PI2.

    remember (wf_hyps_app_left H J (wf_sequent_2hyps (H ++ J) ||- (mk_concl C t) wg)) as wH.
    remember (wf_concl_ext_2typ C t (wf_sequent_2concl (H ++ J) ||- (mk_concl C t) wg)) as wC.
    remember (wf_concl_ext_2ext C t (wf_sequent_2concl (H ++ J) ||- (mk_concl C t) wg)) as wt.

    rw <- (replace_utokens_bhyps_eq H wH wH _ _ e1).
    rw <- (replace_utokens_t_eq C wC wC _ _ e2).
    rw <- (replace_utokens_t_eq t wt wt _ _ e3).

    remember (wf_sequent_2hyps (H) ||- (mk_concl C t) wfs) as wH'.
    remember (wf_concl_ext_2typ C t (wf_sequent_2concl (H) ||- (mk_concl C t) wfs)) as wC'.
    remember (wf_concl_ext_2ext C t (wf_sequent_2concl (H) ||- (mk_concl C t) wfs)) as wt'.
    allsimpl.

    pose proof (wf_term_proof_irrelevance C wC wC') as e; rw e; clear e.
    pose proof (wf_term_proof_irrelevance t wt wt') as e; rw e; clear e.
    pose proof (wf_hyps_proof_irrelevance H wH wH') as e; rw e; clear e.

    exists w'; auto.

  - exrepnd.
    allunfold @closed_extract_baresequent; allsimpl; PI2.
    unfold ext_wf_cseq in h0.
    rw @sequent_true_eq_VR in h0; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/" "../cequiv/" "../per/" "../close/")
*** End:
*)


Require Import Omega.

Require Import Coq.Classes.Morphisms.
Require Import Relation_Definitions.

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

Require Import VST.concurrency.lib.setoid_help.
Require Import VST.concurrency.common.permissions. Import permissions.
Require Import VST.concurrency.common.Clight_bounds.
Require Import VST.concurrency.common.permissions.
(* Require Import VST.concurrency.lib.Coqlib3. *)

Import FunctionalExtensionality.
Import Logic.
Import Basics.
Import BinInt.

Set Bullet Behavior "Strict Subproofs".

(** *Extension to rewrite library:*)
(*    We add partially reflexive relations:
    https://coq.inria.fr/refman/addendum/generalized-rewriting.html#rewriting-and-non-reflexive-relations
 *)

Class PartReflexive {A:Type} (P: A -> Prop) R:=
  { PReflex: forall x : A, P x -> R x x }.
Lemma part_reflexive_proper_proxy {A P} {R: relation A}
      `(PartReflexive A P R) (x : A) : P x -> ProperProxy R x.
  intros. eapply H; auto.
Qed.
(* This ensures that when ProperProxy is ebing resolved,
   partial reflexivity is considered
 *)
Hint Extern 3 (ProperProxy ?R _) =>
not_evar R; class_apply @part_reflexive_proper_proxy;
  try typeclasses eauto; eauto
                         : typeclass_instances.

(* We present two more relations that help take advantage of the above.*)
Inductive trieq {A : Type} (x : A) : A -> A -> Prop :=
| triew_refl: trieq x x x.
Hint Resolve (triew_refl).
Instance trieq_PartReflexive: forall A (x:A), PartReflexive (eq x) (trieq x).
Proof. constructor; intros; subst; constructor. Qed.
Global Instance Symmetric_trieq:
  forall {A} (x:A), Symmetric (trieq x).
Proof.
  intros. intros ???H; inversion H; constructor. Qed.
Global Instance Transitive_trieq:
  forall {A} (x:A), Transitive (trieq x).
Proof.
  intros. intros ??? H1 H2.
  inversion H1; inversion H2. constructor.
Qed.

Definition eq_P {A : Type} (P:A -> Prop) (x y: A) : Prop :=
  (x = y) /\ P x.
Instance eq_P_PartReflexive: forall {A P}, PartReflexive P (@eq_P A P).
Proof. constructor; intros; subst; constructor; auto. Qed.
Global Instance Symmetric_eq_P:
  forall {A P}, Symmetric (@eq_P A P).
Proof.
  intros. intros ???H; inversion H; subst; constructor; auto. Qed.
Global Instance Transitive_eq_P:
  forall {A P}, Transitive (@eq_P A P).
Proof.
  intros. intros ??? H1 H2.
  inversion H1; inversion H2; subst. constructor; auto.
Qed.

(* End rewrite extension*)

Ltac rewrite_getPerm_goal:=
  match goal with
  | [|- context[(?f ?m) !! ?b ?ofs ?k] ] =>
    replace ((f m) !! b ofs k) with (permission_at m b ofs k)
      by reflexivity;
    match k with
    | Cur => rewrite <- getCurPerm_correct
    | Max => rewrite <- getMaxPerm_correct
    end
  end.
Ltac rewrite_getPerm_hyp:=
  match goal with
  | [H: context[(?f ?m) !! ?b ?ofs ?k]|- _ ] =>
    replace ((f m) !! b ofs k) with (permission_at m b ofs k) in H
      by reflexivity;
    match k with
    | Cur => rewrite <- getCurPerm_correct in H
    | Max => rewrite <- getMaxPerm_correct in H
    end
  end.
Ltac rewrite_getPerm := first [rewrite_getPerm_goal|rewrite_getPerm_hyp].

Definition access_map_equiv (a1 a2: access_map): Prop :=
  forall b, a1 !! b =  a2 !! b.
Instance access_map_equiv_Equivalence: Equivalence access_map_equiv.
Proof.
  constructor; try constructor; intros ?; intros.
  - unfold access_map_equiv in *; auto.
  - unfold access_map_equiv in *; etransitivity; auto.
Qed.

Ltac destruct_address_range b ofs b0 ofs0 n:=
  let Hrange:= fresh "Hrange" in
  let Hneq:= fresh "Hneq" in
  destruct (Coqlib.peq b b0) as [Hneq | Hneq];
  [subst b0;
   destruct (Intv.In_dec ofs0
                         (ofs, ofs + BinInt.Z.of_nat(n))%Z )
     as [Hrange | Hrange]
  | ].

Instance setPermBlock_access_map_equiv:
  Proper (eq ==> eq ==> eq ==>
             access_map_equiv ==> eq_P (lt 0) ==>  access_map_equiv)
         (setPermBlock ).
Proof.
  proper_intros; inversion H3; subst.
  intros b; extensionality ofs.
  destruct_address_range y0 y1 b ofs y3.
  - unfold Intv.In in *; simpl in *.
    repeat rewrite setPermBlock_same; auto.
  - eapply Intv.range_notin in Hrange; simpl; try omega.
    repeat rewrite setPermBlock_other_1; auto.
    rewrite H2; auto.
  - subst.
    repeat rewrite setPermBlock_other_2; auto.
    rewrite H2; auto.
Qed.

Definition Max_equiv (m1 m2: mem): Prop :=
  access_map_equiv (getMaxPerm m1) (getMaxPerm m2).

Global Instance Equivalenc_Max_equiv:
  Equivalence Max_equiv.
Proof.
  econstructor.
  - intros??; reflexivity.
  - intros ????. symmetry; auto.
  - intros ??????. etransitivity; eauto.
Qed.
Definition Cur_equiv (m1 m2: mem): Prop :=
  access_map_equiv (getCurPerm m1) (getCurPerm m2).
Global Instance Equivalenc_Cur_equiv:
  Equivalence Cur_equiv.
Proof.
  econstructor.
  - intros??; reflexivity.
  - intros ????. symmetry; auto.
  - intros ??????. etransitivity; eauto.
Qed.

Lemma restr_Max_equiv:
  forall {p m}
         (Hlt: permMapLt p (getMaxPerm m)),
    Max_equiv (restrPermMap Hlt) m.
Proof. intros ????.
       extensionality ofs.
       rewrite getMaxPerm_correct.
       apply restrPermMap_Max.
Qed.

Definition content_equiv (m1 m2: mem):=
  forall b ofs,
    ZMap.get ofs (Mem.mem_contents m1) !! b =
    ZMap.get ofs (Mem.mem_contents m2) !! b.
Global Instance Equivalenc_content_equiv:
  Equivalence content_equiv.
Proof.
  econstructor.
  - intros??; reflexivity.
  - intros ????. symmetry; auto.
  - intros ??????. etransitivity; eauto.
Qed.
Lemma restr_content_equiv:
  forall {p m} Hlt,
    content_equiv (@restrPermMap p m Hlt) m.
Proof. intros ?????; reflexivity. Qed.

Record mem_equiv (m1 m2: mem): Prop :=
  { cur_eqv:> Cur_equiv m1 m2;
    max_eqv:> Max_equiv m1 m2;
    content_eqv:>
               content_equiv m1 m2 ;
    nextblock_eqv:> Mem.nextblock m1 = Mem.nextblock m2 }.

Global Instance Equivalence_mem_equiv:
  Equivalence mem_equiv.
Proof.
  econstructor.
  - intros ?; econstructor; reflexivity.
  - intros ?? H; inversion H; econstructor; symmetry; auto.
  - intros ??? H1 H2. inversion H1; inversion H2.
    econstructor; etransitivity; eauto.
Qed.

Instance Proper_perm_max:
  Proper (Max_equiv ==> eq ==> eq ==> (trieq Max) ==> eq ==> iff) Mem.perm.
Proof.
  proper_iff; proper_intros; subst.
  inversion H2; subst.
  unfold Max_equiv in *.
  unfold Mem.perm in *;
    repeat rewrite_getPerm.
  rewrite <- H; auto.
Qed.
Instance Proper_perm_cur:
  Proper (Cur_equiv ==> eq ==> eq ==> (trieq Cur) ==> eq ==> iff) Mem.perm.
Proof.
  proper_iff; proper_intros; subst.
  inversion H2; subst.
  unfold Cur_equiv in *.
  unfold Mem.perm in *;
    repeat rewrite_getPerm.
  - rewrite <- H; auto.
Qed.

Instance Proper_perm:
  Proper (mem_equiv ==> eq ==> eq ==> eq ==> eq ==> iff) Mem.perm.
Proof.
  proper_iff; proper_intros; subst.
  destruct y2; [rewrite <- (max_eqv _ _ H)| erewrite <- (cur_eqv _ _ H)];
    assumption.
Qed.
Instance Proper_perm_Max:
  Proper (Max_equiv ==> eq ==> eq ==> trieq Max ==> eq ==> iff) Mem.perm.
Proof.
  proper_iff; unfold Mem.perm; proper_intros; subst.
  inversion H2; subst.
  repeat rewrite_getPerm; auto.
  rewrite <- H; assumption.
Qed.

Instance range_perm_mem_equiv:
  Proper (mem_equiv ==> eq ==>  eq ==>  eq ==>  eq ==>  eq ==> iff) Mem.range_perm.
Proof.
  proper_iff; proper_intros; subst.
  unfold Mem.range_perm in *; intros.
  rewrite <- H. eapply H5; auto.
Qed.
Instance range_perm_mem_equiv_Max:
  Proper (Max_equiv ==> eq ==>  eq ==>  eq ==>  trieq Max  ==>  eq ==> iff) Mem.range_perm.
Proof.
  proper_iff; proper_intros; subst.
  inversion H3; subst.
  unfold Mem.range_perm in *; intros.
  rewrite <- H. eapply H5; auto.
Qed.
Instance range_perm_mem_equiv_Cur:
  Proper (Cur_equiv ==> eq ==>  eq ==>  eq ==>  trieq Cur  ==>  eq ==> iff) Mem.range_perm.
Proof.
  proper_iff; proper_intros; subst.
  inversion H3; subst.
  unfold Mem.range_perm in *; intros.
  rewrite <- H. eapply H5; auto.
Qed.

Instance mem_inj_equiv:
  Proper ( eq ==> mem_equiv ==> mem_equiv ==> iff) Mem.mem_inj.
Proof.
  proper_iff. proper_intros; subst.
  econstructor; intros.
  - rewrite <- H1.
    rewrite <- H0 in H3.
    eapply H2; eauto.
  - eapply H2; eauto.
    rewrite H0; eauto.
  - rewrite <- H0 in H3.
    destruct H0; destruct H1.
    unfold content_equiv in *.
    rewrite <- content_eqv0.
    rewrite <- content_eqv1.
    eapply H2; eauto.
Qed.

Instance Proper_nextblock:
  Proper (mem_equiv ==> Logic.eq) Mem.nextblock.
Proof. intros ???. erewrite nextblock_eqv; auto. Qed.

Instance Proper_valid_block:
  Proper (mem_equiv ==> Logic.eq ==> Logic.eq) Mem.valid_block.
Proof.
  intros ??????.
  subst; unfold Mem.valid_block.
  rewrite H; reflexivity.
Qed.

Instance Proper_no_overlap_max_equiv:
  Proper (Logic.eq ==> Max_equiv ==> iff)
         Mem.meminj_no_overlap.
Proof.
  unfold Mem.meminj_no_overlap.
  proper_iff. proper_intros; subst.
  eapply H1; unfold  Mem.perm in *; eauto.
  - repeat rewrite_getPerm.
    rewrite H0; auto.
  - repeat rewrite_getPerm.
    rewrite H0; auto.
Qed.

Instance Proper_no_overlap_mem_equiv:
  Proper (eq ==> mem_equiv ==> iff) Mem.meminj_no_overlap.
Proof.
  proper_iff. proper_intros; subst.
  eapply Proper_no_overlap_max_equiv; eauto.
  symmetry; apply H0.
Qed.

Instance mem_inject_equiv:
  Proper  ( eq ==> mem_equiv ==> mem_equiv ==> iff) Mem.inject.
Proof.
  proper_iff.
  intros ?????  Heqv1 ?? Heqv2 Hinj; subst.
  symmetry in Heqv1, Heqv2.
  econstructor.
  - rewrite Heqv1, Heqv2. eapply Hinj.
  - intros ?.
    rewrite Heqv1. eapply Hinj.
  - intros ???.
    rewrite Heqv2. eapply Hinj.
  - rewrite Heqv1. apply Hinj.
  - intros. eapply Hinj; eauto.
    rewrite <- Heqv1; auto.
  - intros ???????.
    rewrite Heqv2, Heqv1.
    apply Hinj; auto.
Qed.

Instance permMapLt_equiv:
  Proper (access_map_equiv ==> access_map_equiv ==> iff)
         permMapLt.
Proof. proper_iff. intros ?????? HH ??; rewrite <- H, <- H0; auto. Qed.

Lemma getCur_restr:
  forall perm m (Hlt: permMapLt perm (getMaxPerm m)),
    access_map_equiv
      (getCurPerm (restrPermMap Hlt))  perm.
Proof.
  unfold getCurPerm, access_map_equiv.
  intros; simpl.
  rewrite PMap.gmap.
  Import FunctionalExtensionality.
  extensionality ofs; simpl.
  unfold PMap.get; simpl.
  rewrite PTree.gmap.
  destruct ((snd (Mem.mem_access m)) ! b) eqn:HH.
  - reflexivity.
  - simpl.
    specialize (Hlt b ofs).
    rewrite getMaxPerm_correct in Hlt;
      unfold permission_at in Hlt.
    unfold PMap.get in Hlt.
    rewrite HH in Hlt.
    rewrite Clight_bounds.Mem_canonical_useful in Hlt.
    simpl in Hlt.
    destruct ( (snd perm) ! b).
    + destruct (o ofs); first [contradiction | auto].
    + destruct (fst perm ofs); first [contradiction | auto].
Qed.
Lemma getMax_restr:
  forall perm m (Hlt: permMapLt perm (getMaxPerm m)),
    access_map_equiv
      (getMaxPerm (restrPermMap Hlt))  (getMaxPerm m) .
Proof. intros; intros ?; eapply getMax_restr. Qed.

Lemma restrPermMap_equiv:
  forall perm1 perm2 m1 m2
         Hlt1 Hlt2,
    mem_equiv m1 m2 ->
    access_map_equiv perm1 perm2 ->
    mem_equiv (@restrPermMap perm1 m1 Hlt1)
              (@restrPermMap perm2 m2 Hlt2).
Proof.
  intros. inversion H.
  econstructor.
  - unfold Cur_equiv; do 2 rewrite getCur_restr; auto.
  - unfold Max_equiv; intros ?.
    do 2 rewrite getMax_restr; auto.
  - simpl; eauto.
  - simpl. auto.
Qed.
Lemma restrPermMap_idempotent:
  forall perm0 perm1 m1 Hlt0 Hlt1 Hlt2,
    mem_equiv (@restrPermMap perm1 m1 Hlt1)
              (@restrPermMap perm1 (@restrPermMap perm0 m1 Hlt0) Hlt2).
Proof.
  intros; econstructor.
  - unfold Cur_equiv; do 2 rewrite getCur_restr; reflexivity.
  - unfold Max_equiv; intros ?.
    do 3 rewrite getMax_restr; auto.
  - simpl; eauto.
    etransitivity; try eapply restr_content_equiv.
    etransitivity; try eapply (restr_content_equiv Hlt2).
  - simpl; eapply nextblock_eqv; reflexivity.
Qed.
Arguments restrPermMap_idempotent {_ _ _} _ _.

Lemma useful_permMapLt_trans:
  forall {perm m perm0} Hlt0,
    permMapLt perm (getMaxPerm m) ->
    permMapLt perm (getMaxPerm (@restrPermMap perm0 m Hlt0)).

Proof. unfold permMapLt; intros. rewrite getMax_restr; eauto. Qed.

Lemma restrPermMap_idempotent':
  forall perm0 perm1 m1 Hlt0 Hlt1 ,
    mem_equiv (@restrPermMap perm1 m1 Hlt1)
              (@restrPermMap perm1 (@restrPermMap perm0 m1 Hlt0)
                             (useful_permMapLt_trans Hlt0 Hlt1)).
Proof. intros; eapply restrPermMap_idempotent. Qed.

Lemma restr_proof_irr_equiv:
  forall m perm Hlt Hlt',
    mem_equiv (@restrPermMap m perm Hlt) (@restrPermMap m perm Hlt').
  intros. replace Hlt with Hlt'.
  - reflexivity.
  - apply Axioms.proof_irr.
Qed.

Instance valid_access_Proper:
  Proper (mem_equiv  ==> Logic.eq ==> Logic.eq  ==>
                     Logic.eq ==> Logic.eq ==> iff) Mem.valid_access.
Proof.
  unfold Mem.valid_access.
  setoid_help.proper_iff; setoid_help.proper_intros; subst.
  rewrite <- H; auto.
Qed.
Instance load_Proper:
  Proper (Logic.eq ==> mem_equiv ==> Logic.eq ==> Logic.eq  ==> Logic.eq) Mem.load.
Proof.
  setoid_help.proper_intros; subst.
  Transparent Mem.load.
  unfold Mem.load.
  destruct (Mem.valid_access_dec x0 y y1 y2 Readable) as [v|v];
    rewrite H0 in v;
    destruct (Mem.valid_access_dec y0 y y1 y2 Readable);
    (* solve the impossible ones*)
    try solve[contradict v; auto].
  - destruct  H0. do 2 f_equal.
    clear - content_eqv0 y1 y2.
    revert y2 y1.
    induction (size_chunk_nat y); auto; intros.
    simpl.  f_equal; eauto.
  - reflexivity.
Qed.

Instance loadv_Proper:
  Proper (Logic.eq ==> mem_equiv ==> Logic.eq  ==> Logic.eq) Mem.loadv.
Proof. intros ??? ??? ???; subst.
       destruct y1; auto.
       eapply load_Proper; auto.
Qed.

Lemma cur_equiv_restr_mem_equiv:
  forall (m:mem) p
    (Hlt: permMapLt p (getMaxPerm m)),
    access_map_equiv p (getCurPerm m) ->
    mem_equiv (restrPermMap Hlt) m.
Proof.
  intros. constructor; eauto.
  - unfold Cur_equiv. etransitivity; eauto.
    eapply getCur_restr.
  - eapply getMax_restr.
  - eapply restr_content_equiv.
Qed.
Lemma mem_access_max_equiv:
  forall m1 m2, Mem.mem_access m1 =  Mem.mem_access m2 ->
           Max_equiv m1 m2.
Proof. intros ** ?; unfold getMaxPerm; simpl.
       rewrite H; reflexivity.
Qed.
Lemma mem_access_cur_equiv:
  forall m1 m2, Mem.mem_access m1 = Mem.mem_access m2 ->
           Cur_equiv m1 m2.
Proof. intros ** ?; unfold getCurPerm; simpl.
       rewrite H; reflexivity.
Qed.

Lemma Cur_equiv_restr:
  forall p1 p2 m1 m2 Hlt1 Hlt2,
    access_map_equiv p1 p2 ->
    Cur_equiv (@restrPermMap p1 m1 Hlt1)
              (@restrPermMap p2 m2 Hlt2).
Proof. unfold Cur_equiv; intros.
       do 2 rewrite getCur_restr; assumption. Qed.
Lemma Max_equiv_restr:
  forall p1 p2 m1 m2 Hlt1 Hlt2,
    Max_equiv m1 m2 ->
    Max_equiv (@restrPermMap p1 m1 Hlt1)
              (@restrPermMap p2 m2 Hlt2).
Proof. unfold Max_equiv; intros.
       do 2 rewrite getMax_restr; assumption. Qed.

Lemma store_max_eq:
  forall cnk  m b ofs v m',
    Mem.store cnk  m b ofs v = Some m' ->
    getMaxPerm m = getMaxPerm m'.
Proof.
  intros.
  Transparent Mem.store.
  unfold Mem.store in H; simpl in *.
  destruct (Mem.valid_access_dec m cnk b ofs Writable); try discriminate.
  inversion H. reflexivity.
Qed.
Lemma store_max_equiv:
  forall sz m b ofs v m',
    Mem.store sz m b ofs v = Some m' ->
    Max_equiv m m'.
Proof.
  intros. intros ?.
  erewrite store_max_eq; eauto.
Qed.


(* In this file we introduce a reentrancy problem in the Congress
contract described in Congress.v. We then use one of our blockchain
implementations (the depth first local blockchain) to prove that this
version can send out too many transactions. This is done by
constructing a contract that actually exploits this version of the
Congress and then just asking Coq to compute. *)

From Coq Require Import ZArith.
From Coq Require Import Psatz.
From Coq Require Import List.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import BoundedN.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Execution.Test Require LocalBlockchain.
From ConCert.Utils Require Import Extras.
From ConCert.Utils Require Import RecordUpdate.

Import ListNotations.

Section CongressBuggy.
  Context {BaseTypes : ChainBase}.

  Local Open Scope Z.
  Set Primitive Projections.
  Set Nonrecursive Elimination Schemes.

  Definition ProposalId := nat.

  Inductive CongressAction :=
  | cact_transfer (to : Address) (amount : Amount)
  | cact_call (to : Address) (amount : Amount) (msg : SerializedValue).

  Record Proposal :=
    build_proposal {
      actions : list CongressAction;
      votes : FMap Address Z;
      vote_result : Z;
      proposed_in : nat;
    }.

  MetaCoq Run (make_setters Proposal).

  Record Rules :=
    build_rules {
      min_vote_count_permille : Z;
      margin_needed_permille : Z;
      debating_period_in_blocks : nat;
    }.

  Record Setup :=
    build_setup {
      setup_rules : Rules;
    }.

  Definition Error : Type := nat.
  Definition default_error : Error := 1%nat.

  Inductive Msg :=
  | transfer_ownership : Address -> Msg
  | change_rules : Rules -> Msg
  | add_member : Address -> Msg
  | remove_member : Address -> Msg
  | create_proposal : list CongressAction -> Msg
  | vote_for_proposal : ProposalId -> Msg
  | vote_against_proposal : ProposalId -> Msg
  | retract_vote : ProposalId -> Msg
  | finish_proposal : ProposalId -> Msg
  | finish_proposal_remove : ProposalId -> Msg.

  Record State :=
    build_state {
      owner : Address;
      state_rules : Rules;
      proposals : FMap nat Proposal;
      next_proposal_id : ProposalId;
      members : FMap Address unit;
    }.

  (* begin hide *)
  MetaCoq Run (make_setters State).
  (* end hide *)

  Section Serialization.

    Global Instance rules_serializable : Serializable Rules :=
      Derive Serializable Rules_rect <build_rules>.

    Global Instance setup_serializable : Serializable Setup :=
      Derive Serializable Setup_rect <build_setup>.

    Global Instance congress_action_serializable : Serializable CongressAction :=
      Derive Serializable CongressAction_rect <cact_transfer, cact_call>.

    Global Instance proposal_serializable : Serializable Proposal :=
      Derive Serializable Proposal_rect <build_proposal>.

    Global Instance msg_serializable : Serializable Msg :=
      Derive Serializable Msg_rect <transfer_ownership, change_rules, add_member, remove_member,
                                    create_proposal, vote_for_proposal, vote_against_proposal,
                                    retract_vote, finish_proposal, finish_proposal_remove>.

    Global Instance state_serializable : Serializable State :=
      Derive Serializable State_rect <build_state>.

  End Serialization.

  Definition validate_rules (rules : Rules) : bool :=
    (rules.(min_vote_count_permille) >=? 0)
    && (rules.(min_vote_count_permille) <=? 1000)
    && (rules.(margin_needed_permille) >=? 0)
    && (rules.(margin_needed_permille) <=? 1000)
    && (0 <=? rules.(debating_period_in_blocks))%nat.

  Definition init (chain : Chain)
                  (ctx : ContractCallContext)
                  (setup : Setup)
                  : result State Error :=
    if validate_rules setup.(setup_rules) then
      Ok {|
        owner := ctx.(ctx_from);
        state_rules := setup.(setup_rules);
        proposals := FMap.empty;
        next_proposal_id := 1%nat;
        members := FMap.empty
      |}
    else
      Err default_error.

  Definition add_proposal (actions : list CongressAction)
                          (chain : Chain)
                          (state : State)
                          : State :=
    let id := state.(next_proposal_id) in
    let slot_num := chain.(current_slot) in
    let proposal := {| actions := actions;
                      votes := FMap.empty;
                      vote_result := 0;
                      proposed_in := slot_num |} in
    state<|proposals ::= FMap.add id proposal|>
        <|next_proposal_id ::= S|>.

  Definition vote_on_proposal (voter : Address)
                              (pid : ProposalId)
                              (vote : Z)
                              (state : State)
                              : result State Error :=
    do proposal <- result_of_option (FMap.find pid state.(proposals)) default_error;
    let old_vote := match FMap.find voter proposal.(votes) with
                  | Some old => old
                  | None => 0
                  end in
    let new_votes := FMap.add voter vote proposal.(votes) in
    let new_vote_result := proposal.(vote_result) - old_vote + vote in
    let new_proposal :=
        proposal<|votes := new_votes|>
                <|vote_result := new_vote_result|> in
    Ok (state<|proposals ::= FMap.add pid new_proposal|>).

  Definition do_retract_vote (voter : Address)
                             (pid : ProposalId)
                             (state : State)
                             : result State Error :=
    do proposal <- result_of_option (FMap.find pid state.(proposals)) default_error;
    do old_vote <- result_of_option (FMap.find voter proposal.(votes)) default_error;
    let new_votes := FMap.remove voter proposal.(votes) in
    let new_vote_result := proposal.(vote_result) - old_vote in
    let new_proposal :=
        proposal<|votes := new_votes|>
                <|vote_result := new_vote_result|> in
    Ok (state<|proposals ::= FMap.add pid new_proposal|>).

  Definition congress_action_to_chain_action (act : CongressAction) : ActionBody :=
    match act with
    | cact_transfer to amt => act_transfer to amt
    | cact_call to amt msg => act_call to amt msg
    end.

  Definition proposal_passed (proposal : Proposal)
                             (state : State)
                             : bool :=
    let rules := state.(state_rules) in
    let total_votes_for_proposal := Z.of_nat (FMap.size proposal.(votes)) in
    let total_members := Z.of_nat (FMap.size state.(members)) in
    let aye_votes := (proposal.(vote_result) + total_votes_for_proposal) / 2 in
    let vote_count_permille := total_votes_for_proposal * 1000 / total_members in
    let aye_permille := aye_votes * 1000 / total_votes_for_proposal in
    let enough_voters := vote_count_permille >=? rules.(min_vote_count_permille) in
    let enough_ayes := aye_permille >=? rules.(margin_needed_permille) in
    enough_voters && enough_ayes.

  Definition do_finish_proposal (ctx : ContractCallContext)
                                (pid : ProposalId)
                                (state : State)
                                (chain : Chain)
                                : result (State * list ActionBody) Error :=
    do proposal <- result_of_option (FMap.find pid state.(proposals)) default_error;
    let rules := state.(state_rules) in
    let debate_end := (proposal.(proposed_in) + rules.(debating_period_in_blocks))%nat in
    let cur_slot := chain.(current_slot) in
    if (cur_slot <? debate_end)%nat then
      Err default_error
    else
      let response_acts :=
          if proposal_passed proposal state
          then proposal.(actions)
          else [] in
      let response_chain_acts := map congress_action_to_chain_action response_acts in
      let self_call_msg := serialize (finish_proposal_remove pid) in
      let self_call := act_call (ctx_contract_address ctx) 0 self_call_msg in
        Ok (state, response_chain_acts ++ [self_call]).

  Definition receive (chain : Chain)
                     (ctx : ContractCallContext)
                     (state : State)
                     (maybe_msg : option Msg)
                     : result (State * list ActionBody) Error :=
    let sender := ctx.(ctx_from) in
    let is_from_owner := (sender =? state.(owner))%address in
    let is_from_member := FMap.mem sender state.(members) in
    match maybe_msg, is_from_owner, is_from_member with
    | Some (transfer_ownership new_owner), true, _ =>
      Ok (state<|owner := new_owner|>, [])

    | Some (change_rules new_rules), true, _ =>
      if validate_rules new_rules then
        Ok (state<|state_rules := new_rules|>, [])
      else
        Err default_error

    | Some (add_member new_member), true, _ =>
      Ok (state<|members ::= FMap.add new_member tt|>, [])

    | Some (remove_member old_member), true, _ =>
      Ok (state<|members ::= FMap.remove old_member|>, [])

    | Some (create_proposal actions), _, true =>
      Ok (add_proposal actions chain state, [])

    | Some (vote_for_proposal pid), _, true =>
      without_actions (vote_on_proposal sender pid 1 state)

    | Some (vote_against_proposal pid), _, true =>
      without_actions (vote_on_proposal sender pid (-1) state)

    | Some (retract_vote pid), _, true =>
      without_actions (do_retract_vote sender pid state)

    | Some (finish_proposal pid), _, _ =>
      do_finish_proposal ctx pid state chain

    | Some (finish_proposal_remove pid), _, _ =>
      if (sender =? ctx_contract_address ctx)%address then
        Ok (state<|proposals ::= FMap.remove pid|>, [])
      else
        Err default_error

    | _, _, _ =>
          Err default_error
    end.

  Definition contract : Contract Setup Msg State Error :=
    build_contract init receive.

End CongressBuggy.
(* We will show that this contract is buggy and does not satisfy the
   property we proved for the other version of the Congress. We do
   this with a counterexample, where we exploit reentrancy similar to
   the DAO hack. We first define a contract that does this
   exploitation. *)

Section ExploitContract.
  Context {Base : ChainBase}.

  Definition ExploitSetup := unit.
  Definition ExploitState := nat. (* how many times have we called ourselves *)
  Definition ExploitMsg := unit.
  Definition ExploitError := nat.
  Definition exploit_init (chain : Chain)
                          (ctx : ContractCallContext)
                          (setup : ExploitSetup)
                          : result ExploitState ExploitError :=
    Ok 0.

  Definition exploit_receive
              (chain : Chain)
              (ctx : ContractCallContext)
              (state : ExploitState)
              (msg : option ExploitMsg)
              : result (ExploitState * list ActionBody) ExploitError :=
    if 25 <? state then
      Ok (state, [])
    else
      let again := finish_proposal 1 in
      Ok (S state, [act_call (ctx_from ctx) 0 (serialize again)]).

  Definition exploit_contract : Contract ExploitSetup ExploitMsg ExploitState ExploitError :=
    build_contract exploit_init exploit_receive.

End ExploitContract.

(* With this defined we can give the counterexample with relative ease. We use a
concrete implementation of a blockchain for this. *)
Section Theories.
  Import LocalBlockchain.

  Let AddrSize := (2^128)%N.
  Instance Base : ChainBase := LocalChainBase AddrSize.
  Instance Builder : ChainBuilderType := LocalChainBuilderImpl AddrSize true.

  Open Scope nat.
  Definition exploit_example : option (Address * Builder) :=
    let chain := builder_initial in
    let creator := BoundedN.of_Z_const AddrSize 10 in
    let add_block (chain : Builder) act_bodies :=
        let next_header :=
            {| block_height := S (chain_height chain);
               block_slot := S (current_slot chain);
               block_finalized_height := finalized_height chain;
               block_creator := creator;
               block_reward := 50; |} in
        let acts := map (build_act creator creator) act_bodies in
        option_of_result (builder_add_block chain next_header acts) in
    (* Get some money on the creator *)
    do chain <- add_block chain [];
    (* Deploy congress and exploit contracts *)
    let rules :=
        {| min_vote_count_permille := 200;
           margin_needed_permille := 501;
           debating_period_in_blocks := 0; |} in
    let dep_congress := create_deployment 50 contract {| setup_rules := rules |} in
    let dep_exploit := create_deployment 0 exploit_contract tt in
    do chain <- add_block chain [dep_congress; dep_exploit];
    let contracts := map fst (FMap.elements (lc_contracts (lcb_lc chain))) in
    let exploit := nth 0 contracts creator in
    let congress := nth 1 contracts creator in
    (* Add creator to congress, create a proposal to transfer *)
    (* some money to exploit contract, vote for the proposal, and execute the proposal *)
    let add_creator := add_member creator in
    let create_proposal := create_proposal [cact_transfer exploit 1] in
    let vote_proposal := vote_for_proposal 1 in
    let exec_proposal := finish_proposal 1 in
    let act_bodies :=
        map (fun m => act_call congress 0 (serialize m))
            [add_creator; create_proposal; vote_proposal; exec_proposal] in
    do chain <- add_block chain act_bodies;
    Some (congress, chain).

  Definition unpacked_exploit_example : Address * Builder :=
    unpack_option exploit_example.

  Definition num_acts_created_in_proposals (calls : list (ContractCallInfo Msg)) :=
    let count call :=
        match call_msg call with
        | Some (create_proposal acts) => length acts
        | _ => 0
        end in
    sumnat count calls.

  (* Now we prove that this version of the contract is buggy, i.e. it does not satisfy the
     property we proved for the other version of the Congress. We filter out transactions
     from the congress to the congress as we have those now (due to self calls). *)
  Theorem congress_buggy :
    exists bstate caddr (trace : ChainTrace empty_state bstate)
           (inc_calls : list (ContractCallInfo Msg)),
      env_contracts bstate caddr = Some (contract : WeakContract) /\
      incoming_calls Msg trace caddr = Some inc_calls /\
      length (filter (fun tx => negb (tx_to tx =? caddr)%address)
                     (outgoing_txs trace caddr)) >
      num_acts_created_in_proposals inc_calls.
  Proof.
    exists (build_chain_state (snd unpacked_exploit_example) []).
    exists (fst unpacked_exploit_example).
    exists (builder_trace (snd unpacked_exploit_example)).
    set (inc_calls := unpack_option
                        (incoming_calls Msg
                                        (builder_trace (snd unpacked_exploit_example))
                                        (fst unpacked_exploit_example))).
    vm_compute in inc_calls.
    exists inc_calls.
    split; [|split].
    - reflexivity.
    - reflexivity.
    - vm_compute.
      clear inc_calls.
      lia.
  Qed.
End Theories.