(*

  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.


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.