(* 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' .

*)


(* 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.


(**
 CoqTL user theorem: Relational_name_definedness
 Def: if all objects in the source model have name defined,
      then the target objects generated in the target model
      have name defined.
 **)

Require Import String.
Require Import Coq.Logic.Eqdep_dec.
Require Import Arith.
Require Import Coq.Arith.Gt.
Require Import Coq.Arith.EqNat.
Require Import List.

Require Import core.utils.Utils.
Require Import core.SyntaxCertification.
Require Import core.Metamodel.
Require Import core.Model.
Require Import core.Syntax.
Require Import core.Engine.

Require Import transformations.Class2Relational.Class2Relational.
Require Import transformations.Class2Relational.ClassMetamodel.
Require Import transformations.Class2Relational.RelationalMetamodel.

(*Ltac unfoldTransformationIn Tr Ht :=
  unfold Tr in Ht;
  unfold ConcreteSyntax.parse in Ht;
  unfold ConcreteSyntax.parseRule in Ht;
  unfold ConcreteSyntax.parseOutputPatternElement in Ht;
  unfold ConcreteSyntax.parseOutputPatternLink in Ht;
  unfold Expressions.makeGuard in Ht;
  unfold Expressions.makeElement in Ht;
  unfold Expressions.makeIterator in Ht;
  unfold Expressions.makeLink in Ht;
  repeat (unfold Expressions.wrapOptionElement in Ht);
  repeat (unfold Expressions.wrapOptionLink in Ht);
  repeat (unfold Expressions.wrapOption in Ht);
  simpl in Ht.

Ltac unfoldTransformation Tr :=
  unfold Tr;
  unfold ConcreteSyntax.parse;
  unfold ConcreteSyntax.parseRule;
  unfold ConcreteSyntax.parseOutputPatternElement;
  unfold ConcreteSyntax.parseOutputPatternLink;
  unfold Expressions.makeGuard;
  unfold Expressions.makeElement;
  unfold Expressions.makeIterator;
  unfold Expressions.makeLink;
  repeat (unfold Expressions.wrapOptionElement);
  repeat (unfold Expressions.wrapOptionLink);
  repeat (unfold Expressions.wrapOption);
  simpl.*)

Theorem Relational_name_definedness:
forall (te: TransformationEngine CoqTLSyntax) (cm : ClassModel) (rm : RelationalModel),
  (* transformation *) rm = @execute _ _ te Class2Relational cm ->
  (* precondition *)   (forall (c1 : ClassMetamodel_Object), In c1 (allModelElements cm) -> (ClassMetamodel_getName c1 <> ""%string)) ->
  (* postcondition *)  (forall (t1 : RelationalMetamodel_Object), In t1 (allModelElements rm) -> (RelationalMetamodel_getName t1 <> ""%string)).
Proof.
  intros.
  rewrite H in H1.
  rewrite (@tr_execute_in_elements _ _ te Class2Relational) in H1.
  do 2 destruct H1.
  destruct x as [| c]. (* Case analysis on source pattern *)
  - rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
    do 2 destruct H2.
    rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
    destruct H2.
    rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H4.
    simpl in H2.
    destruct H2.
    + rewrite <- H2 in H4.
      simpl in H4.
      inversion H4.
    + destruct H2.
      rewrite <- H2 in H4.
      simpl in H4.
      inversion H4.
      contradiction H2.
  - destruct x as [| c0].
    + (* Singleton *) specialize (H0 c).
      apply allTuples_incl in H1.
      unfold incl in H1.
      specialize (H1 c).
      assert (In c [c]). { left. reflexivity. }
      specialize (H0 (H1 H3)).
      do 2 destruct c. (* Case analysis on source element type *)
      * (* [Class] *)
        rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
        do 2 destruct H2.
        rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
        destruct H2.
        rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H5.
        simpl in H2.
        rewrite (@tr_instantiateRuleOnPattern_in _ _ te Class2Relational) in H4.
        do 2 destruct H4.
        apply tr_instantiateIterationOnPattern_in in H6.
        do 2 destruct H6.
        rewrite tr_instantiateElementOnPattern_leaf in H7.
        destruct H2.
        ** (* Class2Table *)
           rewrite <- H2 in H6.
           simpl in H6.
           destruct H6.
           *** rewrite <- H6 in H7.
               simpl in H7.
               inversion H7.
               simpl.
               apply H0.
           *** contradiction H6.
        ** destruct H2.
           ***  (* Attribute2Column contradict *)
                rewrite <- H2 in H6.
                simpl in H6.
                destruct H6.
                **** rewrite <- H6 in H7. simpl in H7.
                     inversion H7.
                **** contradiction H6.
           *** contradiction H2.
      * (* [Attribute] *) destruct c0.
        destruct b.
        -- (* derived *)
           rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
           do 2 destruct H2.
           rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
           destruct H2.
           rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H5.
           simpl in H2.
           destruct H2.
           ** rewrite <- H2 in H5.
              simpl in H5.
              inversion H5.
           ** destruct H2.
              *** rewrite <- H2 in H5.
                  simpl in H5.
                  inversion H5.
              *** contradiction H2.
        -- (* not derived *)
            rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
            do 2 destruct H2.
            rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
            destruct H2.
            rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H5.
            simpl in H2.
            rewrite (@tr_instantiateRuleOnPattern_in _ _ te Class2Relational) in H4.
            do 2 destruct H4.
            apply tr_instantiateIterationOnPattern_in in H6.
            do 2 destruct H6.
            rewrite tr_instantiateElementOnPattern_leaf in H7.
            destruct H2.
            **  (* Class2Table contradict *)
                 rewrite <- H2 in H6.
                 simpl in H6.
                 destruct H6.
                 *** rewrite <- H6 in H7. simpl in H7.
                      inversion H7.
                 *** contradiction H6.
            ** (* Attribute2Column *)
               destruct H2.
               *** rewrite <- H2 in H6.
                   simpl in H6.
                   destruct H6.
                   **** rewrite <- H6 in H7.
                        simpl in H7.
                        inversion H7.
                        simpl.
                        apply H0.
                   **** contradiction H6.
               *** contradiction H2.
    + (* Other patterns *) do 2 destruct c.
      * destruct c0.
        rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
        do 2 destruct H2.
        rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
        destruct H2.
        rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H4.
        simpl in H2.
        destruct H2.
        ** rewrite <- H2 in H4.
          simpl in H4.
          inversion H4.
        ** destruct H2.
          rewrite <- H2 in H4.
          simpl in H4.
          inversion H4.
          contradiction H2.
      * destruct c0.
        rewrite (@tr_instantiatePattern_in _ _ te Class2Relational) in H2.
        do 2 destruct H2.
        rewrite (@tr_matchPattern_in _ _ te Class2Relational) in H2.
        destruct H2.
        rewrite (@tr_matchRuleOnPattern_leaf _ _ te Class2Relational) in H4.
        simpl in H2.
        destruct H2.
        ** rewrite <- H2 in H4.
          simpl in H4.
          inversion H4.
        ** destruct H2.
          rewrite <- H2 in H4.
          simpl in H4.
          inversion H4.
          contradiction H2.
Qed.

(* Alternative for (* [Attribute] *):
      unfold instantiatePattern in H2.
      unfold matchPattern in H2.
      unfold matchRuleOnPattern in H2. simpl in H2.
      destruct (negb (getAttributeDerived c0)).
      -- simpl in H2. destruct H2.
        ++ rewrite <- H2. simpl. simpl in H0. assumption.
        ++ contradiction H2.
      --  contradiction H2.*)

(* Alternative for (* Other patterns *):
      apply maxArity_length with (sp:=c::c0::x) (tr:=Class2Relational) (sm:=cm).
      * unfold maxArity. simpl. omega.
      * assumption. *)

(*Ltac destructPattern sp tr sm h :=
  destruct sp;
  [> contradiction |
     repeat
      destruct sp;
       [>
          | exfalso;
            apply maxArity_length with (sp:=c::c0::x) (tr:=tr) (sm:=sm);
            [>
              parseTransformationInGoal tr; unfold maxArity; simpl; omega |
              assumption
            ]
            +
            destruct sp;
       ]
  ].*)

Ltac destruct_execute Hexecute sp Hin Hinstantiate :=
  apply tr_execute_in_elements in Hexecute;
  destruct Hexecute as [sp [Hin Hinstantiate]].

Ltac destruct_instantiatePattern Hinstantiate rule Hrule HinstRule :=
  apply tr_instantiatePattern_in in Hinstantiate;
  destruct Hinstantiate as [rule [Hrule HinstRule]].

Ltac destruct_matchPattern Hrule Hr Hmatch :=
  apply tr_matchPattern_in in Hrule;
  destruct Hrule as [Hr Hmatch].

Ltac destruct_rule Hrule :=
  repeat (destruct Hrule as [Hrule | Hrule]; try contradiction Hrule); destruct Hrule.

Ltac destruct_pattern Hinst sp :=
  repeat (let se := fresh "se" in
          destruct sp as [ | se sp ];
          [ | destruct se as [[] ?] eqn:?];
          try contradiction Hinst);
  destruct Hinst as [Hinst | []]; simpl in Hinst.

(*

Theorem Relational_name_definedness':
forall (cm : ClassModel) (rm : RelationalModel),
  (* transformation *) rm = execute Class2Relational cm ->
  (* precondition *)   (forall (c1 : ClassMetamodel_Object), In c1 (allModelElements cm) -> (ClassMetamodel_getName c1 <> ""%string)) ->
  (* postcondition *)  (forall (t1 : RelationalMetamodel_Object), In t1 (allModelElements rm) -> (RelationalMetamodel_getName t1 <> ""%string)).
Proof.
  intros. subst rm.
  destruct_execute H1 sp Hin Hinst. (* t1 comes from a pattern sp *)
  apply allTuples_incl in Hin. (* sp is made of source model elements *)
  destruct_instantiatePattern Hinst r Hr Hinst. (* sp matches a rule r *)
  destruct_matchPattern Hr Hr Hmatch. (* r comes from the transformation *)
  clear Hmatch. (* Hmatch is not used for this proof *)
  destruct_rule Hr; (* case analysis on rules *)
    destruct_pattern Hinst sp. (* retrieve the source pattern for each rule *)
  - (* Class2Table *) specialize (H0 se). crush.
  - (* Attribute2Column *) specialize (H0 se). crush.
Qed.

*)