(* PREAMBLE *)

From compcert.cfrontend  Require Csyntax Csem.
From Coq                 Require Bool.
From trancert.lib        Require Algebraic Decidability Tac.
From trancert.properties Require AST.

Import Bool Csyntax Csem Decidability Algebraic AST Tac.

(** *Subexpressions analysis *)

Section Predicate.

  Variable P: expr -> Prop.

  Inductive subexpr_cond:  expr -> Prop :=
  | ecs_field: forall f ty l,
      subexpr_cond l  ->
      subexpr_cond (Efield l f ty)
  | ecs_valof: forall ty l ,
      subexpr_cond l ->
      subexpr_cond (Evalof l  ty)
  | ecs_deref: forall ty l,
      subexpr_cond l ->
      subexpr_cond (Ederef l  ty)
  | ecs_addrof: forall ty l,
      subexpr_cond l ->
      subexpr_cond (Eaddrof l  ty)
  | ecs_unop: forall ty l op,
      subexpr_cond l ->
      subexpr_cond (Eunop op l  ty)
  | ecs_binop: forall ty l r op,
      subexpr_cond l \/ subexpr_cond r->
      subexpr_cond (Ebinop op l r ty)
  | ecs_cast: forall ty l ,
      subexpr_cond l ->
      subexpr_cond (Ecast  l  ty)
  | ecs_seqand: forall ty l r ,
      subexpr_cond l \/ subexpr_cond r ->
      subexpr_cond (Eseqand l r ty)
  | ecs_seqor: forall ty l r ,
      subexpr_cond l \/ subexpr_cond r ->
      subexpr_cond (Eseqor l r ty)
  | ecs_condition: forall ty c l r ,
      subexpr_cond c \/ subexpr_cond l \/ subexpr_cond r ->
      subexpr_cond (Econdition c l r ty)
  | ecs_assign: forall ty l r ,
      subexpr_cond l \/ subexpr_cond r->
      subexpr_cond (Eassign l r ty)
  | ecs_assignop:
      forall ty1 ty2 l r op ,
        subexpr_cond l \/ subexpr_cond r ->
        subexpr_cond (Eassignop op l r ty1 ty2)
  | ecs_postincr: forall id l ty,
        subexpr_cond l ->
        subexpr_cond (Epostincr id l ty)
  | ecs_comma: forall ty l r ,
      subexpr_cond l \/ subexpr_cond r ->
      subexpr_cond (Ecomma l r ty)
  | ecs_paren:
      forall ty1 ty2 r ,
        subexpr_cond r ->
        subexpr_cond (Eparen r ty1 ty2)
  | ecs_call: forall ty r rargs,
      subexpr_cond r \/ subexprlist_cond rargs ->
      subexpr_cond (Ecall r rargs ty)
  | ecs_builtin: forall rargs tyargs ty ef,
      subexprlist_cond rargs ->
      subexpr_cond (Ebuiltin ef tyargs rargs ty)
  | ecs_found: forall e, P e -> subexpr_cond e
  with subexprlist_cond: exprlist -> Prop :=
  | elcs_econs: forall e es,
      subexpr_cond e \/ subexprlist_cond es ->
      subexprlist_cond (Econs e es).

  Hypothesis Hdec: forall e, dec (P e).

  Local Hint Constructors sumbool: subexpr.
  Local Hint Constructors subexpr_cond: subexpr.
  Local Hint Constructors subexprlist_cond: subexpr.

  Theorem subexpr_cond_dec :
    forall e, dec (subexpr_cond e)
    with subexprlist_cond_dec:
           forall e, dec (subexprlist_cond e)
  .
  Proof.
    {
      clear subexpr_cond_dec.
      unfold dec in *.

      induction e; intros;
        try solve [
              match goal with
                      | [ |- context [subexpr_cond ?x]] =>
                        destruct (Hdec x);
                        try destruct IHe;
                        try destruct IHe1;
                        try destruct IHe2;
                        try destruct IHe3
                      end; auto with subexpr;
              constructor 2; inversion_clear 1; decomp; contradiction
            ].
      - match goal with
        | [ |- context [subexpr_cond ?x]] =>
          destruct (Hdec x), IHe, (subexprlist_cond_dec rargs); auto with subexpr
        end.
        constructor 2; inversion_clear 1; decomp; contradiction.
      - match goal with
        | [ |- context [subexpr_cond ?x]] =>
          destruct (Hdec x), (subexprlist_cond_dec rargs); auto with subexpr
        end.
        constructor 2; inversion_clear 1; contradiction.
    }
    {
      clear subexprlist_cond_dec.
      unfold dec in *.
      induction e.
      - right. inversion 1.
      - destruct (Hdec r1), IHe, (subexpr_cond_dec r1); auto with subexpr.
        constructor 2; inversion_clear 1; decomp; contradiction.
    }
  Defined.

End Predicate.

(*

  Inductive subexpr_cond:  expr -> expr -> Prop :=
| ecs_found: forall e, P e -> subexpr_cond e e
| ecs_field: forall f ty l e,
    subexpr_cond l e ->
    subexpr_cond (Efield l f ty) e
| ecs_valof: forall ty l e,
    subexpr_cond l e ->
    subexpr_cond (Evalof l  ty) e
| ecs_deref: forall ty l e,
    subexpr_cond l e ->
    subexpr_cond (Ederef l  ty) e
| ecs_addrof: forall ty l e,
    subexpr_cond l e ->
    subexpr_cond (Eaddrof l  ty) e
| ecs_unop: forall ty l e op,
    subexpr_cond l e ->
    subexpr_cond (Eunop op l  ty) e
| ecs_binop_l: forall ty l r e op,
    subexpr_cond l e ->
    subexpr_cond (Ebinop op l r ty) e
| ecs_binop_r: forall ty l r e op,
    subexpr_cond r e ->
    subexpr_cond (Ebinop op l r ty) e
| ecs_cast: forall ty l e ,
    subexpr_cond l e ->
    subexpr_cond (Ecast  l  ty) e
| ecs_seqand_l: forall ty l r e ,
    subexpr_cond l e ->
    subexpr_cond (Eseqand l r ty) e
| ecs_seqand_r: forall ty l r e ,
    subexpr_cond r e ->
    subexpr_cond (Eseqand l r ty) e
| ecs_seqor_l: forall ty l r e ,
    subexpr_cond l e ->
    subexpr_cond (Eseqor l r ty) e
| ecs_seqor_r: forall ty l r e ,
    subexpr_cond r e ->
    subexpr_cond (Eseqor l r ty) e
| ecs_condition_c:
    forall ty c l r e , subexpr_cond c e ->
    subexpr_cond (Econdition c l r ty) e
| ecs_condition_l:
    forall ty c l r e , subexpr_cond l e ->
    subexpr_cond (Econdition c l r ty) e
| ecs_condition_r:
    forall ty c l r e, subexpr_cond r e ->
    subexpr_cond (Econdition c l r ty) e
| ecs_assign_l:
    forall ty l r e , subexpr_cond l e ->
    subexpr_cond (Eassign l r ty) e
| ecs_assign_r:
    forall ty l r e , subexpr_cond r e ->
    subexpr_cond (Eassign l r ty) e
| ecs_assignop_l:
    forall ty1 ty2 l r e op , subexpr_cond l e ->
    subexpr_cond (Eassignop op l r ty1 ty2) e
| ecs_assignop_r:
    forall ty1 ty2 l r e op , subexpr_cond r e ->
    subexpr_cond (Eassignop op l r ty1 ty2) e
| ecs_postincr:
    forall id l ty e, subexpr_cond l e ->
    subexpr_cond (Epostincr id l ty) e
| ecs_comma_l:
    forall ty l r e , subexpr_cond l e ->
    subexpr_cond (Ecomma l r ty) e
| ecs_comma_r:
    forall ty l r e , subexpr_cond r e ->
    subexpr_cond (Ecomma l r ty) e
| ecs_paren:
    forall ty1 ty2 r e , subexpr_cond r e ->
    subexpr_cond (Eparen r ty1 ty2) e
| ecs_call_r:
    forall ty r e rargs, subexpr_cond r e ->
    subexpr_cond (Ecall r rargs ty) e
| ecs_call_l:
    forall ty r e rargs, subexprlist_cond rargs e ->
    subexpr_cond (Ecall r rargs ty) e
| ecs_builtin:
    forall e rargs tyargs ty ef, subexprlist_cond rargs e ->
    subexpr_cond (Ebuiltin ef tyargs rargs ty) e
with subexprlist_cond: exprlist ->expr -> Prop :=
     | elcs_econs_l:
         forall e e' es, subexpr_cond e e' ->
         subexprlist_cond (Econs e es) e'
     | elcs_econs_r:
         forall e e' es, subexprlist_cond es e' ->
         subexprlist_cond (Econs e es) e' .

*)


Require Import POCS.

Require Import ReplicatedDiskImpl.
Require Import TwoDiskImpl.
Require Import TwoDiskBaseImpl.
Require Import Common.NbdServer.

Module td := TwoDisk TwoDiskBase.
Module rd := ReplicatedDisk td.
Module s := NBDServer rd.

Definition serverLoop := s.serverLoop.
Definition size := s.size.
Definition init := s.init.


(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs. <contact@nomadic-labs.com> *)

(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"), *)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)

(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)

(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)

(* Finite maps implemented as finite sets of pairs. *)

Require set.
Require Import error.
Import error.Notations.

Section map.

  Variable A : Set.
  Variable B : Set.
  Variable compare : A -> A -> comparison.

  Hypothesis compare_eq_iff : forall a b, compare a b = Eq <-> a = b.
  Hypothesis lt_trans : Relations_1.Transitive (fun a b => compare a b = Lt).
  Hypothesis gt_trans : Relations_1.Transitive (fun a b => compare a b = Gt).

  Lemma compare_refl a : compare a a = Eq.
  Proof.
    apply (compare_eq_iff a a).
    reflexivity.
  Qed.

  Lemma compare_diff : forall a b, compare a b = Lt \/ compare a b = Gt <-> a <> b.
  Proof.
    intros. split.
    - (* -> *)
      intros [Hdiff|Hdiff] contra;
      rewrite <- compare_eq_iff in contra; rewrite Hdiff in contra; discriminate contra.
    - (* <- *)
      intro Hdiff. destruct (compare a b) eqn:Hab.
      + apply compare_eq_iff in Hab. contradiction.
      + left. reflexivity.
      + right. reflexivity.
  Qed.

  Definition map_compare (x_ y_ : A * B) :=
    match x_, y_ with (x, _), (y, _) => compare x y end.

  Definition map := set.set (A * B) map_compare.

  Fixpoint list_mem (x : A) (l : list (A * B)) : bool :=
    match l with
    | nil => false
    | cons y l =>
      let (k, v) := y in
      match compare x k with
      | Lt => false
      | Eq => true
      | Gt => list_mem x l
      end
    end.

  Definition mem (x : A) (m : map) : bool :=
    let (l, _) := m in list_mem x l.

  Fixpoint list_remove (x : A) (l : list (A * B)) : list (A * B) :=
    match l with
    | nil => nil
    | cons y l =>
      let (k, v) := y in
      match compare x k with
      | Lt => cons y l
      | Eq => l
      | Gt => cons y (list_remove x l)
      end
    end.

  Lemma remove_in x v y l : List.In (x, v) (list_remove y l) -> List.In (x, v) l.
  Proof.
    induction l as [|(z, v') l]; simpl.
    - auto.
    - case_eq (compare y z).
      + intuition.
      + intros Hlt Hin.
        simpl in Hin.
        assumption.
      + intros Hgt Hin.
        simpl in Hin.
        intuition.
  Qed.

  Fixpoint list_replace (x : A) (v : B) (l : list (A * B)) : list (A * B) :=
    match l with
    | nil => cons (x, v) nil
    | cons y l =>
      let (k, _) := y in
      match compare x k with
      | Lt => cons (x, v) (cons y l)
      | Eq => cons (x, v) l
      | Gt => cons y (list_replace x v l)
      end
    end.

  Lemma list_replace_same x v v' l :
    Sorted.StronglySorted (set.lt _ map_compare) l ->
    List.In (x, v) (list_replace x v' l) <-> v = v'.
  Proof.
    induction l as [|(y, v'') l].
    - simpl.
      intuition congruence.
    - simpl.
      case_eq (compare x y).
      + intros He Hs.
        apply Sorted.StronglySorted_inv in Hs.
        destruct Hs as (Hs, Hf).
        rewrite compare_eq_iff in He.
        simpl.
        split.
        * intros [He2|Hin].
          {
            congruence.
          }
          {
            rewrite List.Forall_forall in Hf.
            specialize (Hf (x, v) Hin).
            unfold set.lt, map_compare in Hf.
            symmetry in He.
            rewrite <- compare_eq_iff in He.
            congruence.
          }
        * intro; left; congruence.
      + intros Hlt Hs.
        apply Sorted.StronglySorted_inv in Hs.
        destruct Hs as (Hs, Hf).
        simpl.
        split.
        * intros [He2|Hin].
          {
            congruence.
          }
          {
            rewrite List.Forall_forall in Hf.
            specialize (Hf (x, v)).
            unfold set.lt, map_compare in Hf.
            simpl in Hin.
            destruct Hin as [He|Hin].
            - injection He.
              intros _ He2.
              symmetry in He2.
              rewrite <- compare_eq_iff in He2.
              congruence.
            - specialize (Hf Hin).
              assert (compare x x = Lt) by (apply (lt_trans x y x); assumption).
              assert (compare x x = Eq) by (apply (compare_eq_iff x x); reflexivity).
              congruence.
          }
        * intro He.
          destruct He.
          left; reflexivity.
      + simpl.
        intros Hgt Hs.
        rewrite IHl.
        * split; [|intuition].
          intros [He|He]; [|auto].
          injection He.
          intros _ He2.
          symmetry in He2.
          rewrite <- compare_eq_iff in He2.
          congruence.
        * inversion Hs.
          assumption.
  Qed.

  Lemma list_replace_diff x v y v' l :
    Sorted.StronglySorted (set.lt _ map_compare) l ->
    x <> y ->
    List.In (x, v) (list_replace y v' l) <-> List.In (x, v) l.
  Proof.
    induction l as [|(z, v'') l]; simpl.
    - intuition congruence.
    - intros Hs Hd.
      case_eq (compare y z).
      + intro He.
        simpl.
        rewrite compare_eq_iff in He.
        destruct He.
        intuition congruence.
      + intro Hlt.
        simpl.
        intuition congruence.
      + intro Hgt.
        simpl.
        rewrite IHl.
        * intuition congruence.
        * inversion Hs.
          assumption.
        * assumption.
  Qed.

  Lemma list_replace_in x v y v' l :
    Sorted.StronglySorted (set.lt _ map_compare) l ->
    List.In (x, v) (list_replace y v' l) <->
      (match compare x y with Eq => v = v' | _ => List.In (x, v) l end).
  Proof.
    case_eq (compare x y).
    - intro He.
      apply compare_eq_iff in He.
      destruct He.
      apply list_replace_same.
    - intros Hlt Hs.
      apply list_replace_diff.
      + assumption.
      + intro He.
        rewrite <- compare_eq_iff in He.
        congruence.
    - intros Hgt Hs.
      apply list_replace_diff.
      + assumption.
      + intro He.
        rewrite <- compare_eq_iff in He.
        congruence.
  Qed.

  Definition list_update (x : A) (vo : option B) (l : list (A * B)) : list (A * B) :=
    match vo with
    | None => list_remove x l
    | Some v => list_replace x v l
    end.

  Program Definition update (x : A) (vo : option B) (m : map) : map :=
    let (l, _) := m in
    exist _ (list_update x vo l) _.
  Next Obligation.
    destruct vo as [v|]; simpl.
    - induction l as [|(k, v') l]; simpl.
      + constructor.
        * assumption.
        * constructor.
      + apply Sorted.StronglySorted_inv in H.
        destruct H as (Hl, Hf).
        specialize (IHl Hl).
        case_eq (compare x k).
        * intro He.
          apply compare_eq_iff in He.
          destruct He.
          constructor.
          {
            assumption.
          }
          {
            rewrite List.Forall_forall.
            intros (z, v'') Hin.
            rewrite List.Forall_forall in Hf.
            specialize (Hf (z, v'') Hin).
            generalize Hf.
            unfold set.lt, map_compare.
            auto.
          }
        * intro Hxk.
          constructor.
          {
            constructor; assumption.
          }
          {
            apply List.Forall_forall.
            intros (z, v'') Hin.
            rewrite List.Forall_forall in Hf.
            specialize (Hf (z, v'')).
            simpl in Hin.
            destruct Hin as [He | Hin].
            - injection He.
              intros _ He2.
              destruct He2.
              exact Hxk.
            - apply (lt_trans _ k).
              + assumption.
              + apply Hf.
                assumption.
          }
        * intro Hgt.
          constructor; try assumption.
          apply List.Forall_forall.
          intros (y,  v'').
          rewrite list_replace_in; try assumption.
          case_eq (compare y x).
          {
            intro He.
            rewrite compare_eq_iff in He.
            destruct He.
            intros _.
            unfold set.lt, map_compare.
            apply set.compare_gt_lt; assumption.
          }
          {
            intro Hlt.
            rewrite List.Forall_forall in Hf.
            exact (Hf (y, v'')).
          }
          {
            intros Hgt2 _.
            unfold set.lt, map_compare.
            apply set.compare_gt_lt; try assumption.
            apply (gt_trans _ x); assumption.
          }
    - induction l as [|(k, v') l]; simpl.
      + assumption.
      + case_eq (compare x k).
        * intros _.
          inversion H.
          assumption.
        * intros _.
          assumption.
        * apply Sorted.StronglySorted_inv in H.
          destruct H as (Hs, Hf).
          intro Hgt.
          constructor.
          {
            auto.
          }
          {
            apply List.Forall_forall.
            intros (y, v'').
            intro Hy.
            apply remove_in in Hy.
            rewrite List.Forall_forall in Hf.
            exact (Hf _ Hy).
          }
  Qed.

  Program Definition empty : map :=
    exist _ nil _.
  Next Obligation.
    constructor.
  Defined.

  Fixpoint list_get (x : A) (l : list (A * B)) : option B :=
    match l with
    | nil => None
    | cons y l =>
      let (k, v) := y in
      match compare x k with
      | Lt => None
      | Eq => Some v
      | Gt => list_get x l
      end
    end.

  Definition get (x : A) (m : map) : option B :=
    let (l, _) := m in list_get x l.

  Lemma StronglySorted_inv_iff (A' : Type) (R : A' -> A' -> Prop) (a : A')
        (l : list A') :
       Sorted.StronglySorted R (a :: l) <->
       Sorted.StronglySorted R l /\ List.Forall (R a) l.
  Proof.
    split.
    - apply Sorted.StronglySorted_inv.
    - generalize Sorted.SSorted_cons.
      intuition.
  Qed.

  Lemma forall_cons (A' : Type) (P : A' -> Prop) (a : A') (l : list A') :
    List.Forall P (cons a l) <-> (P a /\ List.Forall P l).
  Proof.
    split.
    - intro H.
      inversion H.
      split; assumption.
    - intros (HPa, Hf).
      constructor; assumption.
  Qed.

  Lemma list_sorted_map_fst (l : list (A * B)) :
    Sorted.StronglySorted (fun x y => map_compare x y = Lt) l <->
    Sorted.StronglySorted (fun x y => compare x y = Lt) (List.map fst l).
  Proof.
    induction l as [|(x, v) l]; simpl.
    - split; constructor.
    - rewrite StronglySorted_inv_iff.
      rewrite StronglySorted_inv_iff.
      rewrite IHl.
      clear IHl.
      assert (List.Forall (fun y : A * B => map_compare (x, v) y = Lt) l <->
              List.Forall (fun y : A => compare x y = Lt) (List.map fst l)) as H.
      + induction l as [|(y, v') l]; simpl.
        * split; constructor.
        * rewrite forall_cons.
          rewrite forall_cons.
          rewrite IHl.
          intuition.
      + rewrite H.
        intuition.
  Qed.

  Definition size (m : map) : nat :=
    let (l, _) := m in List.length l.

  Lemma list_get_lt a b l :
    List.Forall (fun y => map_compare (a, b) y = Lt) l ->
    Sorted.StronglySorted (fun x y => map_compare x y = Lt) l ->
    list_get a l = None.
  Proof.
    intros Hf Hl.
    destruct l as [|(a2, b2) l].
    - reflexivity.
    - simpl.
      rewrite List.Forall_forall in Hf.
      specialize (Hf (a2, b2) (or_introl eq_refl)).
      simpl in Hf.
      rewrite Hf.
      reflexivity.
  Qed.

  Lemma extensionality (m1 m2 : map) :
    (forall x, get x m1 = get x m2) -> m1 = m2.
  Proof.
    destruct m1 as (l1, H1).
    destruct m2 as (l2, H2).
    simpl.
    intro Hf.
    assert (l1 = l2).
    - generalize l2 H2 Hf; clear l2 H2 Hf; induction l1 as [|(a1, b1) l1]; intros [|(a2, b2) l2] H2 Hf.
      + reflexivity.
      + exfalso.
        specialize (Hf a2).
        simpl in Hf.
        rewrite compare_refl in Hf.
        discriminate.
      + exfalso.
        specialize (Hf a1).
        simpl in Hf.
        rewrite compare_refl in Hf.
        discriminate.
      + assert (a1 = a2 /\ b1 = b2).
        * generalize (Hf a1); intro Ha1.
          simpl in Ha1.
          rewrite compare_refl in Ha1.
          generalize (Hf a2); intro Ha2.
          simpl in Ha2.
          rewrite compare_refl in Ha2.
          case_eq (compare a1 a2).
          -- intro He.
             rewrite compare_eq_iff in He.
             split; [assumption|].
             subst a2.
             rewrite compare_refl in Ha1.
             injection Ha1.
             auto.
          -- intro Hlt.
             rewrite Hlt in Ha1.
             discriminate.
          -- intro Hgt.
             rewrite Hgt in Ha1.
             rewrite <- set.compare_gt_lt in Hgt;
               [|assumption|assumption|assumption].
             rewrite Hgt in Ha2.
             discriminate.
        * destruct H; subst a2; subst b2.
          f_equal.
          apply IHl1.
          -- inversion H1.
             assumption.
          -- inversion H2.
             assumption.
          -- intro a3.
             specialize (Hf a3).
             simpl in Hf.
             case_eq (compare a3 a1).
             ** intro Heq.
                rewrite compare_eq_iff in Heq.
                subst a3.
                rewrite (list_get_lt a1 b1 l1); [|inversion H1; assumption|inversion H1; assumption].
                rewrite (list_get_lt a1 b1 l2); [|inversion H2; assumption|inversion H2; assumption].
                reflexivity.
             ** intro Hlt.
                rewrite (list_get_lt a3 b1 l1);
                  [rewrite (list_get_lt a3 b1 l2)| |].
                --- reflexivity.
                --- apply (@List.Forall_impl _ (fun y => map_compare (a1, b1) y = Lt)); [|inversion H2; assumption].
                    intros (a4, b4).
                    simpl.
                    apply lt_trans.
                    assumption.
                --- inversion H2; assumption.
                --- apply (@List.Forall_impl _ (fun y => map_compare (a1, b1) y = Lt)); [|inversion H1; assumption].
                    intros (a4, b4).
                    simpl.
                    apply lt_trans.
                    assumption.
                --- inversion H1; assumption.
             ** intro Hgt.
                rewrite Hgt in Hf.
                exact Hf.
    - destruct H.
      f_equal.
      apply set.sorted_irrel.
  Qed.

  (* Interesting lemmas to use when working with maps *)

  Lemma map_getmem : forall k m v,
      get k m = Some v -> mem k m.
  Proof.
    intros.
    destruct m as [l]. simpl. simpl in H.
    induction l.
    - (* nil *)
      simpl in H. inversion H.
    - (* h :: t *)
      simpl. simpl in H.
      destruct a as [k' v']. destruct (compare k k').
      + (* Eq *) constructor.
      + (* Lt *) inversion H.
      + (* Gt *) apply IHl. inversion s. assumption. assumption.
  Qed.

  Lemma map_memget : forall k m,
      mem k m -> exists v, get k m = Some v.
  Proof.
    intros.
    destruct m as [l]. simpl. simpl in H.
    induction l.
    - (* nil *)
      exfalso. simpl in H. inversion H.
    - (* h :: t *)
      inversion s; subst.
      specialize (IHl H2).
      simpl in H. simpl.
      destruct a as [k' v']. destruct (compare k k').
      + (* Eq *) exists v'. reflexivity.
      + (* Lt *) inversion H.
      + (* Gt *)
        specialize (IHl H). destruct IHl as [v'' IHl].
        exists v''. assumption.
  Qed.

  Lemma map_updateeq : forall k m v,
      get k (update k (Some v) m) = (Some v).
  Proof.
    intros.
    destruct m as [l]. unfold get, update.
    assert ((compare k k) = Eq) as Hkk by (apply compare_eq_iff; reflexivity).
    induction l.
    - (* nil *)
      simpl. rewrite Hkk. reflexivity.
    - (* h :: t *)
      simpl. inversion s; subst.
      specialize (IHl H1). simpl in IHl.
      destruct a as [k' v'].
      destruct (compare k k') eqn:Hkk'; simpl.
      + (* Eq *) simpl. rewrite Hkk. reflexivity.
      + (* Lt *) simpl. rewrite Hkk. reflexivity.
      + (* Gt *) rewrite Hkk'. assumption.
  Qed.

  Lemma map_updateneq : forall k k' m v,
      k <> k' ->
      get k' (update k (Some v) m) =
      get k' m.
  Proof.
    intros.
    destruct m as [l]. unfold get, update; simpl.
    induction l; simpl.
    - (* nil *)
      destruct (compare k' k) eqn:Hcp; try reflexivity.
      apply compare_eq_iff in Hcp. symmetry in Hcp. contradiction.
    - (* h :: t *)
      inversion s; subst.
      specialize (IHl H2). simpl in IHl.
      destruct a as [k'' v''].
      destruct (compare k k'') eqn:Hkk''; destruct (compare k' k'') eqn:Hk'k''; simpl;
        try apply compare_eq_iff in Hkk''; try apply compare_eq_iff in Hk'k''; subst;
          assert (compare k'' k'' = Eq) as Hk'' by (apply compare_eq_iff; reflexivity);
          try (rewrite Hk'k''; auto).
      + contradiction.
      + rewrite Hk''. apply set.compare_gt_lt in Hkk''; try assumption.
        rewrite Hkk''. reflexivity.
      + destruct (compare k' k) eqn:Hk'k; try reflexivity.
        apply compare_eq_iff in Hk'k. symmetry in Hk'k. contradiction.
      + apply set.compare_gt_lt in Hkk''; try assumption.
        unfold Relations_1.Transitive in gt_trans.
        assert (compare k' k = Gt) as Hk'k by (eapply gt_trans; eassumption).
        rewrite Hk'k. reflexivity.
      + rewrite Hk''. reflexivity.
  Qed.

  Lemma map_updateSome_spec : forall k v m nm,
      nm = update k (Some v) m <->
      (get k nm = (Some v) /\
       (forall k', k <> k' -> map.get k' nm = map.get k' m)).
  Proof.
    intros. split.
    - (* -> *)
      intros Hnm. subst. split.
      apply map_updateeq. intros k' Hdiff. apply map_updateneq. assumption.
    - (* <- *)
      intros [HSame HDiff].
      apply map.extensionality; try assumption.
      intro k'.
      specialize (compare_diff k k') as HKeyDiff.
      destruct (compare k k') eqn:Hkk'.
      + (* Eq *)
        apply compare_eq_iff in Hkk'; subst.
        rewrite HSame. symmetry. apply map_updateeq.
      + (* Lt *)
        assert (k <> k') by (apply HKeyDiff; left; reflexivity).
        assert (k <> k') as H2 by assumption.
        apply HDiff in H. rewrite H. symmetry.
        apply map_updateneq. assumption.
      + (* Gt *)
        assert (k <> k') by (apply HKeyDiff; right; reflexivity).
        assert (k <> k') as H2 by assumption.
        apply HDiff in H. rewrite H. symmetry.
        apply map_updateneq. assumption.
  Qed.

  Lemma map_updatemem : forall k m v,
      mem k m ->
      forall k', mem k (map.update k' (Some v) m).
  Proof.
    intros.
    destruct m as [l]. unfold get, update. simpl. simpl in H.
    induction l; simpl; simpl in H.
    - (* nil *) inversion H.
    - (* h :: t *)
      inversion s; subst. specialize (IHl H2).
      destruct a as [k'' v''].
      destruct (compare k k'') eqn:Hkk''; destruct (compare k' k'') eqn:Hk'k'';
        simpl in H; simpl;
          try rewrite compare_eq_iff in Hkk''; try rewrite compare_eq_iff in Hk'k''; subst;
            assert (compare k'' k'' = Eq) as Hk'' by (apply compare_eq_iff; reflexivity);
            try inversion H;
            try rewrite Hk''; try rewrite Hkk''; try exact ITT.
      + constructor.
      + apply set.compare_gt_lt in Hk'k''; try assumption.
        rewrite Hk'k''.
        constructor.
      + constructor.
      + assumption.
      + apply set.compare_gt_lt in Hk'k''; try assumption.
        rewrite (gt_trans _ _ _ Hkk'' Hk'k'').
        assumption.
      + apply IHl; assumption.
  Qed.

  Ltac comparison_case k1 k2 H Hmem :=
    case_eq (compare k1 k2); intro H; simpl in Hmem; try rewrite H in Hmem;
    [ rewrite compare_eq_iff in H; try assumption | | ].

  Lemma map_updatemem_rev : forall k k' m v,
      k <> k' ->
      mem k (map.update k' (Some v) m) ->
      mem k m.
  Proof.
    intros k k' m v Hkk' Hmem.
    destruct m as [l].
    simpl in *.
    induction l as [|(k'', v'') l]; simpl in *.
    - (* nil *)
      comparison_case k k' H Hmem.
      + congruence.
      + inversion Hmem.
      + inversion Hmem.
    - (* h :: t *)
      comparison_case k' k'' Hk'k'' Hmem;
        [ subst k'' | comparison_case k k'' Hkk'' Hmem | comparison_case k k'' Hkk'' Hmem ]; simpl in Hmem; comparison_case k k' Hckk' Hmem;
          try constructor; simpl in *; try (exact Hmem); try (destruct Hmem);
            try congruence;
            inversion s; apply IHl; assumption.
  Qed.

End map.

Fixpoint list_map (B B' : Set) (f : B -> M B') (l : list B) : M (list B') :=
  match l with
  | nil => Return nil
  | cons x l =>
    let! b' := f x in
    let! l' := list_map _ _ f l in
    Return (cons b' l')
  end.

Definition list_map_pair (A B B' : Set) (f : (A * B) -> M B') :
  list (A * B) -> M (list (A * B')) :=
  list_map (A * B) (A * B')
           (fun ab => let! b' := f ab in Return (fst ab, b')).

Lemma list_map_fst A B B' f l l' :
  list_map_pair A B B' f l = Return l' ->
  List.map fst l = List.map fst l'.
Proof.
  generalize l'. clear l'.
  induction l as [|(x, v) l].
  - simpl.
    intros l' H.
    injection H.
    intro He.
    destruct He.
    reflexivity.
  - simpl.
    intro l'.
    unfold list_map_pair.
    simpl.
    case_eq (f (x, v)); simpl; try congruence.
    intros b' He.
    case_eq (list_map (A * B) (A * B') (fun ab : A * B =>
        let! b'0 : B' := f ab in Return (fst ab, b'0)) l); simpl; try congruence.
    intros l'' He2.
    specialize (IHl l'').
    intro H3.
    injection H3.
    intro Hl'.
    destruct Hl'.
    simpl.
    f_equal.
    apply IHl.
    assumption.
Qed.

Program Definition map_fun_aux (A B B' : Set) compare (f : A * B -> M B') (l : list (A * B))
        (H : Sorted.StronglySorted (fun x y => map_compare _ _ compare x y = Lt) l): M (map A B' compare) :=
  match (list_map_pair _ _ _ f l) with
  | Return l' => Return (exist _ l' _)
  | Failed _ e => Failed _ e
  end.
Next Obligation.
  unfold set.lt.
  rewrite list_sorted_map_fst.
  rewrite <- (list_map_fst _ _ _ f l).
  + apply list_sorted_map_fst.
    assumption.
  + symmetry.
    assumption.
Defined.

Definition map_fun (A B B' : Set) comp
  (f : A * B -> M B')
  (m : map A B comp) : M (map A B' comp) :=
  let (l, H) := m in
  map_fun_aux _ _ _ comp f l H.


From mathcomp Require Import ssreflect.
From mathcomp Require order.
From stdpp Require Import gmap.
From iris.algebra Require Import agree auth gset gmap namespace_map.
From iris.base_logic.lib Require Import invariants saved_prop.
From iris.heap_lang Require Import notation proofmode.
From iris.heap_lang.lib Require Import nondet_bool.
From cryptis Require Import lib term cryptis.
From cryptis.primitives Require Import notations comp.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition nondet_int_loop : val := rec: "loop" "n" :=
  if: nondet_bool #() then "n" else "loop" ("n" + #1).

Definition nondet_int : val := λ: <>,
  let: "n" := nondet_int_loop #0 in
  if: nondet_bool #() then "n" else - "n".

Definition send : val := λ: "c", Fst "c".
Definition recv : val := λ: "c", Snd "c" #().

Definition tint : val := λ: "n",
  (#TInt_tag, "n").

Definition to_int : val := λ: "t",
  if: Fst "t" = #TInt_tag then SOME (Snd "t")
  else NONE.

Definition tuple : val := λ: "t1" "t2",
  (#TPair_tag, ("t1", "t2")).

Definition untuple : val := λ: "t",
  if: Fst "t" = #TPair_tag then SOME (Snd "t")
  else NONE.

Definition list_of_term : val := rec: "loop" "t" :=
  if: Fst "t" = #TInt_tag then
    if: Snd "t" = #0 then SOMEV NONEV else NONEV
  else if: Fst "t" = #TPair_tag then
    let: "t" := Snd "t" in
    bind: "l" := "loop" (Snd "t") in
    SOME (SOME (Fst "t", "l"))
  else NONE.

Definition term_of_list : val := rec: "loop" "l" :=
  match: "l" with NONE => (#TInt_tag, #0)
  | SOME "p" => tuple (Fst "p") ("loop" (Snd "p"))
  end.

Definition tag (N : namespace) : val := λ: "t",
  tuple (TInt (Zpos (encode N))) "t".

Definition untag (N : namespace) : val := λ: "t",
  bind: "t" := untuple "t" in
  bind: "tag" := to_int (Fst "t") in
  if: "tag" = #(Zpos (encode N))then SOME (Snd "t") else NONE.

Definition mknonce : val := λ: <>,
  let: <>  := ref #() in
  let: "n" := ref #() in
  (#TNonce_tag, "n").

Definition is_key : val := λ: "t",
  if: Fst "t" = #TKey_tag then SOME (Fst (Snd "t"))
  else NONE.

Definition enc : val := λ: "k" "t",
  if: (Fst "k" = #TKey_tag) &&
      (Fst (Snd "k") = #(int_of_key_type Enc)) then
    (#TEnc_tag, (Snd (Snd "k"), "t"))
  else "t".

Definition hash : val := λ: "t", (#THash_tag, "t").

Definition dec : val := λ: "k" "t",
  if: (Fst "k" = #TKey_tag)
      && (Fst (Snd "k") = #(int_of_key_type Dec))
      && (Fst "t" = #TEnc_tag)
      && (eq_term (Snd (Snd "k")) (Fst (Snd "t"))) then
    SOME (Snd (Snd "t"))
  else
    NONE.

Definition tenc c : val := λ: "k" "t",
  enc "k" (tag c "t").

Definition tdec c : val := λ: "k" "t",
  bind: "t" := dec "k" "t" in
  untag c "t".

Definition mkkey : val := λ: "k",
  ((#TKey_tag, (#(int_of_key_type Enc), "k")),
   (#TKey_tag, (#(int_of_key_type Dec), "k"))).

Definition tgroup : val := λ: "t",
  (#TExp_tag, ("t", NONEV)).

Definition to_ek : val := λ: "t",
  bind: "kt" := is_key "t" in
  assert: ("kt" = repr Enc) in
  SOME "t".

Definition to_dk : val := λ: "t",
  bind: "kt" := is_key "t" in
  assert: ("kt" = repr Dec) in
  SOME "t".

Section Proofs.

Context `{!heapG Σ, !cryptisG Σ}.
Notation nonce := loc.

Implicit Types E : coPset.
Implicit Types a : nonce.
Implicit Types t : term.
Implicit Types v : val.
Implicit Types Φ : prodO locO termO -n> iPropO Σ.
Implicit Types Ψ : val → iProp Σ.
Implicit Types N : namespace.

Lemma wp_nondet_int_loop Ψ (m : Z) :
  (∀ n : Z, Ψ #n) -∗
  WP nondet_int_loop #m {{ Ψ }}.
Proof.
iIntros "post"; iLöb as "IH" forall (m); wp_rec.
wp_bind (nondet_bool _).
iApply nondet_bool_spec => //.
iIntros "!> %b _"; case: b; wp_if; first by iApply "post".
by wp_pures; iApply "IH".
Qed.

Lemma wp_nondet_int Ψ :
  (∀ n : Z, Ψ #n) -∗
  WP nondet_int #() {{ Ψ }}.
Proof.
iIntros "post"; rewrite /nondet_int; wp_pures.
wp_bind (nondet_int_loop _); iApply wp_nondet_int_loop.
iIntros "%n"; wp_pures; wp_bind (nondet_bool _).
iApply nondet_bool_spec => //.
iIntros "!> %b _"; case: b; wp_if; first by iApply "post".
by wp_pures; iApply "post".
Qed.

Definition channel c : iProp Σ :=
  ∃ (sf rf : val), ⌜c = (sf, rf)%V⌝ ∗
    □ (∀ E t Ψ, ⌜↑cryptisN ⊆ E⌝ -∗ pterm t -∗ Ψ #() -∗
                WP sf t @ E {{ Ψ }}) ∗
    □ (∀ E Ψ, ⌜↑cryptisN ⊆ E⌝ -∗ (∀ t, pterm t -∗ Ψ t) -∗
              WP rf #() @ E {{ Ψ }}).

Global Instance channel_persistent c : Persistent (channel c).
Proof. apply _. Qed.

Lemma wp_send E c t Ψ :
  ↑cryptisN ⊆ E →
  channel c -∗
  ▷ pterm t -∗
  Ψ #() -∗
  WP send c t @ E {{ Ψ }}.
Proof.
move=> sub; iDestruct 1 as (sf cf) "#(-> & H & _)".
iIntros "#??"; rewrite /send; wp_pures.
by iApply "H".
Qed.

Lemma wp_recv E c Ψ :
  ↑cryptisN ⊆ E →
  channel c -∗
  (∀ t, pterm t -∗ Ψ t) -∗
  WP recv c @ E {{ Ψ }}.
Proof.
move=> sub; iDestruct 1 as (sf cf) "#(-> & _ & H)".
iIntros "?"; rewrite /recv; wp_pures.
by iApply "H".
Qed.

Lemma twp_tint E Ψ n : Ψ (TInt n) -∗ WP tint #n @ E [{ Ψ }].
Proof.
by rewrite /tint val_of_term_eq; iIntros "Hpost"; wp_pures.
Qed.

Lemma wp_tint E Ψ n : Ψ (TInt n) -∗ WP tint #n @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_tint. Qed.

Lemma twp_to_int E t Ψ :
  Ψ (repr (Spec.to_int t)) -∗
  WP to_int t @ E [{ Ψ }].
Proof.
rewrite /to_int val_of_term_eq; iIntros "Hpost"; wp_pures.
case: t; by move=> *; wp_pures; eauto.
Qed.

Lemma wp_to_int E t Ψ :
  Ψ (repr (Spec.to_int t)) -∗
  WP to_int t @ E {{ Ψ }}.
Proof.
by iIntros "?"; iApply twp_wp; iApply twp_to_int.
Qed.

Lemma twp_tuple E t1 t2 Ψ :
  Ψ (TPair t1 t2) -∗
  WP tuple t1 t2 @ E [{ Ψ }].
Proof.
rewrite val_of_term_eq /tuple; by iIntros "?"; wp_pures.
Qed.

Lemma wp_tuple E t1 t2 Ψ :
  Ψ (TPair t1 t2) -∗
  WP tuple t1 t2 @ E {{ Ψ }}.
Proof.
by iIntros "?"; iApply twp_wp; iApply twp_tuple.
Qed.

Lemma twp_untuple E t Ψ :
  Ψ (repr (Spec.untuple t)) -∗
  WP untuple t @ E [{ Ψ }].
Proof.
iIntros "post".
rewrite /Spec.untuple /untuple /= val_of_term_eq.
case: t; by move=> *; wp_pures; iApply "post".
Qed.

Lemma wp_untuple E t Ψ :
  Ψ (repr (Spec.untuple t)) -∗
  WP untuple t @ E {{ Ψ }}.
Proof.
by iIntros "?"; iApply twp_wp; iApply twp_untuple.
Qed.

Lemma twp_term_of_list E ts Ψ :
  Ψ (repr (Spec.of_list ts)) -∗
  WP term_of_list (repr ts) @ E [{ Ψ }].
Proof.
rewrite /= [in repr_list ts]repr_list_eq Spec.of_list_eq.
elim: ts Ψ => [|t ts IH] Ψ /=; iIntros "post"; wp_rec; wp_pures.
  by rewrite val_of_term_eq.
wp_bind (term_of_list _); iApply IH; wp_pures.
by iApply twp_tuple.
Qed.

Lemma wp_term_of_list E ts Ψ :
  Ψ (repr (Spec.of_list ts)) -∗
  WP term_of_list (repr ts) @ E {{ Ψ }}.
Proof.
by iIntros "?"; iApply twp_wp; iApply twp_term_of_list.
Qed.

Lemma twp_list_of_term E t Ψ :
  Ψ (repr (Spec.to_list t)) -∗
  WP list_of_term t @ E [{ Ψ }].
Proof.
rewrite val_of_term_eq /= repr_list_eq.
elim/term_ind': t Ψ;
try by move=> *; iIntros "post"; wp_rec; wp_pures; iApply "post".
  move=> n Ψ /=; iIntros "post"; wp_rec; wp_pures.
  case: bool_decide_reflect => [[->]|]; first by wp_pures.
  case: n => *; by wp_pures.
move=> thead _ trest IH Ψ /=; iIntros "post".
wp_rec; wp_pures; wp_bind (list_of_term _); iApply IH.
case: (Spec.to_list trest) => [ts|] /=; wp_pures; eauto.
by rewrite -val_of_term_eq.
Qed.

Lemma wp_list_of_term E t Ψ :
  Ψ (repr (Spec.to_list t)) -∗
  WP list_of_term t @ E {{ Ψ }}.
Proof.
by iIntros "?"; iApply twp_wp; iApply twp_list_of_term.
Qed.

Lemma twp_list `{!Repr A} (xs : list A) E Ψ :
  Ψ (repr xs) -∗
  WP list_to_expr xs @ E [{ Ψ }].
Proof.
elim: xs Ψ => [|x xs IH] /= Ψ; iIntros "post".
  by iApply (@twp_nil A _).
wp_bind (list_to_expr _); iApply IH.
by iApply (@twp_cons A).
Qed.

Lemma wp_list `{!Repr A} (xs : list A) E Ψ :
  Ψ (repr xs) -∗
  WP list_to_expr xs @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_list. Qed.

Lemma twp_tag E N t Ψ :
  Ψ (repr (Spec.tag N t)) -∗
  WP tag N t @ E [{ Ψ }].
Proof.
iIntros "post".
by rewrite Spec.tag_eq /tag; wp_pures; iApply twp_tuple.
Qed.

Lemma wp_tag E N t Ψ :
  Ψ (repr (Spec.tag N t)) -∗
  WP tag N t @ E {{ Ψ }}.
Proof.
iIntros "post".
by rewrite Spec.tag_eq /tag; wp_pures; iApply wp_tuple.
Qed.

Lemma twp_untag E N t Ψ :
  Ψ (repr (Spec.untag N t)) -∗
  WP untag N t @ E [{ Ψ }].
Proof.
iIntros "post".
rewrite Spec.untag_eq /untag /=; wp_pures.
wp_bind (untuple _); iApply twp_untuple.
case: t; try by [move=> *; wp_pures; iApply "post"].
move=> t1 t2; wp_pures.
wp_bind (to_int _); iApply twp_to_int.
case: t1; try by [move=> *; wp_pures; iApply "post"].
move=> n'; wp_pures.
case: bool_decide_reflect => [[->]|ne]; wp_pures.
  by rewrite decide_left.
case: n' ne; try by move=> *; iApply "post".
move=> n' ne; case: decide => e; try iApply "post".
congruence.
Qed.

Lemma wp_untag E N t Ψ :
  Ψ (repr (Spec.untag N t)) -∗
  WP untag N t @ E {{ Ψ }}.
Proof.
by iIntros "?"; iApply twp_wp; iApply twp_untag.
Qed.

Lemma twp_mknonce E (P Q : term → iProp Σ) Ψ :
  (∀ t, sterm t -∗
        □ (pterm t ↔ ▷ □ P t) -∗
        □ (∀ t', dh_pred t t' ↔ ▷ □ Q t') -∗
        nonce_meta_token t ⊤ -∗
        Ψ t) -∗
  WP mknonce #()%V @ E [{ Ψ }].
Proof.
rewrite /mknonce; iIntros "post".
wp_pures; wp_bind (ref _)%E; iApply twp_alloc=> //.
iIntros (a') "[_ token]"; wp_pures.
wp_pures; wp_bind (ref _)%E; iApply twp_alloc=> //.
iIntros (a) "[_ token']".
iMod (saved_pred_alloc P) as (γP) "#own_P".
iMod (saved_pred_alloc Q) as (γQ) "#own_Q".
rewrite (meta_token_difference a (↑nroot.@"nonce")) //.
iDestruct "token'" as "[nonce token']".
iMod (meta_set _ _ γP with "nonce") as "#nonce"; eauto.
rewrite (meta_token_difference a (↑nroot.@"dh")); last solve_ndisj.
iDestruct "token'" as "[dh token']".
iMod (meta_set _ _ γQ with "dh") as "#dh"; eauto.
iMod (meta_set _ _ a' (nroot.@"meta") with "token'") as "#meta"; eauto.
  solve_ndisj.
iSpecialize ("post" $! (TNonce a)).
rewrite val_of_term_eq /=.
wp_pures; iApply ("post" with "[] [] [] [token]"); eauto.
- rewrite sterm_TNonce; iExists _; eauto.
- rewrite pterm_TNonce; iModIntro; iSplit.
  + iDestruct 1 as (γP' P') "(#meta_γP' & #own_P' & ?)".
    iPoseProof (meta_agree with "nonce meta_γP'") as "->".
    iPoseProof (saved_pred_agree _ _ _ (TNonce a) with "own_P own_P'") as "e".
    by iModIntro; iRewrite "e".
  + iIntros "#?"; iExists γP, P; eauto.
- iIntros (t'); iModIntro; iSplit.
  + iDestruct 1 as (γQ' Q') "(#meta_γQ' & #own_Q' & ?)".
    iPoseProof (meta_agree with "dh meta_γQ'") as "->".
    iPoseProof (saved_pred_agree _ _ _ t' with "own_Q own_Q'") as "e".
    by iModIntro; iRewrite "e".
  + by iIntros "#?"; iExists _, _; eauto.
Qed.

Lemma wp_mknonce E P Q Ψ :
  (∀ t, sterm t -∗
        □ (pterm t ↔ ▷ □ P t) -∗
        □ (∀ t', dh_pred t t' ↔ ▷ □ Q t') -∗
        nonce_meta_token t ⊤ -∗
        Ψ t) -∗
  WP mknonce #()%V @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_mknonce. Qed.

Lemma twp_mkkey E (k : term) Ψ :
  Ψ (TKey Enc k, TKey Dec k)%V -∗
  WP mkkey k @ E [{ Ψ }].
Proof.
rewrite val_of_term_eq /= /mkkey.
by iIntros "post"; wp_pures.
Qed.

Lemma wp_mkkey E (k : term) Ψ :
  Ψ (TKey Enc k, TKey Dec k)%V -∗
  WP mkkey k @ E {{ Ψ }}.
Proof.
by iIntros "post"; iApply twp_wp; iApply twp_mkkey.
Qed.

Lemma twp_enc E t1 t2 Ψ :
  Ψ (repr (Spec.enc t1 t2)) -∗
  WP enc t1 t2 @ E [{ Ψ }].
Proof.
rewrite /repr /repr_option /repr /repr_term !val_of_term_eq /enc.
iIntros "H".
case: t1; try by move=> *; wp_pures; eauto.
case; try by move=> *; wp_pures; eauto.
Qed.

Lemma wp_enc E t1 t2 Ψ :
  Ψ (repr (Spec.enc t1 t2)) -∗
  WP enc t1 t2 @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_enc. Qed.

Lemma twp_hash E t Ψ : Ψ (THash t) -∗ WP hash t @ E [{ Ψ }].
Proof.
by rewrite /hash val_of_term_eq; iIntros "?"; wp_pures.
Qed.

Lemma wp_hash E t Ψ : Ψ (THash t) -∗ WP hash t @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_hash. Qed.

Lemma twp_dec E t1 t2 Ψ :
  Ψ (repr (Spec.dec t1 t2)) -∗
  WP dec t1 t2 @ E [{ Ψ }].
Proof.
rewrite /repr /repr_option /repr /repr_term !val_of_term_eq /dec.
iIntros "H".
wp_pures.
case: t1; try by move=> /= *; wp_pures.
case; try by move=> /= *; wp_pures.
move=> tk; wp_pures.
case: t2; try by move=> /= *; wp_pures.
move=> tk' t; wp_pures; rewrite -val_of_term_eq.
wp_bind (eq_term _ _); iApply twp_eq_term.
by rewrite bool_decide_decide /=; case: decide => [<-|e]; wp_pures.
Qed.

Lemma wp_dec E t1 t2 Ψ :
  Ψ (repr (Spec.dec t1 t2)) -∗
  WP dec t1 t2 @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_dec. Qed.

Lemma twp_tenc E N k t Ψ :
  Ψ (repr (Spec.tenc N k t)) -∗
  WP tenc N k t @ E [{ Ψ }].
Proof.
iIntros "post"; rewrite /tenc; wp_pures.
wp_bind (tag _ _); iApply twp_tag.
by iApply twp_enc.
Qed.

Lemma wp_tenc E N k t Ψ :
  Ψ (repr (Spec.tenc N k t)) -∗
  WP tenc N k t @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_tenc. Qed.

Lemma twp_tdec E N k t Ψ :
  Ψ (repr (Spec.tdec N k t)) -∗
  WP tdec N k t @ E [{ Ψ }].
Proof.
iIntros "post"; rewrite /tdec; wp_pures.
wp_bind (dec _ _); iApply twp_dec.
rewrite /Spec.tdec.
case e: (Spec.dec _ _) => [t'|]; wp_pures => //.
by iApply twp_untag.
Qed.

Lemma wp_tdec E N k t Ψ :
  Ψ (repr (Spec.tdec N k t)) -∗
  WP tdec N k t @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_tdec. Qed.

Lemma twp_is_key E t Ψ :
  Ψ (repr (Spec.is_key t)) -∗
  WP is_key t @ E [{ Ψ }].
Proof.
rewrite /repr /repr_option val_of_term_eq /is_key.
iIntros "?"; by case: t=> *; wp_pures.
Qed.

Lemma wp_is_key E t Ψ :
  Ψ (repr (Spec.is_key t)) -∗
  WP is_key t @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_is_key. Qed.

Lemma twp_tgroup E t Ψ :
  Ψ (TExp t []) -∗
  WP tgroup t @ E [{ Ψ }].
Proof.
iIntros "post".
rewrite /tgroup -val_of_pre_term_unfold; wp_pures.
rewrite val_of_pre_term_eq /= unfold_TExp /=.
by rewrite -val_of_pre_term_eq val_of_pre_term_unfold repr_list_eq.
Qed.

Lemma wp_tgroup E t Ψ :
  Ψ (TExp t []) -∗
  WP tgroup t @ E {{ Ψ }}.
Proof. by iIntros "?"; iApply twp_wp; iApply twp_tgroup. Qed.

Lemma wp_to_ek E t Ψ :
  Ψ (repr (Spec.to_ek t)) -∗
  WP to_ek t @ E {{ Ψ }}.
Proof.
rewrite /to_ek; iIntros "post".
wp_pures; wp_bind (is_key _); iApply wp_is_key.
case: t => /=; try by move=> *; wp_pures => //.
case; try by move => *; wp_pures.
Qed.

Lemma wp_to_dk E t Ψ :
  Ψ (repr (Spec.to_dk t)) -∗
  WP to_dk t @ E {{ Ψ }}.
Proof.
rewrite /to_dk; iIntros "post".
wp_pures; wp_bind (is_key _); iApply wp_is_key.
case: t => /=; try by move=> *; wp_pures => //.
case; try by move => *; wp_pures.
Qed.

End Proofs.

Arguments channel {Σ _ _} c.


(* Copyright (c) 2017, the Dart project authors.  Please see the AUTHORS file
 * for details. All rights reserved. Use of this source code is governed by a
 * BSD-style license that can be found in the LICENSE file. *)

Require Import Utf8.
Require Import InvariantVoidnessPreservation.
Require Import FunctionTestTypes.

Module MyVoidnessPreservation :=
  InvariantVoidnessPreservation.VoidnessPreservationBase Dynamics.NormalDynamics.
Import MyVoidnessPreservation.

(* void Function(void) f = func<dynamic, dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun_dynamic_dynamic dt_fun_void_void.
  apply vp_function; auto.
Qed.

(* void Function(void) f = func<dynamic, void>; // Yes *)
Goal VoidnessPreserves dt_fun_dynamic_void dt_fun_void_void.
  apply vp_function; auto.
Qed.

(* void Function(void) f = func<void, dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun_void_dynamic dt_fun_void_void.
  apply vp_function; auto.
Qed.

(* void Function(void) f = func<Object, Object>; // No *)
Goal ~(VoidnessPreserves dt_fun_Object_Object dt_fun_void_void).
  intro H. inversion H. inversion H5. inversion H9.
Qed.

(* void Function(void) f = func<Object, void>; // No *)
Goal ~(VoidnessPreserves dt_fun_Object_void dt_fun_void_void).
  intro H. inversion H. inversion H5. inversion H9.
Qed.

(* void Function(void) f = func<void, Object>; // Yes *)
Goal VoidnessPreserves dt_fun_void_Object dt_fun_void_void.
  apply vp_function; auto.
Qed.

(* dynamic Function(dynamic) g = func<void, void>; // Yes *)
Goal VoidnessPreserves dt_fun_void_void dt_fun_dynamic_dynamic.
  apply vp_function; auto.
Qed.

(* dynamic Function(dynamic) g = func<dynamic, void>; // Yes *)
Goal VoidnessPreserves dt_fun_dynamic_void dt_fun_dynamic_dynamic.
  apply vp_function; auto.
Qed.

(* dynamic Function(dynamic) g = func<void, dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun_void_dynamic dt_fun_dynamic_dynamic.
  apply vp_function; auto.
Qed.

(* dynamic Function(dynamic) g = func<Object, Object>; // Yes *)
Goal VoidnessPreserves dt_fun_Object_Object dt_fun_dynamic_dynamic.
  apply vp_function; auto.
Qed.

(* dynamic Function(dynamic) g = func<Object, void>; // Yes *)
Goal VoidnessPreserves dt_fun_Object_void dt_fun_dynamic_dynamic.
  apply vp_function; auto.
Qed.

(* dynamic Function(dynamic) g = func<void, Object>; // Yes *)
Goal VoidnessPreserves dt_fun_void_Object dt_fun_dynamic_dynamic.
  apply vp_function; auto.
Qed.

(* Object Function(Object) h = func<void, void>; // No *)
Goal ~(VoidnessPreserves dt_fun_void_void dt_fun_Object_Object).
  intro H. inversion H. inversion H3.
Qed.

(* Object Function(Object) h = func<dynamic, void>; // No *)
Goal ~(VoidnessPreserves dt_fun_dynamic_void dt_fun_Object_Object).
  intro H. inversion H. inversion H3.
Qed.

(* Object Function(Object) h = func<void, dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun_void_dynamic dt_fun_Object_Object.
  apply vp_function; auto.
Qed.

(* Object Function(Object) h = func<Object, Object>; // Yes *)
Goal VoidnessPreserves dt_fun_Object_Object dt_fun_Object_Object.
  apply vp_function.
  - apply vp_class. apply vctsp_cons; auto.
    apply vctp_some. apply vctps_first; auto.
  - apply vpp_cons; auto. apply vp_class. apply vctsp_cons; auto.
    apply vctp_some. apply vctps_first; auto.
Qed.

(* Object Function(Object) h = func<Object, void>; // No *)
Goal ~(VoidnessPreserves dt_fun_Object_void dt_fun_Object_Object).
  intro H. inversion H. inversion H3.
Qed.

(* Object Function(Object) h = func<void, Object>; // Yes *)
Goal VoidnessPreserves dt_fun_void_Object dt_fun_Object_Object.
  apply vp_function; auto.
  apply vp_class. apply vctsp_cons; auto.
  apply vctp_some. apply vctps_first; auto.
Qed.

(* Object Function(void) h = func<Object, Object>; // No *)
Goal ~(VoidnessPreserves dt_fun_Object_Object dt_fun_void_Object).
  intro H. inversion H. inversion H5. inversion H9.
Qed.

(* dynamic Function(void Function(void)) f = func<dynamic Function(dynamic), dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun2_dynamic_dynamic dt_fun2_void_void.
  apply vp_function; auto.
  apply vpp_cons; auto.
  apply vp_function; auto.
Qed.

(* dynamic Function(void Function(void)) f = func<Object Function(dynamic), dynamic>; // No *)
Goal ~(VoidnessPreserves dt_fun2_dynamic_Object dt_fun2_void_void).
  intro H. inversion H. inversion H5.
  inversion H9. inversion H12. inversion H15.
Qed.

(* dynamic Function(void Function(void)) f = func<dynamic Function(Object), dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun2_Object_dynamic dt_fun2_void_void.
  apply vp_function; auto.
  apply vpp_cons; auto.
  apply vp_function; auto.
Qed.

(* dynamic Function(void Function(void)) f = func<Object Function(Object), dynamic>; // No *)
Goal ~(VoidnessPreserves dt_fun2_Object_Object dt_fun2_void_void).
  intro H. inversion H. inversion H5.
  inversion H9. inversion H12. inversion H15.
Qed.

(* dynamic Function(dynamic Function(dynamic)) f = func<void Function(void), dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun2_void_void dt_fun2_dynamic_dynamic.
  apply vp_function; auto.
  apply vpp_cons; auto.
  apply vp_function; auto.
Qed.

(* dynamic Function(dynamic Function(dynamic)) f = func<Object Function(void), dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun2_void_Object dt_fun2_dynamic_dynamic.
  apply vp_function; auto.
  apply vpp_cons; auto.
  apply vp_function; auto.
Qed.

(* dynamic Function(dynamic Function(dynamic)) f = func<void Function(Object), dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun2_Object_void dt_fun2_dynamic_dynamic.
  apply vp_function; auto.
  apply vpp_cons; auto.
  apply vp_function; auto.
Qed.

(* dynamic Function(dynamic Function(dynamic)) f = func<Object Function(Object), dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun2_Object_Object dt_fun2_dynamic_dynamic.
  apply vp_function; auto.
  apply vpp_cons; auto.
  apply vp_function; auto.
Qed.

(* dynamic Function(Object Function(Object)) f = func<void Function(void), dynamic>; // No *)
Goal ~(VoidnessPreserves dt_fun2_void_void dt_fun2_Object_Object).
  intro H. inversion H. inversion H5.
  inversion H9. inversion H17. inversion H21.
Qed.

(* dynamic Function(Object Function(Object)) f = func<dynamic Function(void), dynamic>; // No *)
Goal ~(VoidnessPreserves dt_fun2_void_dynamic dt_fun2_Object_Object).
  intro H. inversion H. inversion H5.
  inversion H9. inversion H17. inversion H21.
Qed.

(* dynamic Function(Object Function(Object)) f = func<void Function(dynamic), dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun2_dynamic_void dt_fun2_Object_Object.
  apply vp_function; auto.
  apply vpp_cons; auto.
  apply vp_function; auto.
Qed.

(* dynamic Function(Object Function(Object)) f = func<dynamic Function(dynamic), dynamic>; // Yes *)
Goal VoidnessPreserves dt_fun2_dynamic_dynamic dt_fun2_Object_Object.
  apply vp_function; auto.
  apply vpp_cons; auto.
  apply vp_function; auto.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Arith.

Section Time_Clocks.

(*** Temporal notions for discrete time ***)

  Definition Instant := nat.
  Definition Clock := nat.

  Definition lt_Ck := lt.              (* <  *)
  Definition le_Ck := le.              (* <= *)
  Definition gt_Ck := gt.              (* >  *)
  Definition ge_Ck := ge.              (* >= *)
  Definition eq_Ck (x y : Clock) := x = y. (* =  *)

  Definition Ini_Ck : Instant := 0.
  Definition tick : Instant := 1.
  Definition plus_Ck := plus.            (* +  *)
  Definition Inc (x : Clock) := plus_Ck x tick.
  Definition Reset : Instant := 0.
  Definition time0 : Instant := 0.

End Time_Clocks.


Require Import PreAutoSep Wrap Conditional.

Import DefineStructured.

Set Implicit Arguments.

(** Simple notation for parsing streams of machine words *)

Inductive pattern0 :=
| Const_ (_ : W)
(* Match this exact word. *)
| Var_ (_ : string)
(* Match anything and stash it in this local variable. *).

Definition pattern := list pattern0.
(* Match a prefix of the stream against these individual word patterns. *)

Definition Const w : pattern := Const_ w :: nil.
Definition Var x : pattern := Var_ x :: nil.

Coercion Const : W >-> pattern.
Coercion Var : string >-> pattern.

Fixpoint matches (p : pattern) (ws : list W) : Prop :=
  match p, ws with
    | nil, _ => True
    | Const_ w :: p', w' :: ws' => w = w' /\ matches p' ws'
    | Var_ _ :: p', _ :: ws' => matches p' ws'
    | _, _ => False
  end.

Fixpoint binds (p : pattern) (ws : list W) : list (string * W) :=
  match p, ws with
    | Const_ _ :: p', _ :: ws' => binds p' ws'
    | Var_ s :: p', w :: ws' => (s, w) :: binds p' ws'
    | _, _ => nil
  end.

Section Parse.
  Hint Extern 1 (Mem _ = Mem _) =>
    eapply scratchOnlyMem; [ | eassumption ];
      simpl; intuition congruence.
  Hint Extern 1 (Mem _ = Mem _) =>
    symmetry; eapply scratchOnlyMem; [ | eassumption ];
      simpl; intuition congruence.

  Hint Resolve evalInstrs_app sepFormula_Mem.

  Hint Extern 2 (interp ?specs2 (![ _ ] (?stn2, ?st2))) =>
    match goal with
      | [ _ : interp ?specs1 (![ _ ] (?stn1, ?st1)) |- _ ] =>
        solve [ equate specs1 specs2; equate stn1 stn2; equate st1 st2; step auto_ext ]
    end.

  Variable stream : string.
  (* Name of local variable containing an array to treat as the stream of words *)
  Variable size : string.
  (* Name of local variable containing the stream length in words *)
  Variable pos : string.
  (* Name of local variable containing the current stream position in words *)

  Variable p : pattern.
  (* We will try to match a prefix of the stream against this pattern. *)

  Variable imports : LabelMap.t assert.
  Hypothesis H : importsGlobal imports.
  Variable modName : string.

  Variables Then Else : cmd imports modName.
  (* Code to run when a single pattern matches or fails, respectively. *)

  Variable ns : list string.
  (* Local variable names *)

  (* Does the pattern match? *)
  Fixpoint guard (p : pattern) (offset : nat) : bexp :=
    match p with
      | nil =>
        Test Rv Le (variableSlot size ns)
        (* Is there enough space left in the stream? *)
      | Const_ w :: p' =>
        And (guard p' (S offset))
        (Test (LvMem (Indir Rp (4 * offset))) IL.Eq w)
      | Var_ _ :: p' => guard p' (S offset)
    end.

  (* Once we know that the pattern matches, we set the appropriate pattern variables with this function. *)
  Fixpoint reads (p : pattern) (offset : nat) : list instr :=
    match p with
      | nil => nil
      | Const_ _ :: p' => reads p' (S offset)
      | Var_ x :: p' => Assign (variableSlot x ns) (LvMem (Indir Rp (4 * offset))) :: reads p' (S offset)
    end.

  Fixpoint suffix (n : nat) (ws : list W) : list W :=
    match n with
      | O => ws
      | S n' => match ws with
                  | nil => nil
                  | w :: ws' => suffix n' ws'
                end
    end.

  Lemma suffix_remains : forall n ws,
    (n < length ws)%nat
    -> suffix n ws = selN ws n :: suffix (S n) ws.
    induction n; destruct ws; simpl; intuition.
    rewrite IHn; auto.
  Qed.

  Fixpoint patternBound (p : pattern) : Prop :=
    match p with
      | nil => True
      | Const_ _ :: p' => patternBound p'
      | Var_ x :: p' => In x ns /\ patternBound p'
    end.

  Fixpoint okVarName (x : string) (p : pattern) : Prop :=
    match p with
      | nil => True
      | Const_ _ :: p' => okVarName x p'
      | Var_ x' :: p' => if string_dec x x' then False else okVarName x p'
    end.

  Definition ThenPre (pre : assert) : assert :=
    (fun stn_st => let (stn, st) := stn_st in
      Ex st', pre (stn, st')
      /\ (AlX, Al V, Al ws, Al r,
        ![ ^[array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st' Sp)] * #0] (stn, st')
        /\ [| sel V size = length ws |]
        ---> [| matches p (suffix (wordToNat (sel V pos)) ws)
          /\ exists st'', Mem st'' = Mem st'
            /\ Regs st'' Sp = Regs st' Sp
            /\ evalInstrs stn st'' (map (fun p => Assign (variableSlot (fst p) ns) (RvImm (snd p)))
              (binds p (suffix (wordToNat (sel V pos)) ws))
              ++ Binop (variableSlot pos ns) (variableSlot pos ns) Plus (length p)
              :: nil) = Some st |]))%PropX.

  Definition ElsePre (pre : assert) : assert :=
    (fun stn_st => let (stn, st) := stn_st in
      Ex st', pre (stn, st')
      /\ (AlX, Al V, Al ws, Al r,
        ![ ^[array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp)] * #0] (stn, st')
        /\ [| sel V size = length ws |]
        ---> [| ~matches p (suffix (wordToNat (sel V pos)) ws) |])
      /\ [| Regs st Sp = Regs st' Sp /\ Mem st = Mem st' |])%PropX.

  (* Here's the raw parsing command, which we will later wrap with nicer VCs. *)
  Definition Parse1_ : cmd imports modName := fun pre =>
    Seq_ H (Straightline_ _ _ (Binop Rv (variableSlot pos ns) Plus (length p)
      :: Binop Rp 4 Times (variableSlot pos ns)
      :: Binop Rp (variableSlot stream ns) Plus Rp
      :: nil))
    (Cond_ _ H _ (guard p O)
      (Seq_ H
        (Straightline_ _ _ (reads p O
          ++ Binop (variableSlot pos ns) (variableSlot pos ns) Plus (length p)
          :: nil))
        (Seq_ H
          (Structured.Assert_ _ _ (ThenPre pre))
          Then))
      (Seq_ H
        (Structured.Assert_ _ _ (ElsePre pre))
        Else))
    pre.

  Hint Rewrite wordToN_nat wordToNat_natToWord_idempotent using assumption : N.
  Require Import Arith.

  Hint Resolve goodSize_weaken.

  Opaque mult.

  Lemma bexpTrue_bound : forall specs stn st ws V r fr,
    interp specs
    (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> forall p' offset, bexpTrue (guard p' offset) stn st
      -> Regs st Rv <= sel V size.
    clear H; induction p' as [ | [ ] ]; simpl; intuition eauto.

    prep_locals; evaluate auto_ext; tauto.
  Qed.

  Lemma bexpSafe_guard : forall specs stn st ws V r fr,
    interp specs
    (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
    -> sel V size = $(length ws)
    -> forall p' offset,
      Regs st Rv = $(offset + wordToNat (sel V pos) + length p')
      -> goodSize (offset + wordToNat (sel V pos) + Datatypes.length p')
      -> bexpSafe (guard p' offset) stn st.
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    prep_locals; evaluate auto_ext.

    apply IHp'.
    rewrite H4; f_equal; omega.
    eauto.

    replace (evalCond (LvMem (Rp + 4 * offset)%loc) IL.Eq w stn st)
      with (evalCond (LvMem (Imm (sel V stream ^+ $4 ^* $(offset + wordToNat (sel V pos))))) IL.Eq w stn st)
        in *.
    assert (goodSize (length ws)) by eauto.
    assert (natToW (offset + wordToNat (sel V pos)) < $(length ws)).
    specialize (bexpTrue_bound _ H H0 H1 _ _ H6).
    rewrite H3, H4.
    intros.
    apply wle_goodSize in H9; auto; eauto.

    prep_locals; evaluate auto_ext.

    unfold evalCond; simpl.
    rewrite H2.
    match goal with
      | [ |- match ReadWord _ _ ?X with None => _ | _ => _ end
        = match ReadWord _ _ ?Y with None => _ | _ => _ end ] => replace Y with X; auto
    end.
    rewrite mult_comm; rewrite natToW_times4.
    rewrite natToW_plus.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    apply IHp'; eauto.
    rewrite H4; f_equal; omega.
  Qed.

  Lemma bexpTrue_matches : forall specs stn st ws V r fr,
    interp specs
    (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
    -> forall p' offset, bexpTrue (guard p' offset) stn st
      -> Regs st Rv = $(offset + wordToNat (sel V pos) + length p')
      -> (offset + wordToNat (sel V pos) <= length ws)%nat
      -> sel V size = $(length ws)
      -> goodSize (offset + wordToNat (sel V pos) + length p')
      -> matches p' (suffix (offset + wordToNat (sel V pos)) ws).
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    specialize (bexpTrue_bound _ H H0 H1 _ _ H8).
    rewrite H4; intros.
    replace (evalCond (LvMem (Rp + 4 * offset)%loc) IL.Eq w stn st)
      with (evalCond (LvMem (Imm (sel V stream ^+ $4 ^* $(offset + wordToNat (sel V pos))))) IL.Eq w stn st)
        in *.
    rewrite H6 in H3.
    eapply wle_goodSize in H3.
    rewrite suffix_remains in * by auto.
    assert (natToW (offset + wordToNat (sel V pos)) < natToW (length ws))
      by (apply lt_goodSize; eauto).
    prep_locals; evaluate auto_ext.

    split.
    subst.
    unfold Array.sel.
    rewrite wordToNat_natToWord_idempotent; auto.
    change (goodSize (offset + wordToNat (sel V pos))); eauto.
    change (S (offset + wordToNat (sel V pos))) with (S offset + wordToNat (sel V pos)).
    apply IHp'; auto.
    rewrite H4; f_equal; omega.
    eauto.
    eauto.
    eauto.

    unfold evalCond; simpl.
    rewrite H2.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    specialize (bexpTrue_bound _ H H0 H1 _ _ H3).
    rewrite H4; intros.
    rewrite H6 in H8.
    eapply wle_goodSize in H8.
    rewrite suffix_remains in * by auto.
    change (S (offset + wordToNat (sel V pos))) with (S offset + wordToNat (sel V pos)).
    apply IHp'; auto.
    rewrite H4; f_equal; omega.
    eauto.
    eauto.
    eauto.
  Qed.

  Lemma suffix_none : forall n ls,
    (n >= length ls)%nat
    -> suffix n ls = nil.
    induction n; destruct ls; simpl; intuition.
  Qed.

  Lemma bexpFalse_not_matches : forall specs stn st ws V r fr,
    interp specs
    (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
    -> sel V size = $(length ws)
    -> forall p' offset, bexpFalse (guard p' offset) stn st
      -> Regs st Rv = $(offset + wordToNat (sel V pos) + length p')
      -> (offset + wordToNat (sel V pos) <= length ws)%nat
      -> goodSize (offset + wordToNat (sel V pos) + length p')
      -> ~matches p' (suffix (offset + wordToNat (sel V pos)) ws).
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    prep_locals; evaluate auto_ext.
    rewrite H3 in *.
    apply lt_goodSize' in H13.
    omega.
    eauto.
    eauto.

    destruct (le_lt_dec (length ws) (offset + wordToNat (sel V pos))).
    rewrite suffix_none in *; auto.
    rewrite suffix_remains in * by auto.
    assert (natToW (offset + wordToNat (sel V pos)) < natToW (length ws))
      by (apply lt_goodSize; eauto).
    prep_locals; evaluate auto_ext.
    eapply IHp'; eauto.
    rewrite H5; f_equal; omega.

    specialize (bexpTrue_bound _ H H0 H1 _ _ H4).
    rewrite H5; intros.
    destruct (le_lt_dec (length ws) (offset + wordToNat (sel V pos))).
    rewrite suffix_none in *; auto.
    rewrite suffix_remains in * by auto.
    replace (evalCond (LvMem (Rp + 4 * offset)%loc) IL.Eq w stn st)
      with (evalCond (LvMem (Imm (sel V stream ^+ $4 ^* $(offset + wordToNat (sel V pos))))) IL.Eq w stn st)
        in *.
    assert (natToW (offset + wordToNat (sel V pos)) < natToW (length ws))
      by (apply lt_goodSize; eauto).
    prep_locals; evaluate auto_ext.
    subst.
    apply H16.
    unfold Array.sel.
    rewrite wordToNat_natToWord_idempotent; auto.
    change (goodSize (offset + wordToNat (sel V pos))); eauto.

    unfold evalCond; simpl.
    rewrite H2.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    destruct (le_lt_dec (length ws) (offset + wordToNat (sel V pos))).
    rewrite suffix_none in *; auto.
    rewrite suffix_remains in * by auto.
    intuition; subst.
    eapply IHp'; eauto.
    rewrite H5; f_equal; omega.
  Qed.

  Transparent evalInstrs.
  Opaque evalInstr.

  Lemma reads_nocrash : forall specs stn ws r fr,
    ~In "rp" ns
    -> forall p' offset st V, patternBound p'
      -> interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
      -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
      -> (offset + wordToNat (sel V pos) + length p' <= length ws)%nat
      -> okVarName stream p'
      -> okVarName pos p'
      -> evalInstrs stn st (reads p' offset) = None
      -> False.
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    eapply IHp'; eauto.
    match goal with
      | [ H : (?U <= ?X)%nat |- (?V <= ?X)%nat ] => replace V with U; auto; omega
    end.

    destruct (string_dec stream s); try tauto.
    destruct (string_dec pos s); try tauto.

    case_eq (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc))); intros;
      match goal with
        | [ H : _ = _ |- _ ] => rewrite H in *
      end.

    replace (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc)))
      with (evalInstr stn st (Assign (variableSlot s ns)
        (LvMem (Imm (sel V stream ^+ $4 ^* $(offset + wordToNat (sel V pos))))))) in *.
    generalize dependent H6; prep_locals.
    assert (natToW (offset + wordToNat (sel V pos)) < $(length ws)).
    apply lt_goodSize; eauto.
    prep_locals.
    rewrite evalInstr_evalInstrs in H0.
    evaluate auto_ext.
    intros.
    eapply IHp'.
    eauto.
    instantiate (1 := s0).
    step auto_ext.
    reflexivity.
    repeat rewrite sel_upd_ne by congruence.
    assumption.
    instantiate (1 := S offset).
    repeat rewrite sel_upd_ne by congruence.
    match goal with
      | [ H : (?U <= ?X)%nat |- (?V <= ?X)%nat ] => replace V with U; auto; omega
    end.
    assumption.
    assumption.
    assumption.
    Transparent evalInstr.
    simpl.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite H2.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    replace (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc)))
      with (evalInstr stn st (Assign (variableSlot s ns)
        (LvMem (Imm (sel V stream ^+ $4 ^* $(offset + wordToNat (sel V pos))))))) in *.
    generalize dependent H6; prep_locals.
    assert (natToW (offset + wordToNat (sel V pos)) < $(length ws)).
    apply lt_goodSize; eauto.
    prep_locals.
    rewrite evalInstr_evalInstrs in H0.
    evaluate auto_ext.

    simpl.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite H2.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.
  Qed.

  Opaque evalInstr.

  Lemma reads_exec' : forall specs stn ws r fr,
    ~In "rp" ns
    -> forall p' offset st st' V, patternBound p'
      -> interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
      -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
      -> (offset + wordToNat (sel V pos) + length p' <= length ws)%nat
      -> okVarName stream p'
      -> okVarName pos p'
      -> evalInstrs stn st (reads p' offset) = Some st'
      -> exists V',
        interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V' r (Regs st Sp) * fr] (stn, st'))
        /\ Regs st' Sp = Regs st Sp.
    clear H; induction p' as [ | [ ] ]; simpl; intuition.

    injection H6; intros; subst.
    eauto.

    eapply IHp'; eauto.
    match goal with
      | [ H : (?U <= ?X)%nat |- (?V <= ?X)%nat ] => replace V with U; auto; omega
    end.

    destruct (string_dec stream s); try tauto.
    destruct (string_dec pos s); try tauto.

    case_eq (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc))); intros;
      match goal with
        | [ H : _ = _ |- _ ] => rewrite H in *
      end.

    replace (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc)))
      with (evalInstr stn st (Assign (variableSlot s ns)
        (LvMem (Imm (sel V stream ^+ $4 ^* $(offset + wordToNat (sel V pos))))))) in *.
    generalize dependent H6; prep_locals.
    assert (natToW (offset + wordToNat (sel V pos)) < $(length ws)).
    apply lt_goodSize; eauto.
    prep_locals.
    rewrite evalInstr_evalInstrs in H0.
    evaluate auto_ext.
    intros.
    eapply (IHp' _ _ _ (upd V s (Array.sel ws (offset + wordToNat (sel V pos))))) in H13.
    rewrite <- H1.
    rewrite sel_upd_ne in H13 by congruence.
    assumption.
    eauto.
    step auto_ext.
    reflexivity.
    rewrite H10.
    repeat rewrite sel_upd_ne by congruence.
    W_eq.
    repeat rewrite sel_upd_ne by congruence.
    match goal with
      | [ H : (?U <= ?X)%nat |- (?V <= ?X)%nat ] => replace V with U; auto; omega
    end.
    assumption.
    assumption.
    Transparent evalInstr.
    simpl.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite H2.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.

    replace (evalInstr stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc)))
      with (evalInstr stn st (Assign (variableSlot s ns)
        (LvMem (Imm (sel V stream ^+ $4 ^* $(offset + wordToNat (sel V pos))))))) in *.
    generalize dependent H6; prep_locals.
    assert (natToW (offset + wordToNat (sel V pos)) < $(length ws)).
    apply lt_goodSize; eauto.
    prep_locals.
    rewrite evalInstr_evalInstrs in H0.
    evaluate auto_ext.

    simpl.
    match goal with
      | [ |- match ?E with None => _ | _ => _ end = match ?E' with None => _ | _ => _ end ] =>
        replace E with E'; auto
    end.
    f_equal.
    rewrite H2.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW.
    rewrite natToWord_wordToNat.
    W_eq.
  Qed.

  Lemma reads_exec : forall stn st p' offset st',
    evalInstrs stn st (reads p' offset) = Some st'
    -> ~In "rp" ns
    -> forall specs ws r fr V, patternBound p'
      -> interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
      -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
      -> (offset + wordToNat (sel V pos) + length p' <= length ws)%nat
      -> okVarName stream p'
      -> okVarName pos p'

      -> exists V',
        interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V' r (Regs st Sp) * fr] (stn, st'))
        /\ Regs st' Sp = Regs st Sp.
    eauto using reads_exec'.
  Qed.

  Opaque evalInstrs.

  Lemma unify_V : forall specs stn st ws V r sp fr ws' V' r' fr',
    interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r sp * fr] (stn, st))
    -> sel V size = length ws
    -> sel V' size = length ws'
    -> interp specs (![array ws' (sel V' stream) * locals ("rp" :: ns) V' r' sp * fr'] (stn, st)
       ---> [| forall x, In x ns -> sel V' x = sel V x |])%PropX.
    clear H; intros.
    assert (Hlocals : exists FR, interp specs (![array (toArray ("rp" :: ns) V) sp * FR] (stn, st)))
      by (eexists; unfold locals in H; step auto_ext); destruct Hlocals as [ FR Hlocals ].
    assert (Hlocals' : exists FR', himp specs
      (array ws' (sel V' stream) * locals ("rp" :: ns) V' r' sp * fr')%Sep
      (array (toArray ("rp" :: ns) V') sp * FR')%Sep)
      by (eexists; unfold locals; step auto_ext); destruct Hlocals' as [ FR' Hlocals' ].
    eapply Imply_trans; try (rewrite sepFormula_eq; apply Hlocals').
    simpl.
    replace ((array (V' "rp" :: toArray ns V') sp * FR')%Sep stn (memoryIn (Mem st)))
      with (![array (V' "rp" :: toArray ns V') sp * FR'] (stn, st))%PropX
        by (rewrite sepFormula_eq; reflexivity).
    eapply Imply_trans.
    eapply array_equals; eauto.
    simpl; repeat rewrite length_toArray in *; apply inj_imply; intuition.
    injection H3; clear H3; intros.
    eauto using toArray_sel.
  Qed.

  Lemma unify_ws : forall specs stn st ws V r sp fr ws' V' r' fr' streamV,
    interp specs (![array ws streamV * locals ("rp" :: ns) V r sp * fr] (stn, st))
    -> length ws' = length ws
    -> interp specs (![array ws' streamV * locals ("rp" :: ns) V' r' sp * fr'] (stn, st)
       ---> [| ws' = ws |])%PropX.
    clear H; intros.
    assert (Hlocals : interp specs (![array ws streamV * (locals ("rp" :: ns) V r sp * fr)] (stn, st)))
       by step auto_ext.
    assert (Hlocals' : himp specs
      (array ws' streamV * locals ("rp" :: ns) V' r' sp * fr')%Sep
      (array ws' streamV * (locals ("rp" :: ns) V' r' sp * fr'))%Sep)
      by step auto_ext.
    eapply Imply_trans; try (rewrite sepFormula_eq; apply Hlocals').
    simpl.
    replace ((array ws' streamV * (locals ("rp" :: ns) V' r' sp * fr'))%Sep stn
      (memoryIn (Mem st)))
      with (![array ws' streamV * (locals ("rp" :: ns) V' r' sp * fr')] (stn, st))%PropX
        by (rewrite sepFormula_eq; reflexivity).
    eapply Imply_trans.
    eapply array_equals; eauto.
    apply inj_imply; intuition.
  Qed.

  Transparent mult.

  Theorem unify : forall specs stn st ws V r sp fr ws' V' r' fr',
    interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r sp * fr] (stn, st))
    -> sel V size = length ws
    -> In stream ns
    -> In size ns
    -> In pos ns
    -> interp specs (![array ws' (sel V' stream) * locals ("rp" :: ns) V' r' sp * fr'] (stn, st)
       /\ [| sel V' size = length ws' |]
       ---> [| ws' = ws /\ sel V' stream = sel V stream /\ sel V' size = sel V size /\ sel V' pos = sel V pos |])%PropX.
    intros.
    apply Imply_I.
    eapply Inj_E; [ eapply And_E2; apply Env; simpl; eauto | ]; intro.
    eapply Inj_E.
    eapply Imply_E.
    apply interp_weaken; eapply unify_V; eauto.
    eapply And_E1; apply Env; simpl; eauto.
    intro.
    apply Inj_E with (goodSize (length ws')).
    rewrite sepFormula_eq; unfold sepFormula_def, starB, star.
    eapply Exists_E; [ eapply And_E1; apply Env; simpl; eauto | cbv beta; intro ].
    eapply Exists_E; [ apply Env; simpl; left; eauto | cbv beta; intro ].
    eapply Exists_E; [ eapply And_E1; eapply And_E2; apply Env; simpl; left; eauto | cbv beta; intro ].
    eapply Exists_E; [ apply Env; simpl; left; eauto | cbv beta; intro ].
    eapply Imply_E.
    apply interp_weaken; apply containsArray_goodSizex'.
    Focus 2.
    eapply And_E1; eapply And_E2; apply Env; simpl; eauto.
    eauto.
    intro.
    repeat rewrite H6 in * by assumption.
    eapply Inj_E.
    eapply Imply_E.
    apply interp_weaken; eapply unify_ws.
    eassumption.
    2: eapply And_E1; apply Env; simpl; eauto.
    apply natToW_inj; congruence || eauto.
    intro.
    apply Inj_I; intuition.
  Qed.

  Theorem splessReads : forall p' offset,
    spless (reads p' offset).
    induction p' as [ | [ ] ]; simpl; intuition.
  Qed.

  Hint Resolve splessReads.

  Opaque evalInstr mult.
  Transparent evalInstrs.

  Lemma simplify_reads : forall st' ws r fr stn specs p' offset st V,
    interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> evalInstrs stn st (reads p' offset) = Some st'
    -> (offset + wordToNat (sel V pos) + length p' <= length ws)%nat
    -> patternBound p'
    -> ~In "rp" ns
    -> Regs st Rp = sel V stream ^+ $4 ^* sel V pos
    -> okVarName stream p'
    -> okVarName pos p'
    -> goodSize (offset + wordToNat (sel V pos) + length p')
    -> evalInstrs stn st (map (fun p0 =>
      Assign
      (LvMem (Sp + S (S (S (S (variablePosition ns (fst p0))))))%loc)
      (RvImm (snd p0))) (binds p' (suffix (offset + wordToNat (sel V pos)) ws))) = Some st'.
    clear H; induction p' as [ | [ ] ]; simpl; intuition;
      rewrite suffix_remains by auto;
        change (S (offset + wordToNat (sel V pos))) with (S offset + wordToNat (sel V pos)); eauto; simpl.

    match goal with
      | [ _ : match ?E with None => _ | _ => _ end = _ |- _ ] => case_eq E; intros
    end; match goal with
           | [ H : _ = _ |- _ ] => rewrite H in *
         end; try discriminate.

    destruct (string_dec stream s); try tauto.
    destruct (string_dec pos s); try tauto.
    assert (evalInstrs stn st (Assign (variableSlot s ns) (LvMem (Rp + 4 * offset)%loc) :: nil) = Some s0)
      by (simpl; rewrite H2; reflexivity).
    clear H2.
    replace (evalInstrs stn st
      (Assign (variableSlot s ns)
        (LvMem (Rp + 4 * offset)%loc) :: nil))
      with (evalInstrs stn st
         (Assign (variableSlot s ns)
            (LvMem (Imm (sel V stream ^+ $4 ^* $(offset + wordToNat (sel V pos))))) :: nil)) in H10.
    assert (natToW (offset + wordToNat (sel V pos)) < $(length ws)) by (apply lt_goodSize; eauto).
    prep_locals.
    generalize dependent H0; evaluate auto_ext; intro.
    case_eq (evalInstrs stn s0 (Assign Rv (variableSlot s ns) :: nil)); intros; prep_locals; evaluate auto_ext.
    rewrite sel_upd_eq in H17 by auto.
    unfold evalInstrs in H10, H15.
    repeat (match goal with
              | [ _ : match ?E with None => _ | _ => _ end = _ |- _ ] => case_eq E; intros
            end; match goal with
                   | [ H : _ = _ |- _ ] => rewrite H in *
                 end; try discriminate).
    unfold variablePosition in H19, H20; fold variablePosition in H19, H20.
    destruct (string_dec "rp" s); try congruence.
    simpl in *.
    replace (evalInstr stn st
      (Assign (LvMem (Sp + S (S (S (S (variablePosition ns s)))))%loc)
        (selN ws (offset + wordToNat (sel V pos))))) with (Some s3).
    change (match ws with
              | nil => nil
              | _ :: ws' => suffix (offset + wordToNat (sel V pos)) ws'
            end) with (suffix (S offset + wordToNat (sel V pos)) ws).
    replace (sel V pos) with (sel (upd V s (Array.sel ws (offset + wordToNat (sel V pos)))) pos).
    injection H10; clear H10; intros; subst.
    injection H15; clear H15; intros; subst.
    eapply IHp'.
    rewrite sel_upd_ne by auto.
    apply sepFormula_Mem with s1.
    step auto_ext.
    assert (evalInstrs stn s0
      (Assign Rv (LvMem (Sp + S (S (S (S (variablePosition ns s)))))%loc) :: nil) =
      Some s1).
    simpl; rewrite H19; reflexivity.
    symmetry; eapply scratchOnlyMem; [ | eassumption ].
    simpl; intuition congruence.
    assumption.
    rewrite sel_upd_ne; auto.
    assumption.
    assumption.
    repeat rewrite sel_upd_ne by auto; assumption.
    assumption.
    assumption.
    repeat rewrite sel_upd_ne by auto; eauto.
    repeat rewrite sel_upd_ne by auto; reflexivity.
    rewrite <- H20.

    injection H15; clear H15; intros; subst.
    injection H10; clear H10; intros; subst.
    assert (evalInstrs stn s0
      (Assign Rv (LvMem (Sp + S (S (S (S (variablePosition ns s)))))%loc) :: nil) =
      Some s1) by (simpl; rewrite H19; reflexivity).
    eapply sepFormula_Mem in H18.
    2: symmetry; eapply scratchOnlyMem; eauto; simpl; intuition.
    change (S (S (S (S (variablePosition ns s))))) with (4 + variablePosition ns s) in *.
    prep_locals.
    evaluate auto_ext.
    rewrite sel_upd_eq in H22 by auto.
    unfold Array.sel in H22.
    unfold natToW in H22; rewrite wordToNat_natToWord_idempotent in H22.
    generalize H19 H20 H22; clear; intros.
    Transparent evalInstr.

    apply evalAssign_rhs.
    simpl.
    unfold evalInstr, evalRvalue, evalLvalue, evalLoc in *.

    match goal with
      | [ _ : context[match ?E with None => _ | _ => _ end] |- _ ] =>
        match E with
          | context[match _ with None => _ | _ => _ end] => fail 1
          | _ => destruct E; try discriminate
        end
    end.
    match goal with
      | [ _ : context[match ?E with None => _ | _ => _ end] |- _ ] =>
        match E with
          | context[match _ with None => _ | _ => _ end] => fail 1
          | _ => case_eq E; intros; match goal with
                                      | [ H : _ = _ |- _ ] => rewrite H in *
                                    end; try discriminate
        end
    end.
    injection H20; clear H20; intros; subst; simpl Regs in *; simpl Mem in *.
    match goal with
      | [ _ : context[match ?E with None => _ | _ => _ end] |- _ ] =>
        match E with
          | context[match _ with None => _ | _ => _ end] => fail 1
          | _ => case_eq E; intros; match goal with
                                      | [ H : _ = _ |- _ ] => rewrite H in *
                                    end; try discriminate
        end
    end.
    injection H19; clear H19; intros; subst; simpl Mem in *; simpl Regs in *.
    eapply ReadWriteEq in H.
    rewrite H in H0.
    rewrite <- H22.
    unfold rupd; simpl.
    assumption.

    change (goodSize (offset + wordToNat (sel V pos))); eauto.

    generalize H4; clear; intros.
    simpl.
    rewrite H4.
    match goal with
      | [ |- match match ?E1 with None => _ | _ => _ end with None => _ | _ => _ end
        = match match ?E2 with None => _ | _ => _ end with None => _ | _ => _ end ] =>
      replace E2 with E1; auto
    end.
    f_equal.
    rewrite natToW_plus.
    rewrite mult_comm; rewrite natToW_times4.
    unfold natToW; rewrite natToWord_wordToNat.
    W_eq.
  Qed.

  Opaque evalInstrs.

  Lemma Rv_preserve : forall rv posV len,
    rv = posV ^+ $(len)
    -> rv = natToW (0 + wordToNat posV + len).
    simpl; intros; subst.
    rewrite natToW_plus.
    f_equal.
    symmetry; apply natToWord_wordToNat.
  Qed.

  Lemma guard_says_safe : forall stn st specs V ws r fr,
    bexpTrue (guard p 0) stn st
    -> Regs st Rv = sel V pos ^+ $(length p)
    -> interp specs (![array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp) * fr] (stn, st))
    -> In size ns
    -> ~In "rp" ns
    -> sel V size = $(length ws)
    -> goodSize (wordToNat (sel V pos) + Datatypes.length p)
    -> (0 + wordToNat (sel V pos) + length p <= length ws)%nat.
    simpl; intros.
    apply wle_goodSize.
    rewrite natToW_plus.
    unfold natToW; rewrite natToWord_wordToNat.
    rewrite <- H1.
    rewrite <- H5.
    eapply bexpTrue_bound; eauto.
    eauto.
    eauto.
  Qed.

  Opaque variablePosition.

  Hint Resolve Rv_preserve bexpSafe_guard guard_says_safe bexpFalse_not_matches simplify_reads.
  Hint Immediate sym_eq.

  Ltac wrap := wrap0; post; wrap1.

  Definition Parse1 : cmd imports modName.
    refine (Wrap _ H _ Parse1_
      (fun pre x => Postcondition (Then (ThenPre pre)) x
        \/ Postcondition (Else (ElsePre pre)) x)%PropX
      (fun pre =>
        In stream ns
        :: In size ns
        :: In pos ns
        :: (~In "rp" ns)
        :: patternBound p
        :: okVarName stream p
        :: okVarName pos p
        :: (forall stn st specs,
          interp specs (pre (stn, st))
          -> interp specs (ExX, Ex V, Ex ws, Ex r,
            ![ ^[array ws (sel V stream) * locals ("rp" :: ns) V r (Regs st Sp)] * #0] (stn, st)
            /\ [| sel V size = length ws
              /\ goodSize (wordToNat (sel V pos) + length p)
              /\ (wordToNat (sel V pos) <= length ws)%nat |]))%PropX
        :: VerifCond (Then (ThenPre pre))
        ++ VerifCond (Else (ElsePre pre)))
      _ _); abstract (wrap;
        try match goal with
              | [ H : context[reads] |- _ ] => generalize dependent H
            end; evaluate auto_ext; intros; eauto;
        repeat match goal with
                 | [ H : evalInstrs _ _ (_ ++ _) = None |- _ ] =>
                   apply evalInstrs_app_fwd_None in H; destruct H as [ | [ ? [ ? ] ] ]; intuition
                 | [ H : evalInstrs _ _ (_ ++ _) = Some _ |- _ ] =>
                   apply evalInstrs_app_fwd in H; destruct H as [ ? [ ] ]
                 | [ H : evalInstrs _ _ (reads _ _) = Some _ |- _ ] =>
                   edestruct (reads_exec _ _ H) as [V' [ ] ]; eauto; evaluate auto_ext
               end;
        try match goal with
              | [ |- exists x, _ /\ _ ] => eexists; split; [ solve [ eauto ] | try split; intros ];
                try (autorewrite with sepFormula; simpl; eapply Imply_trans; [
                  eapply unify; eauto
                  | apply inj_imply; intuition; subst; simpl in * ] )
              | _ => solve [ eapply reads_nocrash; eauto ]
            end;
        repeat match goal with
                 | _ => solve [ eauto ]
                 | [ H : _ = _ |- _ ] => rewrite H in *
                 | [ |- context[suffix ?N _] ] =>
                   match N with
                     | 0 + _ => fail 1
                     | _ =>
                       change N with (0 + N)
                   end
                 | [ H : matches ?a (suffix ?b ?c) |- False ] =>
                   assert (~matches a (suffix (0 + b) c)); try tauto; clear H
                 | [ _ : evalInstrs _ ?x (reads _ _) = Some _ |- _ ] => exists x; split; eauto
                 | _ => solve [ eapply bexpTrue_matches; eauto ]
               end).
  Defined.

End Parse.

Definition ParseOne (stream size pos : string) (p : pattern) (Then Else : chunk) : chunk := fun ns res =>
  Structured nil (fun _ _ H => Parse1 stream size pos p H (toCmd Then _ H ns res) (toCmd Else _ H ns res) ns).

Infix "++" := (fun p1 p2 : pattern => app p1 p2) : pattern_scope.
Delimit Scope pattern_scope with pattern.

Notation "'Match1' stream 'Size' size 'Position' pos 'Pattern' p { c1 } 'else' { c2 }" :=
  (ParseOne stream size pos p%pattern c1 c2)
  (no associativity, at level 95, stream at level 0, size at level 0, pos at level 0, p at level 0) : SP_scope.

Ltac parse0 := try solve [ intuition congruence ].

Ltac especialize H :=
  repeat match type of H with
           | forall x : ?T, _ =>
             let v := fresh in evar (v : T); let v' := eval unfold v in v in clear v; specialize (H v')
         end.

Ltac parse1 solver :=
  match goal with
    | [ H : forall (a : _ -> _), _ |- _ ] =>
      especialize H; post;
      match goal with
        | [ H : interp ?specs (?P ---> ?Q)%PropX |- _ ] =>
          let H' := fresh in assert (H' : interp specs P) by (propxFo; step auto_ext || solver);
            specialize (Imply_sound H H'); clear H H'; intro H
      end; propxFo; autorewrite with StreamParse in *; simpl in *

    | [ H : interp _ (![ _ ] _) |- _ ] => eapply Wrap.sepFormula_Mem in H; [ | eassumption ]
  end.

Ltac reveal_slots :=
  repeat match goal with
           | [ H : evalInstrs _ _ _ = _ |- _ ] =>
             progress unfold variableSlot in H; simpl in H
         end.

Hint Rewrite roundTrip_0 sel_upd_eq sel_upd_ne using congruence : StreamParse.

Hint Extern 1 (_ <= _)%nat => omega : StreamParse.

Ltac parse2 := autorewrite with StreamParse; auto with StreamParse.

Definition ParseOne' stream size pos (pr : pattern * chunk) :=
  ParseOne stream size pos (fst pr) (snd pr).

Notation "'Case' p c 'end'" := (p%pattern, c)
  (no associativity, at level 0, p at level 0, c at level 95, only parsing) : Case_scope.
Delimit Scope Case_scope with Case_.

Notation "'Match' stream 'Size' size 'Position' pos { case1 ;; .. ;; caseN }" :=
  (fun c : chunk => ParseOne' stream size pos case1%Case_ (..
    (ParseOne' stream size pos caseN%Case_
      c) ..))
  (no associativity, at level 95, stream at level 0, size at level 0, pos at level 0,
    case1 at next level, caseN at next level) : SP_scope.

Notation "'Default' { c }" := c (at level 0, c at level 95, no associativity, only parsing) : SP_scope.


Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Wf.
Require Import Crypto.Reflection.InlineInterp.
Require Import Crypto.Reflection.Z.Syntax.
Require Import Crypto.Reflection.Z.Inline.

Definition InterpInlineConst {interp_base_type interp_op} {t} (e : Expr base_type op t) (Hwf : Wf e)
  : forall x, Interp interp_op (InlineConst e) x = Interp interp_op e x
  := @InterpInlineConst _ interp_base_type _ _ _ t e Hwf.

Hint Rewrite @InterpInlineConst using solve [ eassumption | eauto with wf ] : reflective_interp.