(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export list. (* why? *)

Lemma cover_vars_upto_if_cover_vars_lsubst {o} :
  forall (t : @NTerm o) sub s,
    cover_vars (lsubst t s) sub
    -> cover_vars_upto t (csub_filter sub (dom_sub s)) (dom_sub s).
Proof.
  introv c.

  allrw @cover_vars_eq.
  allunfold @cover_vars_upto.
  allrw subvars_prop.
  introv i.
  rw in_app_iff.
  rw @dom_csub_csub_filter.
  rw in_remove_nvars.
  generalize (in_deq NVar deq_nvar x (dom_sub s)); introv j.
  destruct j as [j | j]; try (complete sp).
  right; dands; auto.
  apply c.
  generalize (eqvars_free_vars_disjoint t s); introv e.
  rw eqvars_prop in e; apply e; clear e.
  rw in_app_iff; rw in_remove_nvars; sp.
Qed.

Lemma substc_lsubstc_type_family_codom {o} :
  forall (a : @NTerm o) x B f t s1 s2 wa wb ws ca cb cs,
    !LIn f (free_vars B)
    -> !LIn f (bound_vars B)
    -> disjoint (remove_nvars [x] (free_vars B)) (dom_csub s2)
    -> disjoint (dom_csub s1) (bound_vars B)
    -> disjoint (dom_csub s2) (bound_vars B)
    -> substc (lsubstc a wa (snoc s1 (f, t) ++ s2) ca) x
              (lsubstc_vars B wb (csub_filter s1 [x]) [x] cb)
       = lsubstc (subst B x a) ws (snoc s1 (f, t) ++ s2) cs.
Proof.
  introv nifb1 nifb2 disj1 disj2 disj3.
  rw @substc_eq_lsubstc.
  apply lsubstc_eq_if_csubst; simpl.
  rw @csubst_app; simpl.
  rw @csubst_swap_app.
  unfold csubst, subst.
  rw @simple_lsubst_lsubst; simpl.
  unfold csubst.
  rw @fold_csubst.
  repeat (rw <- @simple_lsubst_cons).
  remember (subst B x (csubst a (snoc s1 (f, t) ++ s2))).
  rw <- @sub_filter_csub2sub.
  rw @lsubst_sub_filter.
  rw <- @csub2sub_app.
  rw @csub2sub_snoc.
  rw @subset_free_vars_sub_app.
  rw snoc_as_append.
  rw @subset_free_vars_sub_app.
  auto.
  introv.
  rw in_app_iff; simpl; sp; cpx.
  allapply @in_csub2sub; sp.
  subst; unfold subst.
  rw @isprogram_lsubst2; simpl.
  rw disjoint_remove_nvars_l; simpl.
  rw remove_nvars_cons; simpl.
  destruct (eq_var_dec x f); subst; sp.
  rw remove_nvars_nil_l.
  apply disjoint_nil_r.
  rw disjoint_singleton_r; auto.
  sp; cpx.
  apply isprogram_csubst; sp; rw @nt_wf_eq; sp.
  introv.
  rw in_app_iff; simpl; rw in_snoc; sp; cpx.
  allapply @in_csub2sub; sp.
  allapply @in_csub2sub; sp.
  subst; unfold subst.
  rw @isprogram_lsubst2; simpl.
  rw @dom_csub_eq.
  insub.
  sp; cpx.
  apply isprogram_csubst; sp; rw @nt_wf_eq; sp.
  intros.
  allapply @in_csub2sub; sp.
  subst; unfold subst.
  rw @isprogram_lsubst2; simpl.
  rw disjoint_remove_nvars_l; simpl.
  rw remove_nvars_eq; sp.
  sp; cpx.
  apply isprogram_csubst; sp; rw @nt_wf_eq; sp.
  apply isprogram_csubst; sp; rw @nt_wf_eq; sp.
  sp.
  allapply @in_csub2sub; sp.
  apply isprogram_csubst; sp; rw @nt_wf_eq; sp.
  sp.
  allapply @in_csub2sub; sp.
  sp; cpx.
  apply cover_vars_disjoint with (sub := snoc s1 (f, t) ++ s2); sp.
  rw @dom_csub_app; rw @dom_csub_snoc; simpl.
  rw disjoint_app_l; rw disjoint_snoc_l; sp.
  insub.
  insub.
  sp.
  allapply @in_csub2sub; sp.
  simpl.
  rw @dom_csub_csub_filter.
  rw disjoint_remove_nvars_l; simpl.
  rw remove_nvars_eq; sp.
Qed.

Lemma lsubstc2_lsubstc_var {o} :
  forall bp ba (B : @NTerm o) p a wB s cvB vp va w c,
    !LIn vp (bound_vars B)
    -> !LIn va (bound_vars B)
    -> ((!LIn vp [bp,ba]) -> !LIn vp (free_vars B))
    -> ((!LIn va [bp,ba]) -> !LIn va (free_vars B))
    -> !LIn vp (dom_csub s)
    -> !LIn va (dom_csub s)
    -> !(ba = bp)
    -> !(va = vp)
    -> lsubstc2 bp p ba a
                (lsubstc_vars B wB (csub_filter s [bp, ba]) [bp, ba] cvB)
       = lsubstc (lsubst B [(bp, mk_var vp), (ba, mk_var va)]) w
                 (snoc (snoc s (vp, p)) (va, a)) c.
Proof.
  introv disj1 disj2 disj3 disj4 disj5 disj6 disj7 disj8.

  apply cterm_eq; simpl.
  unfold csubst; simpl.

  repeat (rw @simple_lsubst_lsubst; simpl);
    try (complete (sp; cpx; simpl; rw disjoint_singleton_l; sp));
    try (complete (sp; allapply @in_csub2sub; sp; allunfold @isprogram; sp; allrw; sp)).

  rw <- @sub_filter_csub2sub.
  rw <- @sub_filter_lsubst_sub; simpl.

  rw @lsubst_sub_trivial_closed1;
    try (complete (simpl; sp; cpx; allapply @in_csub2sub; sp)).

  generalize (lsubst_shift B
                           (sub_filter (csub2sub s) [bp, ba])
                           [(bp, get_cterm p), (ba, get_cterm a)]
                           []).
  intro eq.

  dest_imp eq hyp.
  simpl; introv i; allrw in_app_iff; allsimpl; sp; cpx;
  allrw @in_sub_filter; sp; allapply @in_csub2sub; sp.

  dest_imp eq hyp.
  simpl; rw <- @dom_sub_sub_filter; unfold disjoint; introv i;
  allrw in_remove_nvars; sp.

  allrw app_nil_r.
  rw eq; clear eq; simpl.

  assert (get_cterm p = lsubst (mk_var vp) (csub2sub (snoc (snoc s (vp, p)) (va, a)))) as eq1.
  (* begin proof of assert *)
  repeat (rw @csub2sub_snoc).
  change_to_lsubst_aux4; simpl; sp.
  repeat (rw @sub_find_snoc).
  boolvar.
  assert (!LIn vp (dom_sub (csub2sub s))) as nivp by (rw @dom_csub_eq; sp).
  rw <- @sub_find_none_iff in nivp; rw nivp; sp.
  assert (!LIn vp (dom_sub (csub2sub s))) as nivp by (rw @dom_csub_eq; sp).
  rw <- @sub_find_none_iff in nivp; rw nivp; sp.
  (* end proof of assert *)

  rw <- eq1; clear eq1.

  assert (get_cterm a = lsubst (mk_var va) (csub2sub (snoc (snoc s (vp, p)) (va, a)))) as eq2.
  (* begin proof of assert *)
  rw @csub2sub_snoc.
  change_to_lsubst_aux4; simpl; sp.
  rw @sub_find_snoc.
  boolvar.
  assert (!LIn va (dom_sub (csub2sub (snoc s (vp, p)))))
         as niva
         by (rw @dom_csub_eq; rw @dom_csub_snoc; simpl; rw in_snoc; sp).
  rw <- @sub_find_none_iff in niva; rw niva; sp.
  (* end proof of assert *)

  rw <- eq2; clear eq2.

  repeat (rw @csub2sub_snoc).

  assert (forall T (l : list T) x y, x :: y :: l = [x,y] ++ l) as eqc by sp.

  symmetry.
  rw eqc.
  rw @lsubst_aux_app_sub_filter; simpl;
    try (complete (allrw @prog_sub_cons; sp; unfold prog_sub, sub_range_sat; simpl; sp));
    try (complete (apply @prog_sub_sub_filter; sp));
    try (complete (repeat (rw @prog_sub_snoc; sp))).

  destruct (eq_var_dec vp bp); sp; subst.
  destruct (eq_var_dec va ba); sp; subst.

  repeat (rw @sub_filter_snoc); boolvar; sp; try (complete (allrw not_over_or; sp)).

  dest_imp disj4 hyp; try (complete (simpl; sp)).
  repeat (rw @sub_filter_snoc); boolvar; sp; allrw not_over_or; sp.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: snoc (sub_filter (csub2sub s) [bp, ba]) (va, get_cterm a))
                [va]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  rw @sub_filter_snoc; boolvar; sp; try (complete (allrw not_over_or; sp)).
  rw <- @sub_filter_app_r; simpl.
  symmetry.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: sub_filter (csub2sub s) [bp, ba])
                [va]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  rw <- @sub_filter_app_r; simpl; sp.

  destruct (eq_var_dec vp ba); sp; subst.
  destruct (eq_var_dec va bp); sp; subst.

  repeat (rw @sub_filter_snoc); boolvar; sp; try (complete (allrw not_over_or; sp)).

  repeat (rw @sub_filter_snoc); boolvar; sp; allrw not_over_or; sp.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: snoc (sub_filter (csub2sub s) [bp, ba]) (va, get_cterm a))
                [va]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  rw @sub_filter_snoc; boolvar; sp; try (complete (allrw not_over_or; sp)).
  rw <- @sub_filter_app_r; simpl.
  symmetry.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: sub_filter (csub2sub s) [bp, ba])
                [va]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  rw <- @sub_filter_app_r; simpl; sp.

  dest_imp disj3 hyp; try (complete (simpl; sp)).

  destruct (eq_var_dec va bp); sp; subst.

  repeat (rw @sub_filter_snoc); boolvar; sp; allrw not_over_or; sp.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: snoc (sub_filter (csub2sub s) [bp, ba]) (vp, get_cterm p))
                [vp]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  rw @sub_filter_snoc; boolvar; sp; try (complete (allrw not_over_or; sp)).
  rw <- @sub_filter_app_r; simpl.
  symmetry.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: sub_filter (csub2sub s) [bp, ba])
                [vp]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  rw <- @sub_filter_app_r; simpl; sp.

  destruct (eq_var_dec va ba); sp; subst.

  repeat (rw @sub_filter_snoc); boolvar; sp; allrw not_over_or; sp.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: snoc (sub_filter (csub2sub s) [bp, ba]) (vp, get_cterm p))
                [vp]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  rw @sub_filter_snoc; boolvar; sp; try (complete (allrw not_over_or; sp)).
  rw <- @sub_filter_app_r; simpl.
  symmetry.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: sub_filter (csub2sub s) [bp, ba])
                [vp]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  rw <- @sub_filter_app_r; simpl; sp.

  dest_imp disj4 hyp; try (complete (simpl; sp)).

  repeat (rw @sub_filter_snoc); boolvar; sp; allrw not_over_or; sp.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: snoc (snoc (sub_filter (csub2sub s) [bp, ba]) (vp, get_cterm p)) (va, get_cterm a))
                [vp,va]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_cons_r; rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  repeat (rw @sub_filter_snoc); boolvar; sp; try (complete (allrw not_over_or; sp)).
  rw <- @sub_filter_app_r; simpl.
  symmetry.

  generalize (lsubst_sub_filter
                B
                ((bp, get_cterm p)
                   :: (ba, get_cterm a)
                   :: sub_filter (csub2sub s) [bp, ba])
                [vp,va]); simpl; boolvar; try (complete sp); intro k.
  dest_imp k hyp.
  introv k; sp; cpx.
  allrw in_snoc; sp; cpx.
  allrw @in_sub_filter; sp.
  allapply @in_csub2sub; sp.
  dest_imp k hyp.
  rw disjoint_cons_r; rw disjoint_singleton_r; sp.
  rw <- k; clear k.

  rw <- @sub_filter_app_r; simpl; sp.
Qed.

Lemma simple_lsubst_app2 {o} :
  forall (t : @NTerm o) sub1 sub2,
    (forall v u, LIn (v, u) sub1 -> disjoint (free_vars u) (bound_vars t))
    -> (forall v u, LIn (v, u) sub2 -> isprogram u)
    -> (forall v,
          LIn v (dom_sub sub2)
          -> !LIn v (dom_sub sub1)
          -> !LIn v (free_vars t))
    -> lsubst t (sub1 ++ sub2) = lsubst t sub1.
Proof.
  introv hyp1 hyp2 hyp3.
  change_to_lsubst_aux4;
    try (complete (rw @range_app; rw flat_map_app;
                   rw disjoint_app_r; sp;
                   rw @prog_sub_flatmap_range; sp)).

  revert_dependents sub2.
  revert_dependents sub1.
  nterm_ind t as [| | oo lbt ind] Case; allsimpl;
  introv disj1 disj2 hyp1 hyp2 disj3; auto.

  - Case "vterm".
    rw @sub_find_app.
    cases (sub_find sub1 n); sp.
    rename_last sn1.
    cases (sub_find sub2 n); sp.
    rename_last sn2.
    apply sub_find_none2 in sn1.
    apply sub_find_some in sn2.
    apply in_dom_sub in sn2.
    generalize (hyp2 n); sp.
    allrw not_over_or; sp.

  - Case "oterm".
    apply oterm_eq; sp.
    apply eq_maps; introv i.
    destruct x; simpl.
    apply bterm_eq; sp.
    rw @sub_filter_app.
    apply ind with (lv := l); try (complete sp).

    + rw disjoint_flat_map_l in disj3.
      generalize (disj3 (bterm l n)); intro k; dest_imp k hyp.
      simpl in k.
      rw disjoint_app_l in k; repnd.
      unfold disjoint in k.
      unfold disjoint; introv j.
      apply k in j; intro x.
      allrw lin_flat_map; exrepnd.
      apply j; exists x0; sp.
      allrw @in_range_iff; exrepnd.
      allrw @in_sub_filter; repnd.
      exists v.
      rw in_app_iff; sp.

    + rw disjoint_flat_map_l in disj3.
      generalize (disj3 (bterm l n)); intro k; dest_imp k hyp.
      simpl in k.
      rw disjoint_app_l in k; repnd.
      unfold disjoint in k.
      unfold disjoint; introv j.
      apply k in j; intro x.
      allrw lin_flat_map; exrepnd.
      apply j; exists x0; sp.
      allrw @in_range_iff; exrepnd.
      allrw @in_sub_filter; repnd.
      exists v.
      rw in_app_iff; sp.

    + introv j.
      apply in_sub_filter in j; repnd.
      generalize (hyp1 v u); sp.

    + introv j k.
      rw <- @dom_sub_sub_filter in j.
      rw in_remove_nvars in j; repnd.
      rw <- @dom_sub_sub_filter in k.
      rw in_remove_nvars in k.
      generalize (hyp2 v); intro imp.
      intro x.
      repeat (dest_imp imp hyp).
      apply imp.
      rw lin_flat_map.
      exists (bterm l n); simpl; sp.
      rw in_remove_nvars; sp.

    + rw disjoint_flat_map_l in disj3.
      generalize (disj3 (bterm l n)); intro k; dest_imp k hyp.
      simpl in k.
      rw disjoint_app_l in k; repnd.
      unfold disjoint in k.
      unfold disjoint; introv j.
      apply k in j; intro x.
      allrw lin_flat_map; exrepnd.
      apply j; exists x0; sp.
      allrw @in_range_iff; exrepnd.
      allrw in_app_iff.
      allrw @in_sub_filter.
      exists v.
      rw in_app_iff; sp.
Qed.

Lemma lsubstc3_lsubstc_var1 {o} :
  forall cp ca cb (C : @NTerm o) p a b wC s cvC vp va w c,
    !LIn vp (bound_vars C)
    -> !LIn va (bound_vars C)
    -> ((!LIn vp [cp,ca,cb]) -> !LIn vp (free_vars C))
    -> ((!LIn va [cp,ca,cb]) -> !LIn va (free_vars C))
    -> !LIn vp (dom_csub s)
    -> !LIn va (dom_csub s)
    -> !(va = vp)
    -> lsubstc3 cp p ca a cb b
                (lsubstc_vars C wC (csub_filter s [cp, ca, cb]) [cp, ca, cb] cvC)
       = lsubstc (lsubst C [(cp, mk_var vp), (ca, mk_var va), (cb, get_cterm b)]) w
                 (snoc (snoc s (vp, p)) (va, a)) c.
Proof.
  introv h1 h2 h3 h4 h5 h6 h7.

  apply cterm_eq; simpl.
  unfold csubst; simpl.

  repeat (rw @simple_lsubst_lsubst; simpl);
    try (complete (sp; allapply @in_csub2sub; sp; allunfold @isprogram; sp; allrw; sp));
    try (complete (sp; cpx; simpl; try (rw disjoint_singleton_l; sp); rw @free_vars_cterm; sp)).

  rw <- @sub_filter_csub2sub.
  rw <- @sub_filter_lsubst_sub; simpl.

  rw @lsubst_sub_trivial_closed1;
    try (complete (simpl; sp; cpx; allapply @in_csub2sub; sp)).

  generalize (lsubst_shift C
                           (sub_filter (csub2sub s) [cp, ca, cb])
                           [(cp, get_cterm p), (ca, get_cterm a), (cb, get_cterm b)]
                           []).
  intro eq.

  dest_imp eq hyp.
  simpl; introv i; allrw in_app_iff; allsimpl; sp; cpx;
  allrw @in_sub_filter; sp; allapply @in_csub2sub; sp.

  dest_imp eq hyp.
  simpl; rw <- @dom_sub_sub_filter; unfold disjoint; introv i;
  allrw in_remove_nvars; sp.

  allrw app_nil_r.
  rw eq; clear eq; simpl.

  assert (get_cterm p
          = lsubst (mk_var vp) (csub2sub (snoc (snoc s (vp, p)) (va, a))))
         as eq1.
  (* begin proof of assert *)
  repeat (rw @csub2sub_snoc).
  change_to_lsubst_aux4; simpl; sp.
  repeat (rw @sub_find_snoc).
  boolvar.
  assert (!LIn vp (dom_sub (csub2sub s))) as nivp by (rw @dom_csub_eq; sp).
  rw <- @sub_find_none_iff in nivp; rw nivp; sp.
  assert (!LIn vp (dom_sub (csub2sub s))) as nivp by (rw @dom_csub_eq; sp).
  rw <- @sub_find_none_iff in nivp; rw nivp; sp.
  (* end proof of assert *)

  rw <- eq1; clear eq1.

  assert (get_cterm a
          = lsubst (mk_var va) (csub2sub (snoc (snoc s (vp, p)) (va, a))))
         as eq2.
  (* begin proof of assert *)
  rw @csub2sub_snoc.
  change_to_lsubst_aux4; simpl; sp.
  rw @sub_find_snoc.
  boolvar.
  assert (!LIn va (dom_sub (csub2sub (snoc s (vp, p)))))
         as niva
         by (rw @dom_csub_eq; rw @dom_csub_snoc; simpl; rw in_snoc; sp).
  rw <- @sub_find_none_iff in niva; rw niva; sp.
  (* end proof of assert *)

  rw <- eq2; clear eq2.

  rw @lsubst_cterm.
  repeat (rw @csub2sub_snoc).

  assert (forall T (l : list T) x y z, x :: y :: z :: l = [x,y,z] ++ l) as eqc by sp.

  rw eqc.
  rw <- @lsubst_aux_app_sub_filter;
    try (complete (sp; unfold prog_sub, sub_range_sat; simpl; sp; cpx)).
  rw <- @simple_lsubst_app; try (complete (simpl; sp; allapply @in_csub2sub; cpx)).

  symmetry.
  rw eqc.
  rw <- @simple_lsubst_app;
    try (complete (simpl; sp; allrw in_snoc; sp; allapply @in_csub2sub; cpx)).

  generalize (lsubst_sub_filter
                (lsubst C [(cp, get_cterm p), (ca, get_cterm a), (cb, get_cterm b)])
                (snoc (snoc (csub2sub s) (vp, get_cterm p)) (va, get_cterm a))
                [vp, va]); intro eq.
  dest_imp eq hyp;
    try (complete (intros; allrw in_snoc; sp; cpx; allapply @in_csub2sub; sp)).
  dest_imp eq hyp.
  generalize (eqvars_free_vars_disjoint C [(cp, get_cterm p), (ca, get_cterm a), (cb, get_cterm b)]);
    introv eqv.
  apply eqvars_sym in eqv.
  apply eqvars_disjoint with (s3 := [vp,va]) in eqv; sp.
  simpl; boolvar; simpl; repeat (rw @free_vars_cterm); simpl; allrw app_nil_r;
  apply disjoint_sym; unfold disjoint; intros v i k; simpl in i; repdors; subst;
  try (destruct (eq_var_dec vp v)); try (destruct (eq_var_dec va v)); try (complete sp);
  allrw in_remove_nvars; repnd; allrw in_single_iff; try (complete sp).

  rw <- eq.
  repeat (rw @sub_filter_snoc); boolvar; subst; sp; try (complete (allrw not_over_or; sp)).
  GC; clear eq.

  apply lsubst_sub_filter;
    try (complete (intros; allrw in_snoc; sp; cpx; allapply @in_csub2sub; sp)).

  generalize (eqvars_free_vars_disjoint C [(cp, get_cterm p), (ca, get_cterm a), (cb, get_cterm b)]);
    introv eqv.
  apply eqvars_sym in eqv.
  apply eqvars_disjoint with (s3 := [vp,va]) in eqv; sp.
  simpl; boolvar; simpl; repeat (rw @free_vars_cterm); simpl; allrw app_nil_r;
  apply disjoint_sym; unfold disjoint; intros v i k; simpl in i; repdors; subst;
  try (destruct (eq_var_dec vp v)); try (destruct (eq_var_dec va v)); try (complete sp);
  allrw in_remove_nvars; repnd; allrw in_single_iff; try (complete sp).
Qed.

Lemma csubst_subst_pw_Q {o} :
  forall (Q : @NTerm o) w f b t,
    !LIn b (bound_vars Q)
    -> !LIn f (bound_vars Q)
    -> !b = f
    -> !b = w
    -> !LIn b (free_vars Q)
    -> csubst (subst Q w (mk_apply (mk_var f) (mk_var b))) [(b, t)]
       = subst Q w (mk_apply (mk_var f) (get_cterm t)).
Proof.
  introv bc1 bc2 bc3 bc4 bc5.
  generalize (simple_lsubst_lsubst
                Q [(w, mk_apply (mk_var f) (mk_var b))] [(b, get_cterm t)]);
    introv eq.
  repeat (dest_imp eq hyp);
    try (complete (simpl; introv k; sp; cpx; simpl; repeat (rw disjoint_cons_l); sp)).

  unfold subst, csubst; simpl.
  rw eq; clear eq; simpl.

  rw @fold_csubst1.
  rw @csubst_mk_apply; simpl.
  rw (@csubst_var_not_in o f); simpl; sp.
  rw @csubst_mk_var_in.
  generalize (lsubst_sub_filter2
                Q [(w, mk_apply (mk_var f) (get_cterm t)), (b, get_cterm t)] [b]);
    intro e.
  repeat (dest_imp e hyp);
    try (complete (rw disjoint_singleton_r; sp));
    try (complete (unfold disjoint_bv_sub, sub_range_sat; simpl; sp; cpx; simpl;
                   allrw @free_vars_cterm; simpl;
                   try (rw disjoint_singleton_l); try (rw disjoint_singleton_r); sp)).
  simpl in e.
  rw <- e; clear e.

  boolvar; sp; allrw not_over_or; sp.
Qed.

Lemma lsubstc_snoc_snoc {o} :
  forall (t : @NTerm o) s v1 v2 t1 t2 w c,
    !LIn v1 (free_vars t)
    -> {c' : cover_vars t (snoc s (v2, t2))
        , lsubstc t w (snoc (snoc s (v1, t1)) (v2, t2)) c
          = lsubstc t w (snoc s (v2, t2)) c'}.
Proof.
  introv ni.
  assert (cover_vars t (snoc s (v2, t2)))
         as c'
         by (allrw @cover_vars_eq;
             allrw subvars_prop; introv i;
             applydup c in i as j; splst in j; splst; sp; subst; sp).
  exists c'.
  revert c.
  rw snoc_as_append; introv.
  generalize (lsubstc_csubst_ex2 t (snoc s (v1, t1)) [(v2, t2)] w c); intro eq; exrepnd.
  rw <- eq1; clear eq1.
  revert w' p'.
  lsubst_tac; introv.
  assert (cover_vars t (s ++ [(v2, t2)])) as c'' by (rw <- snoc_as_append; sp).
  generalize (lsubstc_csubst_ex2 t s [(v2, t2)] w c''); intro eq; exrepnd; proof_irr.
  rw eq1; clear eq1.
  revert c''.
  rw <- snoc_as_append; introv; proof_irr; sp.
Qed.


Require Import Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Parsers.Reflective.ParserSyntax.
Require Import Fiat.Parsers.Reflective.ParserSemanticsOptimized.
Require Import Fiat.Parsers.Reflective.ParserSoundness.
Require Import Fiat.Parsers.Reflective.PartialUnfold.
Require Import Fiat.Parsers.Reflective.ParserPartialUnfold.
Set Implicit Arguments.

Module opt.
  Section polypnormalize.
    Context (is_valid_nonterminal : list nat -> nat -> bool)
            (strlen : nat)
            (char_at_matches_interp : nat -> Reflective.RCharExpr Ascii.ascii -> bool)
            (split_string_for_production : nat * (nat * nat) -> nat -> nat -> list nat).

    Let interp {T} := opt.interp_has_parse_term (T := T) is_valid_nonterminal strlen char_at_matches_interp split_string_for_production.

    Lemma polypnormalize_correct {T} (term : polyhas_parse_term T)
      : ParserSyntaxEquivalence.has_parse_term_equiv
          nil
          (term interp_TypeCode) (term (normalized_of interp_TypeCode))
        -> interp (term _) = interp (polypnormalize term _).
    Proof.
      apply polypnormalize_correct; assumption.
    Qed.
  End polypnormalize.
End opt.


Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Platform.Cito.Semantics.
  Require Import Platform.Cito.SemanticsUtil.
  Require Import Coq.Lists.List.

  Notation make_triples := (@make_triples ADTValue).

  Require Import Platform.Cito.GeneralTactics4.

  Lemma split_triples : forall triples words_cinput coutput, words_cinput = List.map (fun x => (Word x, ADTIn x)) triples -> coutput = List.map (@ADTOut _) triples -> triples = make_triples words_cinput coutput.
  Proof.
    induction triples; destruct words_cinput; destruct coutput; simpl in *; intros; try discriminate.
    eauto.
    destruct a; inject H; inject H0.
    f_equal; eauto.
  Qed.

  Lemma split_triples' : forall triples words cinput coutput, words = List.map (@Word _) triples -> cinput = List.map (@ADTIn _) triples -> coutput = List.map (@ADTOut _) triples -> triples = make_triples (combine words cinput) coutput.
  Proof.
    induction triples; destruct words; destruct cinput; destruct coutput; simpl in *; intros; try discriminate.
    eauto.
    destruct a; inject H; inject H0; inject H1.
    f_equal; eauto.
  Qed.

  Lemma nth_error_make_triples_intro words_cinput : forall coutput i p a a', nth_error words_cinput i = Some (p, a) -> nth_error coutput i = Some a' -> nth_error (make_triples words_cinput coutput) i = Some {| Word := p; ADTIn := a; ADTOut := a'|}.
  Proof.
    induction words_cinput; destruct coutput; destruct i; simpl in *; intros; try discriminate.
    destruct a; inject H; inject H0; eauto.
    eauto.
  Qed.

  Lemma nth_error_make_triples_elim wis : forall os i p a a', nth_error (make_triples wis os) i = Some {| Word := p; ADTIn := a; ADTOut := a' |} -> nth_error wis i = Some (p, a) /\ nth_error os i = Some a'.
  Proof.
    induction wis; destruct os; destruct i; simpl in *; intros; try discriminate.
    destruct a; inject H; eauto.
    eauto.
  Qed.

  Arguments store_out {_} _ _.
  Arguments ADTOut {_} _.

  Lemma make_triples_Word_ADTIn : forall pairs outs, length outs = length pairs -> List.map (fun x => (Word x, ADTIn x)) (make_triples pairs outs) = pairs.
    induction pairs; destruct outs; simpl; intuition.
    f_equal; auto.
  Qed.

  Lemma make_triples_ADTOut : forall pairs outs, length outs = length pairs -> List.map ADTOut (make_triples pairs outs) = outs.
    induction pairs; destruct outs; simpl; intuition.
    f_equal; auto.
  Qed.

  Require Import Platform.Cito.SemanticsFacts6.
  Require Import Platform.Cito.ListFacts4.

  Lemma make_triples_ADTIn_ADTOut : forall pairs outs, length outs = length pairs -> List.map (fun x => (ADTIn x, ADTOut x)) (@make_triples pairs outs) = List.combine (List.map snd pairs) outs.
  Proof.
    intros.
    erewrite <- combine_map.
    rewrite make_triples_ADTIn by eauto.
    rewrite make_triples_ADTOut by eauto.
    eauto.
  Qed.

End ADTValue.


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

Parameter div2 : nat -> nat.
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 p)) => (S (log (div2 x)))
     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).

 *)


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris                                  *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Assertions on memory states, in the style of separation logic *)

(** This library defines a number of useful logical assertions about
  CompCert memory states, such as "block [b] at offset [ofs] contains
  value [v]".  Assertions can be grouped using a separating conjunction
  operator in the style of separation logic.

  Currently, this library is used only in module [Stackingproof]
  to reason about the shapes of stack frames generated during the
  [Stacking] pass.

  This is not a full-fledged separation logic because there is no
  program logic (Hoare triples) to speak of.  Also, there is no general
  frame rule; instead, a weak form of the frame rule is provided
  by the lemmas that help us reason about the logical assertions. *)

Require Import Setoid Program.Basics.
Require Import compcert.lib.Coqlib ccc26x86.Decidableplus.
Require Import compcert.common.AST compcert.lib.Integers compcert.common.Values compcert.common.Memory compcert.common.Events compcert.common.Globalenvs.

(** * Assertions about memory *)

(** An assertion is composed of:
- a predicate over memory states (of type [mem -> Prop])
- a set of (block, offset) memory locations that represents the memory footprint of the assertion
- a proof that the predicate is invariant by changes of memory outside of the footprint
- a proof that the footprint contains only valid memory blocks.

This presentation (where the footprint is part of the assertion) makes
it possible to define separating conjunction without explicitly
defining a separation algebra over CompCert memory states (i.e. the
notion of splitting a memory state into two disjoint halves).  *)

Record massert : Type := {
  m_pred : mem -> Prop;
  m_footprint: block -> Z -> Prop;
  m_invar: forall m m', m_pred m -> Mem.unchanged_on m_footprint m m' -> m_pred m';
  m_valid: forall m b ofs, m_pred m -> m_footprint b ofs -> Mem.valid_block m b
}.

Notation "m |= p" := (m_pred p m) (at level 74, no associativity) : sep_scope.

(** Implication and logical equivalence between memory predicates *)

Definition massert_imp (P Q: massert) : Prop :=
  (forall m, m_pred P m -> m_pred Q m) /\ (forall b ofs, m_footprint Q b ofs -> m_footprint P b ofs).
Definition massert_eqv (P Q: massert) : Prop :=
  massert_imp P Q /\ massert_imp Q P.

Remark massert_imp_refl: forall p, massert_imp p p.
Proof.
  unfold massert_imp; auto.
Qed.

Remark massert_imp_trans: forall p q r, massert_imp p q -> massert_imp q r -> massert_imp p r.
Proof.
  unfold massert_imp; intros; firstorder auto.
Qed.

Remark massert_eqv_refl: forall p, massert_eqv p p.
Proof.
  unfold massert_eqv, massert_imp; intros. tauto.
Qed.

Remark massert_eqv_sym: forall p q, massert_eqv p q -> massert_eqv q p.
Proof.
  unfold massert_eqv, massert_imp; intros. tauto.
Qed.

Remark massert_eqv_trans: forall p q r, massert_eqv p q -> massert_eqv q r -> massert_eqv p r.
Proof.
  unfold massert_eqv, massert_imp; intros. firstorder auto.
Qed.

(** Record [massert_eqv] and [massert_imp] as relations so that they can be used by rewriting tactics. *)
Add Relation massert massert_imp
  reflexivity proved by massert_imp_refl
  transitivity proved by massert_imp_trans
as massert_imp_prel.

Add Relation massert massert_eqv
  reflexivity proved by massert_eqv_refl
  symmetry proved by massert_eqv_sym
  transitivity proved by massert_eqv_trans
as massert_eqv_prel.

Add Morphism m_pred
  with signature massert_imp ==> eq ==> impl
  as m_pred_morph_1.
Proof.
  intros P Q [A B]. auto.
Qed.

Add Morphism m_pred
  with signature massert_eqv ==> eq ==> iff
  as m_pred_morph_2.
Proof.
  intros P Q [[A B] [C D]]. split; auto.
Qed.

Hint Resolve massert_imp_refl massert_eqv_refl.

(** * Separating conjunction *)

Definition disjoint_footprint (P Q: massert) : Prop :=
  forall b ofs, m_footprint P b ofs -> m_footprint Q b ofs -> False.

Program Definition sepconj (P Q: massert) : massert := {|
  m_pred := fun m => m_pred P m /\ m_pred Q m /\ disjoint_footprint P Q;
  m_footprint := fun b ofs => m_footprint P b ofs \/ m_footprint Q b ofs
|}.
Next Obligation.
  repeat split; auto.
  apply (m_invar P) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
  apply (m_invar Q) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
Qed.
Next Obligation.
  destruct H0; [eapply (m_valid P) | eapply (m_valid Q)]; eauto.
Qed.

Add Morphism sepconj
  with signature massert_imp ==> massert_imp ==> massert_imp
  as sepconj_morph_1.
Proof.
  intros P1 P2 [A B] Q1 Q2 [C D].
  red; simpl; split; intros.
- intuition auto. red; intros. apply (H2 b ofs); auto.
- intuition auto.
Qed.

Add Morphism sepconj
  with signature massert_eqv ==> massert_eqv ==> massert_eqv
  as sepconj_morph_2.
Proof.
  intros. destruct H, H0. split; apply sepconj_morph_1; auto.
Qed.

Infix "**" := sepconj (at level 60, right associativity) : sep_scope.

Local Open Scope sep_scope.

Lemma sep_imp:
  forall P P' Q Q' m,
  m |= P ** Q -> massert_imp P P' -> massert_imp Q Q' -> m |= P' ** Q'.
Proof.
  intros. rewrite <- H0, <- H1; auto.
Qed.

Lemma sep_comm_1:
  forall P Q,  massert_imp (P ** Q) (Q ** P).
Proof.
  unfold massert_imp; simpl; split; intros.
- intuition auto. red; intros; eapply H2; eauto.
- intuition auto.
Qed.

Lemma sep_comm:
  forall P Q, massert_eqv (P ** Q) (Q ** P).
Proof.
  intros; split; apply sep_comm_1.
Qed.

Lemma sep_assoc_1:
  forall P Q R, massert_imp ((P ** Q) ** R) (P ** (Q ** R)).
Proof.
  intros. unfold massert_imp, sepconj, disjoint_footprint; simpl; firstorder auto.
Qed.

Lemma sep_assoc_2:
  forall P Q R, massert_imp (P ** (Q ** R)) ((P ** Q) ** R).
Proof.
  intros. unfold massert_imp, sepconj, disjoint_footprint; simpl; firstorder auto.
Qed.

Lemma sep_assoc:
  forall P Q R, massert_eqv ((P ** Q) ** R) (P ** (Q ** R)).
Proof.
  intros; split. apply sep_assoc_1. apply sep_assoc_2.
Qed.

Lemma sep_swap:
  forall P Q R, massert_eqv (P ** Q ** R) (Q ** P ** R).
Proof.
  intros. rewrite <- sep_assoc. rewrite (sep_comm P). rewrite sep_assoc. reflexivity.
Qed.

Definition sep_swap12 := sep_swap.

Lemma sep_swap23:
  forall P Q R S, massert_eqv (P ** Q ** R ** S) (P ** R ** Q ** S).
Proof.
  intros. rewrite (sep_swap Q). reflexivity.
Qed.

Lemma sep_swap34:
  forall P Q R S T, massert_eqv (P ** Q ** R ** S ** T) (P ** Q ** S ** R ** T).
Proof.
  intros. rewrite (sep_swap R). reflexivity.
Qed.

Lemma sep_swap45:
  forall P Q R S T U, massert_eqv (P ** Q ** R ** S ** T ** U) (P ** Q ** R ** T ** S ** U).
Proof.
  intros. rewrite (sep_swap S). reflexivity.
Qed.

Definition sep_swap2 := sep_swap.

Lemma sep_swap3:
  forall P Q R S, massert_eqv (P ** Q ** R ** S) (R ** Q ** P ** S).
Proof.
  intros. rewrite sep_swap. rewrite (sep_swap P). rewrite sep_swap. reflexivity.
Qed.

Lemma sep_swap4:
  forall P Q R S T, massert_eqv (P ** Q ** R ** S ** T) (S ** Q ** R ** P ** T).
Proof.
  intros. rewrite sep_swap. rewrite (sep_swap3 P). rewrite sep_swap. reflexivity.
Qed.

Lemma sep_swap5:
  forall P Q R S T U, massert_eqv (P ** Q ** R ** S ** T ** U) (T ** Q ** R ** S ** P ** U).
Proof.
  intros. rewrite sep_swap. rewrite (sep_swap4 P). rewrite sep_swap. reflexivity.
Qed.

Lemma sep_drop:
  forall P Q m, m |= P ** Q -> m |= Q.
Proof.
  simpl; intros. tauto.
Qed.

Lemma sep_drop2:
  forall P Q R m, m |= P ** Q ** R -> m |= P ** R.
Proof.
  intros. rewrite sep_swap in H. eapply sep_drop; eauto.
Qed.

Lemma sep_proj1:
  forall Q P m, m |= P ** Q -> m |= P.
Proof.
  intros. destruct H; auto.
Qed.

Lemma sep_proj2:
  forall P Q m, m |= P ** Q -> m |= Q.
Proof sep_drop.

Definition sep_pick1 := sep_proj1.

Lemma sep_pick2:
  forall P Q R m, m |= P ** Q ** R -> m |= Q.
Proof.
  intros. eapply sep_proj1; eapply sep_proj2; eauto.
Qed.

Lemma sep_pick3:
  forall P Q R S m, m |= P ** Q ** R ** S -> m |= R.
Proof.
  intros. eapply sep_pick2; eapply sep_proj2; eauto.
Qed.

Lemma sep_pick4:
  forall P Q R S T m, m |= P ** Q ** R ** S ** T -> m |= S.
Proof.
  intros. eapply sep_pick3; eapply sep_proj2; eauto.
Qed.

Lemma sep_pick5:
  forall P Q R S T U m, m |= P ** Q ** R ** S ** T ** U -> m |= T.
Proof.
  intros. eapply sep_pick4; eapply sep_proj2; eauto.
Qed.

Lemma sep_preserved:
  forall m m' P Q,
  m |= P ** Q ->
  (m |= P -> m' |= P) ->
  (m |= Q -> m' |= Q) ->
  m' |= P ** Q.
Proof.
  simpl; intros. intuition auto.
Qed.

(** * Basic memory assertions. *)

(** Pure logical assertion *)

Program Definition pure (P: Prop) : massert := {|
  m_pred := fun m => P;
  m_footprint := fun b ofs => False
|}.
Next Obligation.
  tauto.
Qed.

Lemma sep_pure:
  forall P Q m, m |= pure P ** Q <-> P /\ m |= Q.
Proof.
  simpl; intros. intuition auto. red; simpl; tauto.
Qed.

(** A range of bytes, with full permissions and unspecified contents. *)

Program Definition range (b: block) (lo hi: Z) : massert := {|
  m_pred := fun m =>
       0 <= lo /\ hi <= Int.modulus
    /\ (forall i k p, lo <= i < hi -> Mem.perm m b i k p);
  m_footprint := fun b' ofs' => b' = b /\ lo <= ofs' < hi
|}.
Next Obligation.
  split; auto. split; auto. intros. eapply Mem.perm_unchanged_on; eauto. simpl; auto.
Qed.
Next Obligation.
  apply Mem.perm_valid_block with ofs Cur Freeable; auto.
Qed.

Lemma alloc_rule:
  forall m lo hi b m' P,
  Mem.alloc m lo hi = (m', b) ->
  0 <= lo -> hi <= Int.modulus ->
  m |= P ->
  m' |= range b lo hi ** P.
Proof.
  intros; simpl. split; [|split].
- split; auto. split; auto. intros.
  apply Mem.perm_implies with Freeable; auto with mem.
  eapply Mem.perm_alloc_2; eauto.
- apply (m_invar P) with m; auto. eapply Mem.alloc_unchanged_on; eauto.
- red; simpl. intros. destruct H3; subst b0.
  eelim Mem.fresh_block_alloc; eauto. eapply (m_valid P); eauto.
Qed.

Lemma range_split:
  forall b lo hi P mid m,
  lo <= mid <= hi ->
  m |= range b lo hi ** P ->
  m |= range b lo mid ** range b mid hi ** P.
Proof.
  intros. rewrite <- sep_assoc. eapply sep_imp; eauto.
  split; simpl; intros.
- intuition auto.
+ omega.
+ apply H5; omega.
+ omega.
+ apply H5; omega.
+ red; simpl; intros; omega.
- intuition omega.
Qed.

Lemma range_drop_left:
  forall b lo hi P mid m,
  lo <= mid <= hi ->
  m |= range b lo hi ** P ->
  m |= range b mid hi ** P.
Proof.
  intros. apply sep_drop with (range b lo mid). apply range_split; auto.
Qed.

Lemma range_drop_right:
  forall b lo hi P mid m,
  lo <= mid <= hi ->
  m |= range b lo hi ** P ->
  m |= range b lo mid ** P.
Proof.
  intros. apply sep_drop2 with (range b mid hi). apply range_split; auto.
Qed.

Lemma range_split_2:
  forall b lo hi P mid al m,
  lo <= align mid al <= hi ->
  al > 0 ->
  m |= range b lo hi ** P ->
  m |= range b lo mid ** range b (align mid al) hi ** P.
Proof.
  intros. rewrite <- sep_assoc. eapply sep_imp; eauto.
  assert (mid <= align mid al) by (apply align_le; auto).
  split; simpl; intros.
- intuition auto.
+ omega.
+ apply H7; omega.
+ omega.
+ apply H7; omega.
+ red; simpl; intros; omega.
- intuition omega.
Qed.

Lemma range_preserved:
  forall m m' b lo hi,
  m |= range b lo hi ->
  (forall i k p, lo <= i < hi -> Mem.perm m b i k p -> Mem.perm m' b i k p) ->
  m' |= range b lo hi.
Proof.
  intros. destruct H as (A & B & C). simpl; intuition auto.
Qed.

(** A memory area that contains a value sastifying a given predicate *)

Program Definition contains (chunk: memory_chunk) (b: block) (ofs: Z) (spec: val -> Prop) : massert := {|
  m_pred := fun m =>
       0 <= ofs <= Int.max_unsigned
    /\ Mem.valid_access m chunk b ofs Freeable
    /\ exists v, Mem.load chunk m b ofs = Some v /\ spec v;
  m_footprint := fun b' ofs' => b' = b /\ ofs <= ofs' < ofs + size_chunk chunk
|}.
Next Obligation.
  rename H2 into v. split;[|split].
- auto.
- destruct H1; split; auto. red; intros; eapply Mem.perm_unchanged_on; eauto. simpl; auto.
- exists v. split; auto. eapply Mem.load_unchanged_on; eauto. simpl; auto.
Qed.
Next Obligation.
  eauto with mem.
Qed.

Lemma contains_no_overflow:
  forall spec m chunk b ofs,
  m |= contains chunk b ofs spec ->
  0 <= ofs <= Int.max_unsigned.
Proof.
  intros. simpl in H. tauto.
Qed.

Lemma load_rule:
  forall spec m chunk b ofs,
  m |= contains chunk b ofs spec ->
  exists v, Mem.load chunk m b ofs = Some v /\ spec v.
Proof.
  intros. destruct H as (D & E & v & F & G).
  exists v; auto.
Qed.

Lemma loadv_rule:
  forall spec m chunk b ofs,
  m |= contains chunk b ofs spec ->
  exists v, Mem.loadv chunk m (Vptr b (Int.repr ofs)) = Some v /\ spec v.
Proof.
  intros. exploit load_rule; eauto. intros (v & A & B). exists v; split; auto.
  simpl. rewrite Int.unsigned_repr; auto. eapply contains_no_overflow; eauto.
Qed.

Lemma store_rule:
  forall chunk m b ofs v (spec1 spec: val -> Prop) P,
  m |= contains chunk b ofs spec1 ** P ->
  spec (Val.load_result chunk v) ->
  exists m',
  Mem.store chunk m b ofs v = Some m' /\ m' |= contains chunk b ofs spec ** P.
Proof.
  intros. destruct H as (A & B & C). destruct A as (D & E & v0 & F & G).
  assert (H: Mem.valid_access m chunk b ofs Writable) by eauto with mem.
  destruct (Mem.valid_access_store _ _ _ _ v H) as [m' STORE].
  exists m'; split; auto. simpl. intuition auto.
- eapply Mem.store_valid_access_1; eauto.
- exists (Val.load_result chunk v); split; auto. eapply Mem.load_store_same; eauto.
- apply (m_invar P) with m; auto.
  eapply Mem.store_unchanged_on; eauto.
  intros; red; intros. apply (C b i); simpl; auto.
Qed.

Lemma storev_rule:
  forall chunk m b ofs v (spec1 spec: val -> Prop) P,
  m |= contains chunk b ofs spec1 ** P ->
  spec (Val.load_result chunk v) ->
  exists m',
  Mem.storev chunk m (Vptr b (Int.repr ofs)) v = Some m' /\ m' |= contains chunk b ofs spec ** P.
Proof.
  intros. exploit store_rule; eauto. intros (m' & A & B). exists m'; split; auto.
  simpl. rewrite Int.unsigned_repr; auto. eapply contains_no_overflow. eapply sep_pick1; eauto.
Qed.

Lemma range_contains:
  forall chunk b ofs P m,
  m |= range b ofs (ofs + size_chunk chunk) ** P ->
  (align_chunk chunk | ofs) ->
  m |= contains chunk b ofs (fun v => True) ** P.
Proof.
  intros. destruct H as (A & B & C). destruct A as (D & E & F).
  split; [|split].
- assert (Mem.valid_access m chunk b ofs Freeable).
  { split; auto. red; auto. }
  split. generalize (size_chunk_pos chunk). unfold Int.max_unsigned. omega.
  split. auto.
+ destruct (Mem.valid_access_load m chunk b ofs) as [v LOAD].
  eauto with mem.
  exists v; auto.
- auto.
- auto.
Qed.

Lemma contains_imp:
  forall (spec1 spec2: val -> Prop) chunk b ofs,
  (forall v, spec1 v -> spec2 v) ->
  massert_imp (contains chunk b ofs spec1) (contains chunk b ofs spec2).
Proof.
  intros; split; simpl; intros.
- intuition auto. destruct H4 as (v & A & B). exists v; auto.
- auto.
Qed.

(** A memory area that contains a given value *)

Definition hasvalue (chunk: memory_chunk) (b: block) (ofs: Z) (v: val) : massert :=
  contains chunk b ofs (fun v' => v' = v).

Lemma store_rule':
  forall chunk m b ofs v (spec1: val -> Prop) P,
  m |= contains chunk b ofs spec1 ** P ->
  exists m',
  Mem.store chunk m b ofs v = Some m' /\ m' |= hasvalue chunk b ofs (Val.load_result chunk v) ** P.
Proof.
  intros. eapply store_rule; eauto.
Qed.

Lemma storev_rule':
  forall chunk m b ofs v (spec1: val -> Prop) P,
  m |= contains chunk b ofs spec1 ** P ->
  exists m',
  Mem.storev chunk m (Vptr b (Int.repr ofs)) v = Some m' /\ m' |= hasvalue chunk b ofs (Val.load_result chunk v) ** P.
Proof.
  intros. eapply storev_rule; eauto.
Qed.

(** Non-separating conjunction *)

Program Definition mconj (P Q: massert) : massert := {|
  m_pred := fun m => m_pred P m /\ m_pred Q m;
  m_footprint := fun b ofs => m_footprint P b ofs \/ m_footprint Q b ofs
|}.
Next Obligation.
  split.
  apply (m_invar P) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
  apply (m_invar Q) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
Qed.
Next Obligation.
  destruct H0; [eapply (m_valid P) | eapply (m_valid Q)]; eauto.
Qed.

Lemma mconj_intro:
  forall P Q R m,
  m |= P ** R -> m |= Q ** R -> m |= mconj P Q ** R.
Proof.
  intros. destruct H as (A & B & C). destruct H0 as (D & E & F).
  split; [|split].
- simpl; auto.
- auto.
- red; simpl; intros. destruct H; [eelim C | eelim F]; eauto.
Qed.

Lemma mconj_proj1:
  forall P Q R m, m |= mconj P Q ** R -> m |= P ** R.
Proof.
  intros. destruct H as (A & B & C); simpl in A.
  simpl. intuition auto.
  red; intros; eapply C; eauto; simpl; auto.
Qed.

Lemma mconj_proj2:
  forall P Q R m, m |= mconj P Q ** R -> m |= Q ** R.
Proof.
  intros. destruct H as (A & B & C); simpl in A.
  simpl. intuition auto.
  red; intros; eapply C; eauto; simpl; auto.
Qed.

Lemma frame_mconj:
  forall P P' Q R m m',
  m |= mconj P Q ** R ->
  m' |= P' ** R ->
  m' |= Q ->
  m' |= mconj P' Q ** R.
Proof.
  intros. destruct H as (A & B & C); simpl in A.
  destruct H0 as (D & E & F).
  simpl. intuition auto.
  red; simpl; intros. destruct H2. eapply F; eauto. eapply C; simpl; eauto.
Qed.

Add Morphism mconj
  with signature massert_imp ==> massert_imp ==> massert_imp
  as mconj_morph_1.
Proof.
  intros P1 P2 [A B] Q1 Q2 [C D].
  red; simpl; intuition auto.
Qed.

Add Morphism mconj
  with signature massert_eqv ==> massert_eqv ==> massert_eqv
  as mconj_morph_2.
Proof.
  intros. destruct H, H0. split; apply mconj_morph_1; auto.
Qed.

(** The image of a memory injection *)

Program Definition minjection (j: meminj) (m0: mem) : massert := {|
  m_pred := fun m => Mem.inject j m0 m;
  m_footprint := fun b ofs => exists b0 delta, j b0 = Some(b, delta) /\ Mem.perm m0 b0 (ofs - delta) Max Nonempty
|}.
Next Obligation.
  set (img := fun b' ofs => exists b delta, j b = Some(b', delta) /\ Mem.perm m0 b (ofs - delta) Max Nonempty) in *.
  assert (IMG: forall b1 b2 delta ofs k p,
           j b1 = Some (b2, delta) -> Mem.perm m0 b1 ofs k p -> img b2 (ofs + delta)).
  { intros. red. exists b1, delta; split; auto.
    replace (ofs + delta - delta) with ofs by omega.
    eauto with mem. }
  destruct H. constructor.
- destruct mi_inj. constructor; intros.
+ eapply Mem.perm_unchanged_on; eauto.
+ eauto.
+ rewrite (Mem.unchanged_on_contents _ _ _ H0); eauto.
- assumption.
- intros. eapply Mem.valid_block_unchanged_on; eauto.
- assumption.
- assumption.
- intros. destruct (Mem.perm_dec m0 b1 ofs Max Nonempty); auto.
  eapply mi_perm_inv; eauto.
  eapply Mem.perm_unchanged_on_2; eauto.
Qed.
Next Obligation.
  eapply Mem.valid_block_inject_2; eauto.
Qed.

Lemma loadv_parallel_rule:
  forall j m1 m2 chunk addr1 v1 addr2,
  m2 |= minjection j m1 ->
  Mem.loadv chunk m1 addr1 = Some v1 ->
  Val.inject j addr1 addr2 ->
  exists v2, Mem.loadv chunk m2 addr2 = Some v2 /\ Val.inject j v1 v2.
Proof.
  intros. simpl in H. eapply Mem.loadv_inject; eauto.
Qed.

Lemma storev_parallel_rule:
  forall j m1 m2 P chunk addr1 v1 m1' addr2 v2,
  m2 |= minjection j m1 ** P ->
  Mem.storev chunk m1 addr1 v1 = Some m1' ->
  Val.inject j addr1 addr2 ->
  Val.inject j v1 v2 ->
  exists m2', Mem.storev chunk m2 addr2 v2 = Some m2' /\ m2' |= minjection j m1' ** P.
Proof.
  intros. destruct H as (A & B & C). simpl in A.
  exploit Mem.storev_mapped_inject; eauto. intros (m2' & STORE & INJ).
  inv H1; simpl in STORE; try discriminate.
  assert (VALID: Mem.valid_access m1 chunk b1 (Int.unsigned ofs1) Writable)
    by eauto with mem.
  assert (EQ: Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta).
  { eapply Mem.address_inject'; eauto with mem. }
  exists m2'; split; auto.
  split; [|split].
- exact INJ.
- apply (m_invar P) with m2; auto.
  eapply Mem.store_unchanged_on; eauto.
  intros; red; intros. eelim C; eauto. simpl.
  exists b1, delta; split; auto. destruct VALID as [V1 V2].
  apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem.
  apply V1. omega.
- red; simpl; intros. destruct H1 as (b0 & delta0 & U & V).
  eelim C; eauto. simpl. exists b0, delta0; eauto with mem.
Qed.

Lemma alloc_parallel_rule:
  forall m1 sz1 m1' b1 m2 sz2 m2' b2 P j lo hi delta,
  m2 |= minjection j m1 ** P ->
  Mem.alloc m1 0 sz1 = (m1', b1) ->
  Mem.alloc m2 0 sz2 = (m2', b2) ->
  (8 | delta) ->
  lo = delta ->
  hi = delta + Zmax 0 sz1 ->
  0 <= sz2 <= Int.max_unsigned ->
  0 <= delta -> hi <= sz2 ->
  exists j',
     m2' |= range b2 0 lo ** range b2 hi sz2 ** minjection j' m1' ** P
  /\ inject_incr j j'
  /\ j' b1 = Some(b2, delta)
  /\ (forall b, b <> b1 -> j' b = j b).
Proof.
  intros until delta; intros SEP ALLOC1 ALLOC2 ALIGN LO HI RANGE1 RANGE2 RANGE3.
  assert (RANGE4: lo <= hi) by xomega.
  assert (FRESH1: ~Mem.valid_block m1 b1) by (eapply Mem.fresh_block_alloc; eauto).
  assert (FRESH2: ~Mem.valid_block m2 b2) by (eapply Mem.fresh_block_alloc; eauto).
  destruct SEP as (INJ & SP & DISJ). simpl in INJ.
  exploit Mem.alloc_left_mapped_inject.
- eapply Mem.alloc_right_inject; eauto.
- eexact ALLOC1.
- instantiate (1 := b2). eauto with mem.
- instantiate (1 := delta). xomega.
- intros. assert (0 <= ofs < sz2) by (eapply Mem.perm_alloc_3; eauto). omega.
- intros. apply Mem.perm_implies with Freeable; auto with mem.
  eapply Mem.perm_alloc_2; eauto. xomega.
- red; intros. apply Zdivides_trans with 8; auto.
  exists (8 / align_chunk chunk). destruct chunk; reflexivity.
- intros. elim FRESH2. eapply Mem.valid_block_inject_2; eauto.
- intros (j' & INJ' & J1 & J2 & J3).
  exists j'; split; auto.
  rewrite <- ! sep_assoc.
  split; [|split].
+ simpl. intuition auto; try (unfold Int.max_unsigned in *; omega).
* apply Mem.perm_implies with Freeable; auto with mem.
  eapply Mem.perm_alloc_2; eauto. omega.
* apply Mem.perm_implies with Freeable; auto with mem.
  eapply Mem.perm_alloc_2; eauto. omega.
* red; simpl; intros. destruct H1, H2. omega.
* red; simpl; intros.
  assert (b = b2) by tauto. subst b.
  assert (0 <= ofs < lo \/ hi <= ofs < sz2) by tauto. clear H1.
  destruct H2 as (b0 & delta0 & D & E).
  eapply Mem.perm_alloc_inv in E; eauto.
  destruct (eq_block b0 b1).
  subst b0. rewrite J2 in D. inversion D; clear D; subst delta0. xomega.
  rewrite J3 in D by auto. elim FRESH2. eapply Mem.valid_block_inject_2; eauto.
+ apply (m_invar P) with m2; auto. eapply Mem.alloc_unchanged_on; eauto.
+ red; simpl; intros.
  assert (VALID: Mem.valid_block m2 b) by (eapply (m_valid P); eauto).
  destruct H as [A | (b0 & delta0 & A & B)].
* assert (b = b2) by tauto. subst b. contradiction.
* eelim DISJ; eauto. simpl.
  eapply Mem.perm_alloc_inv in B; eauto.
  destruct (eq_block b0 b1).
  subst b0. rewrite J2 in A. inversion A; clear A; subst b delta0. contradiction.
  rewrite J3 in A by auto. exists b0, delta0; auto.
Qed.

Lemma free_parallel_rule:
  forall j m1 b1 sz1 m1' m2 b2 sz2 lo hi delta P,
  m2 |= range b2 0 lo ** range b2 hi sz2 ** minjection j m1 ** P ->
  Mem.free m1 b1 0 sz1 = Some m1' ->
  j b1 = Some (b2, delta) ->
  lo = delta -> hi = delta + Zmax 0 sz1 ->
  exists m2',
     Mem.free m2 b2 0 sz2 = Some m2'
  /\ m2' |= minjection j m1' ** P.
Proof.
  intros. rewrite <- ! sep_assoc in H.
  destruct H as (A & B & C).
  destruct A as (D & E & F).
  destruct D as (J & K & L).
  destruct J as (_ & _ & J). destruct K as (_ & _ & K).
  simpl in E.
  assert (PERM: Mem.range_perm m2 b2 0 sz2 Cur Freeable).
  { red; intros.
    destruct (zlt ofs lo). apply J; omega.
    destruct (zle hi ofs). apply K; omega.
    replace ofs with ((ofs - delta) + delta) by omega.
    eapply Mem.perm_inject; eauto.
    eapply Mem.free_range_perm; eauto. xomega.
  }
  destruct (Mem.range_perm_free _ _ _ _ PERM) as [m2' FREE].
  exists m2'; split; auto. split; [|split].
- simpl. eapply Mem.free_right_inject; eauto. eapply Mem.free_left_inject; eauto.
  intros. apply (F b2 (ofs + delta0)).
+ simpl.
  destruct (zlt (ofs + delta0) lo). intuition auto.
  destruct (zle hi (ofs + delta0)). intuition auto.
  destruct (eq_block b0 b1).
* subst b0. rewrite H1 in H; inversion H; clear H; subst delta0.
  eelim (Mem.perm_free_2 m1); eauto. xomega.
* exploit Mem.mi_no_overlap; eauto.
  apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem.
  eapply Mem.perm_free_3; eauto.
  apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
  eapply (Mem.free_range_perm m1); eauto.
  instantiate (1 := ofs + delta0 - delta). xomega.
  intros [X|X]. congruence. omega.
+ simpl. exists b0, delta0; split; auto.
  replace (ofs + delta0 - delta0) with ofs by omega.
  apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem.
  eapply Mem.perm_free_3; eauto.
- apply (m_invar P) with m2; auto.
  eapply Mem.free_unchanged_on; eauto.
  intros; red; intros. eelim C; eauto. simpl.
  destruct (zlt i lo). intuition auto.
  destruct (zle hi i). intuition auto.
  right; exists b1, delta; split; auto.
  apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
  eapply Mem.free_range_perm; eauto. xomega.
- red; simpl; intros. eelim C; eauto.
  simpl. right. destruct H as (b0 & delta0 & U & V).
  exists b0, delta0; split; auto.
  eapply Mem.perm_free_3; eauto.
Qed.

(** Preservation of a global environment by a memory injection *)

Inductive globalenv_preserved {F V: Type} (ge: Genv.t F V) (j: meminj) (bound: block) : Prop :=
  | globalenv_preserved_intro
      (DOMAIN: forall b, Plt b bound -> j b = Some(b, 0))
      (IMAGE: forall b1 b2 delta, j b1 = Some(b2, delta) -> Plt b2 bound -> b1 = b2)
      (SYMBOLS: forall id b, Genv.find_symbol ge id = Some b -> Plt b bound)
      (FUNCTIONS: forall b fd, Genv.find_funct_ptr ge b = Some fd -> Plt b bound)
      (VARINFOS: forall b gv, Genv.find_var_info ge b = Some gv -> Plt b bound).

Program Definition globalenv_inject {F V: Type} (ge: Genv.t F V) (j: meminj) : massert := {|
  m_pred := fun m => exists bound, Ple bound (Mem.nextblock m) /\ globalenv_preserved ge j bound;
  m_footprint := fun b ofs => False
|}.
Next Obligation.
  rename H into bound. exists bound; split; auto. eapply Ple_trans; eauto. eapply Mem.unchanged_on_nextblock; eauto.
Qed.
Next Obligation.
  tauto.
Qed.

Lemma globalenv_inject_preserves_globals:
  forall (F V: Type) (ge: Genv.t F V) j m,
  m |= globalenv_inject ge j ->
  meminj_preserves_globals ge j.
Proof.
  intros. destruct H as (bound & A & B). destruct B.
  split; [|split]; intros.
- eauto.
- eauto.
- symmetry; eauto.
Qed.

Lemma globalenv_inject_incr:
  forall j m0 (F V: Type) (ge: Genv.t F V) m j' P,
  inject_incr j j' ->
  inject_separated j j' m0 m ->
  m |= globalenv_inject ge j ** P ->
  m |= globalenv_inject ge j' ** P.
Proof.
  intros. destruct H1 as (A & B & C). destruct A as (bound & D & E).
  split; [|split]; auto.
  exists bound; split; auto.
  inv E; constructor; intros.
- eauto.
- destruct (j b1) as [[b0 delta0]|] eqn:JB1.
+ erewrite H in H1 by eauto. inv H1. eauto.
+ exploit H0; eauto. intros (X & Y). elim Y. apply Plt_le_trans with bound; auto.
- eauto.
- eauto.
- eauto.
Qed.

Lemma external_call_parallel_rule:
  forall (F V: Type) ef (ge: Genv.t F V) vargs1 m1 t vres1 m1' m2 j P vargs2,
  external_call ef ge vargs1 m1 t vres1 m1' ->
  m2 |= minjection j m1 ** globalenv_inject ge j ** P ->
  Val.inject_list j vargs1 vargs2 ->
  exists j' vres2 m2',
     external_call ef ge vargs2 m2 t vres2 m2'
  /\ Val.inject j' vres1 vres2
  /\ m2' |= minjection j' m1' ** globalenv_inject ge j' ** P
  /\ inject_incr j j'
  /\ inject_separated j j' m1 m2.
Proof.
  intros until vargs2; intros CALL SEP ARGS.
  destruct SEP as (A & B & C). simpl in A.
  exploit external_call_mem_inject; eauto.
  eapply globalenv_inject_preserves_globals. eapply sep_pick1; eauto.
  intros (j' & vres2 & m2' & CALL' & RES & INJ' & UNCH1 & UNCH2 & INCR & ISEP).
  assert (MAXPERMS: forall b ofs p,
            Mem.valid_block m1 b -> Mem.perm m1' b ofs Max p -> Mem.perm m1 b ofs Max p).
  { intros. eapply external_call_max_perm; eauto. }
  exists j', vres2, m2'; intuition auto.
  split; [|split].
- exact INJ'.
- apply m_invar with (m0 := m2).
+ apply globalenv_inject_incr with j m1; auto.
+ eapply Mem.unchanged_on_implies; eauto.
  intros; red; intros; red; intros.
  eelim C; eauto. simpl. exists b0, delta; auto.
- red; intros. destruct H as (b0 & delta & J' & E).
  destruct (j b0) as [[b' delta'] | ] eqn:J.
+ erewrite INCR in J' by eauto. inv J'.
  eelim C; eauto. simpl. exists b0, delta; split; auto. apply MAXPERMS; auto.
  eapply Mem.valid_block_inject_1; eauto.
+ exploit ISEP; eauto. intros (X & Y). elim Y. eapply m_valid; eauto.
Qed.

Lemma alloc_parallel_rule_2:
  forall (F V: Type) (ge: Genv.t F V) m1 sz1 m1' b1 m2 sz2 m2' b2 P j lo hi delta,
  m2 |= minjection j m1 ** globalenv_inject ge j ** P ->
  Mem.alloc m1 0 sz1 = (m1', b1) ->
  Mem.alloc m2 0 sz2 = (m2', b2) ->
  (8 | delta) ->
  lo = delta ->
  hi = delta + Zmax 0 sz1 ->
  0 <= sz2 <= Int.max_unsigned ->
  0 <= delta -> hi <= sz2 ->
  exists j',
     m2' |= range b2 0 lo ** range b2 hi sz2 ** minjection j' m1' ** globalenv_inject ge j' ** P
  /\ inject_incr j j'
  /\ j' b1 = Some(b2, delta).
Proof.
  intros.
  set (j1 := fun b => if eq_block b b1 then Some(b2, delta) else j b).
  assert (X: inject_incr j j1).
  { unfold j1; red; intros. destruct (eq_block b b1); auto.
    subst b. eelim Mem.fresh_block_alloc. eexact H0.
    eapply Mem.valid_block_inject_1. eauto. apply sep_proj1 in H. eexact H. }
  assert (Y: inject_separated j j1 m1 m2).
  { unfold j1; red; intros. destruct (eq_block b0 b1).
  - inversion H9; clear H9; subst b3 delta0 b0. split; eapply Mem.fresh_block_alloc; eauto.
  - congruence. }
  rewrite sep_swap in H. eapply globalenv_inject_incr with (j' := j1) in H; eauto. rewrite sep_swap in H.
  clear X Y.
  exploit alloc_parallel_rule; eauto.
  intros (j' & A & B & C & D).
  exists j'; split; auto.
  rewrite sep_swap4 in A. rewrite sep_swap4. apply globalenv_inject_incr with j1 m1; auto.
- red; unfold j1; intros. destruct (eq_block b b1). congruence. rewrite D; auto.
- red; unfold j1; intros. destruct (eq_block b0 b1). congruence. rewrite D in H9 by auto. congruence.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal77.

From lfind Require Import LFind.
Lemma lfind_state  (y:lst):@eq lst (rev y) (append (rev y) Nil).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal77_theorem0_46_append_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (y:lst) :=
 let lfind_var := "y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print y lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


Require Import Integers.
Require Import Coqlib.
Require Import Maps.

Import Int.
Require Import Hardware.

Ltac dec_eq_try :=
  repeat (rewrite dec_eq_false;
    [ idtac | solve [ let F := fresh in (intro F; inversion F)] ] +
  rewrite dec_eq_true + fail).

Ltac simpl_code :=
  repeat autounfold with chipmem; simpl;
  repeat match goal with
  | |- context[add (repr ?x) (repr ?y)] =>
    let GR := fresh in assert (GR: add (repr x) (repr y) = repr (x + y)) by
      (rewrite add_unsigned; rewrite unsigned_repr_eq; rewrite <- Z_mod_modulus_eq;
      apply f_equal; auto); rewrite GR; clear GR; simpl
  | |- context[?x # ?y <- ?z] =>
    change (x # y <- z) with (RegMap.set y z x); try unfold RegMap.set
  end; repeat autounfold with chipmem; simpl.

Ltac deal_with_eq_dec :=
  repeat (let F := fresh in
   (case (eq_dec _ _); intro F; try inversion F));
  repeat match goal with
  | |- context[Reg_eq ?x ?x] =>
    rewrite dec_eq_true
  | H: context[Reg_eq ?x ?x] |- _ =>
    rewrite dec_eq_true in H; try rewrite H
  end; repeat (case (Reg_eq _ _); intros).

Ltac inverse_eq :=
  match goal with
  | H: ?x = ?y |- _ => try inversion H
  end.

Ltac deal_with_eq :=
  repeat match goal with
  | |- context [eq ?x ?x] =>
    rewrite Z_eq_eq
  | H: context[eq ?x ?x] |- _ =>
    rewrite Z_eq_eq in H
  end; autounfold with Z_unfold;
  try (case (Z.eq_dec _ _); intros; [intuition | inverse_eq]); simpl in *.

Ltac Fine_eq :=
  match goal with
  | |- context[Fine ?M' ?IM' ?RF' ?St' = Fine _ _ _ _ /\ _] =>
    exists M'; exists IM'; exists RF'; exists St'
  end.

Lemma rsb_is_reverse_sub: forall M IM RF St v v',
  (IM (RF#PC)) = (Isub v v') ->
  let EIMsub := ExecuteStep M IM RF St in
  let EIMrsb := ExecuteStep M (InstructionMap.set (RF#PC) (Irsb v' v) IM) RF St in
  OutputM EIMsub = OutputM EIMrsb /\
  OutputRF EIMsub = OutputRF EIMrsb /\
  OutputStack EIMsub = OutputStack EIMrsb.
Proof.
  intros. subst EIMsub. subst EIMrsb.
  simpl_code. rewrite H. simpl.
  dec_eq_try. destruct (lt _ _); auto.
Qed.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.

Require Import MirrorCore.TypesI.

Require Import MirrorCharge.ModularFunc.BaseType.
Require Import MirrorCharge.ModularFunc.ListType.
Require Import MirrorCharge.ModularFunc.SubstType.

Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.
Require Import MirrorCharge.ModularFunc.EmbedFunc.
Require Import MirrorCharge.ModularFunc.LaterFunc.

Require Import Charge.Open.Subst.
Require Import Charge.Logics.ILInsts.
Require Import Charge.Logics.BILInsts.
Require Import Charge.Logics.ILogic.
Require Import Charge.Logics.Later.

Require Import Java.Logic.AssertionLogic.
Require Import Java.Logic.SpecLogic.
Require Import Java.Language.Lang.
Require Import Java.Language.Program.

Require Import Coq.Strings.String.
Require Import Coq.Bool.Bool.

Set Implicit Arguments.
Set Strict Implicit.

Inductive typ : Type :=
| tyArr : typ -> typ -> typ
| tyList : typ -> typ
| tyPair : typ -> typ -> typ
| tyBool : typ
| tyVal : typ
| tyString : typ
| tyNat : typ
| tyProp : typ
| tySpec : typ
| tyAsn : typ
| tyProg : typ
| tyCmd : typ
| tyDExpr : typ
| tySubst : typ.

Notation "'tyStack'" := (tyArr tyString tyVal).

Notation "'tyPure'" := (tyArr tyStack tyProp).
Notation "'tySasn'" := (tyArr tyStack tyAsn).
Notation "'tyExpr'" := (tyArr tyStack tyVal).
Notation "'tyFields'" := (tyList tyString).

Notation "'tyVarList'" := (tyList tyString).
Notation "'tyDExprList'" := (tyList tyDExpr).
Notation "'tySubstList'" := (tyList (tyPair tyString tyExpr)).

Fixpoint type_cast_typ (a b : typ) : option (a = b) :=
  match a as a , b as b return option (a = b) with
    | tyProp , tyProp => Some eq_refl
    | tySpec , tySpec => Some eq_refl
    | tyVal, tyVal => Some eq_refl
    | tyBool, tyBool => Some eq_refl
    | tyProg, tyProg => Some eq_refl
    | tyNat, tyNat => Some eq_refl
    | tyArr x y , tyArr a b =>
      match type_cast_typ x a , type_cast_typ y b with
        | Some pf , Some pf' =>
          Some (match pf in _ = t
                    , pf' in _ = t'
                      return tyArr x y = tyArr t t'
                with
                  | eq_refl , eq_refl => eq_refl
                end)
        | _ , _ => None
      end
    | tyPair x y , tyPair a b =>
      match type_cast_typ x a , type_cast_typ y b with
        | Some pf , Some pf' =>
          Some (match pf in _ = t
                    , pf' in _ = t'
                      return tyPair x y = tyPair t t'
                with
                  | eq_refl , eq_refl => eq_refl
                end)
        | _ , _ => None
      end
    | tyList x, tyList y =>
    	match type_cast_typ x y with
          | Some pf =>
    		Some (match pf in _ = t return tyList x = tyList t with
    			    | eq_refl => eq_refl
    			  end)
          | None => None
       end
    | tyString, tyString => Some eq_refl
    | tyCmd, tyCmd => Some eq_refl
    | tyDExpr, tyDExpr => Some eq_refl
    | tyAsn, tyAsn => Some eq_refl
    | tySubst, tySubst => Some eq_refl

    | _, _ => None
  end.

Lemma type_cast_typ_sound (a b : typ) :
	(exists pf, type_cast_typ a b = Some pf) <->
	a = b.
Proof.
  split; intros H.
  + destruct a, b; destruct H as [x _]; inversion x; subst; reflexivity.
  + subst. exists eq_refl. induction b; try reflexivity.
    simpl. rewrite IHb1, IHb2. reflexivity.
    simpl. rewrite IHb. reflexivity.
    simpl. rewrite IHb1, IHb2. reflexivity.
Qed.

Instance RelDec_eq_typ : RelDec (@eq typ) :=
{ rel_dec := fun a b => match type_cast_typ a b with
                          | None => false
                          | Some _ => true
                        end }.

Lemma type_cast_typ_refl (a : typ) : type_cast_typ a a = Some eq_refl.
Proof.
  induction a; simpl; try reflexivity.
  rewrite IHa1, IHa2; reflexivity.
  rewrite IHa. reflexivity.
  rewrite IHa1, IHa2; reflexivity.
Qed.

Instance RelDec_correct_typ : RelDec_Correct RelDec_eq_typ.
Proof.
	split; intros x y.
	destruct x, y; simpl; split; intro H; inversion H; subst; try reflexivity.
	+ remember (type_cast_typ x1 y1); destruct o; subst; [|inversion H].
	  remember (type_cast_typ x2 y2); destruct o; subst; [|inversion H].
	  reflexivity.
	+ do 2 rewrite type_cast_typ_refl; reflexivity.
	+ remember (type_cast_typ x y); destruct o; subst; [|inversion H].
	  reflexivity.
	+ rewrite type_cast_typ_refl. reflexivity.
	+ remember (type_cast_typ x1 y1); destruct o; subst; [|inversion H].
	  remember (type_cast_typ x2 y2); destruct o; subst; [|inversion H].
	  reflexivity.
	+ do 2 rewrite type_cast_typ_refl; reflexivity.
Qed.

Fixpoint typD (t : typ) : Type :=
  match t with
    | tyArr a b => typD a -> typD b
    | tyList a => @list (typD a)
    | tyPair a b => (typD a * typD b)%type
    | tyProp => Prop
    | tyNat => nat
    | tyBool => bool
    | tySpec => spec
    | tyAsn => asn
    | tyVal => val
    | tyString => string
    | tyProg => Program
    | tyCmd => cmd
    | tyDExpr => dexpr
    | tySubst => @subst var val
  end.

Inductive tyAcc_typ : typ -> typ -> Prop :=
| tyAcc_tyArrL : forall a b, tyAcc_typ a (tyArr a b)
| tyAcc_tyArrR : forall a b, tyAcc_typ a (tyArr b a).

Instance RType_typ : RType typ :=
{ typD := typD
; tyAcc := tyAcc_typ
; type_cast := type_cast_typ
}.

Instance Typ2_Fun : Typ2 _ (fun x y : Type => x -> y) :=
{ typ2 := tyArr
; typ2_cast := fun _ _ => eq_refl
; typ2_match := fun T t tr =>
                  match t as t return T (typD t) -> T (typD t) with
                    | tyArr a b => fun _ => tr a b
                    | _ => fun fa => fa
                  end
}.

Instance Typ2Ok_Fun : Typ2Ok Typ2_Fun.
Proof.
  split; intros.
  + reflexivity.
  + apply tyAcc_tyArrL.
  + apply tyAcc_tyArrR.
  + unfold Rty in *. inversion H; subst; intuition congruence.
  + destruct x; try solve [right; reflexivity].
    left; exists x1, x2, eq_refl. reflexivity.
  + destruct pf; reflexivity.
Qed.

Instance Typ0_Prop : Typ0 _ Prop :=
{ typ0 := tyProp
; typ0_cast := eq_refl
; typ0_match := fun T t tr =>
                  match t as t return T (typD t) -> T (typD t) with
                    | tyProp => fun _ => tr
                    | _ => fun fa => fa
                  end
}.

Instance Typ0Ok_Prop : Typ0Ok Typ0_Prop.
Proof.
    constructor.
    { reflexivity. }
    { destruct x; try solve [ right ; reflexivity ].
      { left. exists eq_refl. reflexivity. } }
    { destruct pf. reflexivity. }
Qed.

Instance RTypeOk_typ : @RTypeOk _ RType_typ.
Proof.
	split; intros.
	+ reflexivity.
	+ unfold well_founded.
	  intros. induction a; simpl; constructor; intros; inversion H; subst.
	  assumption. assumption.
	+ destruct pf; reflexivity.
	+ destruct pf1, pf2; reflexivity.
	+ apply type_cast_typ_refl.
	+ intro H1. inversion H1; subst.
	  rewrite type_cast_typ_refl in H. inversion H.
	+ intros x.
	  induction x; intros y; destruct y; try (right; congruence); try (left; congruence).
	  * destruct (IHx1 y1) as [Hx1 | Hx1]; clear IHx1;
	    destruct (IHx2 y2) as [Hx2 | Hx2]; clear IHx2;
	    try (right; congruence); try (left; congruence).
	  * destruct (IHx y) as [Hx | Hx]; clear IHx; [
	    left; congruence | right; congruence].
	  * destruct (IHx1 y1) as [Hx1 | Hx1]; clear IHx1;
	    destruct (IHx2 y2) as [Hx2 | Hx2]; clear IHx2;
	    try (right; congruence); try (left; congruence).
Qed.

Instance BaseType_typ : BaseType typ := {
  tyNat := tyNat;
  tyBool := tyBool;
  tyString := tyString;
  tyPair := tyPair
}.

Instance BaseTypeD_typ : BaseTypeD := {
	btNat := eq_refl;
	btBool := eq_refl;
	btString := eq_refl;
	btPair := fun _ _ => eq_refl
}.

Instance ListType_typ : ListType typ := {
	tyList := tyList
}.

Instance ListTypeD_typ : ListTypeD := {
	btList := fun _ => eq_refl
}.

Instance SubstType_typ : SubstType typ := {
	tyVal := tyVal;
	tySubst := tySubst
}.

Definition null' : TypesI.typD tyVal := null.

Program Instance SubstTypeD_typ : @SubstTypeD typ _ _ _ := {
	stSubst := eq_refl
}.

Definition should_not_be_necessary : ILogicOps (TypesI.typD tySpec).
Proof.
  simpl.
  apply _.
Defined.

Definition should_also_not_be_necessary : ILLOperators (TypesI.typD tySpec).
Proof.
  simpl.
  apply _.
Defined.

  Definition ilops : @logic_ops _ RType_typ :=
  fun t =>
    match t
          return option (ILogic.ILogicOps (TypesI.typD t))
    with
      | tyProp => Some _
      | tyAsn => Some _
      | tySasn => Some (@ILFun_Ops stack asn _)
      | tySpec => Some should_not_be_necessary
      | tyPure => Some ( @ILFun_Ops stack Prop _)
      | _ => None
    end.

  Definition bilops : @bilogic_ops _ RType_typ :=
  fun t =>
    match t
          return option (BILogic.BILOperators (TypesI.typD t))
    with
      | tyAsn => Some _
      | tySasn => Some (@BILFun_Ops stack asn _)
      | _ => None
    end.

Definition eops : @embed_ops _ RType_typ :=
  fun t u =>
    match t as t , u as u
          return option
                   (ILEmbed.EmbedOp (TypesI.typD t) (TypesI.typD u))
    with
      | tyPure, tySasn => Some _
      | tyProp, tyAsn => Some _
      | _ , _ => None
    end.

Definition lops : @later_ops _ RType_typ :=
  fun t =>
    match t return option (ILLOperators (TypesI.typD t)) with
	  | tySpec => Some should_also_not_be_necessary
	  | _ => None
    end.


Require Import Coq.Lists.List.
Require Import Coq.Relations.Relations.
Require Import ExtLib.Data.Set.ListSet.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.Injection.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.EnvI.
Require Import MirrorCore.SubstI.

Set Implicit Arguments.
Set Strict Implicit.

Section sealed.
  Variable expr : Type.
  Variable lsubst : Type.
  Context {Subst_lsubst : Subst lsubst expr}.
  Let uvar : Type := nat.

  Record seal_subst : Type := SealedSubst
  { allowed : uvar -> bool
  ; subst : lsubst
  }.

  Instance Injective_seal_subst a b c d
  : Injective ({| allowed := a ; subst := b |} =
               {| allowed := c ; subst := d |}) :=
  { result := a = c /\ b = d }.
  Proof.
    abstract (inversion 1; intuition).
  Defined.

  Instance Subst_seal_subst : Subst seal_subst expr :=
  { set := fun u e s =>
             match s with
               | {| allowed := allow ; subst := subst |} =>
                 if allow u then
                   match set u e subst with
                     | None => None
                     | Some s => Some {| allowed := allow ; subst := s |}
                   end
                 else
                   None
             end
  ; lookup := fun u s => lookup u s.(subst)
  ; empty := {| allowed := fun _ => true ; subst := @SubstI.empty _ _ _ |}
  }.

  Variable typ : Type.
  Variable RType_typ : RType typ.
  Context {Expr_expr : Expr _ expr}.
  Context {mentionsU : uvar -> expr -> bool}.
  Context {SubstOk_lsubst : @SubstOk _ _ _ _ Expr_expr Subst_lsubst}.

  Instance SubstOk : SubstOk Expr_expr Subst_seal_subst :=
  { substD := fun us vs s => substD us vs s.(subst)
  ; WellTyped_subst := fun tus tvs s => WellTyped_subst tus tvs s.(subst)
  }.
  Proof.
    { simpl; apply substD_empty. }
    { simpl; apply WellTyped_empty. }

    destruct s; simpl; eauto using substD_lookup, WellTyped_lookup, WellTyped_set, substD_set.
    destruct s; simpl; eauto using substD_lookup.
    { destruct s; destruct s'; simpl; eauto using substD_lookup, WellTyped_lookup, WellTyped_set, substD_set.
      intros. destruct (allowed0 uv); try congruence.
      consider (set uv e subst0); intros; inv_all; subst; try congruence;
      eauto using WellTyped_set. }
    { destruct s; destruct s'; simpl; intros.
      destruct (allowed0 uv); try congruence; inv_all; subst.
      consider (set uv e subst0); try congruence; intros; inv_all; subst;
      eauto using substD_set. }
  Defined.

  Instance NormalizedSubstOk (N : NormalizedSubstOk Subst_lsubst mentionsU)
  : NormalizedSubstOk Subst_seal_subst mentionsU.
  Proof.
    constructor.
    { destruct s; simpl. eapply lookup_normalized; eauto. }
  Qed.

  Definition seal : (uvar -> bool) -> lsubst -> seal_subst := SealedSubst.

  Definition exclude (ls : list uvar) : lsubst -> seal_subst :=
    seal (fun u => negb (List.anyb (EqNat.beq_nat u) ls)).

  Definition allow (ls : list uvar) : lsubst -> seal_subst :=
    seal (fun u => List.anyb (EqNat.beq_nat u) ls).

End sealed.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(@ref a a_WT)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive array
  (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (@map.Map.map Z _ a a_WT) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): (@map.Map.map
  Z _ a a_WT) := match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(@array a a_WT)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(@array a a_WT)) (i:Z)
  (v:a): (@array a a_WT) := (mk_array (length a1) (map.Map.set (elts a1) i
  v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (@array a a_WT) :=
  (mk_array n (map.Map.const v:(@map.Map.map Z _ a a_WT))).

(* Why3 assumption *)
Definition appear_twice (a:(@array Z _)) (v:Z) (u:Z): Prop := exists i:Z,
  ((0%Z <= i)%Z /\ (i < u)%Z) /\ (((get a i) = v) /\ exists j:Z,
  ((0%Z <= j)%Z /\ (j < u)%Z) /\ ((~ (j = i)) /\ ((get a j) = v))).

(* Why3 goal *)
Theorem WP_parameter_two_equal_elements : forall (a:Z) (a1:(@map.Map.map Z _
  Z _)) (n:Z), let a2 := (mk_array a a1) in (((0%Z <= a)%Z /\
  (((a = (n + 2%Z)%Z) /\ (2%Z <= n)%Z) /\ ((forall (i:Z), ((0%Z <= i)%Z /\
  (i < a)%Z) -> ((0%Z <= (map.Map.get a1 i))%Z /\ ((map.Map.get a1
  i) < n)%Z)) /\ exists v1:Z, (appear_twice a2 v1 (n + 2%Z)%Z) /\
  exists v2:Z, (appear_twice a2 v2 (n + 2%Z)%Z) /\ ~ (v2 = v1)))) ->
  ((0%Z <= n)%Z -> ((0%Z <= n)%Z -> let o := (n + 1%Z)%Z in ((0%Z <= o)%Z ->
  forall (v2:Z) (v1:Z) (deja_vu:(@map.Map.map Z _ bool _)), forall (i:Z),
  ((0%Z <= i)%Z /\ (i <= o)%Z) -> ((((v1 = (-1%Z)%Z) -> (v2 = (-1%Z)%Z)) /\
  (((~ (v1 = (-1%Z)%Z)) -> (appear_twice a2 v1 i)) /\
  (((~ (v2 = (-1%Z)%Z)) -> ((appear_twice a2 v2 i) /\ ~ (v2 = v1))) /\
  ((forall (v:Z), ((0%Z <= v)%Z /\ (v < n)%Z) -> ((((map.Map.get deja_vu
  v) = true) /\ exists j:Z, ((0%Z <= j)%Z /\ (j < i)%Z) /\ ((map.Map.get a1
  j) = v)) \/ ((~ ((map.Map.get deja_vu v) = true)) /\ forall (j:Z),
  ((0%Z <= j)%Z /\ (j < i)%Z) -> ~ ((map.Map.get a1 j) = v)))) /\
  (((v1 = (-1%Z)%Z) -> forall (v:Z), ((0%Z <= v)%Z /\ (v < n)%Z) ->
  ~ (appear_twice a2 v i)) /\ ((v2 = (-1%Z)%Z) -> forall (v:Z),
  ((0%Z <= v)%Z /\ (v < n)%Z) -> ((~ (v = v1)) -> ~ (appear_twice a2 v
  i)))))))) -> (((0%Z <= i)%Z /\ (i < a)%Z) -> let v := (map.Map.get a1 i) in
  (((0%Z <= n)%Z /\ ((0%Z <= v)%Z /\ (v < n)%Z)) -> (((map.Map.get deja_vu
  v) = true) -> ((v1 = (-1%Z)%Z) -> forall (v11:Z), (v11 = v) ->
  ((v2 = (-1%Z)%Z) -> forall (v3:Z), ((0%Z <= v3)%Z /\ (v3 < n)%Z) ->
  ((~ (v3 = v11)) -> ~ (appear_twice a2 v3 (i + 1%Z)%Z)))))))))))).
intros a a1 n a2 (h1,((h2,h3),(h4,(v1,(h5,(v2,(h6,h7))))))) h8 h9 o
        h10 v22 v12 deja_vu i (h11,h12) (h13,(h14,(h15,(h16,(h17,h18)))))
        (h19,h20) v (h21,(h22,h23)) h24 h25 v11 h26 h27 v3 (h28,h29) h30.
subst a2 a o v v11 v12 v22.
intro h0; red in h0.
destruct h0 as (i0,(h00,(h01,(j,(h02,(h03,h04)))))).
intuition.
apply (H3 v3); auto.
red; exists i0; intuition.
assert (case: (i0 < i \/ i0 = i)%Z) by omega. destruct case.
auto.
subst i0.
unfold get in h01; simpl in h01.
omega.
exists j; intuition.
assert (case: (j < i \/ j = i)%Z) by omega. destruct case.
auto.
subst j.
unfold get in h04; simpl in h04.
omega.
Qed.


From Hammer Require Import Hammer.

Require Import Bool.
Require Import ZArith.
From IntMap Require Import Allmaps.
From TreeAutomata Require Import bases.
From TreeAutomata Require Import defs.
From TreeAutomata Require Import semantics.
From TreeAutomata Require Import signature.
From TreeAutomata Require Import pl_path.
From TreeAutomata Require Import refcorrect.
From TreeAutomata Require Import states_kill_empty.
From TreeAutomata Require Import lattice_fixpoint.
From TreeAutomata Require Import empty_test.

Lemma prec_list_kill_correct_wrt_sign_invar :
forall (m : Map bool) (p p' : prec_list) (n : nat),
pl_tl_length p n ->
prec_list_kill m p = Some p' -> pl_tl_length p' n.
Proof. hammer_hook "states_kill_correct" "states_kill_correct.prec_list_kill_correct_wrt_sign_invar".
intros. apply (forall_incl_length p' n). intros. elim (pl_kill_1 p p' m p0 H0 H1). intros. exact (pl_path_incl_length p0 p n H2 H).
Qed.

Lemma states_kill_aux_correct_wrt_sign_invar :
forall (s : state) (m : Map bool) (sigma : signature),
state_correct_wrt_sign s sigma ->
state_correct_wrt_sign (states_kill_aux m s) sigma.
Proof. hammer_hook "states_kill_correct" "states_kill_correct.states_kill_aux_correct_wrt_sign_invar".
unfold state_correct_wrt_sign in |- *. intros. elim (st_kill_2 _ _ _ _ H0).
intros. elim H1. intros. elim (H _ _ H2). intros. split with x0.
elim H4. intros. split. exact H5. exact (prec_list_kill_correct_wrt_sign_invar _ _ _ _ H6 H3).
Qed.

Lemma states_kill_correct_wrt_sign_invar :
forall (s s' : state) (m : Map bool) (sigma : signature),
state_correct_wrt_sign s sigma ->
states_kill m s = Some s' -> state_correct_wrt_sign s' sigma.
Proof. hammer_hook "states_kill_correct" "states_kill_correct.states_kill_correct_wrt_sign_invar".
unfold states_kill in |- *. intros. elim (map_sum prec_list (states_kill_aux m s)); intros. rewrite H1 in H0. inversion H0.
elim H1; intros; elim H2; intros; elim H3; intros; rewrite H4 in H0. inversion H0. rewrite <- H4. exact (states_kill_aux_correct_wrt_sign_invar _ _ _ H). inversion H0.
rewrite <- H4. exact (states_kill_aux_correct_wrt_sign_invar _ _ _ H).
Qed.

Lemma preDTA_kill_correct_wrt_sign_invar :
forall (d : preDTA) (m : Map bool) (sigma : signature),
predta_correct_wrt_sign d sigma ->
predta_correct_wrt_sign (preDTA_kill m d) sigma.
Proof. hammer_hook "states_kill_correct" "states_kill_correct.preDTA_kill_correct_wrt_sign_invar".
unfold predta_correct_wrt_sign in |- *. intros. elim (dt_kill_1 _ _ _ _ H0). intros. elim H1. intros. exact (states_kill_correct_wrt_sign_invar _ _ _ _ (H _ _ H2) H3).
Qed.

Lemma DTA_kill_correct_wrt_sign_invar :
forall (d : DTA) (m : Map bool) (sigma : signature),
dta_correct_wrt_sign d sigma -> dta_correct_wrt_sign (DTA_kill m d) sigma.
Proof. hammer_hook "states_kill_correct" "states_kill_correct.DTA_kill_correct_wrt_sign_invar".
simple induction d. simpl in |- *. intros. elim (option_sum state (MapGet state (preDTA_kill m p) a)). intros y. elim y. intros x y0.
rewrite y0. exact (preDTA_kill_correct_wrt_sign_invar _ _ _ H). intros y. rewrite y. unfold dta_correct_wrt_sign in |- *.
unfold predta_correct_wrt_sign in |- *. intros. simpl in H0.
elim (N.discr a0); intros y0. elim y0. intros x y1. rewrite y1 in H0. inversion H0. rewrite y0 in H0. inversion H0.
unfold state_correct_wrt_sign in |- *. intros. inversion H1.
Qed.

Lemma DTA_kill_empty_states_lazy_correct_wrt_sign_invar :
forall (d : DTA) (sigma : signature),
dta_correct_wrt_sign d sigma ->
dta_correct_wrt_sign (DTA_kill_empty_states_lazy d) sigma.
Proof. hammer_hook "states_kill_correct" "states_kill_correct.DTA_kill_empty_states_lazy_correct_wrt_sign_invar".
intro. rewrite (kill_empty_states_lazy_eg_kill_empty_states d). unfold DTA_kill_empty_states in |- *. exact (DTA_kill_correct_wrt_sign_invar d (dta_states_non_empty d)).
Qed.

Lemma kill_empty_correct_wrt_sign_invar :
forall (d : DTA) (sigma : signature),
dta_correct_wrt_sign d sigma ->
dta_correct_wrt_sign (DTA_kill_empty_states d) sigma.
Proof. hammer_hook "states_kill_correct" "states_kill_correct.kill_empty_correct_wrt_sign_invar".
simple induction d. simpl in |- *. intros. elim
(option_sum state (MapGet state (preDTA_kill (dta_non_empty_states p) p) a));
intros y.
elim y. intros x y0. rewrite y0. simpl in |- *. exact (kill_empty_correct_wrt_sign_invar p sigma (dta_non_empty_states p) H). rewrite y. simpl in |- *. unfold predta_correct_wrt_sign in |- *.
intros. simpl in H0. elim (N.discr a0). intros y0. elim y0.
intros x y1. rewrite y1 in H0. inversion H0. intros y0. rewrite y0 in H0. inversion H0. unfold state_correct_wrt_sign in |- *.
intros. inversion H1.
Qed.

Lemma kill_empty_lazy_correct_wrt_sign_invar :
forall (d : DTA) (sigma : signature),
dta_correct_wrt_sign d sigma ->
dta_correct_wrt_sign (DTA_kill_empty_states_lazy d) sigma.
Proof. hammer_hook "states_kill_correct" "states_kill_correct.kill_empty_lazy_correct_wrt_sign_invar".
intro. rewrite (kill_empty_states_lazy_eg_kill_empty_states d).
exact (kill_empty_correct_wrt_sign_invar d).
Qed.

Lemma prec_list_kill_occur :
forall (p p' : prec_list) (b : ad) (m : Map bool),
prec_list_kill m p = Some p' ->
prec_occur p' b -> MapGet bool m b = Some true.
Proof. hammer_hook "states_kill_correct" "states_kill_correct.prec_list_kill_occur".
simple induction p. intros. simpl in H1. elim (pl_sum p1); intros.
rewrite H3 in H1. elim (option_sum bool (MapGet bool m a)); intros y. elim y. intros x y0. rewrite y0 in H1. elim (bool_is_true_or_false x); intros; rewrite H4 in H1.
elim (option_sum prec_list (prec_list_kill m p0)); intros y1.
elim y1. intros x0 y2. rewrite y2 in H1. inversion H1. rewrite <- H6 in H2. inversion H2. rewrite <- H5. rewrite H4 in y0. exact y0. exact (H _ _ _ y2 H10). inversion H10.
rewrite y1 in H1. inversion H1. inversion H1. rewrite y in H1. inversion H1. elim H3. intros. elim H4. intros.
elim H5. intros. rewrite H6 in H1. elim (option_sum bool (MapGet bool m a)); intros y. elim y. intros x2 y0. rewrite y0 in H1. elim (bool_is_true_or_false x2); intros; rewrite H7 in H1. elim (option_sum prec_list (prec_list_kill m p0)); intros y1. elim y1. intros x3 y2. rewrite y2 in H1. elim (option_sum prec_list (prec_list_kill m (prec_cons x x0 x1)));
intros y3. elim y3. intros x4 y4.
rewrite y4 in H1. inversion H1. rewrite <- H9 in H2.
inversion H2. rewrite <- H8. rewrite H7 in y0. exact y0.
exact (H _ _ _ y2 H13). rewrite <- H6 in y4. exact (H0 _ _ _ y4 H13). rewrite y3 in H1. inversion H1.
rewrite <- H9 in H2. inversion H2. rewrite <- H8.
rewrite H7 in y0. exact y0. exact (H _ _ _ y2 H13).
inversion H13. rewrite y1 in H1. elim (option_sum prec_list (prec_list_kill m (prec_cons x x0 x1)));
intros y2. elim y2. intros x3 y3. rewrite y3 in H1. inversion H1. rewrite <- H9 in H2. rewrite <- H6 in y3. exact (H0 _ _ _ y3 H2). rewrite y2 in H1. inversion H1.
rewrite <- H6 in H1. exact (H0 _ _ _ H1 H2). rewrite y in H1. rewrite <- H6 in H1. exact (H0 _ _ _ H1 H2).
intros. simpl in H. inversion H. rewrite <- H2 in H0.
inversion H0.
Qed.

Lemma prec_list_kill_ref_ok_invar :
forall (d : preDTA) (p p' : prec_list) (sigma : signature),
prec_list_ref_ok p d ->
predta_correct_wrt_sign d sigma ->
prec_list_kill (dta_non_empty_states d) p = Some p' ->
prec_list_ref_ok p' (preDTA_kill (dta_non_empty_states d) d).
Proof. hammer_hook "states_kill_correct" "states_kill_correct.prec_list_kill_ref_ok_invar".
intros. unfold prec_list_ref_ok in |- *. intros. elim (dt_non_empty_fix d a). intros. elim (H3 (prec_list_kill_occur _ _ _ _ H1 H2)). intros.
elim (dt_kill_empty_kill_empty d a sigma H0).
intros. apply H7. split with x. exact H5.
Qed.

Lemma states_kill_aux_ref_ok_invar :
forall (d : preDTA) (s : state) (sigma : signature),
state_ref_ok s d ->
predta_correct_wrt_sign d sigma ->
state_ref_ok (states_kill_aux (dta_non_empty_states d) s)
(preDTA_kill (dta_non_empty_states d) d).
Proof. hammer_hook "states_kill_correct" "states_kill_correct.states_kill_aux_ref_ok_invar".
unfold state_ref_ok in |- *. intros. elim (st_kill_2 _ _ _ _ H1).
intros. elim H2. intros. exact (prec_list_kill_ref_ok_invar d x p sigma (H a x H3) H0 H4).
Qed.

Lemma states_kill_ref_ok_invar :
forall (d : preDTA) (s s' : state) (sigma : signature),
state_ref_ok s d ->
predta_correct_wrt_sign d sigma ->
states_kill (dta_non_empty_states d) s = Some s' ->
state_ref_ok s' (preDTA_kill (dta_non_empty_states d) d).
Proof. hammer_hook "states_kill_correct" "states_kill_correct.states_kill_ref_ok_invar".
intros. unfold states_kill in H1. elim (map_sum prec_list (states_kill_aux (dta_non_empty_states d) s));
intros.
rewrite H2 in H1. inversion H1. elim H2; intros; elim H3; intros; elim H4; intros; rewrite H5 in H1. inversion H1.
rewrite <- H5. exact (states_kill_aux_ref_ok_invar _ _ _ H H0). inversion H1. rewrite <- H5. exact (states_kill_aux_ref_ok_invar _ _ _ H H0).
Qed.

Lemma preDTA_kill_ref_ok_distinct_invar :
forall (d : preDTA) (sigma : signature),
preDTA_ref_ok_distinct d d ->
predta_correct_wrt_sign d sigma ->
preDTA_ref_ok_distinct (preDTA_kill (dta_non_empty_states d) d)
(preDTA_kill (dta_non_empty_states d) d).
Proof. hammer_hook "states_kill_correct" "states_kill_correct.preDTA_kill_ref_ok_distinct_invar".
unfold preDTA_ref_ok_distinct in |- *. intros. elim (dt_kill_1 _ _ _ _ H1). intros. elim H2. intros. exact (states_kill_ref_ok_invar d x s sigma (H a x H3) H0 H4).
Qed.

Lemma preDTA_kill_ref_ok_invar :
forall (d : preDTA) (sigma : signature),
preDTA_ref_ok d ->
predta_correct_wrt_sign d sigma ->
preDTA_ref_ok (preDTA_kill (dta_non_empty_states d) d).
Proof. hammer_hook "states_kill_correct" "states_kill_correct.preDTA_kill_ref_ok_invar".
intros. elim (preDTA_ref_ok_def (preDTA_kill (dta_non_empty_states d) d)). intros. apply H2.
elim (preDTA_ref_ok_def d). intro. intro. exact (preDTA_kill_ref_ok_distinct_invar d sigma (H3 H) H0).
Qed.

Lemma DTA_kill_ref_ok_invar :
forall (d : DTA) (sigma : signature),
DTA_ref_ok d ->
dta_correct_wrt_sign d sigma ->
DTA_ref_ok (DTA_kill (dta_states_non_empty d) d).
Proof. hammer_hook "states_kill_correct" "states_kill_correct.DTA_kill_ref_ok_invar".
simple induction d. simpl in |- *. intros. elim
(option_sum state (MapGet state (preDTA_kill (dta_non_empty_states p) p) a));
intros y. elim y. intros x y0. rewrite y0. exact (preDTA_kill_ref_ok_invar _ _ H H0). rewrite y. simpl in |- *.
unfold preDTA_ref_ok in |- *. intros. simpl in H1. elim (N.discr a0); intros y0. elim y0. intros x y1. rewrite y1 in H1. inversion H1. rewrite y0 in H1. inversion H1. rewrite <- H5 in H2.
inversion H2.
Qed.

Lemma DTA_kill_ref_ok_invar_lazy :
forall (d : DTA) (sigma : signature),
DTA_ref_ok d ->
dta_correct_wrt_sign d sigma -> DTA_ref_ok (DTA_kill_empty_states_lazy d).
Proof. hammer_hook "states_kill_correct" "states_kill_correct.DTA_kill_ref_ok_invar_lazy".
intro. rewrite (kill_empty_states_lazy_eg_kill_empty_states d). exact (DTA_kill_ref_ok_invar d).
Qed.

Lemma inter_DTA_main_state_correct_invar :
forall d : DTA,
DTA_main_state_correct d ->
DTA_main_state_correct (DTA_kill (dta_states_non_empty d) d).
Proof. hammer_hook "states_kill_correct" "states_kill_correct.inter_DTA_main_state_correct_invar".
simple induction d. simpl in |- *. intros. elim
(option_sum state (MapGet state (preDTA_kill (dta_non_empty_states p) p) a));
intros y. elim y. intros x y0. rewrite y0. simpl in |- *.
unfold addr_in_preDTA in |- *. unfold addr_in_preDTA in H.
split with x. exact y0. rewrite y. simpl in |- *. unfold addr_in_preDTA in |- *. intros. split with (M0 prec_list).
reflexivity.
Qed.

Lemma inter_DTA_main_state_correct_invar_lazy :
forall d : DTA,
DTA_main_state_correct d ->
DTA_main_state_correct (DTA_kill_empty_states_lazy d).
Proof. hammer_hook "states_kill_correct" "states_kill_correct.inter_DTA_main_state_correct_invar_lazy".
intro. rewrite (kill_empty_states_lazy_eg_kill_empty_states d).
exact (inter_DTA_main_state_correct_invar d).
Qed.