(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** NNRC is the named nested relational calculus. It serves as an
intermediate language to facilitate code generation for non-functional
targets. *)

(** NNRC is a thin layer over the core language cNNRC. As cNNRC, NNRC
  is evaluated within a local environment. *)

(** Additional operators in NNRC can be easily expressed in terms of
  the core cNNRC, but are useful for optimization purposes. The main
  such operator is group-by. *)

(** Summary:
- Language: NNRC (Named Nested Relational Calculus)
- Based on: "Polymorphic type inference for the named nested
  relational calculus." Jan Van den Bussche, and Stijn
  Vansummeren. ACM Transactions on Computational Logic (TOCL) 9.1
  (2007): 3.
- translating to NNRC: NRAEnv, cNNRC
- translating from NNRC: cNNRC, NNRCMR, DNNRC, Java, JavaScript *)

Require Import String.
Require Import List.
Require Import Arith.
Require Import EquivDec.
Require Import Morphisms.
Require Import Arith.
Require Import Max.
Require Import Bool.
Require Import Peano_dec.
Require Import EquivDec.
Require Import Decidable.
Require Import Utils.
Require Import DataRuntime.
Require Import cNNRCRuntime.

Section NNRC.
  Context {fruntime:foreign_runtime}.

  (** * Abstract Syntax *)

  (** The full abstract syntax for NNRC is already defined in core cNNRC. *)

  Definition nnrc := nnrc.

  (** * Macros *)

  (** All the additional operators are defined in terms of the core cNNRC. *)

  Section Macros.
    Context {h:brand_relation_t}.

    (** The following macro defines group-by in terms of existing cNNRC expressions. *)

    (** <<e groupby[g,keys] ==
         let $group0 := e
         in { $group2 × [ g: ♯flatten({ $group3 = π[keys] ? {$group3} {}
                            | $group3 ∈ $group0 }) ]
            | $group2 ∈ ♯distinct({ π[keys]($group1)
                                  | $group1 ∈ $group0 }) }>>
     *)

    Definition nnrc_group_by (g:string) (sl:list string) (e:nnrc) : nnrc :=
      let t0 := "$group0"%string in
      let t1 := "$group1"%string in
      let t2 := "$group2"%string in
      let t3 := "$group3"%string in
      NNRCLet
        t0 e
        (NNRCFor t2
                 (NNRCUnop OpDistinct
                           (NNRCFor t1 (NNRCVar t0) (NNRCUnop (OpRecProject sl) (NNRCVar t1))))
                 (NNRCBinop OpRecConcat
                            (NNRCVar t2)
                            (NNRCUnop (OpRec g)
                                      (NNRCUnop OpFlatten
                                                (NNRCFor t3 (NNRCVar t0)
                                                         (NNRCIf (NNRCBinop OpEqual
                                                                            (NNRCUnop (OpRecProject sl)
                                                                                (NNRCVar t3))
                                                                            (NNRCVar t2))
                                                                 (NNRCUnop OpBag (NNRCVar t3))
                                                                 (NNRCConst (dcoll nil)))))))).

    (** This definition is equivalent to a nested evaluation group by algorithm. *)

    Lemma nnrc_group_by_correct cenv env
          (g:string) (sl:list string)
          (e:nnrc)
          (incoll:list data):
      nnrc_core_eval h cenv env e = Some (dcoll incoll) ->
      nnrc_core_eval h cenv env (nnrc_group_by g sl e) = lift dcoll (group_by_nested_eval_table g sl incoll).
    Proof.
      intros.
      rewrite <- (group_by_table_correct g sl incoll); simpl.
      rewrite H; trivial.
    Qed.

    Lemma nnrc_group_by_correct_some cenv env
          (g:string) (sl:list string)
          (e:nnrc)
          (incoll outcoll:list data):
      nnrc_core_eval h cenv env e = Some (dcoll incoll) ->
      group_by_nested_eval_table g sl incoll = Some outcoll ->
      nnrc_core_eval h cenv env (nnrc_group_by g sl e) = Some (dcoll outcoll).
    Proof.
      intros.
      unfold nnrc_group_by; simpl.
      rewrite H; simpl; clear H.
      apply (group_by_table_correct_some g sl incoll outcoll H0).
    Qed.

    Lemma nnrc_group_by_correct_none cenv env
          (g:string) (sl:list string)
          (e:nnrc) :
      nnrc_core_eval h cenv env e = None ->
      nnrc_core_eval h cenv env (nnrc_group_by g sl e) = None.
    Proof.
      intros.
      unfold nnrc_group_by; simpl.
      rewrite H; simpl; clear H.
      trivial.
    Qed.

    Lemma nnrc_group_by_correct_some_ncoll cenv env
          (g:string) (sl:list string)
          (e:nnrc) d :
      (forall x, d <> dcoll x) ->
      nnrc_core_eval h cenv env e = Some d ->
      nnrc_core_eval h cenv env (nnrc_group_by g sl e) = None.
    Proof.
      intros.
      unfold nnrc_group_by; simpl.
      rewrite H0; simpl; clear H0.
      destruct d; simpl; trivial.
      eelim H; eauto.
    Qed.

  End Macros.

  (** * Evaluation Semantics *)

  Section Semantics.
    Context {h:brand_relation_t}.
    Context {cenv:bindings}.

    Fixpoint nnrc_to_nnrc_base (e:nnrc) : nnrc :=
      match e with
      | NNRCGetConstant v => NNRCGetConstant v
      | NNRCVar v => NNRCVar v
      | NNRCConst d => NNRCConst d
      | NNRCBinop b e1 e2 =>
        NNRCBinop b (nnrc_to_nnrc_base e1) (nnrc_to_nnrc_base e2)
      | NNRCUnop u e1 =>
        NNRCUnop u (nnrc_to_nnrc_base e1)
      | NNRCLet v e1 e2 =>
        NNRCLet v (nnrc_to_nnrc_base e1) (nnrc_to_nnrc_base e2)
      | NNRCFor v e1 e2 =>
        NNRCFor v (nnrc_to_nnrc_base e1) (nnrc_to_nnrc_base e2)
      | NNRCIf e1 e2 e3 =>
        NNRCIf (nnrc_to_nnrc_base e1) (nnrc_to_nnrc_base e2) (nnrc_to_nnrc_base e3)
      | NNRCEither e1 v2 e2 v3 e3 =>
        NNRCEither (nnrc_to_nnrc_base e1) v2 (nnrc_to_nnrc_base e2) v3 (nnrc_to_nnrc_base e3)
      | NNRCGroupBy g sl e1 =>
        nnrc_group_by g sl (nnrc_to_nnrc_base e1)
      end.

    Definition nnrc_eval (env:bindings) (e:nnrc) : option data :=
      nnrc_core_eval h cenv env (nnrc_to_nnrc_base e).

    Remark nnrc_to_nnrc_base_eq (e:nnrc):
      forall env,
        nnrc_eval env e = nnrc_core_eval h cenv env (nnrc_to_nnrc_base e).
    Proof.
      intros; reflexivity.
    Qed.

    (** Since we rely on cNNRC abstract syntax for the whole NNRC, it is important to check that translating to the core does not reuse the additional operations only present in NNRC. *)

    Lemma nnrc_to_nnrc_base_is_core (e:nnrc) :
      nnrcIsCore (nnrc_to_nnrc_base e).
    Proof.
      induction e; intros; simpl in *; auto.
      repeat (split; auto).
    Qed.

    (** The following function effectively returns an abstract syntax
    tree with the right type for cNNRC. *)

    Program Definition nnrc_to_nnrc_core (e:nnrc) : nnrc_core :=
      nnrc_to_nnrc_base e.
    Next Obligation.
      apply nnrc_to_nnrc_base_is_core.
    Defined.

    (** Additional properties of the translation from NNRC to cNNRC. *)

    Lemma core_nnrc_to_nnrc_ext_id (e:nnrc) :
      nnrcIsCore e ->
      (nnrc_to_nnrc_base e) = e.
    Proof.
      intros.
      induction e; simpl in *.
      - reflexivity.
      - reflexivity.
      - reflexivity.
      - elim H; intros.
        rewrite IHe1; auto; rewrite IHe2; auto.
      - rewrite IHe; auto.
      - elim H; intros.
        rewrite IHe1; auto; rewrite IHe2; auto.
      - elim H; intros.
        rewrite IHe1; auto; rewrite IHe2; auto.
      - elim H; intros.
        elim H1; intros.
        rewrite IHe1; auto; rewrite IHe2; auto; rewrite IHe3; auto.
      - elim H; intros.
        elim H1; intros.
        rewrite IHe1; auto; rewrite IHe2; auto; rewrite IHe3; auto.
      - contradiction. (* GroupBy case *)
    Qed.

    Lemma core_nnrc_to_nnrc_ext_idempotent (e1 e2:nnrc) :
      e1 = nnrc_to_nnrc_base e2 ->
      nnrc_to_nnrc_base e1 = e1.
    Proof.
      intros.
      apply core_nnrc_to_nnrc_ext_id.
      rewrite H.
      apply nnrc_to_nnrc_base_is_core.
    Qed.

    Corollary core_nnrc_to_nnrc_ext_idempotent_corr (e:nnrc) :
      nnrc_to_nnrc_base (nnrc_to_nnrc_base e) = (nnrc_to_nnrc_base e).
    Proof.
      apply (core_nnrc_to_nnrc_ext_idempotent _ e).
      reflexivity.
    Qed.

    Remark nnrc_to_nnrc_ext_eq (e:nnrc):
      nnrcIsCore e ->
      forall env,
        nnrc_core_eval h cenv env e = nnrc_eval env e.
    Proof.
      intros.
      unfold nnrc_eval.
      rewrite core_nnrc_to_nnrc_ext_id.
      reflexivity.
      assumption.
    Qed.

    (** we are only sensitive to the environment up to lookup *)
    Global Instance nnrc_eval_lookup_equiv_prop :
      Proper (lookup_equiv ==> eq ==> eq) nnrc_eval.
    Proof.
      generalize nnrc_core_eval_lookup_equiv_prop; intros.
      unfold Proper, respectful, lookup_equiv in *; intros; subst.
      unfold nnrc_eval.
      rewrite (H h cenv x y H0 (nnrc_to_nnrc_base y0) (nnrc_to_nnrc_base y0)).
      reflexivity.
      reflexivity.
    Qed.

  End Semantics.

  (** * Additional Properties *)

  (** Most of the following properties are useful for shadowing and variable substitution on the full NNRC. *)

  Section Properties.
    Context {h:brand_relation_t}.

    Lemma nnrc_to_nnrc_base_free_vars_same e:
      nnrc_free_vars e = nnrc_free_vars (nnrc_to_nnrc_base e).
    Proof.
      induction e; simpl; try reflexivity.
      - rewrite IHe1; rewrite IHe2; reflexivity.
      - assumption.
      - rewrite IHe1; rewrite IHe2; reflexivity.
      - rewrite IHe1; rewrite IHe2; reflexivity.
      - rewrite IHe1; rewrite IHe2; rewrite IHe3; reflexivity.
      - rewrite IHe1; rewrite IHe2; rewrite IHe3; reflexivity.
      - rewrite app_nil_r.
        assumption.
    Qed.

    Lemma nnrc_to_nnrc_base_bound_vars_impl x e:
      In x (nnrc_bound_vars e) -> In x (nnrc_bound_vars (nnrc_to_nnrc_base e)).
    Proof.
      induction e; simpl; unfold not in *; intros.
      - auto.
      - auto.
      - auto.
      - intuition.
        rewrite in_app_iff in H.
        rewrite in_app_iff.
        elim H; intros; auto.
      - intuition.
      - intuition.
        rewrite in_app_iff in H0.
        rewrite in_app_iff.
        elim H0; intros; auto.
      - intuition.
        rewrite in_app_iff in H0.
        rewrite in_app_iff.
        elim H0; intros; auto.
      - rewrite in_app_iff in H.
        rewrite in_app_iff in H.
        rewrite in_app_iff.
        rewrite in_app_iff.
        elim H; clear H; intros; auto.
        elim H; clear H; intros; auto.
      - rewrite in_app_iff in H.
        rewrite in_app_iff in H.
        rewrite in_app_iff.
        rewrite in_app_iff.
        elim H; clear H; intros; auto.
        elim H; clear H; intros; auto.
        elim H; clear H; intros; auto.
        elim H; clear H; intros; auto.
        right. right. auto.
        right. right. auto.
      - specialize (IHe H).
        right.
        rewrite in_app_iff.
        auto.
    Qed.

    Lemma nnrc_to_nnrc_base_bound_vars_impl_not x e:
      ~ In x (nnrc_bound_vars (nnrc_to_nnrc_base e)) -> ~ In x (nnrc_bound_vars e).
    Proof.
      unfold not.
      intros.
      apply H.
      apply nnrc_to_nnrc_base_bound_vars_impl.
      assumption.
    Qed.

    Definition really_fresh_in_ext sep oldvar avoid e :=
      really_fresh_in sep oldvar avoid (nnrc_to_nnrc_base e).

    Lemma really_fresh_from_free_ext sep old avoid (e:nnrc) :
      ~ In (really_fresh_in_ext sep old avoid e) (nnrc_free_vars (nnrc_to_nnrc_base e)).
    Proof.
      unfold really_fresh_in_ext.
      intros inn1.
      apply (really_fresh_in_fresh sep old avoid (nnrc_to_nnrc_base e)).
      repeat rewrite in_app_iff; intuition.
    Qed.

    Lemma nnrc_to_nnrc_base_subst_comm e1 v1 e2:
      nnrc_subst (nnrc_to_nnrc_base e1) v1 (nnrc_to_nnrc_base e2) =
      nnrc_to_nnrc_base (nnrc_subst e1 v1 e2).
    Proof.
      induction e1; simpl; try reflexivity.
      - destruct (equiv_dec v v1); reflexivity.
      - rewrite IHe1_1; rewrite IHe1_2; reflexivity.
      - rewrite IHe1; reflexivity.
      - rewrite IHe1_1.
        destruct (equiv_dec v v1); try reflexivity.
        rewrite IHe1_2; reflexivity.
      - rewrite IHe1_1.
        destruct (equiv_dec v v1); try reflexivity.
        rewrite IHe1_2; reflexivity.
      - rewrite IHe1_1; rewrite IHe1_2; rewrite IHe1_3; reflexivity.
      - rewrite IHe1_1.
        destruct (equiv_dec v v1);
          destruct (equiv_dec v0 v1);
          try reflexivity.
        rewrite IHe1_3; reflexivity.
        rewrite IHe1_2; reflexivity.
        rewrite IHe1_2; rewrite IHe1_3; reflexivity.
      - unfold nnrc_group_by.
        rewrite IHe1.
        unfold var in *.
        destruct (equiv_dec "$group0"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group1"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group2"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group3"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group2"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group3"%string v1); try congruence; try reflexivity.
    Qed.

    Lemma nnrc_to_nnrc_base_rename_lazy_comm e v1 v2:
      nnrc_rename_lazy (nnrc_to_nnrc_base e) v1 v2 =
      nnrc_to_nnrc_base (nnrc_rename_lazy e v1 v2).
    Proof.
      induction e; unfold nnrc_rename_lazy in *; simpl; try reflexivity.
      - destruct (equiv_dec v1 v2); reflexivity.
      - destruct (equiv_dec v1 v2); try reflexivity.
        destruct (equiv_dec v v1); try reflexivity.
      - destruct (equiv_dec v1 v2); reflexivity.
      - destruct (equiv_dec v1 v2); try reflexivity.
        simpl. rewrite <- IHe1; rewrite <- IHe2; reflexivity.
      - destruct (equiv_dec v1 v2); try reflexivity.
        simpl. rewrite <- IHe; reflexivity.
      - destruct (equiv_dec v1 v2); try reflexivity.
        rewrite IHe1.
        rewrite <- nnrc_to_nnrc_base_subst_comm; simpl.
        destruct (equiv_dec v v1); try reflexivity.
        rewrite <- IHe1; reflexivity.
        rewrite <- IHe1; rewrite <- IHe2; simpl; reflexivity.
      - destruct (equiv_dec v1 v2); try reflexivity.
        rewrite IHe1.
        rewrite <- nnrc_to_nnrc_base_subst_comm; simpl.
        destruct (equiv_dec v v1); try reflexivity.
        rewrite <- IHe1; reflexivity.
        rewrite <- IHe1; rewrite <- IHe2; simpl; reflexivity.
      - destruct (equiv_dec v1 v2); try reflexivity.
        simpl; rewrite <- IHe1; rewrite <- IHe2; rewrite <- IHe3.
        reflexivity.
      - destruct (equiv_dec v1 v2); try reflexivity.
        rewrite IHe1.
        destruct (equiv_dec v v1); try reflexivity.
        destruct (equiv_dec v0 v1); try reflexivity.
        rewrite <- nnrc_to_nnrc_base_subst_comm; simpl.
        rewrite <- nnrc_to_nnrc_base_subst_comm; simpl.
        rewrite <- IHe3.
        reflexivity.
        destruct (equiv_dec v0 v1); try reflexivity.
        rewrite <- nnrc_to_nnrc_base_subst_comm; simpl.
        rewrite <- nnrc_to_nnrc_base_subst_comm; simpl.
        rewrite <- IHe2.
        reflexivity.
        rewrite <- nnrc_to_nnrc_base_subst_comm; simpl.
        rewrite <- nnrc_to_nnrc_base_subst_comm; simpl.
        rewrite <- IHe2.
        rewrite <- IHe3.
        reflexivity.
      - simpl.
        unfold nnrc_group_by.
        destruct (equiv_dec v1 v2); try reflexivity.
        rewrite IHe.
        simpl; unfold nnrc_group_by.
        unfold var in *.
        destruct (equiv_dec "$group0"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group1"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group2"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group3"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group2"%string v1); try congruence; try reflexivity.
        destruct (equiv_dec "$group3"%string v1); try congruence; try reflexivity.
    Qed.

    (** Unshadow properties for the full NNRC. *)
    Lemma unshadow_over_nnrc_ext_idem sep renamer avoid e:
      (nnrc_to_nnrc_base (unshadow sep renamer avoid (nnrc_to_nnrc_base e))) =
      (unshadow sep renamer avoid (nnrc_to_nnrc_base e)).
    Proof.
      generalize (unshadow_preserve_core sep renamer avoid (nnrc_to_nnrc_base e)); intros.
      rewrite core_nnrc_to_nnrc_ext_id.
      reflexivity.
      apply H.
      apply nnrc_to_nnrc_base_is_core.
    Qed.

    Lemma nnrc_eval_cons_subst {cenv} e env v x v' :
      ~ (In v' (nnrc_free_vars e)) ->
      ~ (In v' (nnrc_bound_vars e)) ->
      @nnrc_eval h cenv ((v',x)::env) (nnrc_subst e v (NNRCVar v')) =
      @nnrc_eval h cenv ((v,x)::env) e.
    Proof.
      revert env v x v'.
      nnrc_cases (induction e) Case; simpl; unfold equiv_dec;
        unfold nnrc_eval in *; unfold var in *; trivial; intros; simpl.
      - Case "NNRCVar"%string.
        intuition. destruct (string_eqdec v0 v); simpl; subst; intuition.
        + match_destr; intuition. simpl. dest_eqdec; intuition.
          destruct (equiv_dec v v); try congruence.
        + match_destr; subst; simpl; dest_eqdec; intuition.
          destruct (equiv_dec v v0); try congruence.
      - Case "NNRCBinop"%string.
        rewrite nin_app_or in H. f_equal; intuition.
      - f_equal; intuition.
      - rewrite nin_app_or in H. rewrite IHe1 by intuition.
        case_eq (nnrc_core_eval h cenv ((v0, x) :: env) (nnrc_to_nnrc_base e1)); trivial; intros d deq.
        destruct (string_eqdec v v0); unfold Equivalence.equiv in *; subst; simpl.
        + generalize (@nnrc_core_eval_remove_duplicate_env _ h cenv nil v0 d nil);
            simpl; intros rr1; rewrite rr1.
          destruct (string_eqdec v0 v'); unfold Equivalence.equiv in *; subst.
          * generalize (@nnrc_core_eval_remove_duplicate_env _ h cenv nil v' d nil);
              simpl; auto.
          * generalize (@nnrc_core_eval_remove_free_env _ h cenv ((v0,d)::nil));
              simpl; intros rr2; apply rr2. intuition.
            elim H3. apply remove_in_neq; auto.
            rewrite nnrc_to_nnrc_base_free_vars_same; auto.
        + destruct (string_eqdec v v'); unfold Equivalence.equiv in *; subst; [intuition | ].
          generalize (@nnrc_core_eval_swap_neq _ h cenv nil v d); simpl; intros rr2;
            repeat rewrite rr2 by trivial.
          apply IHe2.
          * intros nin; intuition. elim H2; apply remove_in_neq; auto.
          * intuition.
      - rewrite nin_app_or in H. rewrite IHe1 by intuition.
        case_eq (nnrc_core_eval h cenv ((v0, x) :: env) (nnrc_to_nnrc_base e1)); trivial; intros d deq.
        destruct d; trivial.
        f_equal.
        apply lift_map_ext; intros.
        destruct (string_eqdec v v0); unfold Equivalence.equiv in *; subst; simpl.
        + generalize (@nnrc_core_eval_remove_duplicate_env _ h cenv nil v0 x0 nil);
            simpl; intros rr1; rewrite rr1.
          destruct (string_eqdec v0 v'); unfold Equivalence.equiv in *; subst.
          * generalize (@nnrc_core_eval_remove_duplicate_env _ h cenv nil v' x0 nil);
              simpl; auto.
          * generalize (@nnrc_core_eval_remove_free_env _ h cenv ((v0,x0)::nil));
              simpl; intros rr2; apply rr2. intuition.
            elim H4. apply remove_in_neq; auto.
            rewrite nnrc_to_nnrc_base_free_vars_same; auto.
        + destruct (string_eqdec v v'); unfold Equivalence.equiv in *; subst; [intuition | ].
          generalize (@nnrc_core_eval_swap_neq _ h cenv nil v x0); simpl; intros rr2;
            repeat rewrite rr2 by trivial.
          apply IHe2.
          * intros nin; intuition. elim H3; apply remove_in_neq; auto.
          * intuition.
      - rewrite nin_app_or in H; destruct H as [? HH];
          rewrite nin_app_or in HH, H0.
        rewrite nin_app_or in H0.
        rewrite IHe1, IHe2, IHe3; intuition.
      - apply not_or in H0; destruct H0 as [neq1 neq2].
        apply not_or in neq2; destruct neq2 as [neq2 neq3].
        repeat rewrite nin_app_or in neq3.
        repeat rewrite nin_app_or in H.
        rewrite IHe1 by intuition.
        repeat rewrite <- remove_in_neq in H by congruence.
        match_destr. destruct d; trivial.
        + match_destr; unfold Equivalence.equiv in *; subst.
          * generalize (@nnrc_core_eval_remove_duplicate_env _ h cenv nil v1 d nil); simpl;
              intros re2; rewrite re2 by trivial.
            generalize (@nnrc_core_eval_remove_free_env _ h cenv ((v1,d)::nil));
              simpl; intros re3. rewrite re3. intuition.
            rewrite <- nnrc_to_nnrc_base_free_vars_same; intuition.
          * generalize (@nnrc_core_eval_swap_neq _ h cenv nil v d); simpl;
              intros re1; repeat rewrite re1 by trivial.
            rewrite IHe2; intuition.
        + match_destr; unfold Equivalence.equiv in *; subst.
          * generalize (@nnrc_core_eval_remove_duplicate_env _ h cenv nil v1 d nil); simpl;
              intros re2; rewrite re2 by trivial.
            generalize (@nnrc_core_eval_remove_free_env _ h cenv ((v1,d)::nil));
              simpl; intros re3. rewrite re3. intuition.
            rewrite <- nnrc_to_nnrc_base_free_vars_same; intuition.
          * generalize (@nnrc_core_eval_swap_neq _ h cenv nil v0 d); simpl;
              intros re1; repeat rewrite re1 by trivial.
            rewrite IHe3; intuition.
      - rewrite IHe; try assumption.
        reflexivity.
    Qed.

  End Properties.

  (** * Toplevel *)

  (** Top-level evaluation is used externally by the Q*cert
  compiler. It takes an NNRC expression and a global environment as
  input. *)

  Section Top.
    Context (h:brand_relation_t).
    Definition nnrc_eval_top (q:nnrc) (cenv:bindings) : option data :=
      @nnrc_eval h (rec_sort cenv) nil q.
  End Top.

End NNRC.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coq.Program.Basics.
Require Import Coq.Relations.Relations.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.RelationPairs.
Require Import Coq.Classes.Morphisms.

Require Import ExtensionalityAxioms.
Require Import Lens.
Require Import Functor.
Require Import PowersetMonad.

(** * Lifting operations *)

(** Because [Mem.MemoryModel] contains so many theorems, we need some
  systematic way to lift the memory operations along a lens, so that
  the lifting of the theorems is convenient to automate.

  The signature of most of the memory operations are variations on
  the theme [mem -> F mem], where [F] is a functor such as [option]
  or [- × Z]. Using the functor's [fmap] and the lens operations,
  we can define a generic lifting operator as in the following. *)

Class Lift {S V} π `{πops: LensOps S V π} A B := { lift: A -> B }.

Arguments lift {S V} π {πops A B Lift} _.

Section LIFT.
  Context {S V} `{HSV: Lens S V} `{HF: Functor}.

  Global Instance lens_lift: Lift π (V -> F V) (S -> F S) := {
    lift f s := fmap (fun v => set π v s) (f (π s))
  }.
End LIFT.

(** Typeclass resolution needs some help to figure out those functors
  by unification. *)

Section LIFTINSTANCES.
  Context {S V} `{HSV: Lens S V}.

  Global Instance lift_const A: Lift π (V -> A) (S -> A) :=
    lens_lift (F := (fun _ => A)).
  Global Instance lift_prod A: Lift π (V -> V * A) (S -> S * A) :=
    lens_lift.
  Global Instance lift_powerset: Lift π (V -> V -> Prop) (S -> S -> Prop) :=
    lens_lift (F := (fun X => X -> Prop)).
End LIFTINSTANCES.

(** ** The [lift_peel] tactic *)

(** This is the main tactic we use: it lifts a theorem [Hf] of
  the underlying memory model by "peeling off" its structure
  recursively to prove the lifted goal. The leaf goals are
  handled with the caller-provided tactic [leaftac]. *)

(* Premises are "translated" and used to specialize Hf *)
Ltac lift_peel_intro π recurse Hf x :=
  intro x;
  (specialize (Hf x) ||
   specialize (Hf (π x)) ||
   (match type of Hf with
      forall (H: ?T), _ =>
        let H' := fresh H in
        assert (H': T) by recurse x;
        specialize (Hf H');
        clear H'
    end));
  recurse Hf.

(* Existential: we must use [set] to augment any memory state
  provided by Hf, but we can otherwise just pass everything along *)
Ltac lift_peel_exists π recurse Hf x :=
  let Hf' := fresh Hf in
  destruct Hf as [x Hf'];
  (exists x || eexists (set _ x _));
  recurse Hf'.

(* Conjunction: split and peel each side independently *)
Ltac lift_peel_conj π recurse Hf :=
  let Hl := fresh Hf "l" in
  let Hr := fresh Hf "r" in
  destruct Hf as [Hl Hr];
  split; [recurse Hl | recurse Hr].

Ltac lift_peel π Hf leaftac :=
  let recurse Hf := lift_peel π Hf leaftac in
  try match goal with
    | |- forall (x: _), _ =>
      let x := fresh x in
      lift_peel_intro π recurse Hf x
    | |- exists (x: _), _ =>
      let x := fresh x in
        lift_peel_exists π recurse Hf x
    | |- { x: _ | _ } =>
      let x := fresh x in
        lift_peel_exists π recurse Hf x
    | |- _ /\ _ =>
      lift_peel_conj π recurse Hf
    | |- ?T =>
      leaftac
  end.

(** Now the goal is to come up with an appropriate leaf tactic which
  will be able to prove some theorems instanciated with the lifted
  operations using the original version. *)

(** ** Expressing everything in terms of [lift] *)

(** As a first step, in order to be able to apply general theorems
  about it, we will want to make sure the goal and premises are all
  stated in terms of [lift]. In order to do this, we use the rule
  below to make sure that the [simpl] tactic stops whenever [lift] is
  reached. Then [simpl] allows us to unfold typeclass methods which
  are defined in terms of lift (the most common case). *)

Arguments lift _ _ _ _ _ _ _ _ : simpl never.

(** There are also derived operations (such as [free_list] for
  instance), which are defined in terms of the typeclass methods.
  In such cases, we usually want to prove that lifting such operations
  is equivalent to applying them to a lifted typeclass instance.
  Then we can rewrite them in terms of [lift] as well. Such proofs are
  collected into the "lift" rewrite database. *)

Ltac lift_norm :=
  repeat progress (simpl in *; autorewrite with lift in *).

(** Unfortunately there is no [Create HintDb] command for rewrite
  databases, so we have to create it by adding a fake entry. *)
Hint Rewrite injective_projections using fail : lift.

(** ** Simplifying occurences of [lift] *)

(** Once everything is stated in terms of lift, futher rewriting rules
  from the [lift_simpl] database can be applied. In particular, the
  theorems below try to ensure that the goal and hypotheses are stated
  in terms of [get] and [same_context] rather than in terms of [lift]. *)

Ltac lift_simpl :=
  repeat progress (lift_norm; autorewrite with lift_simpl in *; lens_simpl).

Section LIFTOPTION.
  Context {S V} `{HSV: Lens S V}.

  Lemma lift_option_eq_unlift (f: V -> option V) (s s': S):
    lift π f s = Some s' ->
    f (π s) = Some (π s').
  Proof.
    unfold lift; simpl.
    intros.
    destruct (f (π s)); try discriminate.
    inversion H.
    autorewrite with lens.
    reflexivity.
  Qed.

  Theorem lift_option_eq_same_context (f: V -> option V) (s s': S):
    lift π f s = Some s' ->
    same_context π s s'.
  Proof.
    unfold lift; simpl.
    case (f (π s)).
    * intros ? H; inversion H; subst.
      symmetry.
      apply lens_set_same_context.
    * discriminate.
  Qed.

  Theorem lift_option_eq_intro (f: V -> option V) (s s': S):
      same_context π s s' ->
      f (π s) = Some (π s') ->
      lift π f s = Some s'.
  Proof.
    intros Hc Hv.
    unfold lift; simpl.
    rewrite Hv; clear Hv.
    f_equal.
    rewrite Hc.
    apply lens_set_get.
  Qed.

  Theorem lift_option_eq_iff f s s' `{!Lens π}:
    lift π f s = Some s' <->
    f (π s) = Some (π s') /\ same_context π s s'.
  Proof.
    repeat split.
    - apply lift_option_eq_unlift.
      assumption.
    - eapply lift_option_eq_same_context.
      eassumption.
    - intros [Hf Hc].
      eapply lift_option_eq_intro;
      assumption.
  Qed.
End LIFTOPTION.

Section LIFTPROD.
  Context {S V} `{Hgs: Lens S V} {A: Type}.

  Theorem lift_prod_eq_unlift (f: V -> V * A) (s s': S) (a: A):
    lift π f s = (s', a) ->
    f (π s) = (π s', a).
  Proof.
    unfold lift; simpl.
    destruct (f (π s)) as [v' a'].
    intros H.
    inversion H.
    autorewrite with lens.
    reflexivity.
  Qed.

  Theorem lift_prod_eq_same_context (f: V -> V * A) (s s': S) (a: A):
    lift π f s = (s', a) ->
    same_context π s s'.
  Proof.
    unfold lift; simpl.
    destruct (f (π s)).
    intro H; inversion H; subst.
    symmetry.
    apply lens_set_same_context.
  Qed.

  Theorem lift_prod_eq_intro (f: V -> V * A) (s s': S) (a: A):
    same_context π s s' ->
    f (π s) = (π s', a) ->
    lift π f s = (s', a).
  Proof.
    unfold lift; simpl.
    intros Hc Hv.
    destruct (f (π s)) as [v'].
    inversion Hv; subst; clear Hv.
    rewrite Hc; clear Hc.
    autorewrite with lens.
    reflexivity.
  Qed.

  Theorem lift_prod_eq_iff (f: V -> V * A) (s s': S) (a: A):
    lift π f s = (s', a) <->
    f (π s) = (π s', a) /\ same_context π s s'.
  Proof.
    repeat split.
    - apply lift_prod_eq_unlift.
      assumption.
    - eapply lift_prod_eq_same_context.
      eassumption.
    - intros [Hf Hc].
      apply lift_prod_eq_intro;
      assumption.
  Qed.
End LIFTPROD.

Section LIFTREL.
  Context {S V} `{Lens S V}.

  Global Instance lift_relation_unlift (R: relation V):
    subrelation (lift π R) (R @@ π)%signature.
  Proof.
    unfold lift, RelCompFun; simpl.
    intros s1 s2 Hs.
    inversion Hs.
    autorewrite with lens.
    assumption.
  Qed.

  Global Instance lift_relation_same_context (R: relation V):
    subrelation (lift π R) (same_context π).
  Proof.
    unfold lift; simpl.
    intros s1 s2 Hs.
    inversion Hs.
    autorewrite with lens.
    reflexivity.
  Qed.

  Lemma lift_relation_intro (R: V -> V -> Prop) (s1 s2: S):
    same_context π s1 s2 ->
    R (π s1) (π s2) ->
    lift (Lift := lift_powerset) π R s1 s2.
  Proof.
    intros Hc Hv.
    unfold lift; simpl.
    replace s2 with (set π (π s2) s1).
    * change (set π (π s2) s1) with ((fun v => set π v s1) (π s2)).
      eapply powerset_fmap_intro.
      assumption.
    * rewrite Hc.
      autorewrite with lens.
      reflexivity.
  Qed.

  Lemma lift_relation_iff (R: V -> V -> Prop) (s1 s2: S):
    lift π R s1 s2 <->
    R (π s1) (π s2) /\ same_context π s1 s2.
  Proof.
    repeat split.
    - apply lift_relation_unlift.
      assumption.
    - eapply lift_relation_same_context.
      eassumption.
    - intros [Hv Hc].
      apply lift_relation_intro;
      assumption.
  Qed.
End LIFTREL.

Hint Rewrite
  @lift_option_eq_iff
  @lift_prod_eq_iff
  @lift_relation_iff
  using typeclasses eauto : lift_simpl.

(** ** Solving the residual goals *)

(** The rewriting rules above likely leaves us with several conjunctions.
  We destruct them to make sure that the components are readily available. *)

Ltac split_conjuncts :=
  repeat match goal with
           | [ H: _ /\ _ |- _ ] =>
             let Hl := fresh H "l" in
             let Hr := fresh H "r" in
             destruct H as [Hl Hr]
         end.

(** Hopefully, the residual goal can then easily be solved with
  [eauto], given a few hints in the "lift" database which we use to
  solve corner cases. *)
Hint Extern 10 (eq _ _) =>
  congruence : lift.

(* Use the minimal priority, because we want to use [same_context] as
  a side-condition for some immediate hints. *)
Hint Extern 0 (same_context _ _ _) =>
  congruence || reflexivity : lift.

(** As a last resort, we unfold [lift] and try to normalize the
  result. Hopefully we'll get something easily solvable. *)
Ltac lift_unfold :=
  repeat progress (lift_simpl; unfold lift in *).

(** We're now ready to define our leaf tactic, and use it in
  conjunction with [peel] to solve the goals automatically. *)
Ltac lift_auto :=
  lift_simpl;
  split_conjuncts;
  eauto 10 with lift typeclass_instances;
  lift_unfold;
  eauto 10 with lift typeclass_instances.

(** The [lift_partial] variant allows for some unsolved leaves. *)
Ltac lift_partial π f :=
  pose proof f as Hf;
  lift_peel π Hf lift_auto.

(** The [lift] variant demands 100% success *)
Ltac lift π f :=
  now lift_partial π f.

(** ** Properties of lifted operations *)

(** Lifting commutes with lens composition *)

Section COMPOSE.
  Existing Instances lens_compose compose_lensops.
  Context {A B C} (π: A -> B) (ρ: B -> C) `{Hπ: Lens _ _ π} `{Hρ: Lens _ _ ρ}.
  Context `{HF: Functor}.
  Context (f: C -> F C).

  Lemma lift_compose:
    lift (compose ρ π) f = lift π (lift ρ f).
  Proof.
    unfold lift.
    simpl.
    apply functional_extensionality.
    intros a.
    unfold Basics.compose.
    reflexivity.
  Qed.
End COMPOSE.


Require Import List.
Require Import Coq.Lists.ListSet.
Import ListNotations.
Require Import Omega.
Require Import Coq.Program.Equality.

Require Import Stream.
Require Import Unify.
Require Import MiniKanrenSyntax.
Require Import DenotationalSem.
Require Import OperationalSem.

Module OperationalSemSoundnessAbstr (CS : ConstraintStoreSig).

Import CS.

Module OperationalSemCS := OperationalSemAbstr CS.

Import OperationalSemCS.

Lemma answer_correct
      (s : subst)
      (cs : constraint_store s)
      (n : nat)
      (f : repr_fun)
      (DSS : [ s , f ])
      (DSCS : [| s , cs , f |])
      (st' : state')
      (st : state)
      (EV : eval_step st' (Answer s cs n) st) :
      in_denotational_sem_state' st' f.
Proof.
  remember (Answer s cs n) as l.
  induction EV; good_inversion Heql; simpl_existT_cs_same; auto.
  { assert (DSS_copy := DSS). apply (denotational_sem_uni _ _ _ _ MGU _) in DSS.
    destruct DSS as [DSS EQ]. constructor; auto.
    eapply proj1. apply (upd_cs_success_condition _ _ _ _ UPD_CS f). auto. }
  { specialize (add_constraint_success_condition _ _ _ _ _ ADD_C f). intro ADD_C_COND.
    specialize (conj DSCS DSS). intro CONJ. apply ADD_C_COND in CONJ.
    destruct CONJ as [DSCS0 [_ GT_NEQ]].
    constructor; auto. }
Qed.

Lemma next_state_correct
      (f : repr_fun)
      (st : state)
      (DSS : in_denotational_sem_state st f)
      (st' : state')
      (WF : well_formed_state' st')
      (h : label)
      (EV : eval_step st' h st) :
      in_denotational_sem_state' st' f.
Proof.
  induction EV; good_inversion DSS.
  { good_inversion DSST'; good_inversion DSST'0; simpl_existT_cs_same;
    constructor; auto. }
  { good_inversion DSST'. good_inversion DSST'0. simpl_existT_cs_same. auto. }
  { good_inversion WF. good_inversion DSST'. simpl_existT_cs_same.
    constructor; auto. econstructor; eauto.
    intros HIn. apply FV_LT_COUNTER in HIn.
    { omega. }
    { reflexivity. } }
  { good_inversion DSST'. simpl_existT_cs_same. auto. }
  { auto. }
  { good_inversion WF. good_inversion DSST'; auto. }
  { good_inversion DSST'. constructor; auto.
    simpl_existT_cs_same. eapply answer_correct; eauto. }
  { good_inversion WF. good_inversion DSST'. auto. }
  { good_inversion WF. good_inversion DSST'.
    { good_inversion DSST'0. simpl_existT_cs_same.
      constructor; auto.
      eapply answer_correct; eauto. }
    { good_inversion DSST'0. auto. } }
Qed.

Lemma search_correctness_generalized
      (st   : state)
      (WF   : well_formed_state st)
      (f    : repr_fun)
      (t    : trace)
      (HOP  : op_sem st t)
      (HDA  : {| t , f |}) :
      in_denotational_sem_state st f.
Proof.
  revert HOP WF. revert st.
  red in HDA. destruct HDA as [s [cs [n [HInStr [DSS DSCS]]]]].
  remember (Answer s cs n) as l. induction HInStr.
  { intros. inversion HOP; clear HOP; subst.
    constructor. eapply answer_correct; eauto. }
  { specialize (IHHInStr Heql). intros.
    inversion HOP; clear HOP; subst.
    inversion WF; clear WF; subst.
    specialize (well_formedness_preservation _ _ _ EV wfState).
    intro wf_st0.
    specialize (IHHInStr st0 OP wf_st0).
    constructor. eapply next_state_correct; eauto. }
Qed.

Fixpoint first_nats (k : nat) : list nat :=
  match k with
  | 0   => []
  | S n => n :: first_nats n
  end.

Lemma first_nats_less
      (n k : nat)
      (H : In n (first_nats k)) :
      n < k.
Proof.
  induction k.
  { inversion H. }
  { inversion H. { omega. } { apply IHk in H0. omega. } }
Qed.

Lemma search_correctness
      (g   : goal)
      (k   : nat)
      (HC  : closed_goal_in_context (first_nats k) g)
      (f   : repr_fun)
      (t   : trace)
      (HOP : op_sem (State (Leaf g empty_subst init_cs k)) t)
      (HDA : {| t , f |}) :
      [| g , f |].
Proof.
  remember (State (Leaf g empty_subst init_cs k)) as st.
  assert (in_denotational_sem_state st f).
  { eapply search_correctness_generalized; eauto.
    subst. constructor. apply well_formed_initial_state; auto. }
  subst. inversion H. inversion DSST'. auto.
Qed.

End OperationalSemSoundnessAbstr.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf.

Require Import List. Import ListNotations.
Require Import Strings.String.

Definition irred e : Prop := forall b, ~(step e b).
Definition cirred e : Prop := forall b, ~(cstep e b).

Notation "Γ ⊢ E ⇒ A" := (Typing Γ E Inf A) (at level 45).
Notation "Γ ⊢ E ⇐ A" := (Typing Γ E Chk A) (at level 45).

Notation "[ z ~> u ] e" := (subst_exp u z e) (at level 0).
Notation "t ^^ u"       := (open_exp_wrt_exp t u) (at level 67).
Notation "e ^ x"        := (open_exp_wrt_exp e (e_var_f x)).

Notation "v ~-> A v'" := (TypedReduce v A v') (at level 68).

Notation "t ->* r" := (steps t r) (at level 68).

Lemma star_one:
forall a b, cstep a (Expr b) -> steps a (Expr b).
Proof.
eauto using steps.
Qed.

Lemma star_trans:
forall a b, steps a (Expr b) -> forall c, steps b (Expr c) -> steps a (Expr c).
Proof.
  introv H.
  inductions H; eauto using steps.
Qed.

Hint Resolve star_one star_trans : core.

(** [x # E] to be read x fresh from E captures the fact that
    x is unbound in E . *)

Notation "x '#' E" := (x \notin (dom E)) (at level 67) : env_scope.

Definition env := list (atom * exp).

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  let E := gather_atoms_with (fun x : ctx => dom x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  constr:(A `union` B `union` C `union` D `union` F).

Lemma value_lc : forall v,
    value v -> lc_exp v.
Proof.
  intros v H.
  induction* H.
  eapply lc_e_save.
  inverts* H.
Qed.

Lemma step_not_value: forall (v:exp),
    value v -> irred v.
Proof.
  introv.
  unfold irred.
  inductions v; introv H;
  inverts* H;
  unfold not;intros.
  - inverts* H.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
  - inverts* H.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
  - inverts* H.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
    destruct E; unfold simpl_fill in H0; inverts* H0.
Qed.

Lemma cstep_not_value: forall (v:exp),
    value v -> cirred v.
Proof.
  introv.
  unfold cirred.
  inductions v; introv H;
  inverts* H;
  unfold not;intros.
  - inverts* H.
    destruct E; unfold simpl_fill in H0; inverts* H0.
  - inverts* H.
    destruct E; unfold simpl_fill in H0; inverts* H0.
  - inverts* H.
    destruct E; unfold simpl_fill in H0; inverts* H0.
Qed.

Lemma multi_red_app : forall v t t',
    vvalue v -> t ->* (Expr t') -> (e_app v t) ->* (Expr (e_app v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(simpl_wf (sappCtxR v)). eauto.
  forwards*: cdo_step H1 H.
Qed.

Lemma multi_red_app2 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* (Expr t1') -> (e_app t1 t2) ->* (Expr (e_app t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  assert(simpl_wf (sappCtxL t2)). eauto.
  forwards*: cdo_step H0 H.
Qed.

Lemma multi_red_add : forall v t t',
    vvalue v -> t ->* (Expr t') -> (e_add v t) ->* (Expr (e_add v t')).
Proof.
  introv Val Red.
  inductions Red; eauto.
  forwards*: IHRed.
  assert(simpl_wf (saddCtxR v)). eauto.
  forwards*: cdo_step H1 H.
Qed.

Lemma multi_red_add2 : forall t1 t2 t1',
    lc_exp t2 -> t1 ->* (Expr t1') -> (e_app t1 t2) ->* (Expr (e_app t1' t2)).
Proof.
  introv Val Red.
  inductions Red; eauto.
  assert(simpl_wf (sappCtxL t2)). eauto.
  forwards*: cdo_step H0 H.
Qed.


Require Import Coq.omega.Omega.
Require Import Bedrock.DepList Platform.AutoSep Platform.Malloc.

Set Implicit Arguments.

Lemma hlist_eta' : forall A (B : A -> Type) b (h : hlist B b),
  match b return hlist B b -> Prop with
    | nil => fun _ => True
    | a :: b => fun h => h = HCons (hlist_hd h) (hlist_tl h)
  end h.
  destruct h; auto.
Qed.

Theorem hlist_eta : forall A (B : A -> Type) a b (h : hlist B (a :: b)),
  h = HCons (hlist_hd h) (hlist_tl h).
  intros; apply (hlist_eta' h).
Qed.

Lemma smem_eta : forall ls (sm sm' : smem' ls),
  NoDup ls
  -> List.Forall (fun w => smem_get' ls w sm = smem_get' ls w sm') ls
  -> sm = sm'.
  induction sm; simpl; intuition.
  rewrite hlist_nil; auto.
  inversion H0; clear H0; subst.
  inversion H; clear H; subst.
  destruct (H.addr_dec x x); intuition idtac; subst.
  rewrite (hlist_eta sm'); f_equal.
  apply IHsm; auto.
  eapply Forall_weaken'; eauto.
  simpl; intros.
  destruct (H.addr_dec x x0); subst; tauto.
Qed.

Lemma get_emp' : forall w ls,
  smem_get' ls w (smem_emp' ls) = None.
  induction ls; simpl; intuition.
  destruct (H.addr_dec a w); auto.
Qed.

Lemma get_emp : forall w,
  smem_get w smem_emp = None.
  intros.
  apply get_emp'.
Qed.

Lemma empty_mem : forall (sm : smem),
  (forall w, smem_get w sm = None)
  -> sm = smem_emp.
  intros.
  apply smem_eta.
  apply NoDup_allWords.
  apply Forall_forall; intros.
  rewrite H.
  symmetry; apply get_emp.
Qed.

Theorem materialize_allocated' : forall specs stn size base sm,
  (forall w, w < base -> smem_get w sm = None)
  -> (forall n, (n < 4 * size)%nat -> smem_get (base ^+ $ (n)) sm <> None)
  -> (forall w, base ^+ $ (4 * size) <= w -> smem_get w sm = None)
  -> goodSize (wordToNat base + 4 * size)%nat
  -> interp specs ((base =?> size)%Sep stn sm).
  induction size.

  propxFo.
  apply empty_mem; intros.
  destruct (wlt_dec w base); auto.
  replace w with (base ^+ $ (wordToNat (w ^- base))); auto.
  rewrite natToWord_wordToNat.
  replace (base ^+ (w ^- base)) with w.
  apply H1.
  intros.
  replace (base ^+ $ (4 * 0)) with base in H3.
  tauto.
  simpl.
  W_eq.
  rewrite wminus_def.
  rewrite wplus_comm.
  rewrite <- wplus_assoc.
  rewrite (wplus_comm (^~ base)).
  rewrite wminus_inv.
  rewrite wplus_comm.
  rewrite wplus_unit.
  reflexivity.
  rewrite natToWord_wordToNat.
  W_eq.

  intros.
  generalize (H0 0).
  generalize (H0 1).
  generalize (H0 2).
  generalize (H0 3).
  intros.
  case_eq (smem_get (base ^+ $0) sm); intros.
  2: elimtype False; apply H6; eauto.
  case_eq (smem_get (base ^+ $1) sm); intros.
  2: elimtype False; apply H5; eauto.
  case_eq (smem_get (base ^+ $2) sm); intros.
  2: elimtype False; apply H4; eauto.
  case_eq (smem_get (base ^+ $3) sm); intros.
  2: elimtype False; apply H3; eauto.

  Fixpoint smem_clear ls (sm : smem' ls) (w : W) : smem' ls :=
    match sm with
      | HNil => HNil
      | HCons w' _ v sm' =>
        HCons (if H.addr_dec w w' then None else v) (smem_clear sm' w)
    end.

  propxFo.

  Fixpoint smem_put ls (sm : smem' ls) (w : W) (v : B) : smem' ls :=
    match sm with
      | HNil => HNil
      | HCons w' _ v' sm' =>
        HCons (if H.addr_dec w w' then Some v else v') (smem_put sm' w v)
    end.

  exists (smem_put (smem_put (smem_put (smem_put smem_emp base b)
    (base ^+ $1) b0) (base ^+ $2) b1) (base ^+ $3) b2).
  exists (smem_clear (smem_clear (smem_clear (smem_clear sm base)
    (base ^+ $1)) (base ^+ $2)) (base ^+ $3)).
  split.

  Lemma disjoint_get' : forall ls sm1 sm2,
    NoDup ls
    -> List.Forall (fun w => smem_get' ls w sm1 <> None -> smem_get' ls w sm2 <> None -> False) ls
    -> disjoint' ls sm1 sm2.
    induction sm1; simpl; intuition; rewrite (hlist_eta sm2) in *; simpl in *.
    inversion H; clear H; subst.
    inversion H0; clear H0; subst.
    destruct (H.addr_dec x x); try tauto.
    destruct b; auto.
    destruct (hlist_hd sm2); auto.
    intuition discriminate.
    inversion H; clear H; subst.
    inversion H0; clear H0; subst.
    apply IHsm1; intros; auto.
    eapply Forall_weaken'; eauto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
  Qed.

  Lemma disjoint_get : forall sm1 sm2,
    (forall w, smem_get w sm1 <> None -> smem_get w sm2 <> None -> False)
    -> disjoint sm1 sm2.
    intros; apply disjoint_get'.
    apply BedrockHeap.NoDup_all_addr.
    apply Forall_forall; intros.
    eauto.
  Qed.

  Lemma disjoint_get_fwd' : forall ls sm1 sm2,
    disjoint' ls sm1 sm2
    -> NoDup ls
    -> List.Forall (fun w => smem_get' ls w sm1 <> None -> smem_get' ls w sm2 <> None -> False) ls.
    induction sm1; simpl; intuition; rewrite (hlist_eta sm2) in *; simpl in *;
      subst; constructor; simpl.
    destruct (H.addr_dec x x); tauto.
    inversion H0; clear H0; subst.
    eapply Forall_weaken'; try apply IHsm1.
    eauto.
    auto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
    destruct (H.addr_dec x x); tauto.
    inversion H0; clear H0; subst.
    eapply Forall_weaken'; try apply IHsm1.
    eauto.
    auto.
    simpl; intros.
    destruct (H.addr_dec x x0); subst; tauto.
  Qed.

  Lemma allWordsUpto_universal : forall width init w,
    (wordToNat w < init)%nat
    -> (init <= pow2 width)%nat
    -> In w (allWordsUpto width init).
    induction init; simpl; intuition.
    destruct (weq w $ (init)); subst; auto; right.
    assert (wordToNat w <> init).
    intro; apply n.
    subst.
    symmetry; apply natToWord_wordToNat.
    auto.
  Qed.

  Lemma allWords_universal : forall sz w,
    In w (allWords sz).
    rewrite allWords_eq; intros; apply allWordsUpto_universal.
    apply wordToNat_bound.
    auto.
  Qed.

  Lemma disjoint_get_fwd : forall sm1 sm2,
    disjoint sm1 sm2
    -> (forall w, smem_get w sm1 <> None -> smem_get w sm2 <> None -> False).
    intros; eapply disjoint_get_fwd' in H; try apply BedrockHeap.NoDup_all_addr.
    assert (In w H.all_addr) by apply allWords_universal.
    generalize (proj1 (Forall_forall _ _) H _ H2); tauto.
  Qed.

  Lemma get_clear_ne' : forall a a' ls (sm : smem' ls),
    a <> a'
    -> smem_get' ls a (smem_clear sm a') = smem_get' ls a sm.
    induction sm; simpl; intuition.
    destruct (H.addr_dec x a); auto.
    destruct (H.addr_dec a' x); congruence.
  Qed.

  Lemma get_clear_ne : forall a a' sm,
    a <> a'
    -> smem_get a (smem_clear sm a') = smem_get a sm.
    intros; apply get_clear_ne'; auto.
  Qed.

  Lemma get_clear_eq' : forall a ls (sm : smem' ls),
    smem_get' ls a (smem_clear sm a) = None.
    induction sm; simpl; intuition.
    destruct (H.addr_dec x a); auto.
    destruct (H.addr_dec a x); congruence.
  Qed.

  Lemma get_clear_eq : forall a sm,
    smem_get a (smem_clear sm a) = None.
    intros; apply get_clear_eq'.
  Qed.

  Hint Rewrite get_clear_eq get_clear_ne
    using solve [ assumption | W_neq ] : get.

  Lemma get_put_eq' : forall a v ls (sm : smem' ls),
    In a ls
    -> smem_get' ls a (smem_put sm a v) = Some v.
    induction sm; simpl; intuition.
    subst.
    destruct (H.addr_dec a a); intuition idtac.
    destruct (H.addr_dec x a); intuition idtac.
    subst.
    destruct (H.addr_dec a a); intuition idtac.
  Qed.

  Lemma get_put_eq : forall a v sm,
    smem_get a (smem_put sm a v) = Some v.
    intros; apply get_put_eq'.
    apply allWords_universal.
  Qed.

  Lemma get_put_ne' : forall a a' v ls (sm : smem' ls),
    a <> a'
    -> smem_get' ls a (smem_put sm a' v) = smem_get' ls a sm.
    induction sm; simpl; intuition.
    destruct (H.addr_dec a' x); intuition idtac.
    destruct (H.addr_dec x a); intuition idtac.
    congruence.
    destruct (H.addr_dec x a); intuition idtac.
  Qed.

  Lemma get_put_ne : forall a a' v sm,
    a <> a'
    -> smem_get a (smem_put sm a' v) = smem_get a sm.
    intros; apply get_put_ne'; auto.
  Qed.

  Hint Rewrite get_emp get_put_eq get_put_ne
    using solve [ assumption | W_neq ] : get.

  Lemma join_None' : forall a ls sm1 sm2,
    smem_get' ls a sm1 = None
    -> smem_get' ls a (join' ls sm1 sm2) = smem_get' ls a sm2.
    induction sm1; simpl; intuition.
    destruct (H.addr_dec x a); subst; auto.
  Qed.

  Lemma join_None : forall a sm1 sm2,
    smem_get a sm1 = None
    -> smem_get a (join sm1 sm2) = smem_get a sm2.
    intros; apply join_None'; auto.
  Qed.

  Lemma join_Some' : forall a v ls sm1 sm2,
    smem_get' ls a sm1 = Some v
    -> smem_get' ls a (join' ls sm1 sm2) = Some v.
    induction sm1; simpl; intuition.
    destruct (H.addr_dec x a); subst; auto.
  Qed.

  Lemma join_Some : forall a v sm1 sm2,
    smem_get a sm1 = Some v
    -> smem_get a (join sm1 sm2) = Some v.
    intros; apply join_Some'; auto.
  Qed.

  Lemma split_put_clear : forall sm sm1 sm2 a v,
    split sm sm1 sm2
    -> smem_get a sm2 = Some v
    -> split sm (smem_put sm1 a v) (smem_clear sm2 a).
    unfold split; intuition subst.
    apply disjoint_get; intros.
    destruct (weq w a); subst.
    autorewrite with get in *; tauto.
    autorewrite with get in *.
    eapply disjoint_get_fwd in H1; eassumption.

    apply smem_eta; try apply BedrockHeap.NoDup_all_addr.
    apply Forall_forall; intros.
    destruct (weq x a); subst.
    rewrite join_None.
    erewrite join_Some.
    eauto.
    autorewrite with get; reflexivity.
    case_eq (smem_get a sm1); auto; intros.
    eapply disjoint_get_fwd in H1; try eassumption.
    tauto.
    instantiate (1 := a); congruence.
    congruence.

    case_eq (smem_get x sm1); intros.
    erewrite join_Some.
    erewrite join_Some.
    2: autorewrite with get; eassumption.
    2: eassumption.
    reflexivity.

    rewrite join_None.
    rewrite join_None.
    autorewrite with get; reflexivity.
    autorewrite with get; assumption.
    assumption.
  Qed.

  repeat apply split_put_clear.
  apply split_a_semp_a.
  replace (base ^+ $0) with base in H7 by words.
  congruence.

  autorewrite with get; assumption.
  autorewrite with get; assumption.
  autorewrite with get; assumption.

  split.
  exists (implode stn (b, b0, b1, b2)).
  split.
  unfold smem_get_word.

  unfold H.footprint_w.
  autorewrite with get.
  reflexivity.

  intuition idtac.
  autorewrite with get.
  reflexivity.

  apply simplify_fwd.
  eapply Imply_sound; [ apply allocated_shift_base | ].
  instantiate (1 := 0).
  instantiate (1 := base ^+ $4).
  W_eq.
  eauto.
  apply IHsize.

  intros.
  destruct (weq w base); subst.
  autorewrite with get; reflexivity.
  destruct (weq w (base ^+ $1)); subst.
  autorewrite with get; reflexivity.
  destruct (weq w (base ^+ $2)); subst.
  autorewrite with get; reflexivity.
  destruct (weq w (base ^+ $3)); subst.
  autorewrite with get; reflexivity.
  autorewrite with get.
  apply H.
  pre_nomega.
  rewrite wordToNat_wplus in H11;
    rewrite wordToNat_natToWord_idempotent in * by reflexivity;
      try (eapply goodSize_weaken; [ eassumption | omega ]).

  Lemma wordToNat_ninj : forall sz (u v : word sz),
    u <> v
    -> wordToNat u <> wordToNat v.
    intros; intro; apply H.
    assert (natToWord sz (wordToNat u) = natToWord sz (wordToNat v)) by congruence.
    repeat rewrite natToWord_wordToNat in H1.
    assumption.
  Qed.

  repeat match goal with
           | [ H : _ |- _ ] => apply wordToNat_ninj in H
         end.
  rewrite wordToNat_wplus in n0;
    rewrite wordToNat_natToWord_idempotent in * by reflexivity;
      try (eapply goodSize_weaken; [ eassumption | omega ]).
  rewrite wordToNat_wplus in n1;
    rewrite wordToNat_natToWord_idempotent in * by reflexivity;
      try (eapply goodSize_weaken; [ eassumption | omega ]).
  rewrite wordToNat_wplus in n2;
    rewrite wordToNat_natToWord_idempotent in * by reflexivity;
      try (eapply goodSize_weaken; [ eassumption | omega ]).
  omega.

  intros.
  rewrite get_clear_ne in H12.
  rewrite get_clear_ne in H12.
  rewrite get_clear_ne in H12.
  rewrite get_clear_ne in H12.
  apply H0 with (4 + n).
  omega.
  rewrite natToW_plus.
  etransitivity; try apply H12.
  f_equal.
  unfold natToW.
  W_eq.

  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.

  Lemma wordToNat_ninj' : forall sz (u v : word sz),
    wordToNat u <> wordToNat v
    -> u <> v.
    congruence.
  Qed.

  apply wordToNat_ninj'.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].

  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  apply wordToNat_ninj'.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  omega.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].

  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  apply wordToNat_ninj'.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  omega.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].

  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  apply wordToNat_ninj'.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  omega.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].

  intros.
  rewrite get_clear_ne.
  rewrite get_clear_ne.
  rewrite get_clear_ne.
  rewrite get_clear_ne.
  apply H1.
  Opaque mult.
  pre_nomega.
  rewrite <- wplus_assoc in H11.
  rewrite <- natToW_plus in H11.
  rewrite wordToNat_wplus in H11.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent in H11.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 * S size)); eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  assumption.
  change (goodSize (4 * S size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].

  intro; apply H11; subst.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  pre_nomega.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].

  intro; apply H11; subst.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  pre_nomega.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].

  intro; apply H11; subst.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  pre_nomega.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].

  intro; apply H11; subst.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  pre_nomega.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].

  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
Qed.

Definition goodSize' (n : nat) := (N.of_nat n < 1 + Npow2 32)%N.

Lemma get_memoryIn' : forall m w init,
  (wordToNat w < init)%nat
  -> goodSize' init
  -> smem_get' (allWordsUpto 32 init) w (memoryIn' m _) = m w.
  induction init; simpl; intuition.
  destruct (H.addr_dec $ (init) w).
  unfold H.mem_get, ReadByte.
  congruence.
  apply IHinit.
  apply wordToNat_ninj in n.
  rewrite wordToNat_natToWord_idempotent in n.
  omega.
  generalize H0; clear.
  unfold goodSize'.
  generalize (Npow2 32); intros.
  apply Nlt_out in H0.
  rewrite N2Nat.inj_add in H0.
  autorewrite with N in *.
  pre_nomega.
  simpl in *.
  omega.
  generalize H0; clear.
  unfold goodSize'.
  generalize (Npow2 32).
  intros.
  nomega.
Qed.

Lemma pow2_N : forall n,
  N.of_nat (pow2 n) = Npow2 n.
  intros.
  assert (N.to_nat (N.of_nat (pow2 n)) = N.to_nat (Npow2 n)).
  autorewrite with N.
  symmetry; apply Npow2_nat.
  assert (N.of_nat (N.to_nat (N.of_nat (pow2 n))) = N.of_nat (N.to_nat (Npow2 n))) by congruence.
  autorewrite with N in *.
  assumption.
Qed.

Lemma get_memoryIn : forall m w,
  smem_get w (memoryIn m) = m w.
  intros.
  unfold smem_get, memoryIn, HT.memoryIn, H.all_addr.
  rewrite allWords_eq.
  apply get_memoryIn'.
  apply wordToNat_bound.
  hnf.
  rewrite pow2_N.
  reflexivity.
Qed.

Theorem materialize_allocated : forall stn st size specs,
  (forall n, (n < size * 4)%nat -> st.(Mem) n <> None)
  -> (forall w, $ (size * 4) <= w -> st.(Mem) w = None)
  -> goodSize (size * 4)%nat
  -> interp specs (![ 0 =?> size ] (stn, st)).
  rewrite sepFormula_eq; intros.
  apply materialize_allocated'; simpl.
  intros.
  pre_nomega.
  rewrite roundTrip_0 in H2.
  omega.
  intros.
  rewrite <- natToW_plus; simpl.
  rewrite get_memoryIn.
  auto.
  intros.
  rewrite wplus_unit in H2.
  rewrite get_memoryIn.
  apply H0.
  Require Import Coq.Arith.Arith.
  rewrite mult_comm; assumption.
  rewrite mult_comm; assumption.
Qed.

(** * Now put it all together to prove [genesis]. *)

Section boot.
  Variables heapSize globalsSize : nat.

  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.
  Hypothesis heapSizeUpperBound : goodSize (heapSize * 4).

  Lemma goodSize_heapSize : goodSize heapSize.
    eapply goodSize_weaken; [ eassumption | omega ].
  Qed.

  Hint Immediate goodSize_heapSize.

  Theorem heapSizeLowerBound' : natToW heapSize < natToW 3 -> False.
    change (natToW 3 <= natToW heapSize).
    intro; pre_nomega.
    rewrite wordToNat_natToWord_idempotent in *.
    rewrite wordToNat_natToWord_idempotent in *.
    omega.
    reflexivity.
    change (goodSize heapSize); eapply goodSize_weaken; [ eassumption | omega ].
  Qed.

  Hint Immediate heapSizeLowerBound'.

  Theorem noWrap : noWrapAround (natToW 4) (heapSize - 1).
    simpl; hnf; intros.
    intro.
    rewrite <- natToW_plus in H0.
    apply natToW_inj in H0.
    omega.
    2: reflexivity.
    eapply goodSize_weaken; [ eassumption | omega ].
  Qed.

  Theorem heapSize_roundTrip : wordToNat (natToW heapSize) = heapSize.
    intros; apply wordToNat_natToWord_idempotent;
      change (goodSize heapSize); eauto.
  Qed.

  Hint Rewrite heapSize_roundTrip : sepFormula.

  Definition bootS := {|
    Reserved := 49;
    Formals := nil;
    Precondition := fun _ => st ~> ![ 0 =?> (heapSize + 50 + globalsSize) ] st
  |}.

  Theorem genesis :
    0 =?> (heapSize + 50 + globalsSize)
    ===> (Ex vs, locals ("rp" :: nil) vs 49 (heapSize * 4)%nat) * 0 =?> heapSize * ((heapSize + 50) * 4)%nat =?> globalsSize.
    descend; intros; eapply Himp_trans; [ apply allocated_split | ].
    instantiate (1 := heapSize); auto.
    apply Himp_trans with (0 =?> heapSize *
      ((heapSize * 4)%nat =?> 50 * ((heapSize + 50) * 4)%nat =?> globalsSize))%Sep.
    apply Himp_star_frame.
    apply Himp_refl.
    intros; eapply Himp_trans; [ apply allocated_split | ].
    instantiate (1 := 50); auto.
    apply Himp_star_frame.
    apply allocated_shift_base.
    Require Import Coq.Arith.Arith.
    rewrite mult_comm.
    simpl.
    unfold natToW.
    words.
    reflexivity.
    apply allocated_shift_base.
    simpl.
    rewrite <- mult_plus_distr_l.
    rewrite mult_comm.
    unfold natToW.
    words.
    omega.

    Lemma wiggle : forall P Q R,
      P * (Q * R) ===> Q * P * R.
      sepLemma.
    Qed.

    eapply Himp_trans; [ apply wiggle | ].
    repeat (apply Himp_star_frame; try apply Himp_refl).
    change 50 with (length ("rp" :: nil) + 49).
    apply create_stack.
    NoDup.
  Qed.

  Transparent mult.

  Lemma bootstrap_Sp_nonzero : forall sp : W,
    sp = 0
    -> sp = heapSize * 4
    -> goodSize (heapSize * 4)
    -> False.
    intros; subst; apply natToW_inj in H0; auto; omega.
  Qed.

  Hypothesis globals : nat.
  Hypothesis mem_size : goodSize ((heapSize + 50 + globals) * 4)%nat.

  Lemma bootstrap_Sp_freeable : forall sp : W,
    sp = heapSize * 4
    -> freeable sp 50.
    intros; subst; constructor; auto.
    hnf; intros.
    rewrite <- natToW_plus.
    intro.
    apply natToW_inj in H0.
    omega.
    unfold size in *.
    eapply goodSize_weaken; [ apply mem_size | ].
    omega.
    auto.
  Qed.
End boot.

Definition genesisHints : TacPackage.
  prepare genesis tt.
Defined.

Ltac genesis := post; evaluate genesisHints; simpl in *; sep genesisHints; eauto.

Require Import Platform.Safety.

Ltac safety ok :=
  eapply safety; try eassumption; [
    link_simp; unfold labelSys, labelSys'; simpl; tauto
    | apply ok
    | apply LabelMap.find_2; link_simp; reflexivity
    | propxFo; apply materialize_allocated; assumption ].

Hint Immediate goodSize_heapSize heapSizeLowerBound' bootstrap_Sp_nonzero bootstrap_Sp_freeable.
Hint Rewrite heapSize_roundTrip using assumption : sepFormula.
Hint Extern 1 (noWrapAround _ _) => apply noWrap.

Ltac goodSize :=
  match goal with
    | [ H : goodSize (?size * 4)%nat |- _ ] => unfold size in *
  end; eapply goodSize_weaken; [ eassumption | omega ].


(* 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.
Require Export Wf_nat.
Require Export Compare_dec.

Require Import Term_const.

Fixpoint div2 (n : nat) : nat :=
  match n with
  | S (S p) => S (div2 p)
  | _ => 0
  end.

Parameter div2_lt : forall x : nat, div2 (S x) < S x.

Recursive Definition log (nat -> nat) lt lt_wf div2_lt
 (forall x : nat,
  log x = match x with
          | O => 0
          | S O => 0
          | S (S y) => S (log (div2 x))
          end).

Inspect 5.
(* Pour tester pas-à-pas:

Definition log_nat :=
    [log:nat -> nat] [x:nat]
    (Cases x of
        O => (0)
      | (S O) => (O)
      | (S (S y)) => (S (log (div2 (S (S y)))))
     end).

L_Terminate log_nat nat lt lt_wf log_term div2_lt.

Define_from_terminate log nat log_term.

Make_equation log_equation log_nat log log_term
  (x:nat)(log x)=
	(Case (le_gt_dec x (1)) of [h:?] O [h:?] (S (log (div2 x))) end).

 *)


Require Import msl.base.
Require Import msl.ageable.
Require Import msl.sepalg.
Require Import msl.sepalg_generators.
Require Import msl.age_sepalg.
Require Import msl.predicates_hered.
Require Import msl.predicates_sl.
Require Import msl.subtypes.

Local Open Scope pred.

Lemma unfash_derives {A} `{agA : ageable A}:
  forall {P Q}, (P |-- Q) -> @derives A _ (! P) (! Q).
Proof.
intros. intros w ?. simpl in *. apply H. auto.
Qed.

Lemma subp_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall G P P' Q Q',
  G |-- P >=> P' ->
  G |-- Q >=> Q' ->
  G |-- P * Q >=> P' * Q'.
Proof.
  pose proof I.
  repeat intro.
  specialize (H0 _ H2).
  specialize (H1 _ H2).
  clear G H2.
  destruct H5 as [w1 [w2 [? [? ?]]]].
  exists w1; exists w2; split; auto.
  split.
  eapply H0; auto.
  assert (level w1 = level a').
  apply comparable_fashionR.  eapply join_sub_comparable; eauto.
 apply necR_level in H4. omega.
  eapply H1; auto.
  assert (level w2 = level a').
  apply comparable_fashionR. eapply join_sub_comparable; eauto.
 apply necR_level in H4. omega.
Qed.

Lemma sub_wand {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall G P P' Q Q',
  G |-- P' >=> P ->
  G |-- Q >=> Q' ->
  G |-- (P -* Q) >=> (P' -* Q').
Proof.
  pose proof I.
  repeat intro.
  specialize (H0 _ H2); specialize (H1 _ H2); clear G H2; pose (H2:=True).
  eapply H0 in H8; try apply necR_refl.
  eapply H1; try apply necR_refl.
  apply necR_level in H4. apply necR_level in H6. apply join_comparable in H7.
  apply comparable_fashionR in H7. unfold fashionR in H7. omega.
  eapply H5; eauto.
  apply necR_level in H4. apply necR_level in H6.
   apply join_comparable2 in H7.
  apply comparable_fashionR in H7. unfold fashionR in H7. omega.
Qed.

Lemma find_superprecise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
   forall Q, Q |-- EX P:_, P && !(P >=> Q) && !!superprecise (P).
Proof.
intros.
intros w ?.
exists (exactly w).
split; auto.
split; auto.
hnf; apply necR_refl.
intros w' ? w'' ? ?.
hnf in H2.
apply pred_nec_hereditary with w; auto.
do 3 red.
apply superprecise_exactly.
Qed.

Lemma sepcon_subp' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall (P P' Q Q' : pred A) (st: nat),
    (P >=> P') st ->
    (Q >=> Q') st ->
    (P * Q >=> P' * Q') st.
Proof.
 pose proof I.
intros.
intros w' ? w'' ? [w1 [w2 [? [? ?]]]].
destruct (nec_join4 _ _ _ _ H4 H3) as [w1' [w2' [? [? ?]]]].
exists w1; exists w2; repeat split; auto.
eapply (H0 w1'); eauto.
simpl in *.
subst.
replace (level w1') with (level w'); auto.
symmetry; apply comparable_fashionR; eapply join_comparable; eauto.
eapply (H1 w2'); eauto.
replace (level w2') with (level w'); auto.
symmetry. apply comparable_fashionR.
eapply join_comparable; eauto.
Qed.

Lemma subp_refl'  {A} `{agA : ageable A} :  forall (Q: pred A) (st: nat), (Q >=> Q) st.
Proof.
intros.
intros ? ? ? ?; auto.
Qed.

Lemma subp_trans' {A} `{agA : ageable A}:
  forall (B C D: pred A) (w: nat), (B >=> C)%pred w -> (C >=> D)% pred w -> (B >=> D)%pred w.
Proof.
intros.
intros w' ? w'' ? ?.
eapply H0; eauto.
eapply H; eauto.
Qed.

Lemma andp_subp'  {A} `{agA : ageable A} :
 forall (P P' Q Q': pred A) (w: nat), (P >=> P') w -> (Q >=> Q') w -> (P && Q >=> P' && Q') w.
Proof.
intros.
intros w' ? w'' ? [? ?]; split.
eapply H; eauto.
eapply H0; eauto.
Qed.

Lemma allp_subp' {A} `{agA : ageable A}: forall T (F G: T -> pred A) (w: nat),
   (forall x,  (F x >=> G x) w) -> (allp (fun x:T => (F x >=> G x)) w).
Proof.
intros.
intro x; apply H; auto.
Qed.

Lemma pred_eq_e1 {A} `{agA : ageable A}: forall (P Q: pred A) w,
       ((P <=> Q) w -> (P >=> Q) w).
Proof.
intros.
intros w' ? w'' ? ?.
eapply H; eauto.
Qed.

Lemma pred_eq_e2 {A} `{agA : ageable A}: forall (P Q: pred A)  w,
     ((P <=> Q) w -> (Q >=> P) w).
Proof.
Proof.
intros.
intros w' ? w'' ? ?.
eapply H; eauto.
Qed.

Hint Resolve @sepcon_subp'.
Hint Resolve @subp_refl'.
Hint Resolve @andp_subp'.
Hint Resolve @allp_subp'.
Hint Resolve @derives_subp.
Hint Resolve @pred_eq_e1.
Hint Resolve @pred_eq_e2.

Lemma allp_imp2_later_e2 {B}{A}{agA: ageable A}:
   forall (P Q: B -> pred A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> Q y >=> |> P y.
Proof.
  intros.  intros w ?. specialize (H y). apply pred_eq_e2. auto.
Qed.
Lemma allp_imp2_later_e1 {B}{A}{agA: ageable A}:
   forall (P Q: B -> pred A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> P y >=> |> Q y.
Proof.
  intros.  intros w ?. specialize (H y). apply pred_eq_e1. auto.
Qed.

(*
Lemma subp_later {A} `{agA:  ageable A} (SS: natty A):
 forall (P Q: pred A), |> (P >=> Q) |-- |> P >=> |> Q.
Proof.
intros.
rewrite later_fash; auto.
apply fash_derives.
apply axiomK.
Qed.
*)

Lemma extend_unfash {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P: pred nat), boxy extendM (! P).
Proof.
intros.
apply boxy_i; auto; intros.
unfold unfash in *.
simpl in H. destruct H.
hnf in H0|-*.
replace (level w') with (level w); auto.
apply comparable_fashionR.
eapply join_comparable; eauto.
Qed.

Hint Resolve @extend_unfash.

Lemma subp_unfash {A} `{Age_alg A}:
  forall (P Q : pred nat) (n: nat), (P >=> Q) n -> ( ! P >=> ! Q) n.
Proof.
intros.
intros w ?. specialize (H0 _ H1).
intros w' ? ?. apply (H0 _ (necR_level' H2)).
auto.
Qed.
Hint Resolve @subp_unfash.

Lemma unfash_sepcon_distrib:
        forall {T}{agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T}
           (P: pred nat) (Q R: pred T),
               unfash P && (Q*R) = (unfash P && Q) * (unfash P && R).
Proof.
intros.
apply pred_ext.
intros w [? [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; repeat split; auto.
apply join_level in H0. destruct H0.
hnf in H|-*. congruence.
apply join_level in H0. destruct H0.
hnf in H|-*. congruence.
intros w [w1 [w2 [? [[? ?] [? ?]]]]].
split.
apply join_level in H. destruct H.
hnf in H0|-*. congruence.
exists w1; exists w2; repeat split; auto.
Qed.


(* Declare ML Module "plugin". *)

(*
Declare ML Module "extlib".
Declare ML Module "reif".

Section PartialApply.

  Fixpoint funtype (ls : list Type) (r : Type) : Type :=
    match ls with
      | nil => r
      | cons a b => a -> funtype b r
    end.

  Fixpoint apply_ls (ls : list Type) (T : Type) (R : T -> Type) (V : T)
    : funtype ls (forall x : T, R x) -> funtype ls (R V) :=
    match ls with
      | nil => fun F => F V
      | cons a b => fun F => fun x : a => apply_ls b T R V (F x)
    end.
End PartialApply.

Require Import List.

Ltac refl_app cc e :=
  match e with
    | (fun _ => _) =>
      let rec getTypes As :=
        match As with
          | tt => constr:(@nil Type)
          | (?A, ?B) =>
            match type of A with
              | _ -> ?TT =>
                let r := getTypes B in
                constr:((TT : Type) :: r)
            end
        end
      in
      let rec papply cc F T Tb Ts As :=
        match T with
          | ?T1 -> ?TT =>
            match Ts with
              | ?T :: ?T' =>
                match As with
                  | (?A, ?A') =>
                    let cc' f Ts As :=
                      let Ts' := constr:((T : Type) :: Ts) in
                      let As' := constr:((A, As)) in
                      cc f Ts' As'
                    in
                    let Tb := constr:((T:Type) :: Tb) in
                    papply cc' F TT Tb T' A'
                end
            end
          | forall x : ?T1, @?T2 x =>
            match Ts with
              | _ :: ?T' =>
                match As with
                  | ((fun _ => ?A), ?A') =>
                    let TT' := eval simpl in (T2 A) in
                    let f' := eval simpl in (@apply_ls Tb T1 T2 A F) in
                    papply cc f' TT' Tb T' A'
                end
            end
          | _ =>
            cc F Ts As
        end
      in
      match e with
        | fun x => ?F (@?A x) (@?B x) (@?C x) (@?D x) (@?E x) =>
          let As := constr:((A,(B,(C,(D,(E,tt)))))) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F (@?A x) (@?B x) (@?C x) (@?D x) =>
          let As := constr:((A,(B,(C,(D,tt))))) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F (@?A x) (@?B x) (@?C x) =>
          let As := constr:((A,(B,(C,tt)))) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F (@?A x) (@?B x) =>
          let As := constr:((A,(B,tt))) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F (@?A x) =>
          let As := constr:((A,tt)) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
        | fun x => ?F =>
          let As := constr:(tt) in
          let Ts := getTypes As in
          let Tf := type of F in
          let Tb := constr:(@nil Type) in
          papply cc F Tf Tb Ts As
      end
    | _ =>
      let rec refl cc e As :=
        match e with
          | ?A ?B =>
            let Ta := type of A in
            match Ta with
              | _ -> ?TT =>
                let As := constr:((B, As)) in
                let Tb := type of B in
                let cc f Ts args :=
                  let Ts' := constr:(List.app Ts (cons (Tb : Type) nil)) in
                  cc f Ts' args
                in
                refl cc A As
              | forall x : ?T1, @?T2 x =>
                let cc f Ts args :=
                  let Tb  := type of B in
                  let f'  := eval simpl in (@apply_ls Ts T1 T2 B f) in
                  cc f' Ts args
                in
                refl cc A As
              end
          | _ =>
            let Ts := constr:(@nil Type) in
            cc e Ts As
        end
        in
        let b := constr:(tt) in
        refl cc e b
  end.

Ltac cc1 x ts args :=
  idtac "$$$ plugin" x ts args.
Ltac cc2 x ts args :=
  idtac "$$$ ltac" x ts args.

Definition tutu (x : Type) ( y : x ) (s : Type) (z : nat) (z2 : nat) (u : x) := 1.
Goal tutu bool true nat 3 3  false = 2.
  match goal with
      |- ?l = _ =>  refl_app_cps l cc1
  end.
  match goal with
      |- ?l = _ =>  refl_app cc2 l
  end.
Abort.

Definition bar : forall ( x: Type), nat -> forall (y : Type), x -> y -> x := fun _ _ _ e _ => e.

Definition bar2 : forall ( x: Type), nat -> forall (y : Type), nat -> forall (z : Type),  x -> y -> z -> z. Admitted.

Goal forall a b c d e, bar a b c d e = d.
intros.
  match goal with
      |- ?l = _ => refl_app_cps l cc1
  end.
  match goal with
      |- ?l = _ =>  refl_app cc2 l
  end.
Abort.

Goal forall Hx Hy Hz a b c d e, bar2 Hx a Hy b Hz c d e = e.
intros.
match goal with
    |- ?l = _ => refl_app_cps l cc1
end.
match goal with
    |- ?l = _ =>  refl_app cc2 l
end.

Abort.

Goal (fun x => x + x) = (fun x => 2).
match goal with
    |- ?l = _ => refl_app_cps l cc1
end.
match goal with
    |- ?l = _ =>  refl_app cc2 l
end.
Abort.

Variable A B : Type.
Definition test1 (stn : A) (sm : B) : B. Admitted.
Goal  forall a b, test1 a b = b. intros.
match goal with |- ?l = _  => refl_app_cps l cc1 end.
match goal with |- ?l = _  => refl_app cc2 l end.
Abort.

Definition test2 : A * B -> B. Admitted.
Goal  (fun x y => test2 (x, y)) = (fun _ b => b). intros.
match goal with |- ?l = _  => refl_app cc2 l end.
match goal with |- ?l = _  => refl_app_cps l cc1 end.
Abort.
Require Import String.
Require Bedrock. Require ReifyExpr.
Definition test_dep_0 (n : nat) (arg : bool) := True.
Definition test_dep (n : nat) (arg : bool) := n = 0 -> arg = arg.
Goal True.
reify_expr (test_dep_0 1 true).
reify_expr (test_dep 1 true).
Abort.
(* Require Bedrock. Require ReifyExpr.  *)
(* Goal True.  *)
(* reify_expr (forall (x : bool), x = x).  *)
(* reify_expr (1). *)
(* reify_expr (fun (x : nat )=> x).  *)
(* reify_expr (1 + 3).  *)
(* reify_expr (1 + 3 = 2 + 2).  *)
(* reify_expr (not (1 + 3 = 2 + 2)).  *)
(* reify_expr (not (1 + 3 = 2 + 2)).  *)
(* reify_expr ((1 + 3 = 2 + 2) -> False).  *)
(* (* Time reify_expr ((1 + 1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 + 3 = 2 + 2) -> False).  *) *)
(* reify_expr (fun n => n + n = n + n).  *)
(* reify_expr (fun x => negb (negb x) = x). *)
(* Abort.  *)
(* Require Import Bedrock.SepIL. Import SEP.  *)
(* Locate SEP.Emp.  *)
(* Axiom types : list Type.  *)
(* Axiom pc : Type.  *)
(* Notation "a * b" := (@star pc pc types  a b) (only parsing).  *)
(* Notation "0" := (@emp pc pc types ) (only parsing).  *)
(* Notation "'Ex' x , p" := (@ex pc pc types _ (fun x => p)). *)
(* Notation "'Ex' x : T , p" := (@ex pc pc types T (fun x => p)) . *)
(* Notation "[| P |]" := (@inj pc pc types (@PropX.Inj pc pc types  P )).  *)
(* Require Import IL.  *)
(* Variable st : state.  *)
(* Goal True.  *)
(* reify_expr (Regs st Rp). *)
(* reify_sexpr (0 ).  *)
(* reify_sexpr (0 * 0 * 0).  *)
(* reify_sexpr ( [| 1 + 1 = 2 |] * 0 * [| 12 = 6 + 6 |] ). *)
(* reify_sexpr ( [| 1 + 1 = 2 |] * 0 * [| 12 = 6 + 6 |] ).  *)
(* reify_sexpr ( Ex x, [| x = 1|]).  *)
(* reify_sexpr ( Ex x, Ex y, Ex z, [| x = y + z|]).  *)
(* reify_sexpr ( Ex x, [| x = 1|]).  *)
(* reify_sexpr ( Ex x : bool, Ex y, Ex z, [| (if x then 1 else 2) = y + z|]).  *)
(* reify_sexpr ( Ex x: bool, [| (if x then true else false) = x|]).  *)
(* reify_sexpr ( Ex x:bool, Ex y : bool, [| (if x then y else false) = andb x y|]).  *)
(* reify_sexpr ( Ex x:bool, Ex y : nat, [| (if x then y else y) = y|]).  *)
(* Fail reify_sexpr (Ex x : (bool -> bool), [| x true = false |]).  *)
(* evar (x : nat); let s := eval simpl in (Ex y : nat, [|x = y|] * [| S x = S y|]) in reify_sexpr s ; clear x.   *)
(* Abort.  *)

(* Goal forall P,    *)
(*        P( Ex x : bool, [|negb (negb x) = false |]). *)
(* intros.   *)
(* assert (forall x, false = (x && negb x)%bool). admit.  *)
(* Require Import Setoid. erewrite H.  *)
(* match goal with  *)
(*     |- P ?l =>  *)
(*       reify_sexpr l *)
(* end.  *)
(* Abort.  *)

(* Goal True.  *)
(* Ltac t f := *)
(* match f with  *)
(*   | (fun x => @?B x) => idtac 1 B;  *)
(*       refl_app ltac:(fun x y z => idtac x y z) B *)
(*   | (fun x => _) => idtac 2 *)
(* end.  *)

(* t ((fun x => (if (x : bool) then true else false))).  *)
(* Abort.  *)
*)


(* Hendra : DEX big step semantics, looking into BigStepLoad.v as reference *)

  Import DEX_Dom DEX_Prog.

  Open Scope type_scope.
  Definition DEX_InitCallState :=  DEX_Method * DEX_Registers.t.
  Definition DEX_IntraNormalState := DEX_PC * DEX_Registers.t.
  Definition DEX_ReturnState := DEX_ReturnVal.

  Inductive DEX_NormalStep (p:DEX_Program) : DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState  -> Prop :=
  | nop : forall m pc pc' regs,

    instructionAt m pc = Some DEX_Nop ->
    next m pc = Some pc' ->

    DEX_NormalStep p m (pc, regs) (pc', regs)

  | const : forall m pc pc' regs regs' k rt v,

    instructionAt m pc = Some (DEX_Const k rt v) ->
    In rt (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    (-2^31 <= v < 2^31)%Z ->
    DEX_METHOD.valid_reg m rt ->
    regs' = DEX_Registers.update regs rt (Num (I (Int.const v))) ->

    DEX_NormalStep p m (pc, regs) (pc', regs')

  | move_step_ok : forall m pc pc' regs regs' k rt rs v,

    instructionAt m pc = Some (DEX_Move k rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some v = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt v ->

    DEX_NormalStep p m (pc, regs) (pc', regs')

  | goto_step_ok : forall m pc regs o,

    instructionAt m pc = Some (DEX_Goto o) ->

    DEX_NormalStep p m (pc, regs) ((DEX_OFFSET.jump pc o), regs)

  | packedswitch_step_ok1 : forall m pc l v r firstKey size list_offset n o,

    instructionAt m pc = Some (DEX_PackedSwitch r firstKey size list_offset) ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    (firstKey <= Int.toZ v < firstKey + (Z_of_nat size))%Z ->
    length list_offset = size ->
    Z_of_nat n = ((Int.toZ v) - firstKey)%Z ->
    nth_error list_offset n = Some o ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, l) ((DEX_OFFSET.jump pc o), l)

  | packedswitch_step_ok2 : forall m pc pc' l v r firstKey size list_offset,

    instructionAt m pc = Some (DEX_PackedSwitch r firstKey size list_offset) ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    length list_offset = size ->
    (Int.toZ v < firstKey \/ firstKey + (Z_of_nat size) <= Int.toZ v)%Z ->
    next m pc = Some pc' ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, l) (pc', l)

  | sparseswitch_step_ok1 : forall m pc l v v' o r size listkey,

    instructionAt m pc = Some (DEX_SparseSwitch r size listkey) ->
    length listkey = size ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    List.In (pair v' o) listkey ->
    v' = Int.toZ v ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, l) ((DEX_OFFSET.jump pc o), l)

  | sparseswitch_step_ok2 : forall m pc pc' l v r size listkey,

    instructionAt m pc = Some (DEX_SparseSwitch r size listkey) ->
    length listkey = size ->
    Some (Num (I v)) = DEX_Registers.get l r ->
    (forall v' o, List.In (pair v' o) listkey ->  v' <> Int.toZ v) ->
    next m pc = Some pc' ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, l) (pc', l)

  | ifcmp_step_jump : forall m pc regs va vb cmp ra rb o,

    instructionAt m pc = Some (DEX_Ifcmp cmp ra rb o) ->
    In ra (DEX_Registers.dom regs) ->
    In rb (DEX_Registers.dom regs) ->
    Some (Num (I va)) = DEX_Registers.get regs ra ->
    Some (Num (I vb)) = DEX_Registers.get regs rb ->
    SemCompInt cmp (Int.toZ va) (Int.toZ vb) ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m rb ->

    DEX_NormalStep p m (pc, regs) ((DEX_OFFSET.jump pc o), regs)

  | ifcmp_step_continue : forall m pc pc' regs va vb cmp ra rb o,

    instructionAt m pc = Some (DEX_Ifcmp cmp ra rb o) ->
    In ra (DEX_Registers.dom regs) ->
    In rb (DEX_Registers.dom regs) ->
    Some (Num (I va)) = DEX_Registers.get regs ra ->
    Some (Num (I vb)) = DEX_Registers.get regs rb ->
    ~SemCompInt cmp (Int.toZ va) (Int.toZ vb) ->
    next m pc = Some pc' ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m rb ->

    DEX_NormalStep p m (pc, regs) (pc', regs)

  | ifz_step_jump : forall m pc regs v cmp r o,

    instructionAt m pc = Some (DEX_Ifz cmp r o) ->
    In r (DEX_Registers.dom regs) ->
    Some (Num (I v)) = DEX_Registers.get regs r ->
    SemCompInt cmp (Int.toZ v) (0) ->
    DEX_METHOD.valid_reg m r ->

    DEX_NormalStep p m (pc, regs) ((DEX_OFFSET.jump pc o), regs)

  | ifz_step_continue : forall m pc pc' regs v cmp r o,

    instructionAt m pc = Some (DEX_Ifz cmp r o) ->
    In r (DEX_Registers.dom regs) ->
    Some (Num (I v)) = DEX_Registers.get regs r ->
    ~SemCompInt cmp (Int.toZ v) (0) ->
    next m pc = Some pc' ->

    DEX_NormalStep p m (pc, regs) (pc', regs)

  (** <addlink>ineg</addlink>: Negate [int] *)
  | ineg_step : forall m pc regs regs' pc' rt rs v,

    instructionAt m pc = Some (DEX_Ineg rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (Int.neg v))) ->

    DEX_NormalStep p m (pc, regs) (pc', regs')

  (** <addlink>ineg</addlink>: Not [int] (one's complement) *)
  | inot_step : forall (*h*) m pc regs regs' pc' rt rs v,

    instructionAt m pc = Some (DEX_Inot rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (Int.not v))) ->

    DEX_NormalStep p m (pc, regs) (pc', regs')

  (** <addlink>i2b</addlink>: Convert [int] to [byte] *)
  | i2b_step_ok : forall m pc pc' regs regs' rt rs v,

    instructionAt m pc = Some (DEX_I2b rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (b2i (i2b v)))) ->

    DEX_NormalStep p m (pc, regs) (pc', regs')

 (** <addlink>i2s</addlink>: Convert [int] to [short] *)
  | i2s_step_ok : forall m pc pc' regs regs' rt rs v,

    instructionAt m pc = Some (DEX_I2s rt rs) ->
    In rt (DEX_Registers.dom regs) ->
    In rs (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    Some (Num (I v)) = DEX_Registers.get regs rs ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m rs ->
    regs' = DEX_Registers.update regs rt (Num (I (s2i (i2s v)))) ->

    DEX_NormalStep p m (pc, regs) (pc', regs')

  | ibinop_step_ok : forall m pc pc' regs regs' op rt ra rb va vb,

    instructionAt m pc = Some (DEX_Ibinop op rt ra rb) ->
    In rt (DEX_Registers.dom regs) ->
    In ra (DEX_Registers.dom regs) ->
    In rb (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    (*(op = DivInt \/ op = RemInt -> ~ Int.toZ i2 = 0) -> at this moment there is no exception*)
    Some (Num (I va)) = DEX_Registers.get regs ra ->
    Some (Num (I vb)) = DEX_Registers.get regs rb ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m ra ->
    DEX_METHOD.valid_reg m rb ->
    regs' = DEX_Registers.update regs rt (Num (I (SemBinopInt op va vb))) ->

    DEX_NormalStep p m (pc, regs) (pc', regs')

  | ibinopconst_step_ok : forall m pc pc' regs regs' op rt r va v,

    instructionAt m pc = Some (DEX_IbinopConst op rt r v) ->
    In r (DEX_Registers.dom regs) ->
    In rt (DEX_Registers.dom regs) ->
    next m pc = Some pc' ->
    (*(op = DivInt \/ op = RemInt -> ~ Int.toZ i2 = 0) -> at this moment there is no exception*)
    Some (Num (I va)) = DEX_Registers.get regs r ->
    DEX_METHOD.valid_reg m rt ->
    DEX_METHOD.valid_reg m r ->
    regs' = DEX_Registers.update regs rt (Num (I (SemBinopInt op va (Int.const v)))) ->

    DEX_NormalStep p m (pc, regs) (pc', regs')
.

  Inductive DEX_ReturnStep (p:DEX_Program) : DEX_Method -> DEX_IntraNormalState -> DEX_ReturnState -> Prop :=
  | void_return : forall m pc regs,

    instructionAt m pc = Some DEX_Return ->
    DEX_METHODSIGNATURE.result (DEX_METHOD.signature m) = None ->

    DEX_ReturnStep p m (pc, regs) (Normal None)

  | vreturn : forall m pc regs val t k rs,
    (* Implicit in the assumption is that the register has a value in it *)
    instructionAt m pc = Some (DEX_VReturn k rs) ->
    In rs (DEX_Registers.dom regs) ->
    DEX_METHODSIGNATURE.result (DEX_METHOD.signature m) = Some t ->
    assign_compatible p val t ->
    compat_ValKind_value k val ->
    Some val = DEX_Registers.get regs rs ->

    DEX_ReturnStep p m (pc, regs) (Normal (Some val))
.

  Inductive DEX_exec_intra (p:DEX_Program) (m:DEX_Method) : DEX_IntraNormalState -> DEX_IntraNormalState -> Prop :=
  | exec_intra_normal : forall s1 s2,
     DEX_NormalStep p m s1 s2 ->
     DEX_exec_intra p m s1 s2.

  Inductive DEX_exec_return (p:DEX_Program) (m:DEX_Method) : DEX_IntraNormalState -> DEX_ReturnState -> Prop :=
  | exec_return_normal : forall s ov,
     DEX_ReturnStep p m s (Normal ov) ->
     DEX_exec_return p m s (Normal ov)
.

 Inductive DEX_IntraStep (p:DEX_Program) :
    DEX_Method -> DEX_IntraNormalState -> DEX_IntraNormalState + DEX_ReturnState -> Prop :=
  | IntraStep_res :forall m s ret,
     DEX_exec_return p m s ret ->
     DEX_IntraStep p m s (inr _ ret)
  | IntraStep_intra_step:forall m s1 s2,
     DEX_exec_intra p m s1 s2 ->
     DEX_IntraStep p m s1 (inl _ s2) .

 Definition DEX_IntraStepStar p m s r := TransStep_l (DEX_IntraStep p m) s r.

 Definition DEX_IntraStepStar_intra p m s s' := DEX_IntraStepStar p m s (inl _ s').

 Definition DEX_BigStep  p m s ret := DEX_IntraStepStar p m s (inr _ ret).

 Inductive DEX_ReachableStep (P:DEX_Program) :
      (DEX_Method*DEX_IntraNormalState)->(DEX_Method*DEX_IntraNormalState) ->Prop :=
   | ReachableIntra : forall M s s',
       DEX_IntraStep P M s (inl _ s') ->
       DEX_ReachableStep P (M,s) (M,s').

 Definition DEX_Reachable P M s s' :=
   exists M',  ClosReflTrans (DEX_ReachableStep P) (M,s) (M',s').