Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Key_Properties
        Subtyping_inversion
        Deterministic
        Typing.

Require Import List. Import ListNotations.
Require Import Arith Lia.

(* requires sub Top A -> toplike A *)
Lemma TypedReduce_trans : forall v v1 v2 A B,
    value v -> TypedReduce v A v1 -> TypedReduce v1 B v2 -> TypedReduce v B v2.
Proof.
  introv Val Red1 Red2.
  lets Lc: value_lc Val.
  gen B v2.
  induction* Red1;
    introv Red2.
  - (* v1 = v_top *)
    remember e_top.
    induction* Red2;
      try solve [inversion Heqe].
  - (* v1 = abs e B *)
    inductions Red2;
      try solve [constructor*].
    apply TReduce_arrow; auto.
    auto_sub.
  - (* v = v1,,v2 v1'~->v0 *)
    inverts* Val.
    inverts* Lc.
    induction Red2;
      eauto.
  - (* v = v1,,v2 v2'~->v0 *)
    inverts* Val.
    inverts* Lc.
    induction Red2;
      eauto.
  - (* and *)
    gen v0.
    induction B0; introv Red2;
      try solve [inverts* Red2];
      try solve [inversion Ord].
Qed.

Lemma consistent_afterTR : forall v A B C v1 v2, value v -> Typing nil v Inf C -> TypedReduce v A v1 -> TypedReduce v B v2 -> consistencySpec v1 v2.
Proof.
  intros v A B C v1 v2 Val Typ Red1 Red2.
  unfold consistencySpec.
  intros D v1' v2' Red1' Red2'.
  forwards*: TypedReduce_trans Red1 Red1'.
  forwards*: TypedReduce_trans Red2 Red2'.
  forwards*: TypedReduce_unique H H0.
Qed.

Lemma TypedReduce_prv_value: forall v A v',
    value v -> TypedReduce v A v' -> value v'.
Proof.
  intros v A v' Val Red.
  induction* Red.
  -
    apply value_anno.
    inverts* H.
  - inverts* Val.
  - inverts* Val.
Qed.

#[export]
Hint Immediate TypedReduce_prv_value : core.

Lemma TypedReduce_preservation: forall v v' A,
    value v -> TypedReduce v A v'-> Typing nil v Chk A
    -> exists B, Typing nil v' Inf B /\ subsub B A.
Proof with auto.
  introv Val Red Typ'.
  lets (C & Typ & Sub): Typing_chk2inf Typ'.
  clear Typ' Sub. gen C.
  induction Red; intros;
    try solve [inverts* Typ].
  - (* absv *)
    inverts Typ.
    exists*. split.
    eapply Typ_abs.
    intros.
    applys~ Typing_chk_sub.
    auto_sub.
  - (* mergel *)
    inverts Val.
    inverts Typ;
      forwards*: IHRed.
  - (* merger *)
    inverts Val.
    inverts Typ;
      forwards*: IHRed.
  - (* merge_and *)
    forwards* (?&?&?): IHRed1 Val Typ.
    forwards* (?&?&?): IHRed2 Val Typ.
    lets Con: consistent_afterTR Val Typ Red1 Red2.
    exists. split.
    applys* Typ_mergev.
    eauto.
Qed.

Lemma preservation_subsub : forall e e' dir A,
    Typing nil e dir A ->
    step e e' ->
    exists C, Typing nil e' dir C /\ subsub C A.
Proof.
  introv Typ. gen e'.
  lets Typ' : Typ.
  inductions Typ;
    try solve [introv J; inverts* J]; introv J.
  - (* typing_app *)
    inverts* J.
    + (* top *)
      inverts Typ1. inverts* H.
    + (* e_absv A0 . e : A0->B0  v *)
      inverts Typ1. inverts H.
      exists B. split*.
      constructor.
      forwards* (?&Typ_v'&Sub): TypedReduce_preservation H5.
      pick_fresh y.
      forwards~ Typ_chk: H8 y.
      rewrite_env(nil++[(y,A)]++nil) in Typ_chk.
      forwards~ (?&?&?): Typing_subst_2 Typ_chk Typ_v'.
      eapply Typing_chk_sub.
      rewrite* (@subst_exp_intro y).
      apply~ subsub2sub.
    + forwards* (?&?&?): IHTyp1.
      forwards* (?&C'&?&?&?): arrTyp_subsub H H1.
      exists C'. split*.
      applys* Typ_app.
      applys~ Typing_chk_sub Typ2.
    +
      forwards* (?&?&?): IHTyp2.
      apply subsub2sub in H1.
      forwards*: Typing_chk_sub H0 H1.
  - (* Typ_merge *)
    inverts* J.
    + forwards~ (?&?&?): IHTyp1 H4.
      exists (t_and x B). split*.
      apply~ Typ_merge.
      forwards*: subsub_disjointSpec_l H1 H.
    + forwards~ (?&?&?): IHTyp2 H4.
      exists (t_and A x). split*.
      apply~ Typ_merge.
      forwards*: subsub_disjointSpec_r H1 H.
  - (* typing_anno *)
    inverts J.
    + forwards*: TypedReduce_prv_value e e'.
      inverts* Typ'.
      forwards*: TypedReduce_preservation H3.
    + forwards* (?&?&?): IHTyp.
      exists A. split*.
      apply Typ_anno.
      apply subsub2sub in H0.
      forwards*: Typing_chk_sub H H0.
  - (* typing_fix *)
    inverts J.
    exists A. split*.
    eapply Typ_anno.
    pick_fresh x.
    rewrite* (@subst_exp_intro x).
    forwards~ Typ_chk: H.
    rewrite_env(nil++[(x,A)]++nil) in Typ_chk.
    lets~ (?&?&?): Typing_subst_2 Typ_chk Typ'.
    apply subsub2sub in H2.
    forwards*: Typing_chk_sub H2.
  - (* typing_mergev *)
    inverts J.
    + inverts H0.
      forwards*: step_not_value H5 H6.
    + inverts H0.
      forwards*: step_not_value H7 H6.
  - (* Typ_sub *)
    forwards* (?&?&?): IHTyp.
    exists B. split*.
    apply subsub2sub in H1.
    assert (S: sub x B) by auto_sub.
    forwards*: Typ_sub H0 S.
Qed.

Theorem preservation : forall e e' dir A,
    Typing nil e dir A ->
    step e e' ->
    Typing nil e' Chk A.
Proof.
  intros e e' dir A H H0.
  lets* (?&?&?): preservation_subsub H H0.
  apply subsub2sub in H2.
  destruct dir.
  - sapply* Typ_sub.
  - sapply* Typing_chk_sub.
Qed.

#[export]
Hint Resolve value_lc : core.

(* Progress *)
Lemma TypedReduce_progress: forall v A,
    value v -> Typing [] v Chk A -> exists v', TypedReduce v A v'.
Proof with auto_sub.
  intros v A Val TypC.
  (* convert Chk to Inf & introduce B <: A*)
  lets* (B&Typ&Sub): Typing_chk2inf TypC. clear TypC.
  gen B.
  induction A; intros.
  - (* int *)
    inductions Typ; inverts* Val;
    try solve [inverts Sub; solve_false];
    (* intersection <: ordinary type *)
    try solve [forwards* [?|[?|(?&?&HF)]]: sub_inversion_and_l Sub;
               try solve [forwards* (?&?): IHTyp1];
               try solve [forwards* (?&?): IHTyp2];
               try solve [inverts HF]].
  - (* top *)
    exists. apply~ TReduce_top.
  - (* arrow *)
    destruct (toplike_decidable A2).
    + exists. apply~ TReduce_top.
    + clear IHA1 IHA2.
      inductions Typ; inverts* Val;
    try solve [inverts Sub; solve_false];
    (* intersection <: ordinary type *)
    try solve [forwards* [?|[?|(?&?&HF)]]: sub_inversion_and_l Sub;
               try solve [forwards* (?&?): IHTyp1];
               try solve [forwards* (?&?): IHTyp2];
               try solve [inverts HF]].
      * (* arrow *)
        inverts* Sub.
  - (* and *)
    forwards* (?&?): IHA1...
    forwards* (?&?): IHA2...
Qed.

#[export]
Hint Resolve Typing_regular_1 : core.

Theorem progress : forall e dir A,
    Typing nil e dir A ->
    value e \/ exists e', step e e' .
Proof.
  introv Typ.
  inductions Typ;
    try solve [left*];
    try solve [right*].
  - (* var *)
    invert H0.
  - (* app *)
    right.
    lets* [Val1 | [e1' Red1]]: IHTyp1.
    lets* [Val2 | [e2' Red2]]: IHTyp2.
    inverts* Typ1;
      try solve [ inverts Val1 ]; inverts H.
    + (* e_app (e_absv _ _) v2 *)
      lets* (v2' & Tyr): TypedReduce_progress Typ2.
  - (* merge *)
    destruct~ IHTyp1 as [ Val1 | [t1' Red1]];
      destruct~ IHTyp2 as [ Val2 | [t2' Red2]];
      subst.
    + (* e_merge v1 e2 *)
      inverts* Typ1.
    + (* e_merge e1 v2 *)
      inverts* Typ2.
    + (* e_merge e1 e2 *)
      inverts* Typ2.
  - (* anno *)
    right.
    destruct~ IHTyp as [? | (?&?)].
    + (* value e *)
      lets* (v1' & Tyr) : TypedReduce_progress H.
    + exists*.
  - (* subsumption *)
    destruct~ IHTyp.
Qed.

(* Type Safety *)
Theorem preservation_multi_step : forall e e' dir A,
    Typing nil e dir A ->
    e ->* e' ->
    exists C, Typing nil e' dir C /\ subsub C A.
Proof.
  introv Typ Red.
  gen A. induction* Red.
  intros.
  lets* (?&?&?): preservation_subsub Typ H.
  forwards* (?&?&?): IHRed H0.
  exists x0. split*.
  forwards*: subsub_trans H3 H1.
Qed.

Theorem type_safety : forall e e' dir A,
    Typing nil e dir A ->
    e ->* e' ->
    value e' \/ exists e'', step e' e''.
Proof.
  introv Typ Red. gen A.
  induction Red; intros.
  lets*: progress Typ.
  lets* (?&?&?): preservation_subsub Typ H.
Qed.


(** Code, specifications, proofs for manipulating arrays in kernel memory *)

Require Import ZArith.
Require Import Lia.
Require Import List.
Require Import Utils.
Require Import LibTactics.
Import ListNotations.

Require Import Memory.
Require Import Instr.
Require Import Lattices.
Require Import Concrete.
Require Import CodeGen.
Require Import CodeTriples.
Require Import CodeSpecs.
Require Import Concrete.
Require Import ConcreteExecutions.
Require Import ConcreteMachine.
Require Import Coq.Arith.Compare_dec.

(* Everything to do with machine execution and triples has to be parameterized over SysTable. *)
Section with_cblock.

Variable cblock : block privilege.
Hypothesis stamp_cblock : Mem.stamp cblock = Kernel.
Variable table : CSysTable.

Local Notation val := (val privilege).
Local Notation Atom := (Atom val privilege).
Local Notation memory := (Mem.t Atom privilege).
Local Notation PcAtom := (PcAtom val).
Local Notation block := (block privilege).

Fixpoint narrow (n : nat) (A B : Type) : Type :=
  match n with
    | O => B
    | S n' => A -> narrow n' A B
  end.

Fixpoint nexists {n : nat} {A : Type}
                 (P : narrow n A Prop) : Prop :=
  match n return narrow n A Prop -> Prop with
    | O => fun P => P
    | S n' => fun P => exists a, nexists (P a)
  end P.

Fixpoint stk_env_aux
           (e : list val) (s0 : list CStkElmt)
           (k : list CStkElmt -> Prop) : narrow (length e) val Prop :=
  match e with
    | nil => k s0
    | v :: e' => fun t => stk_env_aux e' s0 (fun r => k ((v,t):::r))
  end.

Definition stk_env (s : list CStkElmt) (e : list val)
                   (s0 : list CStkElmt) : Prop :=
  Eval compute in
    nexists (stk_env_aux e s0 (fun r => s = r)).

Ltac apply_wp :=
  try unfold pop, nop, push, dup, swap, sub, genEq;
  try eapply add_spec;
  try eapply sub_spec;
  try eapply genEq_spec;
  try eapply dup_spec;
  try eapply swap_spec;
  try eapply push_spec;
  try eapply pop_spec;
  try eapply PushCachePtr_spec;
  try eapply alloc_spec;
  try eapply load_spec;
  try eapply store_spec;
  try eapply unpack_spec;
  try eapply pack_spec;
  try eapply getoff_spec;
  simpl.

Ltac build_vc wptac :=
  let awp := (try apply_wp; try wptac) in
  try (eapply HT_compose_flip; [(build_vc wptac; awp)| (awp; eapply HT_strengthen_premise; awp)]).

(*
Ltac apply_wp :=
  try unfold pop, nop, push, dup, swap;
  match goal with
  | |- HT _ _ [Store] _ _ => eapply store_spec
  | |- HT _ _ [Add] _ _  => eapply add_spec
  | |- HT _ _ [Dup ?N] _ _ => eapply dup_spec
  | |- HT _ _ [Swap ?N] _ _ => eapply swap_spec
  | |- HT _ _ [Load] _ _ => eapply load_spec
  | |- HT _ _ [Push ?N] _ _ => eapply push_spec
  | |- HT _ _ [Pop] _ _ => eapply pop_spec
  end;
  simpl.

Ltac build_vc wptac :=
  let awp := (try apply_wp; try wptac) in
  try (eapply HT_compose_flip; [(build_vc wptac; awp)| (awp; eapply HT_strengthen_premise; awp)]).
*)

(* This version doesn't progress past introductions, which makes it useful when
   we need to do some manual work after an introduction but before doing an eexists *)
Ltac split_vc' :=
  (try subst; simpl;
   match goal with
   | H: exists X,_ |- _ => (destruct H; split_vc')
   | H: ?P /\ ?Q |- _ => (destruct H; split_vc')
   | |- exists X, _ => (eexists; split_vc')
   | |- ?P /\ ?Q => (split; [(eauto; try (zify; lia);fail) | split_vc'])
   | _ => (eauto; try (zify; lia))
   end).

(* This version is more aggressive. *)
Ltac split_vc :=
  (try subst; simpl;
   match goal with
   | H: exists X,_ |- _ => (destruct H; split_vc)
   | H: ?P /\ ?Q |- _ => (destruct H; split_vc)
   | |- forall P, _ => (intro; try subst; split_vc)
   | |- exists X, _ => (eexists; split_vc)
   | |- ?P /\ ?Q => (split; [(eauto; try (zify; lia);fail) | split_vc])
   | _ => (eauto; try (zify; lia))
   end).

Section with_hints.  (* Limit hints to this section. *)

(* These are intended to work with split_vc. *)
Hint Resolve extends_refl : core.
Hint Resolve extends_trans : core.
Hint Resolve extends_valid_address : core.
Hint Resolve extends_update : core.

(* Memory copy.  *)

(* Initial stack:  count :: dst0 :: src0 :: _
   Final stack:    0 :: dst0 :: src0 :: _
   Side Effects: copies (src0,src0+count] to (dst0,dst0+count]  (provided these regions are disjoint) *)

Definition copy :=
  genFor ([Dup 2] ++ (* src0 :: count :: dst0 :: src0 :: _ *)
          [Dup 1] ++ (* count :: src0 :: count :: dst0 :: src0 :: _ *)
          [Add] ++   (* src0+count :: count :: dst0 :: src0 :: _ *)
          [Load] ++  (* mem[src0+count] :: count :: dst0 :: src0 :: _ *)
          [Dup 2] ++ (* dst0 :: mem[src0+count] :: count :: dst0 :: src0 :: _ *)
          [Dup 2] ++ (* count :: dst0 :: mem[src0+count] :: count :: dst0 :: src0 :: _ *)
          [Add] ++   (* dst0+count :: mem[src0+count] :: count :: dst0 :: src0 :: _ *)
          [Store]).

(* The loop invariant for copy. *)
Definition Icopy (sz cnt:Z) bdst odst bsrc osrc (m0 : memory) s0 :=
  fun m s =>
    exists t2 t3,
      s = (Vptr (bdst, odst),t2):::(Vptr (bsrc, osrc),t3):::s0 /\
      (cnt <= sz) /\
      (forall z, osrc < z <= osrc+cnt -> valid_address (bsrc, z) m) /\
      (forall z, odst < z <= odst+cnt -> valid_address (bdst, z) m) /\
      (bdst <> bsrc) /\
      (Mem.stamp bdst = Kernel) /\
      (Mem.stamp bsrc = Kernel) /\
      (forall z, cnt < z <= sz -> load (bsrc,osrc+z) m = load (bdst,odst+z) m) /\
      (forall z, ~ (odst+cnt < z <= odst+sz) -> load (bdst,z) m = load (bdst,z) m0) /\
      (forall b, b <> bdst -> Mem.get_frame m b = Mem.get_frame m0 b).

Lemma copy_spec : forall (Q : memory -> stack -> Prop),
  HT cblock table copy
  (fun m s => exists sz bdst odst bsrc osrc s0 t1 t2 t3,
                0 <= sz /\
                s = (Vint sz,t1):::(Vptr (bdst,odst),t2):::(Vptr (bsrc,osrc),t3):::s0 /\
                (forall z, osrc < z <= osrc+sz -> valid_address (bsrc,z) m) /\
                (forall z, odst < z <= odst+sz -> valid_address (bdst,z) m) /\
                (bdst <> bsrc) /\
                Mem.stamp bdst = Kernel /\
                Mem.stamp bsrc = Kernel /\
                (forall m1 t1' t2' t3',
                   (forall z, 0 < z <= sz -> load (bsrc,osrc+z) m1 = load (bdst,odst+z) m1) /\
                   (forall z, ~ (odst < z <= odst+sz) -> load (bdst,z) m1 = load (bdst,z) m) /\
                   (forall b, b <> bdst -> Mem.get_frame m1 b = Mem.get_frame m b) ->
                   Q m1 ((Vint 0,t1'):::(Vptr (bdst,odst),t2'):::(Vptr (bsrc,osrc),t3'):::s0)))
  Q.
Proof.
  intros. unfold copy.
  eapply HT_strengthen_premise with
  (fun m s => exists sz bdst odst bsrc osrc s0 m0 t1 t2 t3,
                0 <= sz /\
                m = m0 /\
                s = (Vint sz,t1):::(Vptr (bdst,odst),t2):::(Vptr (bsrc,osrc),t3):::s0 /\
                (forall z, osrc < z <= osrc+sz -> valid_address (bsrc,z) m) /\
                (forall z, odst < z <= odst+sz -> valid_address (bdst,z) m) /\
                (bdst <> bsrc) /\
                Mem.stamp bdst = Kernel /\
                Mem.stamp bsrc = Kernel /\
                (forall m1 t1' t2' t3',
                   (forall z, 0 < z <= sz -> load (bsrc,osrc+z) m1 = load (bdst,odst+z) m1) /\
                   (forall z, ~ (odst < z <= odst+sz) -> load (bdst,z) m1 = load (bdst,z) m) /\
                   (forall b, b <> bdst -> Mem.get_frame m1 b = Mem.get_frame m b) ->
                   Q m1 ((Vint 0,t1'):::(Vptr (bdst,odst),t2'):::(Vptr (bsrc,osrc),t3'):::s0)));
    [|solve [split_vc]].
  eapply HT_forall_exists. intro sz.
  eapply HT_forall_exists. intro bdst.
  eapply HT_forall_exists. intro odst.
  eapply HT_forall_exists. intro bsrc.
  eapply HT_forall_exists. intro osrc.
  eapply HT_forall_exists. intro s0.
  eapply HT_forall_exists. intro m0.
  eapply HT_forall_exists. intro t1.
  eapply HT_forall_exists. intro t2.
  eapply HT_forall_exists. intro t3.
  eapply HT_fold_constant_premise; intro.
  eapply HT_strengthen_premise.
  { eapply genFor_spec
      with (I := fun (Q : _ -> _ -> Prop) m s i =>
                   Icopy sz i bdst odst bsrc osrc m0 s0 m s /\
                   forall m' s' ti',
                     Icopy sz 0 bdst odst bsrc osrc m0 s0 m' s' ->
                     Q m' ((Vint 0, ti') ::: s')).
    { intros i POS.
      eexists. split.
      - build_vc idtac.
      - intros m s t (INV & END).
        unfold Icopy in *.
        destruct INV as (t5 & t6 & Hs & ? & VALIDSRC & VALIDDST & ? & ? & ? & COPY & REST & ?).
        subst.
        exploit (VALIDSRC (i + osrc)); try lia. intros [val Hval].
        exploit (VALIDDST (i + odst)); try lia. intros [val' Hval'].
        eapply load_some_store_some in Hval'. destruct Hval' as [m' Hm'].
        split_vc.
        split; [|split; eauto]; eauto.
        split_vc.
        split.
        { split_vc.
          repeat split; eauto; try lia.
          + intros.
            eapply valid_address_upd; eauto.
            eapply VALIDSRC. lia.
          + intros.
            eapply valid_address_upd; eauto.
            apply VALIDDST. lia.
          + intros.
            destruct (Z.eq_dec i z) as [ZEQ | ZNEQ].
            * subst.
              replace (odst + z) with (z + odst) by lia.
              erewrite (load_store_new Hm').
              rewrite <- Hval.
              replace (osrc + z) with (z + osrc) by ring.
              eapply load_store_old; eauto.
              congruence.
            * do 2 (erewrite (load_store_old Hm'); eauto; try congruence).
              2: (intros contra; inversion contra; lia).
              eapply COPY. lia.
          + intros.
            erewrite (load_store_old Hm'); eauto; try congruence.
            2: (intros contra; inversion contra; lia).
            apply REST. lia.
          + intros.
            erewrite (get_frame_store_neq _ _ _ _ _ _ _ _ Hm'); eauto. }
        intros. split_vc. apply END.
        do 2 eexists. repeat (split; eauto). }

    intros m s t (END & POST). eauto. }

  unfold Icopy. split_vc. split.
  - split_vc.
  - split_vc.
    replace (odst + 0) with odst in * by ring. eauto.
Qed.

(* A (counted) array is a sequence of values in memory, proceeded by their count:

        -----------
a ----> |    n    |
        -----------
        |  v_1    |
        -----------
        |  ...    |
        -----------
        |  v_n    |
        -----------

*)

Inductive memseq (m:memory) b : Z -> list val -> Prop :=
| memseq_nil : forall z, memseq m b z nil
| memseq_cons : forall z v t vs, load (b,z) m = Some (v, t) -> memseq m b (z+1) vs -> memseq m b z (v::vs)
.

Lemma memseq_valid : forall m b a vs,
  memseq m b a vs ->
  forall z, a <= z < a + Z.of_nat(length vs) -> valid_address (b,z) m.
Proof.
  induction 1; intros.
  simpl in H. exfalso; lia.
  simpl in H1.
  destruct (Z.eq_dec z z0).
  { subst. econstructor. eauto. }
  eapply IHmemseq. zify; lia.
Qed.

Hint Resolve memseq_valid : core.

Lemma memseq_read : forall m b a vs,
  memseq m b a vs ->
  forall z, a <= z < a + Z.of_nat(length vs) -> exists v t, load (b,z) m = Some(v,t).
Proof.
  induction 1; intros.
  simpl in H. exfalso; lia.
  simpl in H1.
  destruct (Z.eq_dec z z0).
  { subst. eexists; eauto. }
  eapply IHmemseq. zify; lia.
Qed.

Lemma memseq_app: forall m b a vs1 vs2,
  memseq m b a (vs1 ++ vs2) <-> (memseq m b a vs1 /\ memseq m b (a + Z.of_nat(length vs1)) vs2).
Proof.
  intros. split.
  - generalize dependent a.
    induction vs1; intros.
    + simpl in *.
      split. constructor.
      replace (a+0) with a by ring. auto.
    + simpl in H.
      inv H.
      destruct (IHvs1 (a0+1) H4).
      split.
      econstructor; eauto.
      simpl (length (a::vs1)).
      replace (a0 + Z.of_nat (S (length vs1))) with (a0 + 1 + Z.of_nat(length vs1)) by (zify;lia).
      assumption.
  - generalize dependent a.
    induction vs1; intros.
    + simpl in *. inv H. replace (a+0) with a in H1 by ring. auto.
    + inv H. simpl. inv H0. econstructor; eauto.
      eapply IHvs1. split. auto. simpl (length (a::vs1)) in H1.
      replace (a0 + 1 + Z.of_nat (length vs1)) with (a0 + Z.of_nat(S(length vs1))) by (zify;lia).
      assumption.
Qed.

Lemma memseq_eq :
  forall m1 m2 b1 b2 a1 a2 vs
         (LOAD : forall z, 0 <= z < Z.of_nat (length vs) ->
                           load (b1,a1+z) m1 = load (b2,a2+z) m2)
         (SEQ : memseq m1 b1 a1 vs),
    memseq m2 b2 a2 vs.
Proof.
  intros.
  generalize dependent a2.
  induction SEQ.
  - intros. constructor.
  - intros.
    assert (Hz : load (b1,z) m1 = load (b2,a2) m2).
    { replace z with (z+0) by ring. replace a2 with (a2+0) by ring.
      eapply LOAD. simpl. zify; lia. }
    destruct (load (b2,a2) m2) as [[v0 l0]|] eqn:E; try congruence.
    rewrite Hz in H. inv H.
    econstructor; eauto.
    eapply IHSEQ. intros.
    replace (z+1 + z0) with (z+(1+z0)) by lia.
    replace (a2+1 + z0) with (a2+ (1+z0)) by lia.
    eapply LOAD. simpl (length (v::vs)). zify; lia.
Qed.

Lemma memseq_drop :
  forall ms b z p vs
         (MEM : memseq ms b z vs),
    memseq ms b (z + Z.of_nat p) (drop p vs).
Proof.
  intros.
  gdep z. gdep p.
  induction vs as [|v vs IH]; intros p z MEM.
  - destruct p; constructor.
  - destruct p.
    * simpl.
      rewrite Zplus_comm. auto.
    * rewrite Nat2Z.inj_succ in *.
      inv MEM.
      replace (z + Z.succ (Z.of_nat p)) with (z + 1 + Z.of_nat p); try lia.
      apply IH. auto.
Qed.

Inductive memarr (m:memory) b (vs:list val) : Prop :=
| memarr_i : forall c t
                    (LOAD : load (b,0) m = Some (Vint (Z_of_nat c), t))
                    (SEQ : memseq m b 1 vs)
                    (LEN : c = length vs),
               memarr m b vs.

(* Array allocation.  *)

(* Initial stack: count :: _
   Final stack:  ptr-to-array :: _
   Side effects: allocates fresh array of size count *)

Definition alloc_array:= push 0 ++ [Dup 1] ++ push 1 ++ [Add] ++ [Alloc] ++ dup ++ [Swap 2] ++ [Swap 1] ++ [Store].

Lemma alloc_array_spec: forall (Q : memory -> stack -> Prop),
  HT cblock table alloc_array
     (fun m s => exists cnt t s0,
                   s = (Vint cnt,t):::s0 /\
                   cnt >= 0 /\
                   (forall b m1 t2,
                      extends m m1 ->
                      (forall p, 0 < p <= cnt -> valid_address (b,p) m1) ->
                      (exists t1, load (b,0) m1 = Some (Vint cnt, t1)) ->
                      Mem.get_frame m b = None ->
                      Mem.stamp b = Kernel ->
                      Q m1 ((Vptr (b,0),t2):::s0)))
     Q.
Proof.
  intros.
  unfold alloc_array.
  Opaque Z.add. (* not sure why this is necessary this time *)
  unfold alloc_array.
  build_vc ltac: (try apply alloc_spec; eauto).
  intros m s (cnt & t & s0 & ? & ? & H). subst.
  split_vc'. intros.
  assert (VALID : valid_address (b,0) m0).
  { eexists (Vint 0, handlerTag).
    erewrite load_alloc; eauto.
    simpl.
    (* suffices for 8.4pl1:
    destruct (EquivDec.equiv_dec b b ). *)
    (* explicit arguments in following needed for 8.4 *)
    destruct(
       @EquivDec.equiv_dec _ _
         (@eq_equivalence (Memory.block privilege)) _ b b); try congruence.
    destruct (Z_lt_dec 0 (1 + cnt)); try lia.
    reflexivity. }
  eapply valid_store in VALID. destruct VALID.
  assert (ALLOC' := H0).
  unfold c_alloc, alloc in H0.
  match goal with
    | H : match ?B with _ => _ end = Some _ |- _ =>
      destruct B; inv H
  end.
  split_vc. intuition eauto.
  - eapply Mem.alloc_stamp; eauto.
  - assert (FRESH : Mem.get_frame m b = None).
    { eapply Mem.alloc_get_fresh; eauto. }
    apply H; eauto.
    + intros b' fr' FRAME'.
      assert (b <> b') by congruence.
      eapply get_frame_store_neq in H2; eauto.
      eapply alloc_get_frame_old in H4; eauto.
      congruence.
    + intros.
      unfold c_alloc in ALLOC'.
      eexists (Vint 0, handlerTag).
      erewrite load_store_old; eauto.
      * erewrite (load_alloc (b := b)); eauto.
        (* suffices for 8.4pl1:
        destruct (EquivDec.equiv_dec b b); try congruence. *)
        (* explicit arguments for 8.4 *)
        destruct (
           @EquivDec.equiv_dec _
              (@eq (Memory.block privilege)) _ _ b); try congruence.
        destruct (Z_le_dec 0 p); try lia.
        destruct (Z_lt_dec p (1 + cnt)); try lia.
        reflexivity.
      * intros contra.
        inv contra.
        lia.
    + eexists. eapply load_store_new; eauto.
    + eapply Mem.alloc_stamp; eauto.
Qed.
Transparent Z.add.

(* Sum array lengths *)

(* Initial stack:  array1 :: array2 :: _
   Final stack:    (l1+l2) :: array1 :: array2 :: _
      where l1,l2 are lengths of array1,array2
   Side effects: none
*)

Definition sum_array_lengths := [Dup 1] ++ [Load] ++ [Dup 1] ++ [Load] ++ [Add].

Lemma sum_array_lengths_spec : forall Q : HProp,
  HT cblock table sum_array_lengths
     (fun m s => exists a1 a2 s0 l1 l2 t1 t2 t1' t2',
                 s = (Vptr (a2,0),t2):::(Vptr (a1,0),t1):::s0 /\
                 load (a2,0) m = Some (Vint l2, t1') /\
                 load (a1,0) m = Some (Vint l1, t2') /\
                 Mem.stamp a1 = Kernel /\
                 Mem.stamp a2 = Kernel /\
                 forall t1'' t2'',
                   Q m ((Vint (l2+l1),handlerTag):::(Vptr (a2,0),t2''):::(Vptr (a1,0),t1''):::s0))
      Q.
Proof.
  intros. unfold sum_array_lengths.
  build_vc ltac:(idtac).
  split_vc.
Qed.

(* Concatenate two existing arrays into a freshly allocated new array. *)

(* Initial stack: array1::array2::_
   Final stack:   r::_
        where r is pointer to newly allocated array
   Side effects: allocates new array and concatenates existing contents into it.  *)

Definition concat_arrays :=      (* a2 a1 *)
     sum_array_lengths           (* (l2+l1) a2 a1 *)
  ++ alloc_array                 (* r a2 a1 *)
  ++ [Dup 2]                     (* a1 r a2 a1 *)
  ++ [Dup 1]                     (* r a1 r a2 a1 *)
  ++ [Dup 1]                     (* a1 r a1 r a2 a1 *)
  ++ [Load]                      (* l1 r a1 r a2 a1 *)
  ++ copy                        (* 0 r a1 r a2 a1 *)
  ++ pop                         (* r a1 r a2 a1 *)
  ++ [Dup 1]                     (* a1 r a1 r a2 a1 *)
  ++ [Load]                      (* l1 r a1 r a2 a1 *)
  ++ [Add]                       (* (l1+r) a1 r a2 a1 *)
  ++ [Swap 1]                    (* a1 (l1+r) r a2 a1 *)
  ++ pop                         (* (l1+r) r a2 a1 *)
  ++ [Dup 2]                     (* a2 (l1+r) r a2 a1 *)
  ++ [Swap 1]                    (* (l1+r) a2 r a2 a1 *)
  ++ [Dup 1]                     (* a2 (l1+r) a2 r a2 a1 *)
  ++ [Load]                      (* l2 (l1+r) a2 r a2 a1 *)
  ++ copy                        (* 0 (l1+r) a2 r a2 a1 *)
  ++ pop                         (* (l1+r) a2 r a2 a1 *)
  ++ pop                         (* a2 r a2 a1 *)
  ++ pop                         (* r a2 a1 *)
  ++ [Swap 2]                    (* a2 a1 r *)
  ++ pop                         (* a1 r *)
  ++ pop                         (* r *)
.

Lemma concat_arrays_spec : forall (Q :memory -> stack -> Prop),
  HT cblock table
   concat_arrays
   (fun m s => exists a2 a1 vs1 vs2 s0 t1 t2,
                 s = (Vptr (a2,0),t2):::(Vptr (a1,0),t1):::s0 /\
                 memarr m a1 vs1 /\ memarr m a2 vs2 /\
                 Mem.stamp a1 = Kernel /\ Mem.stamp a2 = Kernel /\
                 (forall r m1 t,
                    extends m m1 ->
                    memarr m1 r (vs1 ++ vs2) ->
                    Mem.get_frame m r = None ->
                    Mem.stamp r = Kernel ->
                    Q m1 ((Vptr (r,0),t):::s0)))
   Q.
Proof.
  intros. unfold concat_arrays.

  build_vc ltac:(try apply copy_spec; try apply alloc_array_spec; try apply sum_array_lengths_spec).

  intros m s (a2 & a1 & vs1 & vs2 & t1 & t2 & s0 & ? & ARR1 & ARR2 & K1 & K2 & POST).
  destruct ARR1. destruct ARR2.
  split_vc'. intros t1'' t2''. split_vc'.
  intros b m1 t'' EXT VALID [t''' LOADSUM] FRESH KERNEL.
  assert (a1 <> b).
  { intros contra. subst. unfold load in *. simpl in *.
    rewrite FRESH in LOAD.
    congruence. }
  assert (a2 <> b).
  { intros contra. subst. unfold load in *. simpl in *.
    rewrite FRESH in LOAD0.
    congruence. }
(* XXX *)

  split_vc'.
  split; eauto using extends_load.
  exists (Z.of_nat (length vs1)).
  split_vc'.
  split.
  { intros.
    eapply extends_valid_address; eauto.
    eapply memseq_valid; eauto.
    lia. }
  split.
  { intros. apply VALID. lia. }
  split; try congruence.
  split_vc.
  assert (LOADm0m1 : forall b' off,
                       b' <> b ->
                       load (b', off) m0 = load (b', off) m1).
  { unfold load.
    intros.
    rewrite H3; trivial. }
  split.
  { assert (LOAD'' := LOAD).
    eapply extends_load with (m3 := m1) in LOAD''; eauto.
    cut (load (a1, 0) m0 = load (a1, 0) m1).
    { intros E. rewrite E. eassumption. }
    unfold load.
    rewrite H3; trivial. }
  split_vc.
  split.
  { assert (LOAD'' := LOAD0).
    eapply extends_load with (m3 := m1) in LOAD''; eauto.
    cut (load (a2, 0) m0 = load (a2, 0) m1).
    { intros E. rewrite E. eassumption. }
    unfold load.
    rewrite H3; trivial. }
  exists (Z.of_nat (length vs2)).
  split_vc.
  split.
  { simpl. intros.
    eapply memseq_valid with (z := z) in SEQ0; try lia.
    exploit @extends_valid_address; eauto.
    unfold valid_address in *.
    rewrite LOADm0m1; eauto. }
  split.
  { intros.
    unfold valid_address in *.
    rewrite H2; try lia.
    apply VALID. lia. }
  split_vc.
  apply POST; trivial.
  - intros b' fr' FRAME'.
    rewrite H6; try congruence.
    rewrite H3; try congruence.
    eauto.
  - econstructor; eauto.
    + rewrite H5; try lia.
      rewrite H2; try lia.
      rewrite LOADSUM.
      repeat f_equal.
      rewrite app_length. zify. lia.
    + rewrite memseq_app.
      split.
      * apply memseq_eq with (m1 := m) (b1 := a1) (a1 := 1); eauto.
        intros.
        rewrite H5; try lia.
        rewrite <- H1; try lia.
        rewrite LOADm0m1; try congruence.
        assert (VALID' : valid_address (a1,1 + z) m).
        { eapply memseq_valid; eauto. lia. }
        destruct VALID' as [a VALID'].
        rewrite VALID'.
        symmetry.
        eapply extends_load; eauto.
      * apply memseq_eq with (m1 := m) (b1 := a2) (a1 := 1); eauto.
        intros.
        replace (1 + Z.of_nat (length vs1) + z) with (Z.of_nat (length vs1) + 0 + (1 + z)) by ring.
        rewrite <- H4; try lia.
        assert (LOADm2m0 : load (a2,1 + z) m2 = load (a2,1 + z) m0).
        { unfold load. rewrite H6; trivial. }
        rewrite LOADm2m0.
        rewrite LOADm0m1; try congruence.
        assert (VALID' : valid_address (a2,1 + z) m).
        { eapply memseq_valid; eauto. lia. }
        destruct VALID' as [a VALID'].
        rewrite VALID'.
        symmetry.
        eapply extends_load with (m3 := m); eauto.
Qed.

(* Foldr over an array. *)

(* Initial stack:   a::S
   Final stack:     r::S
       where gen_n assumes _::S and generates v::_::S  with v the initial accumulator value
       where gen_f assumes x::v::_::_::_::S and generates v'::_::_::_::S with v' the new accumulator value
       and r is overall accumulator value for entire list. *)
Definition fold_array_body gen_f :=   (* i v a S *)
      [Dup 1]                         (* v i v a S *)
   ++ [Dup 3]                         (* a v i v a S *)
   ++ [Dup 2]                         (* i a v i v a S *)
   ++ [Add]                           (* i+a v i v a S *)
   ++ [Load]                          (* x v i v a S *)
   ++ gen_f                           (* v' i v a S *)
   ++ [Swap 2]                        (* v i v' a S *)
   ++ pop                             (* i v' a S *)
.

Definition fold_array gen_n gen_f :=     (* a S *)
      gen_n                              (* v a S *)
  ++  [Dup 1]                            (* a v a S *)
  ++  [Load]                             (* l v a S *)
  ++  genFor                             (* i v a S *)
        (fold_array_body gen_f)          (* i v' a S *)
  ++ pop                                 (* r a S *)
  ++ [Swap 1]                            (* a r S *)
  ++ pop                                 (* r S *)
.

(* Invariant for fold array body *)
Definition Ifab (f : val -> val -> val) (n: val)
                (a:block) (vs:list val) m0 s0 i :=
    fun m s =>
      exists v,
        i <= Z.of_nat (length vs) /\
        memarr m a vs /\
        Mem.stamp a = Kernel /\
        m = m0 /\
        stk_env s [v; Vptr (a,0)] s0 /\
        v = fold_right f n (dropZ i vs).

Lemma memseq_dropZ :
  forall ms b z p vs
         (SEQ : memseq ms b z vs)
         (POS : p >= 0),
    memseq ms b (z + p) (dropZ p vs).
Proof.
  intros.
  unfold dropZ.
  destruct (Z.ltb_spec0 p 0); try lia.
  replace (_ + p) with (z + Z.of_nat (Z.to_nat p)) by (rewrite Z2Nat.id; lia).
  auto using memseq_drop.
Qed.

Lemma memarr_load :
  forall m a vs i x t
         (ARR : memarr m a vs)
         (LOAD : load (a,i) m = Some (x,t))
         (BOUNDS : 0 < i <= Z.of_nat (length vs)),
    index_list_Z (Z.pred i) vs = Some x.
Proof.
  intros.
  destruct ARR.
  assert (SEQ' : memseq m a i (dropZ (Z.pred i) vs)).
  { assert (E : i = 1 + Z.pred i) by lia.
    rewrite E at 1. apply memseq_dropZ; trivial.
    lia. }
  rewrite index_list_Z_dropZ_zero; try lia.
  exploit (@dropZ_cons _ (Z.pred i) vs); try lia.
  intros (x' & H). rewrite H in *.
  rewrite <- Zsucc_pred in *.
  inv SEQ'.
  assert (x' = x) by congruence. subst.
  reflexivity.
Qed.

(* AAA: When we use a Hoare triple in the premise of a WP rule (such
as in fab_spec' below), using WP style is not very convenient.

Suppose for concreteness that we want to prove a rule for a
higher-order generator [macro] of the form

   macro_spec : forall c (Q : HProp),
                  Hc -> HT (macro c) P Q

where P is some expression involving Q, and Hc is some hypothesis that
states that some triple should be valid for c. (An example of this is
fab_spec.) After proving this, we use macro_spec for proving another
triple. If Hc is in WP form (i.e., something like (forall Q, HT c P'
Q), where P' depends on Q), more likely than not, there will be a
mismatch between P' and the precondition that is computed from Q when
applying other previously proven Hoare logic rules. This forces us to
apply HT_strengthen_premise explicitly to be able to prove the triple,
and then prove the additional implication forall m s, P' m s -> P'' m
s.

One partial solution is to quantify the precondition in Hc
existentially and supplying the postcondition we want as "input", as
in genFor_spec:

(* genFor_spec *)
(*      : forall (cblock : block) (table : CSysTable) *)
(*          (I : HProp -> CodeTriples.memory -> list CStkElmt -> Z -> Prop) *)
(*          (c : CodeTriples.code) (Q : HProp), *)
(*        (forall i : Z, *)
(*         i > 0 -> *)
(*         exists Pc, *)
(*         HT cblock table c Pc *)
(*           (fun (m : CodeTriples.memory) (s : CodeTriples.stack) => *)
(*            exists t s', s = (Vint i, t) ::: s' /\ I Q m s' (Z.pred i)) /\ *)
(*         (forall (m : CodeTriples.memory) (s : list CStkElmt) (t : val), *)
(*          I Q m s i -> Pc m ((Vint i, t) ::: s))) -> *)
(*        (forall (m : CodeTriples.memory) (s : list CStkElmt) (t : val), *)
(*         I Q m s 0 -> Q m ((Vint 0, t) ::: s)) -> *)
(*        HT cblock table (genFor c) *)
(*          (fun (m : CodeTriples.memory) (s : CodeTriples.stack) => *)
(*           exists i t s', s = (Vint i, t) ::: s' /\ i >= 0 /\ I Q m s' i) Q *)

A good rule-of-thumb seems to be: triples in conclusions map an
arbitrary postcondition to a precondition that validates the
triple. In hypotheses, however, we instead suply the postcondition we
need as input and let the other rules we've proved before figure out
what the precondition should be.
*)

Definition fab_spec :
  forall gen_f f n m0 s0
         (HTf : forall (Q : memory -> stack -> Prop),
                  HT cblock table gen_f
                     (fun m s =>
                        exists x v i0 i1 i2,
                          stk_env s [x; v; i0; i1; i2] s0 /\
                          m = m0 /\
                          forall s',
                            stk_env s' [f x v; i0; i1; i2] s0 ->
                            Q m s')
                     Q)
         (Q : memory -> stack -> Prop),
    HT cblock table (fold_array_body gen_f)
       (fun m s =>
          exists i a vs s',
            stk_env s [Vint i] s' /\
            i > 0 /\
            Ifab f n a vs m0 s0 i m s' /\
            forall s'' s''',
              stk_env s'' [Vint i] s''' ->
              Ifab f n a vs m0 s0 (Z.pred i) m s''' ->
              Q m s'')
       Q.
Proof.
  intros.
  unfold fold_array_body.
  eapply HT_strengthen_premise.
  { repeat (eapply HT_compose; [eapply dup_spec|]).
    eapply HT_compose; try eapply add_spec.
    eapply HT_compose; try eapply load_spec.
    eapply HT_compose; try eapply HTf.
    eapply HT_compose; try eapply swap_spec.
    apply pop_spec. }
  clear.
  intros m ? (i & a & vs & s' & (ti & ?) & POS & INV & POST). subst.
  destruct INV as (v & BOUNDS & ARR & STAMP & ? & (tv & ta & ?) & ?).
  subst m0. subst. simpl.

  do 3 (eexists; split; eauto).
  do 6 eexists. split; eauto. simpl. split; eauto.
  assert (Hx : exists x tx, load (a,i) m = Some (x,tx)).
  { eapply memseq_read.
    destruct ARR. eauto. lia. }
  destruct Hx as (x & tx & Hx).
  do 4 eexists. split; eauto. simpl. split; trivial.
  replace (i + 0) with i by ring. split; eauto.
  do 5 eexists. split; [do 5 eexists; eauto|].
  split; trivial.
  intros s' (? & ? & ? & ? & ?). subst.
  do 4 eexists. do 3 (split; eauto).
  do 3 eexists. split; eauto.
  change (f x (fold_right f n (dropZ i vs))) with (fold_right f n (x :: dropZ i vs)).
  exploit (@dropZ_cons _ (Z.pred i) vs); try lia.
  intros (x' & H).
  rewrite <- Zsucc_pred in H.
  replace x' with x in *.
  { rewrite <- H. eapply POST.
    - eexists. eauto.
    - eexists. repeat split; eauto; try lia.
      do 2 eexists. reflexivity. }
  exploit memarr_load; eauto; try lia.
  intros H'.
  rewrite index_list_Z_dropZ_zero in H'; try lia.
  rewrite H in H'. compute in H'.
  congruence.
Qed.

Lemma fold_array_spec :
  forall gen_f gen_n n f m0 s0
         (HTn : forall (Q : memory -> stack -> Prop),
                  HT cblock table gen_n
                     (fun m s =>
                        exists i0,
                          stk_env s [i0] s0 /\
                          m = m0 /\
                          forall s',
                            stk_env s' [n; i0] s0 ->
                            Q m s')
                     Q)
         (HTf : forall (Q : memory -> stack -> Prop),
                  HT cblock table gen_f
                     (fun m s =>
                        exists x v i0 i1 i2,
                          stk_env s [x; v; i0; i1; i2] s0 /\
                          m = m0 /\
                          forall s',
                            stk_env s' [f x v; i0; i1; i2] s0 ->
                            Q m s')
                     Q)
         (Q : memory -> stack -> Prop),
    HT cblock table
       (fold_array gen_n gen_f)
       (fun m s => exists a vs,
                     memarr m a vs /\
                     Mem.stamp a = Kernel /\
                     stk_env s [Vptr (a, 0)] s0 /\
                     m = m0 /\
                     forall s',
                       stk_env s' [fold_right f n vs] s0 ->
                       Q m s')
       Q.
Proof.
  intros.
  unfold fold_array.
  eapply HT_strengthen_premise.

  (* Using PTs would remove the need for the things between the { }
     with no need for ad-hoc tactics. *)

  { eapply HT_compose; try eapply HTn.
    eapply HT_compose; try eapply dup_spec.
    eapply HT_compose; try eapply load_spec.
    eapply HT_compose; try eapply genFor_spec
                       with (I := fun (Q : HProp) m s i =>
                                    exists a vs,
                                      Ifab f n a vs m0 s0 i m s /\
                                      forall s' s'',
                                        stk_env s' [Vint 0] s'' ->
                                        Ifab f n a vs m0 s0 0 m s'' ->
                                        Q m s').
    { intros. eexists. split.
      - eapply fab_spec. apply HTf.
      - simpl.
        intros m s t (a & vs & INV & POST).
        do 4 eexists. split; [eexists; eauto|]. split; try lia.
        split; eauto.
        intros s'' s''' (? & ?) INV'. subst.
        do 2 eexists. split; eauto. }

    { intros m s t (a & vs & INV & POST). eapply POST; eauto. eexists. eauto. }
    eapply HT_compose; try eapply pop_spec.
    eapply HT_compose; try eapply swap_spec.
    eapply pop_spec. }

  intros m s (a & vs & ARR & KERNEL & ? & ? & POST).
  subst. simpl.
  eexists. do 2 (split; eauto).
  intros s' (? & ? & ?). subst.
  destruct ARR as [c ? LOAD SEQ ?]. subst.
  eexists. split; eauto.
  do 4 eexists. do 3 (split; eauto).
  do 3 eexists. split; eauto. split; try lia.
  do 2 eexists.
  split.
  { unfold Ifab.
    eexists.
    repeat split; eauto; try solve [econstructor; eauto]; try lia.
    rewrite dropZ_all. do 2 eexists. reflexivity. }
  clear - POST.
  intros s' s'' (? & ?) (? & _ & ARR & KERNEL & _ & (? & ? & ?) & ?). subst.
  do 3 eexists. split; eauto.
  do 4 eexists. do 3 (split; eauto).
  do 3 eexists. split; eauto.
  apply POST.
  eexists. reflexivity.
Qed.

(* Existsb. *)

(* Initial stack: a::S
   Final stack: r::S
        where gen_f assumes x::_::_::_::_::S and generates b::_::_::_::_::S with b the result of testing x
        and r = boolean: gen_f answers true on some element
*)
Definition exists_array gen_f :=  (* a S *)
      fold_array (                (* _ S *)
                    genFalse      (* 0 _ S *)
                 )                (* v _ S *)
                 (                (* x v _ _ _ S *)
                    gen_f         (* b v _ _ _ S *)
                 ++ genOr         (* b\/v _ _ _ S *)
                 )                (* v' _ _ _ S *)
.

Definition boolToVal (b : bool) : val := Vint (boolToZ b).

Lemma boolToVal_existsb : forall f xs,
                          boolToVal (existsb f xs) =
                          fold_right (fun x v : val => orv (boolToVal (f x)) v) (Vint 0) xs.
Proof.
  induction xs;  simpl; auto.
  destruct (f a); unfold orv in *; simpl; auto.
Qed.

Lemma exists_array_spec : forall gen_f (f: val -> bool) s0 m0,
  (forall (Q: memory -> stack -> Prop),
  HT cblock table gen_f
     (fun m s => exists x i0 i1 i2 i3,
                   stk_env s [x; i0; i1; i2; i3] s0 /\
                   m = m0 /\
                   forall s',
                     stk_env s' [boolToVal (f x); i0; i1; i2; i3] s0 ->
                     Q m s')
     Q) ->
  forall (Q: memory -> stack -> Prop),
  HT cblock table (exists_array gen_f)
     (fun m s => exists a vs,
                      memarr m a vs /\
                      Mem.stamp a = Kernel /\
                      stk_env s [Vptr (a, 0)] s0 /\
                      m = m0 /\
                      forall s',
                        stk_env s' [boolToVal (existsb f vs)] s0 ->
                        Q m s')
     Q.
Proof.
  intros.
  unfold exists_array.
  eapply HT_strengthen_premise.
  { eapply fold_array_spec with
           (n:= boolToVal false)
           (f:= fun x v => orv (boolToVal (f x)) v); eauto.
    - clear Q. intros Q.
      eapply HT_strengthen_premise. eapply genFalse_spec.
      intros m s (i0 & (? & ?) & ? & POST).
      subst s.
      apply POST.
      do 2 eexists. reflexivity.
    - clear Q. intro Q.
      eapply HT_compose_flip; try eapply genOr_spec; eauto.
      eapply HT_strengthen_premise.
      eapply H.
      intros m s (x & v & i0 & i1 & i2 & E & ? & POST).
      do 5 eexists. split; eauto. split; eauto.
      intros s' (? & ? & ? & ? & ? & ?). subst.
      do 5 eexists. split; eauto.
      intros.
      eapply POST.
      do 4 eexists. eauto. }

  - unfold stk_env. split_vc.
    rewrite <- boolToVal_existsb. eauto.
Qed.

(* Forallb. *)

(* Initial stack: a::S
   Final stack: r::S
        where gen_f assumes x::_::_::_::_::S and generates b::_::_::_::_::S with b the result of testing x
        and r = boolean: gen_f answers true on all elements
*)

Definition forall_array gen_f :=  (* a S *)
      fold_array (                (* _ S *)
                    genTrue       (* 1 _ S *)
                 )                (* v _ S *)
                 (                (* x v _ _ _ S *)
                    gen_f         (* b v _ _ _ S *)
                 ++ genAnd        (* b/\v _ _ _ S *)
                 )                (* v' _ _ _ S *)
.

Lemma boolToVal_forallb : forall f xs, boolToVal (forallb f xs) =
                                       fold_right (fun x v : val => andv (boolToVal (f x)) v) (Vint 1) xs.
Proof.
  induction xs;  simpl; auto.
  destruct (f a); unfold andv in *; simpl; auto.
Qed.

Lemma forall_array_spec : forall gen_f (f: val -> bool) s0 m0,
  (forall (Q: memory -> stack -> Prop),
  HT cblock table gen_f
     (fun m s => exists x i0 i1 i2 i3,
                   stk_env s [x; i0; i1; i2; i3] s0 /\
                   m = m0 /\
                   forall s',
                     stk_env s' [boolToVal (f x); i0; i1; i2; i3] s0 ->
                     Q m s')
     Q) ->
  forall (Q: memory -> stack -> Prop),
  HT cblock table (forall_array gen_f)
     (fun m s => exists a vs,
                      memarr m a vs /\
                      Mem.stamp a = Kernel /\
                      stk_env s [Vptr (a, 0)] s0 /\
                      m = m0 /\
                      forall s',
                        stk_env s' [boolToVal (forallb f vs)] s0 ->
                        Q m s')
     Q.
Proof.
  intros.
  unfold exists_array.
  eapply HT_strengthen_premise.
  { eapply fold_array_spec with
           (n:= boolToVal true)
           (f:= fun x v => andv (boolToVal (f x)) v); eauto.
    - clear Q. intros Q.
      eapply HT_strengthen_premise. eapply genFalse_spec.
      intros m s (i0 & (? & ?) & ? & POST).
      subst s.
      apply POST.
      do 2 eexists. reflexivity.
    - clear Q. intro Q.
      eapply HT_compose_flip; try eapply genAnd_spec; eauto.
      eapply HT_strengthen_premise.
      eapply H.
      intros m s (x & v & i0 & i1 & i2 & E & ? & POST).
      do 5 eexists. split; eauto. split; eauto.
      intros s' (? & ? & ? & ? & ? & ?). subst.
      do 5 eexists. split; eauto.
      intros.
      eapply POST.
      do 4 eexists. eauto. }

  - unfold stk_env. split_vc.
    rewrite <- boolToVal_forallb. eauto.
Qed.

(* In_array *)

(* Initial stack:  a::x::_
   Final stack:    r::_
      where r = boolean: x is in array a. *)

Definition in_array :=           (* a x *)
      exists_array (             (* y _ _ _ _ x *)
                       [Dup 5]   (* x y _ _ _ _ x *)
                   ++  genEq     (* x=y _ _ _ _ x *)
                   )             (* r x *)
   ++ [Swap 1]                   (* x r *)
   ++ pop                        (* r *)
.

Definition val_list_in_b (x: val) (xs:list val) : bool :=
  existsb (fun x' => if EquivDec.equiv_dec x x' then true else false) xs.

Lemma in_array_spec : forall (Q: memory -> stack -> Prop),
  HT cblock table
    in_array
    (fun m s => exists a vs x t1 t2 s0 m0,
                  memarr m0 a vs /\
                  s = (Vptr (a, 0),t1):::(x,t2):::s0 /\
                  Mem.stamp a = Kernel /\
                  m = m0 /\
                  forall t,
                    Q m0 ((boolToVal(val_list_in_b x vs),t):::s0))
    Q.
Proof.
  intros. unfold in_array.
  eapply HT_forall_exists. intro a.
  eapply HT_forall_exists. intro vs.
  eapply HT_forall_exists. intro x.
  eapply HT_forall_exists. intro t1.
  eapply HT_forall_exists. intro t2.
  eapply HT_forall_exists. intro s0.
  eapply HT_forall_exists. intro m0.
  eapply HT_strengthen_premise.
  { eapply HT_compose; try eapply exists_array_spec with
                         (f := fun y => if EquivDec.equiv_dec x y then true else false)
                         (s0 := (x,t2):::s0).
    { clear Q. intros Q.
      eapply HT_strengthen_premise.
      { eapply HT_compose; try eapply dup_spec.
        eapply genEq_spec. }
      intros m s (? & ? & ? & ? & ? & (? & ? & ? & ? & ? & ?) & ? & POST).
      subst s. simpl.
      eexists. split; eauto.
      do 5 eexists. split; eauto.
      eapply POST.
      do 5 eexists.
      unfold val_eq.
      destruct (EquivDec.equiv_dec x x0); eauto. }

    eapply HT_compose; try eapply swap_spec.
    eapply pop_spec. }

  intros m s (? & ? & ? & ? & POST). subst.
  unfold stk_env.
  split_vc.
Qed.

(* Subset_arrays *)

(* Initial stack:  a1::a2::_.
   Final_stack:    r::_.
      where r = boolean: all elements of a1 are in a2
*)
Definition subset_arrays :=      (* a1 a2 *)
    forall_array (               (* x1 _ _ _ _ a2 *)
                    [Dup 5]      (* a2 x1 _ _ _ _ a2 *)
                 ++ in_array     (* x1ina2 _ _ _ _ a2 *)
                 )               (* r a2 *)
 ++ [Swap 1]                     (* a2 r *)
 ++ pop                          (* r *)
.

Definition val_list_subset_b (xs1 xs2:list val) : bool :=
  forallb (fun x1 => val_list_in_b x1 xs2) xs1.

Lemma subset_arrays_spec : forall (Q: memory -> stack -> Prop),
  HT cblock table
    subset_arrays
    (fun m s => exists a1 a2 vs1 vs2 t1 t2 s0 m0,
                  memarr m0 a1 vs1 /\
                  memarr m0 a2 vs2 /\
                  Mem.stamp a1 = Kernel /\ Mem.stamp a2 = Kernel /\
                  s = (Vptr (a1, 0),t1):::(Vptr (a2, 0),t2):::s0 /\
                  m = m0 /\
                  forall t,
                    Q m0 ((Vint (boolToZ(val_list_subset_b vs1 vs2)),t):::s0))
    Q.
Proof.
  intros. unfold subset_arrays.
  eapply HT_forall_exists. intro a1.
  eapply HT_forall_exists. intro a2.
  eapply HT_forall_exists. intro vs1.
  eapply HT_forall_exists. intro vs2.
  eapply HT_forall_exists. intro t1.
  eapply HT_forall_exists. intro t2.
  eapply HT_forall_exists. intro s0.
  eapply HT_forall_exists. intro m0.
  eapply HT_fold_constant_premise. intro.
  eapply HT_fold_constant_premise. intro.
  eapply HT_fold_constant_premise. intro.
  eapply HT_fold_constant_premise. intro.
  eapply HT_strengthen_premise.
  { eapply HT_compose; try eapply forall_array_spec with
                           (f := fun y => val_list_in_b y vs2)
                           (s0 := (Vptr (a2, 0), t2) ::: s0).
    { clear Q. intros Q.
      eapply HT_strengthen_premise.
      { eapply HT_compose; try eapply dup_spec.
        eapply in_array_spec. }
      intros m s (x & ? & ? & ? & ? & (? & ? & ? & ? & ? & ?) & ? & POST).
      subst s. simpl.
      eexists. split; eauto.
      do 7 eexists. split_vc.
      eapply POST.
      unfold stk_env.
      split_vc. }
    build_vc idtac. }
  intros m s (? & ? & POST). subst.
  unfold stk_env.
  eexists a1. split_vc.
Qed.

(* Extend array *)

(* Initial stack:   a::x::_
   Final stack:     r::_
          where r is a fresh array containing the contents of a followed by x
   Side effects: allocates and fills the fresh array *)

Definition extend_array :=   (* a x *)
     [Dup 0]                 (* a a x *)
  ++ [Load]                  (* l a x *)
  ++ [Push 1]                (* 1 l a x *)
  ++ [Add]                   (* l+1 a x *)
  ++ alloc_array             (* r a x *)
  ++ [Dup 1]                 (* a r a x *)
  ++ [Load]                  (* l r a x *)
  ++ copy                    (* 0 r a x *)
  ++ pop                     (* r a x *)
  ++ [Dup 0]                 (* r r a x *)
  ++ [Swap 2]                (* a r r x *)
  ++ [Load]                  (* l r r x *)
  ++ [Push 1]                (* 1 l r r x *)
  ++ [Add]                   (* l+1 r r x *)
  ++ [Add]                   (* r+l+1 r x *)
  ++ [Swap 1]                (* r r+l+1 x *)
  ++ [Swap 2]                (* x r+l+1 r *)
  ++ [Swap 1]                (* r+l+1 x r *)
  ++ [Store]                 (* r *)
.

Lemma extend_array_spec : forall (Q : memory -> stack -> Prop),
  HT cblock table
   extend_array
   (fun m s => exists a vs x s0 t1 t2,
                 s = (Vptr (a, 0),t1):::(x,t2):::s0 /\
                 memarr m a vs /\
                 Mem.stamp a = Kernel /\
                 (forall r m1 t,
                    extends m m1 ->
                    Mem.get_frame m r = None ->
                    Mem.stamp r = Kernel ->
                    memarr m1 r (vs++[x]) ->
                    Q m1 ((Vptr (r, 0),t):::s0)))
   Q.

Proof.
  intros. unfold extend_array.

  build_vc ltac:(try apply copy_spec; try apply alloc_array_spec). auto.

  intros m ? (a & vs & x & s & t1 & t2 & ? & ARR & STAMPa & POST). subst.
  destruct ARR. subst.
  simpl.
  eexists. split; eauto.
  do 4 eexists.
  do 3 (split; eauto).
  do 6 eexists.
  do 2 (split; try reflexivity).
  do 3 eexists.
  do 2 (split; try reflexivity; try lia).
  intros b m' t' EXT VALID [t'' LOAD'] FRESH STAMPb.
  assert (NEQab : a <> b).
  { intros contra. subst. unfold load in LOAD. simpl in *.
    destruct (Mem.get_frame m b); congruence. }
  eexists. split; try reflexivity.
  assert (LOAD'' := extends_load _ _ _ _ EXT LOAD).
  do 4 eexists.
  do 3 (split; eauto).
  do 9 eexists.
  split.
  2: split; eauto. lia.
  split.
  { intros.
    eapply extends_valid_address; eauto.
    eapply memseq_valid; eauto. lia. }
  split.
  { intros. apply VALID. lia. }
  split; try congruence.
  do 2 (split; auto).
  intros m'' t1' t2' t3' (COPY & EQLOAD & EQFRAME).
  simpl in COPY.
  assert (EQFRAME' : forall b' off, b' <> b -> load (b', off) m'' = load (b', off) m').
  { unfold load.
    intros.
    rewrite EQFRAME; eauto. }
  do 3 eexists.
  split; eauto.
  simpl.
  eexists. split; eauto.
  do 4 eexists. do 3 (split; eauto).
  do 4 eexists.
  do 3 (split; eauto).
  { rewrite EQFRAME'; eauto. }
  do 6 eexists. do 2 (split; try reflexivity).
  do 6 eexists. do 2 (split; try reflexivity).
  do 4 eexists. do 3 (split; eauto).
  do 4 eexists. do 3 (split; eauto).
  do 4 eexists. do 3 (split; eauto).
  assert (STORE : valid_address (b,1 + Z.of_nat (length vs) + 0) m'').
  { unfold valid_address.
    rewrite EQLOAD; try lia.
    apply VALID. lia. }
  eapply valid_store in STORE. destruct STORE as [m''' STORE].
  do 5 eexists. split; [|split; eauto]; eauto.
  split; eauto.
  apply POST; eauto.
  - intros b' fr' FRAME.
    assert (b' <> b) by congruence.
    erewrite (get_frame_store_neq _ _ _ _ _ _ _ _ STORE); eauto.
    rewrite EQFRAME; eauto.
  - econstructor; eauto.
    + erewrite load_store_old; eauto.
      * rewrite EQLOAD; try lia.
        rewrite LOAD'.
        repeat f_equal.
        rewrite app_length.
        simpl (length [x]).
        zify. ring.
      * intros contra.
        assert (0 = 1 + Z.of_nat (length vs) + 0) by congruence.
        lia.
    + apply memseq_app with (vs1 := vs) (vs2 := [x]).
      split.
      * eapply memseq_eq with (m1 := m); eauto.
        intros z RANGE.
        { rewrite (load_store_old STORE); eauto.
          - rewrite <- COPY; try lia.
            rewrite EQFRAME'; try congruence.
            unfold load in LOAD.
            unfold load. simpl in *.
            destruct (Mem.get_frame m a) as [fr|] eqn:FRAME; try congruence.
            apply EXT in FRAME.
            rewrite FRAME.
            reflexivity.
          - intros contra.
            assert (1 + z = 1 + Z.of_nat (length vs) + 0) by congruence.
            lia. }
      * econstructor; try solve [constructor].
        replace (1 + Z.of_nat (length vs) + 0) with (1 + Z.of_nat (length vs)) in STORE by ring.
        erewrite load_store_new; eauto.
Qed.

End with_hints.

End with_cblock.


Require Import VST.floyd.proofauto.
Require Import malloc2.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Open Scope logic.  (* this should not be necessary *)

Definition HEAPSIZE := proj1_sig (opaque_constant 1000).
Definition HEAPSIZE_eq : HEAPSIZE = 1000 := proj2_sig (opaque_constant _).
Hint Rewrite HEAPSIZE_eq : rep_lia.

Definition tcell := Tunion _cell noattr.

Definition idT := ltac:(
   let x := constr:(fn_return f_T_alloc) in
   let x := eval simpl in x in
   match x with tptr (Tstruct ?i _) => exact i end).

Definition tT := Tstruct idT noattr.

Fixpoint freelistrep (n: nat) (x: val) : mpred :=
 match n with
 | S n' =>
    EX y:val,
      data_at Ews tcell (inr y) x  *  freelistrep n' y
 | O =>
    !! (x = nullval) && emp
 end.

Arguments freelistrep n x : simpl never.

(** Whenever you define a new spatial operator, such as
 ** [listrep] here, it's useful to populate two hint databases.
 ** The [saturate_local] hint is a lemma that extracts
 ** pure propositional facts from a spatial fact.
 ** The [valid_pointer] hint is a lemma that extracts a
 ** valid-pointer fact from a spatial lemma.
 **)

Lemma freelistrep_local_facts:
  forall n p,
   freelistrep n p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> n=O)).
Proof.
intros.
revert p; induction n; intros; unfold freelistrep; fold freelistrep; simpl.
- entailer!. intuition.
- Intros y. entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

Hint Resolve freelistrep_local_facts : saturate_local.

Lemma freelistrep_valid_pointer:
  forall n p,
   freelistrep n p |-- valid_pointer p.
Proof.
 destruct n; unfold freelistrep; fold freelistrep;
 intros; normalize.
 auto with valid_pointer.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

Hint Resolve freelistrep_valid_pointer : valid_pointer.

Definition mem_mgr (k: Z) (gv: globals) :=
 EX r:Z, EX n: nat, EX p: val,
   !! (0 <= r <= HEAPSIZE /\ k = (HEAPSIZE-r)+(Z.of_nat n)
       /\ field_compatible (tarray tcell HEAPSIZE) nil (gv _heap)) &&
   data_at Ews (tptr tcell) p (gv _first_free) *
   freelistrep n p *
   data_at Ews (tptr tcell)
           (field_address0 (tarray tcell HEAPSIZE) [ArraySubsc r] (gv _heap))
           (gv _limit) *
   data_at_ Ews (tarray tcell (HEAPSIZE-r))
       (field_address0 (tarray tcell HEAPSIZE) [ArraySubsc r] (gv _heap)).

Definition T_alloc_token (p: val) : mpred :=
  !! (field_compatible tcell [] p) && data_at_ Ews tT p -* data_at_ Ews tcell p.

Definition T_alloc_spec :=
   DECLARE _T_alloc
   WITH k: Z, gv: globals
   PRE [ ]
       PROP ()
       PARAMS() GLOBALS(gv)
       SEP (mem_mgr k gv)
    POST [ tptr tT ] EX p:val,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (if zlt 0 k
             then (mem_mgr (k-1) gv * data_at_ Ews tT p * T_alloc_token p)
             else (!!(p=nullval) &&  mem_mgr k gv)).

Definition T_free_spec :=
   DECLARE _T_free
   WITH p: val, k: Z, gv: globals
   PRE [ tptr tT ]
       PROP ()
       PARAMS (p) GLOBALS (gv)
       SEP (data_at_ Ews tT p; T_alloc_token p; mem_mgr k gv)
    POST [ tvoid ]
       PROP ()
       LOCAL ()
       SEP (mem_mgr (k+1) gv).

Definition vstrcpy_spec :=
   DECLARE _vstrcpy
   WITH bl: list byte, d: val, shd: share, n: Z, s: val, shs: share
   PRE [ tptr tschar, tptr tschar ]
     PROP(writable_share shd; readable_share shs; Zlength bl < n)
     PARAMS(d;s) GLOBALS()
     SEP(data_at_ shd (tarray tschar n) d; cstring shs bl s)
   POST [ tvoid ]
     PROP() LOCAL() SEP(cstringn shd bl n d; cstring shs bl s).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     PROP()
     LOCAL (temp ret_temp (Vint (Int.repr 0)))
     SEP(TT).

Definition Gprog : funspecs :=
         [T_alloc_spec; T_free_spec; vstrcpy_spec; main_spec].

Lemma init_mem_mgr:
 forall (gv: globals),
data_at Ews tuint (Vint (Int.repr 0)) (gv _first_free) *
   data_at Ews (tptr (Tunion _cell noattr))
     (offset_val 0 (gv _heap)) (gv _limit) *
   data_at_ Ews (tarray (Tunion _cell noattr) 1000) (gv _heap) |--
 mem_mgr 1000 gv.
Proof.
intros.
unfold mem_mgr.
rewrite <- HEAPSIZE_eq.
Exists 0 O nullval.
unfold freelistrep.
entailer!.
rewrite <- data_at_nullptr.
change size_t with tuint.
unfold field_address0.
rewrite if_true.
2:{
 apply field_compatible0_ArraySubsc0.
 auto with field_compatible.
 split; auto; simpl; rep_lia.
}
simpl.
normalize.
cancel.
Qed.

Ltac strip_int_repr L :=
 match L with
 | Int.repr ?a :: ?L' => let bl := strip_int_repr L' in
                                 let cl := constr:(a::bl) in
                                 cl
 | nil => constr:(@nil Z)
 end.

Ltac process_stringlit :=
 match goal with
 | |- context [data_at Ers (tarray tschar ?n)
    (map (Vint oo cast_int_int I8 Signed) ?L) (_ ?id)] =>
    let bl := strip_int_repr L in
   let v := fresh id "_val" in
   pose (v := map Vbyte (map Byte.repr bl));
    change (map (Vint oo cast_int_int I8 Signed) L)
     with v
  end.

Lemma data_at__tT_eq:
  forall p sh,
  field_compatible tT nil p ->
   data_at_ sh tT p = data_at_ sh (tarray tschar 42) p.
Proof.
intros.
rewrite data_at__memory_block.
rewrite data_at__memory_block.
rewrite !prop_true_andp; auto.
destruct H as [? [? [? [? ?]]]].
split3; auto.
split3; auto.
destruct p; try contradiction.
red.
apply align_compatible_rec_Tarray.
intros.
eapply align_compatible_rec_by_value; [reflexivity | ].
apply Z.divide_1_l.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply init_mem_mgr.
repeat process_stringlit.
forward_call (1000, gv).
if_tac; try lia.
Intros p.
assert_PROP (field_compatible tT nil p) by entailer!.
forward_call (map Byte.repr [102; 111; 111], p, Ews, 42,
                    gv ___stringlit_1, Ers).
rewrite data_at__tT_eq by auto.
unfold cstring.
rewrite prop_true_andp.
cancel.
clear; intro.
compute in H.
decompose [or] H; try discriminate; auto.
repeat apply seq_assoc1.
match goal with |- semax _ ?pre _ _ =>
 apply semax_seq' with pre
end.
admit.  (* printf *)
forward_call (p, 1000-1, gv).
unfold cstringn.
Intros.
rewrite data_at__tT_eq by auto.
cancel.
forward.
Admitted.

Lemma field_at_union_convert:
  (* shouldn't need this if unfold_data_at worked correctly *)
  forall q p,
    field_at Ews (Tunion _cell noattr) [UnionField _next_free] q p
           |-- data_at Ews (tptr tcell) q p.
Proof.
 intros.
 entailer!.
 unfold field_at.
 Intros. simpl. unfold at_offset. normalize.
 unfold data_at, field_at, at_offset; simpl.
 normalize. fold tcell.
 apply andp_right; auto.
 apply prop_right.
 destruct H as [? [? [? [? ?]]]].
 split3; auto. split3; simpl; auto.
 destruct p; try contradiction.
 simpl in H2|-*. lia.
 destruct p; try contradiction.
 red. red in H3.
 eapply align_compatible_rec_Tunion_inv' in H3.
 instantiate (1:= _next_free) in H3.
 simpl field_type in H3.
 eapply align_compatible_rec_by_value_inv in H3; [ | reflexivity].
 eapply align_compatible_rec_by_value; [reflexivity | ].
 auto.
 compute; auto.
Qed.

Lemma fold_alloc_token: forall p,
 data_at_ Ews tcell p |-- data_at_ Ews tT p * T_alloc_token p.
Proof.
intros.
 unfold T_alloc_token.
 rewrite data_at__memory_block.
 Intros.
 rewrite !prop_true_andp by auto.
 change (sizeof tcell) with (sizeof tT + (sizeof tcell - sizeof tT)).
 make_Vptr p.
 rewrite <- (Ptrofs.repr_unsigned i) in *.
 rewrite memory_block_split.
 2,3: compute; congruence.
 2:{  simpl. destruct H as [_ [? [? _]]].
 red in H0. rewrite Ptrofs.repr_unsigned in H0. simpl in H0. rep_lia. }
 apply sepcon_derives.
 -
  rewrite data_at__memory_block.
  rewrite prop_true_andp; auto.
 destruct H as [? [? [? [? ?]]]].
 split3; auto. split3; auto.
 simpl in H1|-*. lia.
 unfold tT.
 eapply align_compatible_rec_Tstruct.
 simpl. reflexivity.
 intros.
 simpl in H4.
 if_tac in H4; [ | inv H4].
 subst i0.
 inv H5. inv H4.
 apply align_compatible_rec_Tarray. intros.
 eapply align_compatible_rec_by_value; [reflexivity |].
 apply Z.divide_1_l.
-
 apply wand_sepcon_adjoint.
 cancel.
 rewrite data_at__memory_block.
 Intros. auto.
Qed.

Lemma body_T_alloc: semax_body Vprog Gprog f_T_alloc T_alloc_spec.
Proof.
start_function.
unfold mem_mgr.
Intros r n p.
forward.
forward_if (
   EX q:val, PROP ( ) LOCAL (temp _ptr q)
         SEP (if zlt 0 k
              then mem_mgr (k - 1) gv * data_at_ Ews tT q * T_alloc_token q
              else !! (q = nullval) && mem_mgr k gv)).
-
destruct n; unfold freelistrep; fold freelistrep.
+
Intros. subst. contradiction.
+
Intros q.
assert_PROP (field_compatible tcell nil p) as FCcell by entailer!.
unfold tcell.
unfold_data_at (data_at Ews (Tunion _ _) _ _).
forward.
forward.
forward.
Exists p.
entailer!.
rewrite if_true by (rewrite inj_S; lia).
unfold mem_mgr.
Exists r n q.
entailer!.
eapply derives_trans; [ | apply fold_alloc_token].
sep_apply field_at_union_convert.
unfold spacer.
rewrite if_false by computable.
unfold at_offset.
sep_apply data_at_data_at_.
rewrite data_at__memory_block.
Intros.
rewrite data_at__memory_block.
rewrite prop_true_andp by auto.
change (sizeof tcell) with (4+(44-4)).
make_Vptr p.
 rewrite <- (Ptrofs.repr_unsigned i) in *.
rewrite memory_block_split.
 simpl sizeof. simpl Z.sub.
 unfold offset_val.
 rewrite ptrofs_add_repr.
 cancel.
 computable.
 computable.
 simpl.
 clear - FCcell.
 destruct FCcell as [_ [_ [? _]]].
 simpl in H.
 rewrite Ptrofs.repr_unsigned in H.
 rep_lia.
-
 forward.
 forward_if.
 +
 set (A := (_ * freelistrep _ _)%logic). clearbody A.
 clear - H.
 unfold field_address0.
 if_tac.
 2: entailer!; destruct H3; contradiction.
 simpl.
 make_Vptr (gv _heap).
 simpl.
 unfold test_order_ptrs.
 simpl.
 destruct (peq b b); [ | contradiction n; auto].
 simpl.
 clear e.
 rewrite data_at__memory_block. Intros.
 apply andp_right; apply sepcon_weak_valid_pointer2.
 eapply derives_trans.
 apply memory_block_weak_valid_pointer with (i:=0).
 simpl. rewrite Z.max_r by lia. lia.
 simpl. rewrite Z.max_r by lia.
 admit.
 auto. normalize.

 eapply derives_trans.
 apply memory_block_weak_valid_pointer with (i:=(44 * (HEAPSIZE-r))%Z).
 simpl. rewrite Z.max_r by lia. lia.
 simpl. rewrite Z.max_r by lia.
 admit.
 auto.
 simpl.
 normalize.
 apply derives_refl'. f_equal. f_equal. f_equal. f_equal.
 rewrite HEAPSIZE_eq. lia.
 +
  forward.
  Exists (Vint (Int.repr 0)).
  entailer!.
Admitted.


Require Export FcEtt.tactics.
Require Export FcEtt.ett_inf.

Require Import FcEtt.utils.
Require Import FcEtt.imports.

Require Import FcEtt.ett_ind.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

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

Hint Resolve AnnCtx_uniq.
Hint Unfold AtomSetImpl.Subset.

Ltac solve_binds :=
  match goal with
    | [ b : binds ?v _ ?G
      , H : forall v' _, binds v' _ ?G -> _ [<=] dom ?G ∧ _ [<=] dom ?G
      |- _ ] =>
      apply H in b; simpl in b; split_hyp; (done || fsetdec)
  end.

Theorem ann_context_fv_mutual :
  (forall G (a : tm) A (H: AnnTyping G a A),
      fv_tm_tm_tm a [<=] dom G /\ fv_co_co_tm a [<=] dom G /\
      fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] dom G)
  /\
  (forall G phi (H : AnnPropWff G phi),
      fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] dom G)
  /\
  (forall G D g p1 p2 (H : AnnIso G D g p1 p2),
      fv_tm_tm_co         g  [<=] dom G /\ fv_co_co_co         g  [<=] dom G /\
      fv_tm_tm_constraint p1 [<=] dom G /\ fv_co_co_constraint p1 [<=] dom G /\
      fv_tm_tm_constraint p2 [<=] dom G /\ fv_co_co_constraint p2 [<=] dom G)
  /\
  (forall G D g A B (H : AnnDefEq G D g A B),
      fv_tm_tm_co g [<=] dom G /\ fv_co_co_co g [<=] dom G /\
      fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] dom G /\
      fv_tm_tm_tm B [<=] dom G /\ fv_co_co_tm B [<=] dom G)
  /\
  (forall G (H : AnnCtx G),
      (forall x A,
          binds x (Tm A)   G ->
          fv_tm_tm_tm         A   [<=] dom G /\ fv_co_co_tm         A   [<=] dom G) /\
      (forall c phi,
          binds c (Co phi) G ->
          fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] dom G)).

Proof.
  eapply ann_typing_wff_iso_defeq_mutual.
  all: autounfold.
  (* We can't just use `repeat split` because we don't want to split under foralls *)
  all: intros; repeat match goal with |- _ ∧ _ => split end; split_hyp; simpl.
  all: eauto 1.
  (* split all asummptions about unions *)

  (* Do the cases about the context at the end. *)
  all: try (intros x0 A0 BI).
  all: try solve [inversion BI].
  all: try (match goal with |- _ ∧ _ => split end).
  all: try solve
  [intros y h1; inversion BI; [inversion H5; subst; clear H5; eauto|
                               destruct (H x0 _ H5); eauto]].
  all: try solve
  [intros y h1; inversion BI; [inversion H5; subst; clear H5; eauto|
                              destruct (H4 x0 _ H5); eauto]].
  all: try solve
  [intros y h1; inversion BI; [inversion H3; subst; clear H3; eauto|
                              destruct (H x0 _ H3); eauto]].
  all: try solve
  [intros y h1; inversion BI; [inversion H3; subst; clear H3; eauto|
                               destruct (H2 x0 _ H3); eauto]].

  (* rest of the cases *)
  all: intros y IN.

  (* more splitting, assumption has a union type *)
  all: try match goal with
    [ H7 : ?y `in` union ?A ?B |- _ ] =>
    apply F.union_iff in H7; destruct H7; eauto end.

  all: try solve [ apply notin_empty_1 in IN; contradiction].
  all: try solve [ assert (x = y) by fsetdec; subst; eapply binds_In; eauto ].
  all: try solve [ destruct (H _ _ b); eauto ].

  all: try solve [apply H1; eauto; simpl; auto].
  all: try solve [apply H2; eauto; simpl; auto].
  all: try solve [apply H3; eauto; simpl; auto].
  all: try solve [apply H4; eauto; simpl; auto].

  all: try match goal with
    [ H5 : forall x : atom, (x `in` ?L -> False) -> ( _ /\ _ ) |- _ ] =>
    pick fresh x; destruct (H5 x); eauto; split_hyp
           end.

  all: try match goal with
    [ H4 : ?y `in` fv_tm_tm_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_tm_tm_tm (open_tm_wrt_tm ?B (a_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; auto;
    eapply fv_tm_tm_tm_open_tm_wrt_tm_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.
  all: try match goal with
    [ H4 : ?y `in` fv_co_co_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_co_co_tm (open_tm_wrt_tm ?B (a_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_co_co_tm_open_tm_wrt_tm_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.
  all: try match goal with
    [ H4 : ?y `in` fv_tm_tm_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_tm_tm_tm (open_tm_wrt_co ?B (g_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_tm_tm_tm_open_tm_wrt_co_lower; auto);
    simpl in h0; apply F.add_neq_iff in h0; auto
           end.
  all: try match goal with
    [ H4 : ?y `in` fv_co_co_tm ?B,
      H5 : ∀ a : atom,
       a `in` fv_co_co_tm (open_tm_wrt_co ?B (g_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_co_co_tm_open_tm_wrt_co_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.

  all: try (simpl in *; eapply fv_tm_tm_tm_open_tm_wrt_tm_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).
  all: try (simpl in *; eapply fv_co_co_tm_open_tm_wrt_tm_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).
  all: try (simpl in *; eapply fv_tm_tm_tm_open_tm_wrt_co_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).
  all: try (simpl in *; eapply fv_co_co_tm_open_tm_wrt_co_upper in IN;
    apply F.union_iff in IN; destruct IN; eauto).

  all: try (apply H0 in IN; apply notin_empty_1 in IN; contradiction).
  all: try (apply H1 in IN; apply notin_empty_1 in IN; contradiction).

  all: try match goal with
    [ H7 : ?y `in` union ?A ?B |- _ ] =>
    apply F.union_iff in H7; destruct H7; eauto end.

  all: try solve [apply H1; eauto; simpl; auto].
  all: try solve [apply H2; eauto; simpl; auto].
  all: try solve [apply H3; eauto; simpl; auto].
  all: try solve [apply H4; eauto; simpl; auto].
  all: try solve [apply H5; eauto; simpl; auto].

  all: try match goal with
    [IN : ?y `in` singleton ?c |- _ ] =>
                assert (c = y) by fsetdec; subst; eapply binds_In; eauto
     end.
  all: try solve [ destruct (H0 _ _ b0); simpl in *; eauto].

  all: try  match goal with
    [ H4 : ?y `in` fv_tm_tm_co ?B,
      H5 : ∀ a : atom,
       a `in` fv_tm_tm_co (open_co_wrt_tm ?B (a_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_tm_tm_co_open_co_wrt_tm_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.

  all: try match goal with
    [ H4 : ?y `in` fv_co_co_co ?B,
      H5 : ∀ a : atom,
       a `in` fv_co_co_co (open_co_wrt_tm ?B (a_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_co_co_co_open_co_wrt_tm_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.

  all: try match goal with
    [ H4 : ?y `in` fv_tm_tm_co ?B,
      H5 : ∀ a : atom,
       a `in` fv_tm_tm_co (open_co_wrt_co ?B (g_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_tm_tm_co_open_co_wrt_co_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.

  all: try match goal with
    [ H4 : ?y `in` fv_co_co_co ?B,
      H5 : ∀ a : atom,
       a `in` fv_co_co_co (open_co_wrt_co ?B (g_Var_f ?x))
            → a `in` dom ([(?x, ?s)] ++ ?G) |- _ ] =>
    assert (h0: y `in` dom ([(x,s)] ++ G)) by
    (eapply H5; eauto;
    eapply fv_co_co_co_open_co_wrt_co_lower; auto);
      simpl in h0; apply F.add_neq_iff in h0; auto
           end.

  (* Eta cases *)

  all: try match goal with
      [ IN : ?y `in` ?fv_tm_tm_tm ?a,
        H : ∀ a : atom, a `in` ?fv_tm_tm_tm ?b → a `in` dom ?G,
        e : ∀ x : atom,
            (x `in` ?L → False) →
            ?open_tm_wrt_tm ?a (a_Var_f x) = ?c
       |- _ ] =>
      eapply H; pick fresh x; move: (e x ltac:(auto)) => h0;
      assert (x <> y); [ fsetdec|];
      clear Fr;
      have h1: y `in` fv_tm_tm_tm (open_tm_wrt_tm a (a_Var_f x));
      [ move: (fv_tm_tm_tm_open_tm_wrt_tm_lower a (a_Var_f x)) => ?;
        move: (fv_co_co_tm_open_tm_wrt_tm_lower a (a_Var_f x)) => ?;
        fsetdec|
      rewrite h0 in h1;
      simpl in h1;
      fsetdec ]
    end.

  all: try match goal with
      [ IN : ?y `in` ?fv_tm_tm_tm ?a,
        H : ∀ a : atom, a `in` ?fv_tm_tm_tm ?b → a `in` dom ?G,
        e : ∀ x : atom,
            (x `in` ?L → False) →
            ?open_tm_wrt_tm ?a (g_Var_f x) = ?c
       |- _ ] =>
      eapply H; pick fresh x; move: (e x ltac:(auto)) => h0;
      assert (x <> y); [ fsetdec|];
      clear Fr;
      have h1: y `in` fv_tm_tm_tm (open_tm_wrt_tm a (g_Var_f x));
      [ move: (fv_tm_tm_tm_open_tm_wrt_co_lower a (g_Var_f x)) => ?;
        move: (fv_co_co_tm_open_tm_wrt_co_lower a (g_Var_f x)) => ?;
        fsetdec|];
      rewrite h0 in h1;
      simpl in h1;
      fsetdec
    end.

  (* last hard cases *)
  - assert (FR1 : x `notin` L) by auto. assert (FR2 : x <> y) by auto.
    clear Fr. clear H0. clear r. clear r0.
    clear H19. clear H20. clear H22. clear H24.
    clear H10 H12 H13 H7 H4 H9 H6.
    move: (e x FR1) => EX.
    match goal with
      [H18 :  y `in` fv_tm_tm_tm b3 |- _ ] =>
       erewrite fv_tm_tm_tm_open_tm_wrt_tm_lower  in H18;
       erewrite EX in H18;
       erewrite fv_tm_tm_tm_open_tm_wrt_tm_upper  in H18;
       apply F.union_iff in H18; destruct H18 as [h2 | h3]
       end.
    simpl in h2.
    apply F.union_iff in h2; destruct h2 as [h4 | h5].
    fsetdec.
    eauto.

    assert (y `in` dom ((x ~ Tm A1) ++ G)). eapply H23.
    eapply fv_tm_tm_tm_open_tm_wrt_tm_lower.  auto.
    simpl in H0; apply F.add_neq_iff in H0; auto.
  - assert (FR1 : x `notin` L) by auto. assert (FR2 : x <> y) by auto.
    clear Fr. clear H0. clear r. clear r0.
    move: (e x FR1) => EX.
    match goal with
      [H14 : y `in` fv_co_co_tm b3 |- _ ] =>
      erewrite fv_co_co_tm_open_tm_wrt_tm_lower  in H14;
        erewrite EX in H14;
        erewrite fv_co_co_tm_open_tm_wrt_tm_upper  in H14;
        apply F.union_iff in H14; destruct H14 as [h2 | h3]
    end.
    simpl in h2.
    apply F.union_iff in h2; destruct h2 as [h4 | h5].
    fsetdec.
    eauto.

    assert (y `in` dom ((x ~ Tm A1) ++ G)). eapply H24.
    eapply fv_co_co_tm_open_tm_wrt_tm_lower.  auto.
    simpl in H0; apply F.add_neq_iff in H0; auto.
Qed.

Definition AnnTyping_context_fv  := @first  _ _ _ _ _ ann_context_fv_mutual.
Definition AnnPropWff_context_fv := @second _ _ _ _ _ ann_context_fv_mutual.
Definition AnnIso_context_fv     := @third  _ _ _ _ _ ann_context_fv_mutual.
Definition AnnDefEq_context_fv   := @fourth _ _ _ _ _ ann_context_fv_mutual.
Definition AnnCtx_context_fv     := @fifth  _ _ _ _ _ ann_context_fv_mutual.


Require Import Omega.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.

Set Implicit Arguments.

Module MemoryFacts.
  Lemma promise_time_lt
        promises1 mem1 loc from to val released promises2 mem2 kind
        (PROMISE: Memory.promise promises1 mem1 loc from to val released promises2 mem2 kind):
    Time.lt from to.
  Proof.
    inv PROMISE.
    - inv MEM. inv ADD. auto.
    - inv MEM. inv SPLIT. auto.
    - inv MEM. inv LOWER. auto.
  Qed.

  Lemma write_time_lt
        promises1 mem1 loc from to val released promises2 mem2 kind
        (WRITE: Memory.write promises1 mem1 loc from to val released promises2 mem2 kind):
    Time.lt from to.
  Proof.
    inv WRITE. eapply promise_time_lt. eauto.
  Qed.

  Lemma promise_get1_diff
        promises1 mem1 loc from to val released promises2 mem2 kind
        l t f v r
        (PROMISE: Memory.promise promises1 mem1 loc from to val released promises2 mem2 kind)
        (GET: Memory.get l t mem1 = Some (f, Message.mk v r))
        (DIFF: (loc, to) <> (l, t)):
    exists f', Memory.get l t mem2 = Some (f', Message.mk v r).
  Proof.
    inv PROMISE.
    - erewrite Memory.add_o; eauto. condtac; ss.
      + des. subst. congr.
      + esplits; eauto.
    - erewrite Memory.split_o; eauto. repeat condtac; ss.
      + des. subst. congr.
      + guardH o. des. subst.
        exploit Memory.split_get0; eauto. i. des.
        rewrite GET3 in GET. inv GET. esplits; eauto.
      + esplits; eauto.
    - erewrite Memory.lower_o; eauto. condtac; ss.
      + des. subst. congr.
      + esplits; eauto.
  Qed.

  Lemma promise_get_inv_diff
        promises1 mem1 loc from to val released promises2 mem2 kind
        l t f v r
        (PROMISE: Memory.promise promises1 mem1 loc from to val released promises2 mem2 kind)
        (GET: Memory.get l t mem2 = Some (f, Message.mk v r))
        (DIFF: (loc, to) <> (l, t)):
    exists f', Memory.get l t mem1 = Some (f', Message.mk v r).
  Proof.
    revert GET. inv PROMISE.
    - erewrite Memory.add_o; eauto. condtac; ss.
      + des. subst. congr.
      + i. inv GET. esplits; eauto.
    - erewrite Memory.split_o; eauto. repeat condtac; ss.
      + des. subst. congr.
      + guardH o. des. subst. i. inv GET.
        exploit Memory.split_get0; try exact MEM; eauto. i. des. esplits; eauto.
      + i. esplits; eauto.
    - erewrite Memory.lower_o; eauto. condtac; ss.
      + des. subst. congr.
      + i. inv GET. esplits; eauto.
  Qed.

  Lemma promise_get_promises_inv_diff
        promises1 mem1 loc from to val released promises2 mem2 kind
        l t f v r
        (PROMISE: Memory.promise promises1 mem1 loc from to val released promises2 mem2 kind)
        (GET: Memory.get l t promises2 = Some (f, Message.mk v r))
        (DIFF: (loc, to) <> (l, t)):
    exists f', Memory.get l t promises1 = Some (f', Message.mk v r).
  Proof.
    revert GET. inv PROMISE.
    - erewrite Memory.add_o; eauto. condtac; ss.
      + des. subst. congr.
      + i. inv GET. esplits; eauto.
    - erewrite Memory.split_o; eauto. repeat condtac; ss.
      + des. subst. congr.
      + guardH o. des. subst. i. inv GET.
        exploit Memory.split_get0; try exact PROMISES; eauto. i. des. esplits; eauto.
      + i. esplits; eauto.
    - erewrite Memory.lower_o; eauto. condtac; ss.
      + des. subst. congr.
      + i. inv GET. esplits; eauto.
  Qed.

  Lemma remove_get_diff
        promises0 mem0 loc from to val released promises1
        l t
        (LOC: loc <> l)
        (LE: Memory.le promises0 mem0)
        (REMOVE: Memory.remove promises0 loc from to val released promises1):
    Memory.get l t promises1 = Memory.get l t promises0.
  Proof.
    erewrite Memory.remove_o; eauto. condtac; ss.
    des. subst. congr.
  Qed.

  Lemma remove_cell_diff
        promises0 loc from to val released promises1
        l
        (LOC: loc <> l)
        (REMOVE: Memory.remove promises0 loc from to val released promises1):
    promises1 l = promises0 l.
  Proof.
    apply Cell.ext. i. eapply remove_get_diff; eauto. refl.
  Qed.

  Lemma get_same_from_aux
        l f t1 t2 m msg1 msg2
        (GET1: Memory.get l t1 m = Some (f, msg1))
        (GET2: Memory.get l t2 m = Some (f, msg2))
        (LE: Time.le t1 t2)
        (T1: t1 <> Time.bot):
    t1 = t2 /\ msg1 = msg2.
  Proof.
    inv LE; cycle 1.
    { inv H. rewrite GET1 in GET2. inv GET2. ss. }
    destruct (m l).(Cell.WF). exfalso.
    assert (t1 <> t2).
    { ii. subst. eapply Time.lt_strorder. eauto. }
    eapply DISJOINT; try exact H0; eauto.
    - apply Interval.mem_ub. exploit VOLUME; try exact GET1; eauto. i. des; ss.
      inv x. congr.
    - econs; ss.
      + exploit VOLUME; try exact GET1; eauto. i. des; ss. inv x. congr.
      + left. ss.
  Qed.

  Lemma get_same_from
        l f t1 t2 m msg1 msg2
        (GET1: Memory.get l t1 m = Some (f, msg1))
        (GET2: Memory.get l t2 m = Some (f, msg2))
        (T1: t1 <> Time.bot)
        (T2: t2 <> Time.bot):
    t1 = t2 /\ msg1 = msg2.
  Proof.
    destruct (Time.le_lt_dec t1 t2).
    - eapply get_same_from_aux; eauto.
    - exploit get_same_from_aux; (try by left; eauto); eauto. i. des. ss.
  Qed.

  Lemma write_not_bot
        pm1 mem1 loc from to val released pm2 mem2 kind
        (WRITE: Memory.write pm1 mem1 loc from to val released pm2 mem2 kind):
    to <> Time.bot.
  Proof.
    ii. subst. inv WRITE. inv PROMISE.
    - inv MEM. inv ADD. inv TO.
    - inv MEM. inv SPLIT. inv TS12.
    - inv MEM. inv LOWER. inv TS0.
  Qed.

  Lemma write_add_promises
        promises1 mem1 loc from to val released promises2 mem2
        (WRITE: Memory.write promises1 mem1 loc from to val released promises2 mem2 Memory.op_kind_add):
    promises2 = promises1.
  Proof.
    apply Memory.ext. i.
    inv WRITE. inv PROMISE.
    erewrite (@Memory.remove_o promises2); eauto. condtac; ss.
    - des. subst. symmetry. eapply Memory.add_get0. eauto.
    - guardH o. erewrite (@Memory.add_o promises0); eauto. condtac; ss.
  Qed.

  Lemma promise_exists_None
        promises1 mem1 loc from to val released
        (LE: Memory.le promises1 mem1)
        (GET: Memory.get loc to promises1 = Some (from, Message.mk val released))
        (LT: Time.lt from to):
    exists promises2 mem2,
      Memory.promise promises1 mem1 loc from to val None promises2 mem2 (Memory.op_kind_lower released).
  Proof.
    exploit Memory.lower_exists; eauto; try by econs. i. des.
    exploit LE; eauto. i.
    exploit Memory.lower_exists; eauto; try by econs. i. des.
    esplits. econs; eauto. apply Time.bot_spec.
  Qed.

  Lemma some_released_time_lt
  mem loc from to val released
  (CLOSED: Memory.closed mem)
  (GET: Memory.get loc to mem = Some (from, Message.mk val (Some released))):
    Time.lt from to.
  Proof.
    destruct (mem loc).(Cell.WF). exploit VOLUME; eauto. i. des; ss. inv x.
    inv CLOSED. rewrite INHABITED in GET. inv GET.
  Qed.
End MemoryFacts.


Require Import Rules Channel DataTypes MsiState ChannelAxiomHelp.

Module mkLatestValueAxioms (ch: ChannelPerAddr mkDataTypes).
  Import mkDataTypes ch.

  Theorem toChild: forall {n a t p m},
                     defined n -> defined p ->
                     parent n p ->
                     mark mch p n a t m -> from m = MsiState.In -> dataM m = data p a t.
  Proof.
    intros n a t p m defn defp n_p markm fromm.
    unfold mark in *; unfold data in *. unfold mkDataTypes.mark in *.
    destruct (trans oneBeh t).
    firstorder.
    firstorder.
    destruct markm as [[_ [_ [use _]]] _]; discriminate.
    destruct markm as [[use0 [_ [_ [_ [_ [use1 [use2 _]]]]]]] use3];
    rewrite <- use1 in *; rewrite use3 in *; rewrite use0 in *; assumption.
    firstorder.
    destruct markm as [[_ [_ [use _]]] _]; discriminate.
    destruct markm as [[use3 [use0 _]] _];
    rewrite use3 in *; rewrite use0 in *; pose proof (noCycle n_p p1); firstorder.
    firstorder.
    destruct markm as [[use3 [use0 _]] _];
    rewrite use3 in *; rewrite use0 in *; pose proof (noCycle n_p p1); firstorder.
    firstorder.
  Qed.

  Theorem fromParent: forall {n a t p m}, defined n -> defined p ->
                      parent n p ->
                      recv mch p n a t m -> from m = MsiState.In -> data n a (S t) = dataM m.
  Proof.
    intros n a t p m defn defp n_p recvm fromm.
    unfold recv in *; unfold data; unfold mkDataTypes.recv in *.
    destruct (trans oneBeh t).
    firstorder.
    firstorder.
    firstorder.
    destruct recvm as [[use1 [use2 _]] _];
    rewrite use1 in *; rewrite use2 in *; pose proof (noCycle n_p p1); firstorder.
    simpl;
    assert (eq: m0 = List.last (ch (sys oneBeh t) mch p0 c) dmy) by auto;
      assert (eq2: a0 = addrB m0) by auto;
    destruct recvm as [[use1 [use2 [_ [use3 [_ [use4 [use5 _]]]]]]] use0]; rewrite <- eq in *;
    rewrite use1 in *; rewrite use2 in *;
    rewrite use3 in *; rewrite use4 in *; rewrite use0 in *; rewrite eq2 in *; rewrite fromm in *; rewrite use5 in *;
    destruct (decTree n n); destruct (decAddr a a); firstorder.
    firstorder.
    assert (e2: r = List.last (ch (sys oneBeh t) mch p0 c) dmy) by auto.
    rewrite <- e2 in recvm.
    rewrite e in *.
    destruct recvm as [[_ [_ [use _]]] _]; discriminate.
    destruct recvm as [[use1 [use2 _]] _];
    rewrite use1 in *; rewrite use2 in *; pose proof (noCycle n_p p1); firstorder.
    firstorder.
    assert (e2: r = List.last (ch (sys oneBeh t) mch p0 c) dmy) by auto.
    rewrite <- e2 in recvm.
    rewrite e in *.
    destruct recvm as [[_ [_ [use _]]] _]; discriminate.
  Qed.

  Theorem toParent: forall {n a t c m},
                      defined n -> defined c ->
                      parent c n ->
                      mark mch c n a t m -> slt Sh (from m) -> dataM m = data c a t.
  Proof.
    intros n a t c m defn defc c_n markm isM.
    assert (fromm: from m = Mo) by (unfold slt; destruct (from m); firstorder); clear isM.
    unfold mark in *; unfold data in *. unfold mkDataTypes.mark in *.
    destruct (trans oneBeh t).
    firstorder.
    firstorder.
    destruct markm as [[_ [_ [use _]]] _]; discriminate.
    destruct markm as [[use0 [_ [_ [_ [_ [use1 [use2 _]]]]]]] use3];
    rewrite <- use1 in *; rewrite use3 in *; rewrite use0 in *; assumption.
    firstorder.
    destruct markm as [[_ [_ [use _]]] _]; discriminate.
    destruct markm as [[use0 [_ [_ [_ [_ [use1 [use2 _]]]]]]] use3];
    rewrite <- use1 in *; rewrite use3 in *; rewrite use0 in *; assumption.
    firstorder.
    destruct markm as [[use0 [_ [_ [_ [_ [use1 [use2 _]]]]]]] use3];
    rewrite <- use1 in *; rewrite use3 in *; rewrite use0 in *; assumption.
    firstorder.
  Qed.

  Theorem fromChild: forall {n a t c m},
                       defined n -> defined c ->
                       parent c n ->
                       recv mch c n a t m -> slt Sh (from m) -> data n a (S t) = dataM m.
  Proof.
    intros n a t c m defn defc c_n recvm isM.
    assert (fromm: from m = Mo) by (unfold slt; destruct (from m); firstorder); clear isM.
    unfold recv in *; unfold data in *. unfold mkDataTypes.recv in *.
    destruct (trans oneBeh t).
    firstorder.
    firstorder.
    firstorder.
    pose proof (enqC2P p0 n0) as contra.
    rewrite contra in recvm.
    destruct recvm as [[_ [_ [use _]]] _]; discriminate.
    destruct recvm as [[use1 [use2 _]] _];
    rewrite use1 in *; rewrite use2 in *; pose proof (noCycle c_n p0); firstorder.
    firstorder.
    assert (re: r = List.last (ch (sys oneBeh t) mch p c0) dmy) by auto.
    rewrite re in e.
    rewrite e in recvm.
    destruct recvm as [[_ [_ [use _]]] _]; discriminate.
    simpl;
    assert (eq: m0 = List.last (ch (sys oneBeh t) mch c0 p) dmy) by auto;
      assert (eq2: a0 = addrB m0) by auto;
    destruct recvm as [[use1 [use2 [_ [use3 [_ [use4 [use5 _]]]]]]] use0]; rewrite <- eq in *;
    rewrite use1 in *; rewrite use2 in *;
    rewrite use3 in *; rewrite use4 in *; rewrite use0 in *; rewrite eq2 in *; rewrite fromm in *; rewrite use5 in *;
    destruct (decTree n n); destruct (decAddr a a); firstorder.
    firstorder.
    assert (re: r = List.last (ch (sys oneBeh t) mch p c0) dmy) by auto.
    rewrite re in e.
    rewrite e in recvm.
    destruct recvm as [[_ [_ [use _]]] _]; discriminate.
  Qed.

  Theorem initLatest: forall a, data hier a 0 = initData a /\ state hier a 0 = Mo.
  Proof.
    intros a.
    unfold data; unfold state.
    pose proof (init oneBeh) as initi.
    rewrite initi.
    unfold initGlobalState.
    simpl.
    destruct (decTree hier hier) as [eq |neq].
    constructor; firstorder.
    firstorder.
  Qed.

  Theorem deqImpData: forall {a n t i}, defined n -> deqR a n i t -> desc (reqFn a n i) = St ->
                                          data n a (S t) = dataQ (reqFn a n i).
  Proof.
    intros a n t i defn deqr isSt.
    unfold deqR in *; unfold data.
    destruct (trans oneBeh t).
    destruct deqr as [e1 [eq reqI]].
    rewrite <- e1, eq in *.
    rewrite reqI in e.
    rewrite e in isSt.
    discriminate.
    simpl.
    destruct deqr as [e1 [seq reqi]].
    destruct (decTree n c) as [eq | neq].
    rewrite e1, seq in *.
    rewrite reqi in *.
    destruct (decAddr a a).
    reflexivity.
    firstorder.
    assert (n = c) by auto; firstorder.
    firstorder.
    firstorder.
    firstorder.
    firstorder.
    firstorder.
    firstorder.
    firstorder.
    firstorder.
  Qed.

  Theorem changeData:
    forall {n a t}, defined n ->
                    data n a (S t) <> data n a t ->
                    (exists m, (exists p, defined p /\ parent n p /\ recv mch p n a t m /\ from m = MsiState.In) \/
                               (exists c, defined c /\ parent c n /\ recv mch c n a t m /\
                                          slt Sh (from m))) \/
                    exists i, deqR a n i t /\ desc (reqFn a n i) = St.
  Proof.
    intros n a t defn dtNeq.
    unfold data in *; unfold recv in *; unfold deqR in *; unfold mkDataTypes.recv in *.
    destruct (trans oneBeh t).

    simpl in *. firstorder.

    simpl in *.
    right.
    destruct (decTree n c).
    destruct (decAddr a a0).
    rewrite e1, e2 in *.
    exists (req (sys oneBeh t) a c).
    firstorder; auto.
    rewrite e2 in *.
    firstorder.
    rewrite e2 in *.
    firstorder.

    simpl in *.
    firstorder.

    simpl in *.
    firstorder.

    simpl in *.
    firstorder.

    simpl in *.
    firstorder.

    simpl in *.
    left.
    exists (Build_Mesg (fromB m) (toB m) (addrB m) (dataBM m) (List.last (labelCh t mch p c) 0)).
    simpl.
    left.
    exists p.
    assert (sth: m = List.last (ch (sys oneBeh t) mch p c) dmy) by auto.
    rewrite <- sth in *.
    destruct (decTree n c) as [nEq | nNeq].
    rewrite <- nEq in *.
    destruct (decAddr a a0) as [aEq | aNeq].
    destruct (fromB m); intuition.
    firstorder.
    firstorder.

    simpl in *; firstorder.
    simpl in *; firstorder.

    simpl in *.
    left.
    exists (Build_Mesg (fromB m) (toB m) (addrB m) (dataBM m) (List.last (labelCh t mch c p) 0)).
    simpl.
    right.
    exists c.
    assert (sth: m = List.last (ch (sys oneBeh t) mch c p) dmy) by auto.
    rewrite <- sth in *.
    destruct (decTree n p) as [nEq | nNeq].
    rewrite <- nEq in *.
    destruct (decAddr a a0) as [aEq | aNeq].
    pose proof (enqC2P p0 n0) as sth2.
    rewrite <- sth in sth2.
    rewrite sth2.
    destruct (fromB m); intuition.
    firstorder.
    firstorder.

    simpl in *; firstorder.
    simpl in *; firstorder.
  Qed.

  Theorem deqImpNoSend: forall {c a i t},
                          defined c -> deqR a c i t ->
                          forall {m p}, defined p -> ~ mark mch c p a t m.
  Proof.
    unfold not; intros c a i t defc deqr m p defp markm.
    unfold deqR in *; unfold mark in *; unfold mkDataTypes.mark in *.

    destruct (trans oneBeh t); firstorder.
  Qed.
End mkLatestValueAxioms.


Require Export Iron.Language.SystemF2Store.Store.
Require Export Iron.Language.SystemF2Store.StepContext.
Require Export Iron.Language.SystemF2Store.TyJudge.
Require Export Iron.Language.SystemF2Store.SubstExpExp.
Require Export Iron.Language.SystemF2Store.Exp.

(********************************************************************)
(** * Single Small Step Evaluation *)
(** The single step rules model the individual transitions that the
     machine can make at runtime. *)

Inductive STEP : store -> exp -> store -> exp -> Prop :=

 (* Step some sub-expression in an evaluation context *)
 | EsContext
   :  forall C s x s' x'
   ,  exp_ctx C
   -> STEP s x      s' x'
   -> STEP s (C x)  s' (C x')

 | EsLamApp
   : forall s t11 x12 v2
   ,  wnfX v2
   -> STEP s (XApp   (XLam t11 x12) v2)
           s (substXX 0 v2 x12)

 (* Type application *)
 | EsLAMAPP
   :  forall s x12 t2
   ,  STEP s (XAPP (XLAM x12) t2)
           s (substTX 0 t2 x12)

 (* Allocate a new data object in the store *)
 | EsAlloc
   :  forall s dc tsParam xs svs
   ,  Forall2 svalueOf xs svs
   -> STEP s                      (XCon dc tsParam xs)
           (snoc (SObj dc svs) s) (XLoc (length s))

 (* Case branching reads data objects from the store *)
 | EsCaseAlt
   :  forall s dc svs vs alts x l
   ,  get l s        = Some (SObj dc svs)
   -> getAlt dc alts = Some (AAlt dc x)
   -> Forall2 svalueOf vs svs
   -> STEP s (XCase (XLoc l) alts)
           s (substXXs 0 vs x)

 (* If an update operator matches the data constructor in the heap then
    update the appropriate field. *)
 | EsUpdate
   :  forall l s dc cn i tsParam svs vField svField
   ,  get l s =  Some (SObj dc svs)
   -> dc      =  cn
   -> svalueOf vField svField
   -> STEP s
           (XUpdate cn i tsParam (XLoc l) vField)
           (replace l (SObj dc (replace i svField svs)) s)
           xUnit

 (* If an update operator does not match the data constructor in the heap
    then just return unit. *)
 | EsUpdateSkip
   :  forall l s dc cn i tsParam svs vField
   ,  get l s =  Some (SObj dc svs)
   -> ~(dc    = cn)
   -> STEP s (XUpdate cn i tsParam (XLoc l) vField)
           s xUnit.

Hint Constructors STEP.

(* Multi-step evaluation
   A sequence of small step transitions.
   As opposed to STEPSL, this version has an append constructor
   ESAppend that makes it easy to join two evaluations together.
   We use this when converting big-step evaluations to small-step. *)
Inductive STEPS : store -> exp -> store -> exp -> Prop :=

 (* After no steps, we get the same exp.
    We need this constructor to match the EVDone constructor
    in the big-step evaluation, so we can convert between big-step
    and multi-step evaluations. *)
 | EsNone
   :  forall s1 x1
   ,  STEPS s1 x1 s1 x1

 (* Take a single step. *)
 | EsStep
   :  forall s1 x1 s2 x2
   ,  STEP  s1 x1 s2 x2
   -> STEPS s1 x1 s2 x2

 (* Combine two evaluations into a third. *)
 | EsAppend
   :  forall s1 x1 s2 x2 s3 x3
   ,  STEPS s1 x1 s2 x2 -> STEPS s2 x2 s3 x3
   -> STEPS s1 x1 s3 x3.

Hint Constructors STEPS.

(* Stepping a wnf doesn't change it. *)
Lemma step_wnfX
 :  forall x v s1 s2
 ,  wnfX x -> STEP s1 x s2 v -> v = x.
Proof.
 intros x v s1 s2 HW HS.
 induction HS; nope.
  destruct H; auto; nope.
Qed.

(* If we have a list context we can step some expression
   applied to a data constructor *)
Lemma step_context_XCon_exists
 :  forall  C x dc ts s1 s2
 ,  exps_ctx wnfX C
 -> (exists x', STEP s1 x s2 x')
 -> (exists x', STEP s1 (XCon dc ts (C x)) s2 (XCon dc ts (C x'))).
Proof.
 intros C x dc ts s1 s2 HC HS.
 shift x'.
 eapply (EsContext (fun xx => XCon dc ts (C xx))); auto.
Qed.

(* Multi-step evaluating a wnf doesn't change it. *)
Lemma steps_wnfX
 :  forall x v s1 s2
 ,  wnfX x -> STEPS s1 x s2 v -> v = x.
Proof.
 intros x v s1 s2 HW HS.
 induction HS; auto.
  Case "EsStep".
   eapply step_wnfX; eauto.

  Case "EsAppend".
   have (x2 = x1).
   subst. auto.
Qed.

(* Multi-step evaluation in a context. *)
Lemma steps_context
 :  forall C s1 x1 s2 x1'
 ,  exp_ctx C
 -> STEPS s1 x1     s2 x1'
 -> STEPS s1 (C x1) s2 (C x1').
Proof.
 intros C s1 x1 s2 x1' HC HS.
 induction HS; eauto.
Qed.

(* Multi-step evaluation of a data constructor argument. *)
Lemma steps_context_XCon
 :  forall C s1 x s2 v dc ts
 ,  exps_ctx wnfX C
 -> STEPS s1 x s2 v
 -> STEPS s1 (XCon dc ts (C x)) s2 (XCon dc ts (C v)).
Proof.
 intros C s1 x s2 v dc ts HC HS.
 induction HS; auto.

 Case "XCon".
  lets D: EsContext XcCon; eauto.
  eauto.
Qed.

(* TODO: First premise doesn't work because each xs uses a different store
Lemma steps_in_XCon
 :  forall xs ts vs dc
 ,  Forall2 STEPS xs vs
 -> Forall wnfX vs
 -> STEPS (XCon dc ts xs) (XCon dc ts vs).
Proof.
 intros xs ts vs dc HS HW.
 lets HC: make_chain HS HW.
  eapply steps_wnfX.

 clear HS. clear HW.
 induction HC; auto.
  eapply (EsAppend (XCon dc ts (C x)) (XCon dc ts (C v))); auto.
  eapply steps_context_XCon; auto.
Qed.
*)

(********************************************************************)
(* Left linearised multi-step evaluation
   As opposed to STEPS, this version provides a single step at a time
   and does not have an append constructor. This is convenient
   when converting a small-step evaluations to big-step, via the
   eval_expansion lemma. *)
Inductive STEPSL : store -> exp -> store -> exp -> Prop :=
 | EslNone
   : forall s1 x1
   , STEPSL s1 x1 s1 x1

 | EslCons
   :  forall s1 x1 s2 x2 s3 x3
   ,  STEP   s1 x1 s2 x2 -> STEPSL s2 x2 s3 x3
   -> STEPSL s1 x1 s3 x3.

Hint Constructors STEPSL.

(* Transitivity of left linearised multi-step evaluation.
   We use this when "flattening" a big step evaluation to the
   small step one. *)
Lemma stepsl_trans
 :  forall s1 x1 s2 x2 s3 x3
 ,  STEPSL s1 x1 s2 x2 -> STEPSL s2 x2 s3 x3
 -> STEPSL s1 x1 s3 x3.
Proof.
 intros s1 x1 s2 x2 s3 x3 H1 H2.
 induction H1; eauto.
Qed.

(* Linearise a regular multi-step evaluation.
   This flattens out all the append constructors, leaving us with
   a list of individual transitions. *)
Lemma stepsl_of_steps
 :  forall s1 x1 s2 x2
 ,  STEPS  s1 x1 s2 x2
 -> STEPSL s1 x1 s2 x2.
Proof.
 intros s1 x1 s2 x2 HS.
 induction HS;
  eauto using stepsl_trans.
Qed.