Require Import AutoSep.
Require Import TimeAbstract.

(** * Like TrivialMem, but tests use of equality prover in symbolic evaluation *)

Definition readS : spec := SPEC("x", "y") reserving 1
  Al v,
  PRE[V] V "x" =*> v
  POST[R] [| R = v |] * V "x" =*> v.

Definition read := bmodule "read" {{
  bfunction "read"("x", "y", "z") [readS]
    If ("x" = "y") {
      "z" <-* "y"
    } else {
      "z" <-* "x"
    };;
    Return "z"
  end
}}.

Theorem readOk : moduleOk read.
(*TIME  Clear Timing Profile. *)
(*TIME  (time "vcgen:all" *) vcgen
(*TIME ) *); time_abstract ltac:(sep_auto).
(*TIME  Print Timing Profile. *)
Qed.


Require Import ZArith.
Require Import Lia.
Require Import List.

(** * Useful tactics *)
Ltac inv H := inversion H; clear H; subst.
Ltac gdep x := generalize dependent x.

(* inv by name of the Inductive relation *)
Ltac invh f :=
    match goal with
      [ id: f |- _ ] => inv id
    | [ id: f _ |- _ ] => inv id
    | [ id: f _ _ |- _ ] => inv id
    | [ id: f _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ _ _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ _ _ _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ _ _ _ _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ _ _ _ _ _ _ _ _ |- _ ] => inv id
    | [ id: f _ _ _ _ _ _ _ _ _ _ _ _ _ _ |- _ ] => inv id
    end.

Require Coq.Strings.String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

(* ---------------------------------------------------------------- *)
(* Tactics for replacing definitional equality with provable equality *)
Module EqualityTactics.
(* NC: Using a module here to show where these equality related defs
start and end.  It appears that [Ltac] defs don't escape from sections
... *)

Lemma modusponens: forall (P Q: Prop), P -> (P -> Q) -> Q.
Proof.
auto. Qed.

(* Existentially instantiate a hypothesis. *)
Ltac exploit x :=
 refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _ _) _)
 || refine (modusponens _ _ (x _ _ _) _)
 || refine (modusponens _ _ (x _ _) _)
 || refine (modusponens _ _ (x _) _).

Ltac try_exploit l :=
  try (exploit l;
       try solve [eauto];
       let H := fresh "H" in intros H;
       repeat match goal with
                | [H : (exists _, _) |- _ ] => destruct H
                | [H : _ /\ _ |- _ ] => destruct H
              end;
       subst).

(* NC: need to change the order of the premises, versus [modusponens],
so I can get at the implication [P -> Q] first; the proof of [P] may
generate arbitrarily many subgoals. *)
Lemma cut': forall (P Q: Prop), (P -> Q) -> P -> Q.
Proof. auto. Qed.

(* Like [exploit], but using [cut']. *)
Ltac ecut' x :=
    refine (cut' _ _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _ _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _ _))
 || refine (cut' _ _ _ (x _ _ _))
 || refine (cut' _ _ _ (x _ _))
 || refine (cut' _ _ _ (x _))
 || refine (cut' _ _ _ (x)).

(* Like [exact H], but allow indexes to be definitionally different if
   they are provably equal.

   For example, a goal

     H : T a1 ... an
     ---------------
     T b1 ... bn

   is reduced to proving

     a1 = b1, ..., an = bn

   by [exact_f_equal H].
*)
Ltac exact_f_equal h :=
  let h_eq := fresh "h_eq" in
  let t := type of h in
  match goal with
  | [ |- ?g ] =>
    cut (g = t); [ intro h_eq; rewrite h_eq; exact h | f_equal; auto ]
  end.

(* A generalization of [exact_f_equal] to implications.

   This is like [applys_eq] from LibTactics.v, except you do not need
   to specify which vars you want equalities for.  See Software
   Foundations for a description of [applys_eq]:
   http://www.cis.upenn.edu/~bcpierce/sf/UseTactics.html#lab869

*)
Ltac apply_f_equal h :=
  let h_specialized := fresh "h_specialized" in
  let t := intro h_specialized; exact_f_equal h_specialized in
  (ecut' h; [t|..]).

(* Solve sub goals with [tac], using [f_equal] to make progress when
   possible
*)
Ltac rec_f_equal tac :=
  tac || (progress f_equal; rec_f_equal tac).

Section Test.

Open Scope nat.

Lemma test_apply_f_equal:
  forall (n1 n2: nat) (P: nat -> list (list nat) -> nat -> Prop),
  (forall a, 0 = a -> a = 0 ->
             P a (((n1+1)::nil)::nil) (n1+n2)) ->
  forall b, P (b - b) (((1+n1)::nil)::nil) (n2+n1).
Proof.
  intros ? ? ? HP ?.
  apply_f_equal HP; rec_f_equal lia.
Qed.

Lemma test_exact_f_equal: forall (n1 n2: nat) (P: nat -> nat -> Prop),
  P (n1+1) (n1+n2) -> P (1+n1) (n2+n1).
Proof.
  intros ? ? ? HP. exact_f_equal HP; lia.
Qed.

Lemma test_rec_f_equal:
  forall (n1 n2: nat) (P: list (list nat) -> nat -> Prop),
  P (((n1+1)::nil)::nil) (n1+n2) -> P (((1+n1)::nil)::nil) (n2+n1).
Proof.
  intros ? ? ? HP. exact_f_equal HP; rec_f_equal lia.
Qed.

End Test.

End EqualityTactics.
Export EqualityTactics.

(* Borrowed from CPDT *)
(* Instantiate a quantifier in a hypothesis [H] with value [v], or,
if [v] doesn't have the right type, with a new unification variable.
Also prove the lefthand sides of any implications that this exposes,
simplifying [H] to leave out those implications. *)

Ltac guess v H :=
 repeat match type of H with
          | forall x : ?T, _ =>
            match type of T with
              | Prop =>
                (let H' := fresh "H'" in
                  assert (H' : T); [
                    solve [ eauto 6 ]
                    | specialize (H H'); clear H' ])
                || fail 1
              | _ =>
                specialize (H v)
                || let x := fresh "x" in
                  evar (x : T);
                  let x' := eval unfold x in x in
                    clear x; specialize (H x')
            end
        end.

Ltac eq_H_intros :=
  repeat
    (match goal with
      | [  |- _ = _ -> _ ] =>
        intros ?Heq
    end).

Ltac eq_H_getrid :=
  repeat
    (match goal with
       | [  |- _ = _ -> _ ] =>
         intros _
     end).

Ltac decEq :=
  match goal with
  | [ |- _ = _ ] => f_equal
  | [ |- (?X ?A <> ?X ?B) ] =>
      cut (A <> B); [intro; congruence | try discriminate]
  end.

Ltac allinv :=
  repeat
    match goal with
      | [ H: Some _ = Some _ |- _ ] => inv H
      | [ H: Some _ = None |- _ ] => inv H
      | [ H: None = Some _ |- _ ] => inv H
      | _ => idtac
    end.

Ltac allinv' :=
  allinv ;
    (match goal with
       | [ H1:  ?f _ _ = _ ,
           H2:  ?f _ _ = _ |- _ ] => rewrite H1 in H2 ; inv H2
     end).

(* NC: Ltac is not exported from [Section]. This is for simplifying
the existential in [predicted_outcome]. *)
Ltac simpl_exists_tag :=
  match goal with
  | [ H: exists _, ?x = (_,_) |- _ ] => destruct H; subst x; simpl
  end.

(* And basic lemmas *)
Lemma rev_nil_nil (A: Type) : forall (l: list A),
  rev l = nil ->
  l = nil.
Proof.
  induction l; intros ; auto.
  simpl in *.
  exploit app_eq_nil ; eauto.
  intros [Hcont1 Hcont2].
  inv Hcont2.
Qed.

(* Useful functions on lists *)

Set Implicit Arguments.

Fixpoint zip_with_keep_rests (A B C : Type) (f : A -> B -> C)
    (xs : list A) (ys : list B) : (list C * (list A * list B)) :=
  match xs, ys with
  | x::xs', y::ys' =>
      let (zs, rest) := zip_with_keep_rests f xs' ys' in
        (f x y :: zs, rest)
  | nil, _ => (nil, (nil, ys))
  | _, nil => (nil, (xs, nil))
  end.

(*
Eval compute in zip_with_keep_rests plus (1 :: 2 :: 3 :: nil)
                                         (1 :: 1 :: nil).

Eval compute in zip_with_keep_rests plus (1 :: 1 :: nil)
                                         (1 :: 2 :: 3 :: nil).
*)

Definition zip_with (A B C : Type) (f : A -> B -> C)
    (xs : list A) (ys : list B) : list C :=
  fst (zip_with_keep_rests f xs ys).

Fixpoint consecutive_with (A B : Type) (f : A -> A -> B) (xs : list A)
    : list B :=
  match xs with
  | nil => nil
  | x1 :: xs' =>
    match xs' with
    | nil => nil
    | x2 :: xs'' => f x1 x2 :: consecutive_with f xs'
    end
  end.

Definition consecutive (A : Type) := consecutive_with (@pair A A).

(*
Eval compute in consecutive (1 :: 2 :: 3 :: 4 :: 5 :: nil).
*)

Fixpoint last_with (A B : Type) (f : A -> B) (l : list A) (d : B) : B :=
  match l with
  | nil => d
  | a :: nil => f a
  | a :: l => last_with f l d
  end.

Definition last_opt (A : Type) xs := last_with (@Some A) xs None.

(*
Eval compute in last_opt (1 :: 2 :: 3 :: nil).
Eval compute in last_opt (@nil nat).
*)

Fixpoint snoc (A : Type) (xs : list A) (y : A) : list A :=
  match xs with
  | nil => y :: nil
  | x :: xs' => x :: (snoc xs' y)
  end.

Fixpoint init (X : Type) (xs : list X) : list X :=
  match xs with
  | nil => nil
  | x1 :: xs' =>
    match xs' with
    | nil => nil
    | x2 :: xs'' => x1 :: (init xs')
    end
  end.

(*
Eval compute in init (1 :: 2 :: 3 :: nil).
Eval compute in init (1 :: nil).
Eval compute in init (@nil nat).
*)
(** * Finite and infinite traces *)

CoInductive trace (A : Type) : Type :=
  | TNil : trace A
  | TCons : A -> trace A -> trace A.

Arguments TNil {A}.

Fixpoint list_to_trace (A : Type) (xs : list A) : trace A :=
  match xs with
  | nil => TNil
  | x :: xs' => TCons x (list_to_trace xs')
  end.

CoFixpoint map_trace (A B: Type) (f: A -> B) (t: trace A) : trace B :=
  match t with
    | TNil => TNil
    | TCons a ta => TCons (f a) (map_trace f ta)
  end.

Definition frob A (t : trace A) : trace A :=
  match t with
    | TCons h t' => TCons h t'
    | TNil => TNil
  end.

Theorem frob_eq : forall A (t : trace A), t = frob t.
  destruct t; reflexivity.
Qed.

Fixpoint index_list A n (xs : list A) : option A :=
  match xs, n with
  | nil, _ => None
  | x :: _, 0 => Some x
  | _ :: xs', S n' => index_list n' xs'
  end.

Lemma index_list_nil : forall A pc,
  index_list pc nil = @None A .
Proof.
  induction pc; auto.
Qed.

Definition index_list_Z A i (xs: list A) : option A :=
  if Z.ltb i 0 then
    None
  else
    index_list (Z.to_nat i) xs.

Lemma index_list_Z_nil : forall A i,
  index_list_Z i nil = @None A .
Proof.
  intros. unfold index_list_Z. destruct (i <? 0)%Z. auto. apply index_list_nil.
Qed.

Lemma index_list_Z_nat (A: Type) :
  forall l i (v:A),
    index_list_Z i l = Some v ->
    index_list (Z.to_nat i) l = Some v.
Proof.
  intros. unfold index_list_Z in *. destruct (i <? 0)%Z. congruence. auto.
Qed.

Lemma index_list_cons (T: Type): forall n a (l:list T),
 index_list n l = index_list (n+1)%nat (a :: l).
Proof.
  intros.
  replace ((n+1)%nat) with (S n) by lia.
  gdep n. induction n; intros.
  destruct l ; simpl; auto.
  destruct l. auto.
  simpl. eauto.
Qed.

Lemma index_list_Z_cons (T: Type): forall i (l1: list T) a,
  (i >= 0)%Z ->
  index_list_Z i l1 = index_list_Z (i+1) (a::l1).
Proof.
  induction i; intros.
  auto.
  unfold index_list_Z. simpl.
  replace (Pos.to_nat (p + 1)) with ((Pos.to_nat p)+1)%nat by (zify; lia).
  eapply index_list_cons with (l:= l1) (a:= a) ; eauto.
  zify; lia.
Qed.

Lemma index_list_Z_app:
  forall (T : Type)  (l1 l2: list T) (i : Z),
  i = Z.of_nat (length l1) -> index_list_Z i (l1 ++ l2) = index_list_Z 0 l2.
Proof.
  induction l1; intros.
  simpl in *. subst. auto.
  simpl (length (a::l1)) in H.  zify.
  simpl.
  replace i with (i - 1 + 1)%Z by lia.
  erewrite <- index_list_Z_cons by try lia.
  eapply IHl1. lia.
Qed.

Lemma index_list_Z_eq (T: Type) : forall (l1 l2: list T),
  (forall i, index_list_Z i l1 = index_list_Z i l2) ->
  l1 = l2.
Proof.
  induction l1; intros.
  destruct l2 ; auto.
  assert (HCont:= H 0%Z). inv HCont.
  destruct l2.
  assert (HCont:= H 0%Z). inv HCont.
  assert (a = t).
  assert (Helper:= H 0%Z). inv Helper. auto.
  inv H0.
  erewrite IHl1 ; eauto.
  intros. destruct i.
  erewrite index_list_Z_cons with (a:= t); eauto; try lia.
  erewrite H ; eauto.
  erewrite index_list_Z_cons with (a:= t); eauto; try (zify ; lia).
  erewrite H ; eauto. symmetry. eapply index_list_Z_cons; eauto. zify; lia.
  destruct l1, l2 ; auto.
Qed.

Lemma index_list_valid (T:Type): forall n (l:list T) v,
   index_list n l = Some v -> n < length l.
Proof.
  induction n; intros; destruct l; simpl in H.
     inv H.
     inv H.  simpl.  lia.
     inv H.
     pose proof (IHn _ _ H). simpl. lia.
Qed.

Lemma index_list_Z_valid (T:Type): forall i (l:list T) v,
   index_list_Z i l = Some v -> (0 <= i)%Z  /\ (Z.to_nat i < length l)%nat.
Proof.
   intros.
   unfold index_list_Z in H.  destruct ((i <? 0)%Z) eqn:?. inv H.
   split. apply Z.ltb_ge; auto.
   eapply index_list_valid; eauto.
Qed.

Fixpoint update_list A (n : nat) (y : A) (xs : list A) : option (list A) :=
  match xs, n with
  | nil, _ => None
  | _ :: xs', 0 => Some (y :: xs')
  | a :: xs', S n' =>
    match update_list n' y xs' with
      | None => None
      | Some l => Some (a::l)
    end
  end.

Lemma update_some_not_nil : forall A (v:A) l a l',
  update_list a v l = Some l' ->
  l' = nil ->
  False.
Proof.
  destruct l; intros.
  destruct a ; simpl in * ; congruence.
  destruct a0 ; simpl in *. congruence.
  destruct update_list.  inv H.
  congruence.
  congruence.
Qed.

Lemma index_list_map : forall (A B: Type) m x (e:A) (f: A -> B),
  index_list x m = Some e ->
  index_list x (map f m) = Some (f e).
Proof.
  induction m ; intros.
  - rewrite index_list_nil in *. inv H.
  - destruct x ; simpl in *.
    inv H; auto.
    eauto.
Qed.

Definition update_list_Z A i y (xs: list A) : option (list A) :=
  if Z.ltb i 0 then
    None
  else
    update_list (Z.to_nat i) y xs.

Lemma update_Z_some_not_nil : forall A (v:A) l i l',
  update_list_Z i v l = Some l' ->
  l' = nil ->
  False.
Proof.
  intros. unfold update_list_Z in *.  destruct (i <? 0)%Z. congruence.
  eapply update_some_not_nil; eauto.
Qed.

Lemma update_list_Z_nat (A: Type) (v:A) l i l':
  update_list_Z i v l = Some l' ->
  update_list (Z.to_nat i) v l = Some l'.
Proof.
  intros. unfold update_list_Z in *. destruct (i <? 0)%Z. congruence.
  auto.
Qed.

Lemma update_list_spec (T: Type) : forall (v: T) l a l',
  update_list a v l = Some l' ->
  index_list a l' = Some v.
Proof.
  induction l ; intros.
  destruct a ; simpl in *; inv H.
  destruct a0 ; simpl in *; inv H; auto.
  case_eq (update_list a0 v l) ; intros ; rewrite H in * ; inv H1.
  auto.
Qed.

Lemma update_list_Z_spec (T: Type) : forall (v: T) l a l',
  update_list_Z a v l = Some l' ->
  index_list_Z a l' = Some v.
Proof.
  unfold update_list_Z, index_list_Z. intros.
  destruct (a <? 0)%Z.  congruence.
  eapply update_list_spec; eauto.
Qed.

Lemma update_list_spec2 (T:Type) : forall (v:T) l n n' l',
  update_list n v l = Some l' ->
  n <> n' ->
  index_list n' l = index_list n' l'.
Proof.
  induction l; intros.
  destruct n; simpl in *; inv H.
  destruct n.
    destruct n'.
      exfalso; lia.
      destruct l'; inv H.
      simpl. auto.
    destruct n'.
      destruct l'; inv H.
        destruct (update_list n v l); inv H2.
        destruct (update_list n v l); inv H2.
        auto.
      destruct l'; inv H.
        destruct (update_list n v l); inv H2.
        simpl.
        destruct  (update_list n v l) eqn:?; inv H2.
        eapply IHl; eauto.
Qed.

Lemma update_list_Z_spec2 (T:Type) : forall (v:T) l a a' l',
  update_list_Z a v l = Some l' ->
  a' <> a ->
  index_list_Z a' l = index_list_Z a' l'.
Proof.
  unfold update_list_Z, index_list_Z. intros.
  destruct (a <? 0)%Z eqn:?. congruence.
  destruct (a' <? 0)%Z eqn:?. auto.
  eapply update_list_spec2; eauto.
  apply Z.ltb_ge in Heqb.
  apply Z.ltb_ge in Heqb0.
  intro. apply H0. apply Z2Nat.inj; eauto.
Qed.

Lemma update_list_Some (T: Type): forall (v: T) l n,
  n < length l ->
  exists l', update_list n v l = Some l'.
Proof.
  induction l; intros.
  - inv H.
  - destruct n.
    + simpl.  eauto.
    + simpl. edestruct IHl as [l' E]. simpl in H. instantiate (1:= n). lia.
      eexists. rewrite E. eauto.
Qed.

Lemma valid_update :
  forall T i (l : list T) x x',
    index_list_Z i l = Some x ->
    exists l',
      update_list_Z i x' l = Some l'.
Proof.
  intros.
  unfold index_list_Z, update_list_Z in *.
  destruct (i <? 0)%Z; try congruence.
  - remember (Z.to_nat i) as n; clear Heqn.
    generalize dependent n.
    generalize dependent l.
    induction l; intros.
    + destruct n; simpl in H; try congruence.
    + destruct n; simpl in *.
      * simpl; eauto.
      * simpl in *.
        edestruct IHl as [l' Hl']; eauto.
        rewrite Hl'. eauto.
Qed.

Definition swap T n (l : list T) : option (list T) :=
  match l with
    | nil => None
    | y :: l' =>
      match index_list n (y :: l') with
        | Some x => update_list n y (x :: l')
        | None => None
      end
  end.

Lemma filter_cons_inv_strong :
  forall X (l1 : list X) x2 l2
         (f : X -> bool),
    x2 :: l2 = filter f l1 ->
    exists l11 l12,
      l1 = l11 ++ l12 /\
      filter f l11 = x2 :: nil /\
      filter f l12 = l2.
Proof.
  intros X l1.
  induction l1 as [|x1 l1 IH]; simpl; try congruence.
  intros.
  destruct (f x1) eqn:E.
  - exists (x1 :: nil).
    exists l1.
    simpl.
    rewrite E.
    inv H.
    eauto.
  - exploit IH; eauto.
    clear IH.
    intros [l11 [l12 [H1 [H2 H3]]]].
    subst.
    exists (x1 :: l11).
    exists l12.
    simpl.
    rewrite E. eauto.
Qed.

Lemma filter_cons_inv :
  forall A (f : A -> bool) a l1 l2,
    a :: l1 = filter f l2 ->
    exists l2', l1 = filter f l2'.
Proof.
  induction l2 as [|a' l2 IH]; simpl. congruence.
  destruct (f a'); intros H; auto.
  inv H. eauto.
Qed.

Lemma filter_app :
  forall X (l1 l2 : list X) (f : X -> bool),
    filter f (l1 ++ l2) = filter f l1 ++ filter f l2.
Proof.
  induction l1 as [|x l1 IH]; simpl; intros. trivial.
  rewrite IH. destruct (f x); auto.
Qed.

Lemma update_list_Z_Some (T:Type): forall (v:T) l (i:Z),
  (0 <= i)%Z ->
  Z.to_nat i < length l ->
  exists l', update_list_Z i v l = Some l'.
Proof.
  intros. unfold update_list_Z.
  destruct (i <? 0)%Z eqn:?.
  - rewrite Z.ltb_lt in Heqb. lia.
  - eapply update_list_Some; eauto.
Qed.

Lemma update_preserves_length: forall T a (vl:T) m m',
  update_list a vl m = Some m' ->
  length m' = length m.
Proof.
  induction a; intros.
  - destruct m; simpl in *.
    + inv H.
    + inversion H; subst; reflexivity.
  - destruct m; simpl in *.
    + inv H.
    + destruct (update_list a vl m) eqn:?.
      * exploit IHa; eauto.
        inversion H; subst.
        intros eq; rewrite <- eq; reflexivity.
      * inv H.
Qed.

Lemma app_same_length_eq (T: Type): forall (l1 l2 l3 l4: list T),
  l1++l2 = l3++l4 ->
  length l1 = length l3 ->
  l1 = l3.
Proof.
  induction l1; intros; simpl in *.
  destruct l3; auto. inv H0.
  destruct l3. inv H0. simpl in *.
  inv H. erewrite IHl1 ; eauto.
Qed.

Lemma app_same_length_eq_rest (T: Type): forall (l1 l2 l3 l4: list T),
  l1++l2 = l3++l4 ->
  length l1 = length l3 ->
  l2 = l4.
Proof.
  intros.
  exploit app_same_length_eq; eauto.
  intro Heq ; inv Heq.
  gdep l3. induction l3 ; intros; auto.
  simpl in *.
  inv H. eauto.
Qed.

Definition is_some T (o : option T) :=
  match o with
    | Some _ => true
    | None => false
  end.

Definition remove_none {T} (l : list (option T)) :=
  filter (@is_some _) l.

Inductive with_silent {T:Type} := | E (e:T) | Silent.
Notation "T +τ" := (@with_silent T) (at level 1).

Inductive match_actions {T1 T2} (match_events : T1 -> T2 -> Prop) : T1+τ -> T2+τ -> Prop :=
| match_actions_silent : match_actions match_events Silent Silent
| match_actions_event : forall e1 e2,
  match_events e1 e2 -> match_actions match_events (E e1) (E e2).

(** Reflexive transitive closure. *)
Definition op_cons (E: Type) (oe: E+τ) (l: list E) :=
  match oe with
      | E e => e::l
      | Silent => l
  end.

Inductive star (S E: Type) (Rstep: S -> E+τ -> S -> Prop): S -> list E -> S -> Prop :=
  | star_refl: forall s,
      star Rstep s nil s
  | star_step: forall s1 s2 s3 e t t',
      Rstep s1 e s2 -> star Rstep s2 t s3 ->
      t' = (op_cons e t) ->
      star Rstep s1 t' s3.
Hint Constructors star : core.

Lemma op_cons_app : forall E (e: E+τ) t t', (op_cons e t)++t' = op_cons e (t++t').
Proof. intros. destruct e; reflexivity. Qed.

Lemma star_right : forall S E (Rstep: S -> E+τ -> S -> Prop) s1 s2 t,
                     star Rstep s1 t s2 ->
                     forall s3 e t',
                       Rstep s2 e s3 ->
                       t' = (t++(op_cons e nil)) ->
                       star Rstep s1 t' s3.
Proof.
  induction 1; intros.
  eapply star_step; eauto.
  exploit IHstar; eauto. intros.
  inv H3. rewrite op_cons_app; eauto.
Qed.

Inductive plus (S E: Type) (Rstep: S -> E+τ -> S -> Prop): S -> list E -> S -> Prop :=
  | plus_step: forall s t s' e,
      Rstep s e s' ->
      t = (op_cons e nil) ->
      plus Rstep s t s'
  | plus_trans: forall s1 s2 s3 e t t',
      Rstep s1 e s2 -> plus Rstep s2 t s3 ->
      t' = (op_cons e t) ->
      plus Rstep s1 t' s3.

Hint Constructors star : core.
Hint Constructors plus : core.

Lemma plus_right : forall E S (Rstep: S -> E+τ -> S -> Prop) s1 s2 t,
                     plus Rstep s1 t s2 ->
                     forall s3 e t',
                       t' = (t++(op_cons e nil)) ->
                       Rstep s2 e s3 -> plus Rstep s1 t' s3.
Proof.
  induction 1; intros.
  inv H1.
  rewrite op_cons_app. simpl.
  eapply plus_trans; eauto.
  exploit IHplus; eauto.
  inv H2. rewrite op_cons_app.  eauto.
Qed.

Lemma step_star_plus :
  forall (S E: Type)
         (Rstep: S -> E+τ -> S -> Prop) s1 t s2
         (STAR : star Rstep s1 t s2)
         (NEQ : s1 <> s2),
    plus Rstep s1 t s2.
Proof.
  intros. inv STAR. congruence.
  clear NEQ.
  gdep e. gdep s1.
  induction H0; subst; eauto.
Qed.
Hint Resolve step_star_plus : core.

Lemma star_trans: forall S E (Rstep: S -> E+τ -> S -> Prop) s0 t s1,
  star Rstep s0 t s1 ->
  forall t' s2,
  star Rstep s1 t' s2 ->
  star Rstep s0 (t++t') s2.
Proof.
  induction 1.
  - auto.
  - inversion 1.
    + rewrite app_nil_r.
      subst; econstructor; eauto.
    + subst; econstructor; eauto.
      rewrite op_cons_app; reflexivity.
Qed.

Fixpoint replicate T (a: T) n : list T :=
  match n with
    | O => nil
    | S n => a::(replicate a n)
  end.

Lemma index_list_In :
  forall T n (l : list T) (x : T),
    index_list n l = Some x ->
    In x l.
Proof.
  intros.
  gdep l.
  induction n as [|n IH]; intros l H; destruct l as [|x' l]; simpl in *;
  try solve [inv H].
  - inv H. auto.
  - auto.
Qed.
Hint Resolve index_list_In : core.

Lemma update_list_In :
  forall T n x y (l l' : list T)
         (UPD: update_list n x l = Some l')
         (IN: In y l'),
    y = x \/ In y l.
Proof.
  induction n as [|n IH]; intros; destruct l as [|x' l]; simpl in *;
  try solve [inv UPD].
  - inv UPD. destruct IN; eauto.
  - destruct (update_list n x l) as [l''|] eqn:UPD'; inv UPD.
    destruct IN; auto.
    exploit IH; eauto.
    intros []; eauto.
Qed.

Lemma swap_In :
  forall T n (l l' : list T) x
         (SWAP : swap n l = Some l')
         (IN : In x l'),
    In x l.
Proof.
  unfold swap.
  intros.
  destruct l as [|y l]; try congruence.
  destruct n as [|n]; simpl in *.
  - inv SWAP. eauto.
  - destruct (index_list n l) as [x'|] eqn:IDX; try congruence.
    destruct (update_list n y l) as [l''|] eqn:UPD; try congruence.
    inv SWAP.
    destruct IN as [H | H]; subst; eauto.
    clear - UPD H.
    exploit update_list_In; eauto.
    intros []; auto.
Qed.

Lemma index_list_app :
  forall T n (l1 l2 : list T) x,
    index_list n l1 = Some x ->
    index_list n (l1 ++ l2) = Some x.
Proof.
  induction n as [|n IH]; intros [|x' l1] l2 x H; simpl in *;
  try solve [inv H]; auto.
Qed.

Lemma update_list_app :
  forall T n x (l1 l1' l2 : list T)
         (UPD : update_list n x l1 = Some l1'),
    update_list n x (l1 ++ l2) = Some (l1' ++ l2).
Proof.
  induction n; intros;
  destruct l1 as [|x' l1]; simpl in *; allinv; auto.
  destruct (update_list n x l1) as [l1''|] eqn:UPD'; allinv.
  erewrite IHn; eauto.
  simpl.
  reflexivity.
Qed.

Lemma swap_app :
  forall T n (l1 l1' l2 : list T)
         (SWAP : swap n l1 = Some l1'),
    swap n (l1 ++ l2) = Some (l1' ++ l2).
Proof.
  unfold swap.
  intros.
  destruct l1 as [|y l1]; simpl; try congruence.
  destruct (index_list n (y :: l1)) as [x|] eqn:SWAP'; allinv.
  eapply index_list_app in SWAP'.
  simpl in SWAP'.
  rewrite SWAP'.
  eapply update_list_app in SWAP.
  simpl in *.
  eauto.
Qed.

Lemma swap_forall :
  forall T (P : T -> Prop) n l l'
         (SWAP : swap n l = Some l')
         (FORALL : forall x, In x l -> P x),
    forall x, In x l' -> P x.
Proof.
  unfold swap.
  intros.
  destruct l as [|y l]; try congruence.
  destruct (index_list n (y :: l)) as [x'|] eqn:IDX; try congruence.
  destruct n as [|n]; simpl in *; allinv; simpl in *; eauto.
  match goal with
    | H : (match ?UP with _ => _ end) = _ |- _ =>
      destruct UP as [l''|] eqn:?; simpl in *; try congruence
  end.
  allinv.
  destruct H.
  - subst. eauto.
  - exploit update_list_In; eauto.
    intros [? | ?]; subst; eauto.
Qed.

Fixpoint drop {X:Type} (n:nat) (xs:list X) : list X :=
match n with
| O => xs
| S n' => match xs with
          | nil => nil
          | (x::xs') => drop n' xs'
          end
end.

Definition dropZ {X:Type} (z:Z) (xs:list X) : list X :=
  if (z <? 0)%Z then
    xs
  else drop (Z.to_nat z) xs.

Lemma length_drop : forall {X:Type} n (xs:list X),
           length (drop n xs) = ((length xs) -  n)%nat.
Proof.
  intros X n. induction n; intros xs.
    simpl. lia.
    destruct xs. simpl.
       auto.
       simpl. auto.
Qed.

Lemma drop_cons : forall {X:Type} p (l : list X),
    (p < length l)%nat ->
    exists x,
      drop p l = x :: drop (S p) l.
Proof.
  induction p; intros [|x l] H; simpl in *; try lia; eauto.
  apply IHp.
  lia.
Qed.

Import ListNotations.

Lemma dropZ_all: forall {X:Type} (xs:list X),
  (dropZ (Z.of_nat (length xs)) xs = []).
Proof.
  intros.
  destruct (dropZ (Z.of_nat (length xs)) xs) eqn:E. auto.
  exfalso.
  unfold dropZ in E.  destruct (Z.of_nat (length xs) <? 0)%Z eqn:M.
    apply Z.ltb_lt in M.  lia.
    rewrite Nat2Z.id in E.
    assert (length (drop (length xs) xs) = length (x::l)). rewrite E; auto.
    rewrite length_drop in H. simpl in H. replace (length xs - length xs)%nat with O in H by lia. inv H.
Qed.

Lemma dropZ_nil :
  forall X (i : Z) (l : list X)
         (POS : (i >= 0)%Z)
         (BOUNDS : dropZ i l = []),
    (i >= Z.of_nat (length l))%Z.
Proof.
  intros.
  destruct (Z_lt_dec i (Z.of_nat (length l))) as [H|]; try lia.
  unfold dropZ in *.
  destruct (Z.ltb_spec0 i 0); try lia.
  rewrite Z2Nat.inj_lt in H; try lia.
  rewrite Nat2Z.id in H.
  apply drop_cons in H.
  destruct H.
  congruence.
Qed.

Lemma index_list_drop_zero :
  forall X (i : nat) (l : list X),
    index_list i l = index_list 0 (drop i l).
Proof.
  intros X i.
  induction i as [|i IH].
  - intros [|a l]; reflexivity.
  - intros [|a l]; try reflexivity.
    simpl. rewrite IH. reflexivity.
Qed.

Lemma index_list_Z_dropZ_zero :
  forall X (i : Z) (l : list X)
         (POS : (i >= 0)%Z),
    index_list_Z i l = index_list_Z 0 (dropZ i l).
Proof.
  intros.
  unfold index_list_Z, dropZ.
  destruct (Z.ltb_spec0 i 0); try lia.
  rewrite index_list_drop_zero.
  reflexivity.
Qed.

Lemma index_list_drop :
  forall X (i i' : nat) (l : list X),
    index_list (i + i') l = index_list i (drop i' l).
Proof.
  intros X i.
  induction i as [|i IH]; auto using index_list_drop_zero.
  intros [|i'] [|a l]; try reflexivity.
  - rewrite plus_0_r. reflexivity.
  - simpl.
    rewrite IH.
    destruct (lt_dec i' (length l)) as [LT|GTE].
    + apply drop_cons in LT.
      destruct LT as [x H]. rewrite H. reflexivity.
    + assert (LEN := length_drop i' l).
      replace (length l - i')%nat with 0%nat in LEN by lia.
      assert (LEN' := length_drop (S i') l).
      replace (length l - S i')%nat with 0%nat in LEN' by lia.
      destruct (drop i' l), (drop (S i') l); simpl in *; try discriminate.
      destruct i; reflexivity.
Qed.

Lemma index_list_Z_dropZ :
  forall X (i i' : Z) (l : list X)
         (POS1 : (i' >= 0)%Z)
         (POS2 : (i >= 0)%Z),
    index_list_Z (i + i') l = index_list_Z i (dropZ i' l).
Proof.
  intros.
  unfold index_list_Z, dropZ.
  destruct (Z.ltb_spec0 i' 0); try lia.
  destruct (Z.ltb_spec0 i 0); try lia.
  destruct (Z.ltb_spec0 (i + i') 0); try lia.
  rewrite Z2Nat.inj_add; try lia.
  apply index_list_drop.
Qed.

Lemma dropZ_cons :
  forall X i (l : list X)
         (BOUNDS : (0 <= i < Z.of_nat (length l))%Z),
    exists x, dropZ i l = x :: dropZ (Z.succ i) l.
Proof.
  intros.
  unfold dropZ.
  destruct (Z.ltb_spec0 i 0); try lia.
  destruct (Z.ltb_spec0 (Z.succ i) 0); try lia.
  rewrite Z2Nat.inj_succ; try lia.
  apply drop_cons.
  rewrite <- Nat2Z.id.
  rewrite <- Z2Nat.inj_lt; lia.
Qed.

Inductive match_options {A B} (R : A -> B -> Prop) : option A -> option B -> Prop :=
| mo_none : match_options R None None
| mo_some : forall a b, R a b -> match_options R (Some a) (Some b).

Lemma Forall2_length :
  forall A B (R : A -> B -> Prop) l1 l2,
    Forall2 R l1 l2 -> length l1 = length l2.
Proof.
  induction 1; eauto; simpl; congruence.
Qed.

Fixpoint take {T} (n : nat) (l : list T) : list T :=
  match n with
    | O => []
    | S n' =>
      match l with
        | [] => []
        | x :: l' => x :: take n' l'
      end
  end.

Lemma index_list_app' X : forall (l1 l2 : list X) (x : X),
                            index_list (length l1) (l1 ++ x :: l2) = Some x.
Proof.
  induction l1 as [|x' l1 IH]; intros; simpl in *; subst; eauto.
Qed.


From iris.algebra Require Export ofe.
From iris.prelude Require Import options.

(** The Monoid class that is used for generic big operators in the file
[algebra/big_op]. The operation is an argument because we want to have multiple
monoids over the same type (for example, on [uPred]s we have monoids for [∗],
[∧], and [∨]). However, we do bundle the unit because:

- If we would not, it would appear explicitly in an argument of the big
  operators, which confuses rewrite. Now it is hidden in the class, and hence
  rewrite won't even see it.
- The unit is unique.

We could in principle have big ops over setoids instead of OFEs. However, since
we do not have a canonical structure for setoids, we do not go that way.

Note that we do not declare any of the projections as type class instances. That
is because we only need them in the [big_op] file, and nowhere else. Hence, we
declare these instances locally there to avoid them being used elsewhere. *)
Class Monoid {M : ofe} (o : M → M → M) := {
  monoid_unit : M;
  monoid_ne : NonExpansive2 o;
  monoid_assoc : Assoc (≡) o;
  monoid_comm : Comm (≡) o;
  monoid_left_id : LeftId (≡) monoid_unit o;
}.
Lemma monoid_proper {M : ofe} {o : M → M → M} `{!Monoid o} : Proper ((≡) ==> (≡) ==> (≡)) o.
Proof. apply ne_proper_2, monoid_ne. Qed.
Lemma monoid_right_id {M : ofe} {o : M → M → M} `{!Monoid o} : RightId (≡) monoid_unit o.
Proof. intros x. etrans; [apply monoid_comm|apply monoid_left_id]. Qed.

(** The [Homomorphism] classes give rise to generic lemmas about big operators
commuting with each other. We also consider a [WeakMonoidHomomorphism] which
does not necessarily commute with unit; an example is the [own] connective: we
only have `True ==∗ own γ ∅`, not `True ↔ own γ ∅`. *)
Class WeakMonoidHomomorphism {M1 M2 : ofe}
    (o1 : M1 → M1 → M1) (o2 : M2 → M2 → M2) `{!Monoid o1, !Monoid o2}
    (R : relation M2) (f : M1 → M2) := {
  monoid_homomorphism_rel_po : PreOrder R;
  monoid_homomorphism_rel_proper : Proper ((≡) ==> (≡) ==> iff) R;
  monoid_homomorphism_op_proper : Proper (R ==> R ==> R) o2;
  monoid_homomorphism_ne : NonExpansive f;
  monoid_homomorphism x y : R (f (o1 x y)) (o2 (f x) (f y))
}.

Class MonoidHomomorphism {M1 M2 : ofe}
    (o1 : M1 → M1 → M1) (o2 : M2 → M2 → M2) `{!Monoid o1, !Monoid o2}
    (R : relation M2) (f : M1 → M2) := {
  monoid_homomorphism_weak :> WeakMonoidHomomorphism o1 o2 R f;
  monoid_homomorphism_unit : R (f monoid_unit) monoid_unit
}.

Lemma weak_monoid_homomorphism_proper
  `{WeakMonoidHomomorphism M1 M2 o1 o2 R f} : Proper ((≡) ==> (≡)) f.
Proof. apply ne_proper, monoid_homomorphism_ne. Qed.


Require Import VST.floyd.proofauto.
Require Import VST.progs.message.

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

(* This program, and its verification, are described in Chapter 29
   of _Program Logics for Certified Compilers_, by Appel et al., 2014 *)

Local Open Scope Z.
Local Open Scope logic.

(*   mf_assert msgfmt sh buf len data  := the [data] is formatted into a message
         at most [len] bytes,  stored starting at address [buf] with share [sh] *)

Record message_format (t: type) : Type :=
mf_build {
   mf_size: Z;
   mf_data_assert: forall (data: reptype t), Prop;
   mf_assert: forall (sh: share) (buf: val) (len: Z) (data: reptype t), mpred;
   mf_size_range:  0 <= mf_size <= Int.max_signed;
   mf_bufprop: forall sh buf len data,
           mf_assert sh buf len data |--
                 !!(0 <= len <= mf_size) && memory_block sh len buf;
   mf_restbuf := fun (sh: share) (buf: val) (len: Z) =>
          memory_block sh (mf_size-len) (offset_val len buf)
}.

Arguments mf_build {t}.
Arguments mf_size {t}.
Arguments mf_data_assert {t}.
Arguments mf_assert {t}.
Arguments mf_bufprop {t}.
Arguments mf_size_range {t}.
Arguments mf_restbuf {t}.

Lemma mf_assert_local_facts: forall t (mf: message_format t) sh buf len (data: reptype t),
   mf_assert mf sh buf len data |--
    !! (0 <= len <= mf_size mf /\ isptr buf).
Proof.
intros.
eapply derives_trans;[ apply mf_bufprop | ].
entailer!.
Qed.

#[export] Hint Resolve mf_assert_local_facts : saturate_local.

Definition t_struct_intpair := Tstruct _intpair noattr.
Definition t_struct_message := Tstruct _message noattr.

Program Definition intpair_message: message_format t_struct_intpair :=
  mf_build 8 (fun data => is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
             (fun sh buf len data => !!(len=8/\ is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
                           && data_at sh (tarray tint 2) [fst data; snd data] buf)
      _ _.
Next Obligation.
compute; split; congruence.
Qed.
Next Obligation.
  entailer!.
  change 8 with (sizeof (tarray tint 2)).
  apply data_at_memory_block.
Qed.

Definition serialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share
  PRE [ tptr tvoid, tptr tuchar ]
          PROP (readable_share sh; writable_share sh';
                mf_data_assert format data;
                align_compatible tint buf)
          PARAMS (p; buf)
          SEP (data_at sh t data p;
                 memory_block sh' (mf_size format) buf)
  POST [ tint ]
         EX len: Z,
          PROP() RETURN (Vint (Int.repr len))
          SEP( data_at sh t data p;
                 mf_assert format sh' buf len data;
                 mf_restbuf format sh' buf len).

Definition deserialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share, len: Z
  PRE [ tptr tvoid, tptr tuchar, tint ]
          PROP (readable_share sh'; writable_share sh;
                0 <= len <= mf_size format)
          PARAMS (p; buf; Vint (Int.repr len))
          SEP (mf_assert format sh' buf len data;
                 data_at_ sh t p)
  POST [ tvoid ]
          PROP (mf_data_assert format data)  RETURN ()
          SEP (mf_assert format sh' buf len data;
                 data_at sh t data p).

Definition intpair_serialize_spec :=
 DECLARE _intpair_serialize (serialize_spec intpair_message).

Definition intpair_deserialize_spec :=
 DECLARE _intpair_deserialize (deserialize_spec intpair_message).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition message (sh: share) {t: type} (format: message_format t) (m: val) : mpred :=
  EX fg: val*val,
          func_ptr' (serialize_spec format) (fst fg) *
          func_ptr' (deserialize_spec format) (snd fg) *
       data_at sh t_struct_message (Vint (Int.repr (mf_size format)), (fst fg, snd fg)) m.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    intpair_serialize_spec; intpair_deserialize_spec; main_spec]).

Lemma body_intpair_serialize: semax_body Vprog Gprog f_intpair_serialize intpair_serialize_spec.
Proof.
unfold intpair_serialize_spec.
unfold serialize_spec.
start_function.
destruct H as [Dx Dy].
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction. clear Dx Dy.

change (mf_size intpair_message) with (sizeof (tarray tint 2)).
assert_PROP (field_compatible (tarray tint 2) [] buf).
  entailer!.
  hnf in H; decompose[and] H; repeat split; auto.
  (* TODO: abstract the following proof. *)
  unfold align_compatible in H0 |- *.
  destruct buf; auto.
  constructor.
  intros.
  eapply align_compatible_rec_by_value_inv in H0; [| reflexivity].
  econstructor; [reflexivity |].
  apply Z.divide_add_r; auto.
  exists i0; rewrite Z.mul_comm; auto.
rewrite memory_block_data_at_; auto.
change (data_at_ sh' (tarray tint 2) buf) with
   (data_at sh' (tarray tint 2) [Vundef;Vundef] buf).
forward. (* x = p->x; *)
forward. (* y = p->y; *)
forward. (*  ((int * )buf)[0]=x; *)
forward. (*  ((int * )buf)[1]=y; *)
forward. (* return 8; *)
Exists 8.
unfold mf_restbuf. simpl.
rewrite memory_block_zero.
entailer!.
Qed.

Lemma body_intpair_deserialize: semax_body Vprog Gprog f_intpair_deserialize intpair_deserialize_spec.
Proof.
unfold intpair_deserialize_spec, deserialize_spec.
start_function.
hnf in data; simpl in data. (* This speeds things up dramatically *)
simpl. Intros. subst len.
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction.
clear H H1 H2.
forward. (* x = ((int * )buf)[0]; *)
forward. (* y = ((int * )buf)[1]; *)
forward. (* p->x = x; *)
forward. (* p->y = y; *)
entailer!.
split; simpl; auto.
unfold mf_assert.
simpl.
entailer!.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
function_pointers.
start_function.
set (ipm := gv _intpair_message).
fold cc_default noattr.
make_func_ptr _intpair_deserialize.
make_func_ptr _intpair_serialize.
set (des := gv _intpair_deserialize).
set (ser := gv _intpair_serialize).
match goal with
 |- context [mapsto_zeros 4 Ews _] =>
  (* 64-bit mode *)
  sep_apply mapsto_zeros_memory_block; auto;
  gather_SEP (mapsto _ _ _ (offset_val 0 des))
      (mapsto _ _ _ (offset_val 0 ser))
      (memory_block Ews 4 _)
      (data_at _ _ _ ipm)
 | _ => (*32-bit mode *)
  gather_SEP (mapsto _ _ _ (offset_val 0 des))
      (mapsto _ _ _ (offset_val 0 ser))
      (data_at _ _ _ ipm)
end.
replace_SEP 0
    (data_at Ews t_struct_message
      (Vint (Int.repr (mf_size intpair_message)), (ser, des)) ipm). {
 entailer!.
 unfold_data_at (data_at _ t_struct_message _ ipm).
 rewrite (field_at_data_at _ _ _ _ ipm).
rewrite data_at_tuint_tint.
(* rewrite <- (mapsto_field_at _ _ [StructField _bufsize] (Vint (Int.repr 8))) by auto with field_compatible. *)
 rewrite <- (mapsto_field_at _ _ [StructField _deserialize] des) by auto with field_compatible.
 rewrite <- (mapsto_field_at _ _ [StructField _serialize] ser) by auto with field_compatible.
 rewrite !field_compatible_field_address by auto with field_compatible.
 simpl.
 normalize.
 unfold spacer, at_offset; simpl.
 cancel.
}
forward. (* p.x = 1; *)
forward. (* p.y = 2; *)
forward. (* ser = intpair_message.serialize; *)

rewrite <- memory_block_data_at__tarray_tuchar_eq by computable.
change (memory_block Tsh 8 v_buf)
with (memory_block Tsh (mf_size intpair_message) v_buf).

assert_PROP (align_compatible tint v_buf).
  entailer!.
  destruct HPv_buf; subst; simpl.
  econstructor; [reflexivity | apply Z.divide_0_r].
forward_call (* len = ser(&p, buf); *)
      ((Vint (Int.repr 1), Vint (Int.repr 2)), v_p, v_buf, Tsh, Tsh).
  split3; auto.
  repeat split; auto.
Intros rest.
simpl.
Intros. subst rest.

forward. (* des = intpair_message.deserialize; *)
forward_call (* des(&q, buf, 8); *)
        ((Vint (Int.repr 1), Vint (Int.repr 2)), v_q, v_buf, Tsh, Tsh, 8).
  simpl. fold t_struct_intpair. entailer!.
  simpl; computable.
(* after the call *)
forward. (* x = q.x; *)
forward. (* y = q.y; *)
forward. (* return x+y; *)
simpl.
entailer!.
sep_apply (data_at_memory_block Tsh (tarray tint 2) [Vint (Int.repr 1); Vint (Int.repr 2)] v_buf).
unfold sizeof; simpl Ctypes.sizeof.
sep_apply (memory_block_data_at__tarray_tuchar Tsh v_buf 8).
   computable.
entailer!.
Qed.


From st.prelude Require Import generic forall_three.
From st.STLCmuVS Require Import lang typing tactics contexts contexts_subst scopedness.
From st.STLCmu Require Import types.

Definition GammaType (Γ : list type) (τ : type) : type := foldr (TArrow) τ (rev Γ).

Lemma GammaType_snoc Γ τ τr : TArrow τ (GammaType Γ τr) = GammaType (Γ ++ [τ]) τr.
Proof. by rewrite /GammaType rev_unit /=. Qed.

Definition LamGamma_ctx (n : nat) : ctx := replicate n CTX_Lam.

Fixpoint LamGamma (n : nat) (e : expr) : expr :=
  match n with
  | O => e
  | S x => Lam (LamGamma x e)
  end.

Lemma fill_LamGamma_ctx (n : nat) (e : expr) : fill_ctx (LamGamma_ctx n) e = LamGamma n e.
Proof. induction n. done. simpl. by rewrite IHn. Qed.

Definition LamGammaV_S (n : nat) (e : expr) : val := LamV (LamGamma n e).

Lemma LamGammaV_S_rw (n : nat) (e : expr) : of_val (LamGammaV_S n e) = LamGamma (S n) e.
Proof. by simpl. Qed.

Lemma LamGamma_ctx_typed (Γ : list type) (τ : type) :
  |C> [] ⊢ₙₒ LamGamma_ctx (length Γ) ☾ Γ; τ ☽ : GammaType Γ τ.
Proof.
  induction Γ as [|τ' τs IHτs] using rev_ind.
  - simpl. by apply TPCTX_nil.
  - rewrite /LamGamma app_length /= Nat.add_1_r.
    rewrite /=. econstructor.
    + rewrite /GammaType rev_unit. simpl. econstructor.
    + fold (GammaType τs). change [τ'] with ([] ++ [τ']).
      by apply typed_ctx_append.
Qed.

Lemma LamGamma_typed e (Γ : list type) (τ : type) (de : typed Γ e τ) :
  [] ⊢ₙₒ LamGamma (length Γ) e : GammaType Γ τ.
Proof.
  rewrite -fill_LamGamma_ctx. eapply typed_ctx_typed. apply de.
  apply LamGamma_ctx_typed.
Qed.

Lemma LamGamma_scoped e n (de : expr_scoped n e) :
  expr_scoped 0 (LamGamma n e).
Proof.
  rewrite -fill_LamGamma_ctx. eapply scoped_ctx_fill. apply de.
  replace n with (length (replicate n TUnit)).
  replace 0 with (length ([] : list type)).
  apply (ctx_typed_scoped _ TUnit _ (GammaType (replicate n TUnit) TUnit)).
  apply LamGamma_ctx_typed. auto. by rewrite replicate_length.
Qed.

Fixpoint AppGamma (F : expr) (es : list expr) : expr :=
  match es with
  | nil => F
  | cons e es' => ((AppGamma F es') e)%Eₙₒ
  end.

Definition AppGamma_ectx (es : list expr) : list ectx_item :=
  fmap AppLCtx (rev es).

Lemma AppGamma_snoc (F : expr) (es : list expr) (e : expr) :
  AppGamma F (es ++ [e]) = AppGamma (F e) es.
Proof.
  induction es.
  - by simpl.
  - simpl. f_equiv. by rewrite IHes.
Qed.

Lemma fill_AppGamma_ectx (F : expr) (es : list expr) : AppGamma F es = fill (AppGamma_ectx es) F.
Proof.
  revert F.
  induction es using rev_ind.
  - done.
  - intro F. by rewrite AppGamma_snoc /AppGamma_ectx rev_unit /= (IHes (F x)).
Qed.

Lemma AppGamma_subst (F : expr) (es : list expr) (σ : var → expr) :
  (AppGamma F es).[σ] = AppGamma F.[σ] (fmap (subst σ) es).
Proof. induction es. by asimpl. asimpl. by rewrite IHes. Qed.

Fixpoint wrap_funs_vars (F : expr) (k : nat) (fs : list val) : expr :=
  match fs with
  | nil => F
  | cons f' fs' => ((wrap_funs_vars F (S k) fs') (f' (Var $ k)))%Eₙₒ
  end.

Lemma wrap_funs_vars_rw (F : expr) (k : nat) (fs : list val) :
  wrap_funs_vars F k fs = AppGamma F (imap (fun l f => (App (of_val f) (Var (l + k)))) fs).
Proof.
  revert k. induction fs as [|f fs IHfs]. done.
  intro k. rewrite /= IHfs (imap_ext _ ((λ (l : nat) (f0 : val), f0 (%(l + k))%Eₙₒ) ∘ S)). done.
  intros. simpl. f_equiv. f_equiv. lia.
Qed.

Lemma wrap_funs_vars_subst1 (F : expr) (k : nat) (fs : list val) (Hfs : Forall (fun f => Closed (of_val f)) fs) σ :
  (wrap_funs_vars F k fs).[upn (length fs + k) σ] = wrap_funs_vars F.[upn (length fs + k) σ] k fs.
Proof.
  rewrite !wrap_funs_vars_rw AppGamma_subst fmap_imap. f_equiv.
  apply imap_ext. intros i f lkp. asimpl. rewrite (upn_lt (i + k) (length fs + k)).
  by rewrite (Forall_lookup_1 _ _ _ _ Hfs lkp).
  assert (i < length fs) by by eapply lookup_lt_Some. lia.
Qed.

Lemma wrap_funs_vars_subst1' l (F : expr) (fs : list val) (Hfs : Forall (fun f => Closed (of_val f)) fs) σ :
  length fs = l → (wrap_funs_vars F 0 fs).[upn l σ] = wrap_funs_vars F.[upn l σ] 0 fs.
Proof. intros <-. replace (length fs) with (length fs + 0) by lia. by apply wrap_funs_vars_subst1. Qed.

(* Fixpoint wrap_funs_vals' (F : expr) (fs vs : list val) (H : length fs = length vs) : expr := *)
(*   match (fs , vs) with *)
(*   | nil, nil => F *)
(*   | cons f fvs => ((wrap_funs_vals F fvs) (f v))%Eₙₒ *)
(*   end. *)

Fixpoint wrap_funs_vals (F : expr) (fvs : list (val * val)) : expr :=
  match fvs with
  | nil => F
  | cons (f, v) fvs => ((wrap_funs_vals F fvs) (f v))%Eₙₒ
  end.

Lemma wrap_funs_vals_rw (F : expr) (fvs : list (val * val)) :
  wrap_funs_vals F fvs = AppGamma F (fmap (fun fv => (App (of_val fv.1) (of_val fv.2))) fvs).
Proof.
  induction fvs as [|[f v] fvs IHfs]. done.
  by rewrite /= IHfs.
Qed.

Lemma wrap_funs_vals_snoc (F : expr) (fvs : list (val * val)) (f v : val) :
  wrap_funs_vals F (fvs ++ [(f, v)]) = wrap_funs_vals (F (f v)) fvs.
Proof. by rewrite !wrap_funs_vals_rw fmap_app AppGamma_snoc. Qed.

Lemma wrap_funs_vars_subst2 (F : expr) (HF : Closed F) (fvs : list (val * val)) (H : Forall (fun f => Closed (of_val f)) fvs.*1) :
  (wrap_funs_vars F 0 fvs.*1).[subst_list_val fvs.*2] = wrap_funs_vals F fvs.
Proof.
  rewrite !wrap_funs_vars_rw wrap_funs_vals_rw AppGamma_subst fmap_imap HF. f_equiv.
  rewrite imap_fmap. rewrite -(imap_const (λ fv : val * val, fv.1 fv.2) fvs).
  apply imap_ext. intros i (f, v) lkp. simpl.
  assert (lkp1 : fvs.*1 !! i = Some f) by by rewrite list_lookup_fmap lkp.
  assert (lkp2 : fvs.*2 !! i = Some v) by by rewrite list_lookup_fmap lkp.
  rewrite (Forall_lookup_1 _ _ _ _ H lkp1) Nat.add_0_r.
  replace (subst_list_val fvs.*2 i) with (ids i).[subst_list_val fvs.*2] by by asimpl. by rewrite (Var_subst_list_val_lookup _ _ _ lkp2).
Qed.

Lemma wrap_funs_vars_subst2' (F : expr) (HF : Closed F) (fs vs : list val) (Hl : length fs = length vs) (H : Forall (fun f => Closed (of_val f)) fs) :
  (wrap_funs_vars F 0 fs).[subst_list_val vs] = wrap_funs_vals F (zip fs vs).
Proof.
  rewrite <- (snd_zip fs vs) at 1 by lia. rewrite <- (fst_zip fs vs) at 2 by lia.
  apply wrap_funs_vars_subst2; auto. rewrite fst_zip; auto; lia.
Qed.

Lemma wrap_funs_vars_typed_help (fs : list val) τr Γ Γ' (H : Forall3 (fun τ' f τ => ∀Γ, Γ ⊢ₙₒ (of_val f) : TArrow τ' τ) Γ' fs Γ) :
  ∀ k, k ≤ length fs → Γ' ++ [GammaType Γ τr] ⊢ₙₒ wrap_funs_vars (Var (length Γ')) (length fs - k) (drop (length fs - k) fs) : GammaType (take (length Γ - k) Γ) τr.
Proof.
  induction k.
  - rewrite !Nat.sub_0_r drop_all firstn_all /=.
    constructor. rewrite lookup_app_r; try lia. by rewrite Nat.sub_diag.
  - destruct (drop (length fs - S k) fs) as [|f rem] eqn:eq.
    + (* exfalso *) destruct fs as [|f' fs'].
      * simpl. intro abs. exfalso. lia.
      * intro plt. exfalso.
        assert (abs : (rev (drop (length (rev (f' :: fs')) - S k) (rev (f' :: fs')))) = []).
        { apply nil_length_inv. rewrite rev_length. rewrite drop_length.
          assert (length (drop (length (f' :: fs') - S k) (f' :: fs')) = 0) by by rewrite eq /=.
          rewrite drop_length in H0. by rewrite rev_length. }
        rewrite -firstn_rev rev_involutive /= in abs. inversion abs.
    + intro plt. specialize (IHk ltac:(lia)). assert (lkp : fs !! (length fs - S k) = Some f).
      { rewrite <- (take_drop (length fs - S k) fs) at 2. rewrite lookup_app_r.
        rewrite take_length_le; try lia. rewrite eq. by replace (length fs - S k - (length fs - S k)) with 0 by lia.
        rewrite take_length_le; lia. }
      simpl. replace (S (length fs - S k)) with (length fs - k) by lia.
      destruct (Forall3_lookup_m _ _ _ _ _ _ H lkp) as (τ' & τ & eq1 & eq2 & P).
      apply App_typed with (τ1 := τ).
      * assert (rem = (drop (length fs - k) fs)) as ->.
        { replace rem with (drop 1 (f :: rem)) by by rewrite /= drop_0.
          rewrite -eq drop_drop. by replace (length fs - S k + 1) with (length fs - k) by lia. }
        assert (TArrow τ (GammaType (take (length Γ - S k) Γ) τr) = GammaType (take (length Γ - k) Γ) τr) as ->.
        { assert (take (length Γ - k) Γ = take (length Γ - S k) Γ ++ [τ]) as ->.
          rewrite -(Forall3_length_lm _ _ _ _ H) (Forall3_length_lr _ _ _ _ H) in eq2.
          rewrite <- (take_drop_middle _ _ _ eq2) at 2. rewrite firstn_app take_take.
          replace ((length Γ - k) `min` (length Γ - S k)) with (length Γ - S k) by lia.
          replace (length Γ - k - length (take (length Γ - S k) Γ)) with 1. by rewrite /= take_0.
          rewrite take_length_le; try lia.
          rewrite -(Forall3_length_lm _ _ _ _ H) (Forall3_length_lr _ _ _ _ H) in plt. lia.
          by apply GammaType_snoc.
        }
        apply IHk.
      * apply App_typed with (τ1 := τ'). apply P. constructor. by apply lookup_app_l_Some.
Qed.

Lemma wrap_funs_vars_typed fs τr Γ Γ' (H : Forall3 (fun τ' f τ => ∀Γ, Γ ⊢ₙₒ of_val f : TArrow τ' τ) Γ' fs Γ) :
  Γ' ++ [GammaType Γ τr] ⊢ₙₒ wrap_funs_vars (Var (length Γ')) 0 fs : τr.
Proof.
  rewrite <- (drop_0 fs).
  replace 0 with (length fs - length fs) by lia.
  replace τr with (GammaType (take (length Γ - length fs) Γ) τr) at 2.
  apply (wrap_funs_vars_typed_help fs τr Γ Γ' H). lia.
  by rewrite -(Forall3_length_lm _ _ _ _ H) (Forall3_length_lr _ _ _ _ H) -minus_diag_reverse /= take_0.
Qed.

Lemma wrap_funs_vals_eval_ctx (e1 e2 : expr) (fvs : list (val * val)) (H : rtc STLCmuVS_step e1 e2) :
  rtc STLCmuVS_step (wrap_funs_vals e1 fvs) (wrap_funs_vals e2 fvs).
Proof.
  induction fvs as [|[f v] fvs IH]; first done.
  by apply (rtc_STLCmuVS_step_ctx (fill [AppLCtx _])).
Qed.

Lemma wrap_funs_vals_eval (fvs : list (val * val)) (vs' : list val) (H : Forall2 (fun fv v' => rtc STLCmuVS_step (of_val fv.1 (of_val fv.2)) (of_val v')) fvs vs') :
  ∀ e, let STLCmuVSgam : expr := (LamGamma (length fvs) e) in
       rtc STLCmuVS_step (wrap_funs_vals STLCmuVSgam fvs) (e.[subst_list_val vs']).
Proof.
  revert H. revert vs'. induction fvs as [|[f v] fvs IHfvs] using rev_ind.
  - intros vs' H; destruct vs' as [|v' vs' _] using rev_ind.
    + intros e. by asimpl.
    + exfalso.
      assert (abs : length ([] : list val) = length (vs' ++ [v'])).
      by rewrite -(Forall2_length _ _ _ H). rewrite /= app_length /= in abs. lia.
  - intros ws' I. destruct ((iffLR (Forall2_app_inv_l _ _ _ _)) I) as (vs' & v' & H & P & ->). clear I.
    destruct v' as [|v' empty]; first by inversion P.
    assert (empty = []) as ->. { apply nil_length_inv. cut (length (v :: empty) = length [(f,v)]); auto. by rewrite (Forall2_length _ _ _ P). }
    inversion_clear P. clear H1. rename H0 into P. simpl in P.
    (* okay *)
    rewrite !app_length !Nat.add_1_r. intros e.
    rewrite /= wrap_funs_vals_snoc. fold (LamGamma (length fvs)).
    change (Lam ?e) with (of_val $ LamV e).
    apply rtc_transitive with (y := wrap_funs_vals (LamGamma (length fvs) e).[of_val v'/] fvs).
    apply wrap_funs_vals_eval_ctx.
    eapply rtc_transitive. apply (rtc_STLCmuVS_step_ctx (fill [AppRCtx _])). apply P. simpl. apply rtc_once. apply head_prim_step. auto_head_step.
    rewrite -fill_LamGamma_ctx subst_fill_ctx.
    assert (scp : |sC> 0 ⊢ₙₒ (LamGamma_ctx (length fvs)) ☾ length fvs ☽).
    { change 0 with (length ([] : list type)).
      rewrite <- (replicate_length (length fvs) TUnit).
      eapply (ctx_typed_scoped _ TUnit _ _).
      apply (LamGamma_ctx_typed (replicate (length fvs) TUnit) TUnit).
    }
    rewrite (subst_closed_ctx _ _ _ scp) (subst_closed_ctx_cont _ _ _ scp).
    rewrite subst_list_val_snoc.
    replace e.[upn (length vs') (of_val v' .: ids) >> subst_list_val vs'] with e.[upn (length vs') (of_val v' .: ids)].[subst_list_val vs'] by by asimpl.
    rewrite -(Forall2_length _ _ _ H).
    specialize (IHfvs vs' H e.[upn (length fvs) ((of_val v') .: ids)]). simpl in IHfvs. rewrite fill_LamGamma_ctx. apply IHfvs.
Qed.

Lemma wrap_funs_vals_eval' (vs' : list val) e (fs vs : list val) l (Hl : l = (length fs)) (Hfs : Forall (fun f => Closed (of_val f)) fs)
      (H : Forall3 (fun f v v' => rtc STLCmuVS_step (of_val f (of_val v)) (of_val v')) fs vs vs') :
  let STLCmuVSgam : expr := (LamGamma l e) in
       rtc STLCmuVS_step (wrap_funs_vals STLCmuVSgam (zip fs vs)) (e.[subst_list_val vs']).
Proof.
  rewrite Hl.
  assert (length fs = length (zip fs vs)) as ->.
  { rewrite <- (fst_zip fs vs) at 1. by rewrite fmap_length.
    rewrite (Forall3_length_lm _ _ _ _ H). lia.
  }
  apply wrap_funs_vals_eval.
  pose proof (Forall3_Forall2 _ _ _ _ H) as H'.
  apply (Forall2_impl _ _ _ _ H'). by intros (a, b) c.
Qed.

Lemma zip_snoc {A B} (ls : list A) l (ks : list B) k : length ls = length ks → zip (ls ++ [l]) (ks ++ [k]) = zip ls ks ++ [(l,k)].
Proof.
  revert ks.
  induction ls as [|l0 ls].
  - intros ks Hl; destruct ks;[|inversion Hl]. by simpl.
  - intros ks Hl; destruct ks as [|k0 ks];[inversion Hl|]. simpl in *.
    rewrite IHls; auto.
Qed.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Every parse tree has a corresponding minimal parse tree *)

Require Import Coq.ZArith.ZArith.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Properties.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.Reachable.ParenBalanced.Core.
Require Import Fiat.Parsers.Refinement.BinOpBrackets.ParenBalanced.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Common.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}
          {predata : @parser_computational_predataT Char}
          {rdata' : @parser_removal_dataT' _ G predata}.

  Fixpoint paren_balanced_pb_parse_of_productions
             {valid0 pats}
             (str : String) (p : parse_of G str pats)
             (Hforall : Forall_parse_of (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
             (Hp : pb'_productions G valid0 pats)
             {struct Hp}
  : paren_balanced' str 0 = true
  with paren_balanced_pb_parse_of_production
         {valid0 pat level}
         (str : String) (p : parse_of_production G str pat)
         (Hforall : Forall_parse_of_production (fun _ nt' => is_valid_nonterminal valid0 (of_nonterminal nt')) p)
         (Hp : pb'_production G valid0 level pat)
         {struct Hp}
       : paren_balanced' str level = true.
  Proof.
    { destruct Hp as [|??? Hp0 Hp1].
      { inversion p. }
      { specialize (fun str p H => paren_balanced_pb_parse_of_production _ _ _ str p H Hp0).
        specialize (fun str p H => paren_balanced_pb_parse_of_productions _ _ str p H Hp1).
        dependent destruction p; eauto with nocore. } }
    { destruct Hp as [|????? Hp0 Hp1|??????? Hp].
      { inversion p.
        rewrite paren_balanced'_nil by assumption.
        reflexivity. }
      { specialize (fun str p H => paren_balanced_pb_parse_of_production _ _ _ str p H Hp1).
        specialize (fun str p H => paren_balanced_pb_parse_of_productions _ _ str p H Hp0).
        dependent destruction p.
        let p1 := match goal with p1 : parse_of_production _ _ _ |- _ => constr:(p1) end in
        specialize (paren_balanced_pb_parse_of_production _ p1 (snd Hforall)).
        let p0 := match goal with p0 : parse_of_item _ _ _ |- _ => constr:(p0) end in
        let p := fresh in
        rename p0 into p;
          dependent destruction p.
        let p0 := match goal with p0 : parse_of _ _ _ |- _ => constr:(p0) end in
        specialize (paren_balanced_pb_parse_of_productions _ p0 (snd (fst Hforall))).
        eapply paren_balanced'_split_0; eassumption. }
      { specialize (fun str p H => paren_balanced_pb_parse_of_production _ _ _ str p H Hp).
        clear paren_balanced_pb_parse_of_productions.
        dependent destruction p.
        let p1 := match goal with p1 : parse_of_production _ _ _ |- _ => constr:(p1) end in
        specialize (paren_balanced_pb_parse_of_production _ p1 (snd Hforall)).
        let p0 := match goal with p0 : parse_of_item _ _ _ |- _ => constr:(p0) end in
        let p := fresh in
        rename p0 into p;
          dependent destruction p.
        match goal with
          | [ H : is_true (take _ _ ~= [ _ ]) |- _ ]
            => generalize (length_singleton _ _ H);
              pose proof (take_n_1_singleton _ _ _ H)
        end.
        rewrite paren_balanced'_recr.
        erewrite (proj1 (get_0 _ _)) by eassumption.
        rewrite take_length.
        unfold paren_balanced'_step, pb_check_level, pb_new_level in *.
        split_iff.
        apply Min.min_case_strong;
          repeat match goal with
                   | _ => progress subst
                   | _ => progress intros
                   | [ H : is_true (P ?ch), H' : forall ch', is_true (P ch') -> _ |- _ ]
                     => specialize (H' _ H)
                   | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
                   | [ H : is_true ?x |- context[?x] ] => rewrite H
                   | _ => progress simpl in *
                   | _ => solve [ eauto with nocore ]
                   | [ n : nat, str : _ |- _ ]
                     => let H' := fresh in
                        assert (H' : drop 1 str =s drop n str)
                          by (apply bool_eq_empty; rewrite drop_length; omega);
                          rewrite H';
                          solve [ eauto with nocore ]
                 end. } }
  Defined.
End cfg.


Require Export Base.
Require Export Instances.Galois.
Require Import Classes.Galois.
Require Import Classes.IsBool.
Require Import Classes.IsBool.
Require Import Classes.IsNat.
Require Import Classes.Joinable.
Require Import Classes.Monad.
Require Import Classes.Monad.MonadFail.
Require Import Classes.PreorderedSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.Even.
Require Import Coq.Arith.PeanoNat.
Require Import GenericInterpreter.
Require Import Instances.Joinable.
Require Import Instances.MonadExcept.
Require Import Instances.MonadFail.
Require Import Instances.Preorder.
Require Import Instances.Store.
Require Import Language.Statements.
Require Import Psatz.
Require Import Types.AbstractBool.
Require Import Types.Interval.
Require Import Types.Maps.
Require Import Types.Option.
Require Import Types.Parity.
Require Import Types.State.
Require Import Types.Stores.
Require Import Types.Subtype.

(* Soundness of unit *)
Lemma gamma_unit_sound :
  γ tt tt.
Proof. constructor.  Qed.
Hint Resolve gamma_unit_sound : soundness.

(* Soundness of functions *)
Lemma gamma_fun_apply {A A' B B'} `{Galois A A', Galois B B'}
    (f : A -> B) (f' : A' -> B') x x' :
  γ f f' -> γ x x' -> γ (f x) (f' x').
Proof.
  eauto with soundness.
Qed.
Hint Extern 3 (γ (?f ?x) (?g ?y)) => apply gamma_fun_apply : soundness.

(* Soundness of interpreters *)

Definition avalue := (parity+abstr_bool)%type.

Definition ConcreteState := optionT (StateT (store cvalue) option).

Definition AbstractState := optionAT (StateT (store (avalue+⊤)) option).

Theorem eval_expr_sound : ∀ (e : expr),
  γ
    (shared_eval_expr (M:=AbstractState) (valType:=avalue+⊤) e)
    (shared_eval_expr (M:=ConcreteState) (valType:=cvalue) e).
Proof.
  eapply shared_eval_expr_sound; typeclasses eauto + eauto with soundness.
Qed.
Hint Resolve eval_expr_sound : soundness.

Theorem sound_interpreter: ∀ c,
  γ (shared_ceval (M:=AbstractState) (valType:=avalue+⊤)
    (boolType:=(abstr_bool+⊤)) (natType:=(parity+⊤)) c)
    (shared_ceval (M:=ConcreteState) (valType:=cvalue)
    (boolType:=bool) (natType:=nat) c).
Proof.
  eapply shared_ceval_sound; typeclasses eauto + eauto with soundness.
Qed.