(*

  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 approx_star_props1.
(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing $  $\times$ #×# *)
(** printing &  $\times$ #×# *)

Hint Resolve approx_star_relates_only_wf : slow.

Lemma alpha_implies_approx_star {p} :
  forall lib nt1 nt2,
  @nt_wf p nt1
  -> alpha_eq nt1 nt2
  -> approx_star lib nt1 nt2.
Proof.
  introv H1nt H2nt.
  apply approx_open_implies_approx_star.
  apply alpha_implies_approx_open; trivial.
Qed.

Lemma approx_star_trans {p} : forall lib t1 t2 t3,
  @approx_star p lib t1 t2
  -> approx_star lib t2 t3
  -> approx_star lib t1 t3.
Proof.
  nterm_ind1s t1 as [v1|f ind|o lbt1 Hind] Case; introv H1as H2as;
  inversion H1as as [? ? ? aop|?|]; subst; clear H1as.
Abort. (** see comments above for approx_star_open_trans*)

Lemma le_approx_ntwf {p} :
  forall lib, le_bin_rel (approx_star lib) (indep_bin_rel nt_wf (@nt_wf p)).
Proof.
  eauto with slow.
Qed.

Lemma approx_rel_wf_sub {p} :
  forall lib lvi lnta lntb,
  bin_rel_nterm (@approx_star p lib) lnta lntb
  -> wf_sub (combine lvi lnta) # wf_sub (combine lvi lntb).
Proof.
  introv Hb. apply (le_binrel_list_un _ _ _ _ (le_approx_ntwf lib)) in Hb.
  exrepnd. unfold wf_sub, sub_range_sat.   dands; eauto with slow.
Qed.

Lemma approx_star_btermd_fr {p} :
  forall lib op bt1 bt2 lva,
    op = NCan NFresh
    -> approx_star_bterm lib op bt1 bt2
    -> {lvn : list NVar
        & {nt1',nt2' : @NTerm p
        $ {sub : Sub
        $ approx_star lib (lsubst nt1' sub) (lsubst nt2' sub)
        # nrut_sub (get_utokens nt1' ++ get_utokens nt2') sub
        # lvn = dom_sub sub
        # alpha_eq_bterm bt1 (bterm lvn nt1')
        # alpha_eq_bterm bt2 (bterm lvn nt2')
        # no_repeats lvn
        (* # disjoint lvn (all_vars (get_nt bt1) ++ all_vars (get_nt bt2)) *)
        # disjoint (lvn ++ (bound_vars nt1') ++ (bound_vars nt2')) lva }}}.
Proof.
  introv d Hab.
  unfold approx_star_bterm in Hab.
  repnud Hab. exrepnd.
  pose proof (alpha_bterm_pair_change _ _ _ _ _ lva Hab2 Hab0) as Hp.
  exrepnd.
  exists lvn.

  repndors; exrepnd; subst; tcsp; GC.
  allrw disjoint_app_r; allrw disjoint_app_l; repnd.

  exists (lsubst nt1n (var_ren (dom_sub sub) lvn))
         (lsubst nt2n (var_ren (dom_sub sub) lvn))
         (combine lvn (range sub)).
  rw @boundvars_lsubst_vars; auto.
  rw @boundvars_lsubst_vars; auto.
  rw @get_utokens_lsubst_allvars; eauto 3 with slow.
  rw @get_utokens_lsubst_allvars; eauto 3 with slow.
  rw @dom_sub_combine; allrw @length_range; allrw @length_dom; auto.

  dands; eauto 3 with slow.

  - pose proof (lsubst_nest_same_alpha nt1n (dom_sub sub) lvn (range sub)) as nest1.
    allrw @length_dom; allrw @length_range.
    repeat (autodimp nest1 hyp).
    { apply alphaeq_preserves_free_vars in Hp2; rw <- Hp2; auto. }
    rw <- @sub_eta in nest1.

    pose proof (lsubst_nest_same_alpha nt2n (dom_sub sub) lvn (range sub)) as nest2.
    allrw @length_dom; allrw @length_range.
    repeat (autodimp nest2 hyp).
    { apply alphaeq_preserves_free_vars in Hp3; rw <- Hp3; auto. }
    rw <- @sub_eta in nest2.

    pose proof (lsubst_alpha_congr2 nt1 nt1n sub Hp2) as as1.
    pose proof (lsubst_alpha_congr2 nt2 nt2n sub Hp3) as as2.

    eapply approx_star_alpha_fun_l;[|apply alpha_eq_sym; exact nest1].
    eapply approx_star_alpha_fun_r;[|apply alpha_eq_sym; exact nest2].
    eauto 3 with slow.

  - apply alphaeq_preserves_utokens in Hp2.
    apply alphaeq_preserves_utokens in Hp3.
    rw <- Hp2; rw <- Hp3.
    eapply nrut_sub_change_sub_same_range;[|exact Hab5].
    rw @range_combine; auto; allrw @length_range; allrw @length_dom; auto.

  - allrw disjoint_app_l; dands; auto.
Qed.

(*
Lemma change_nr_ut_sub_in_lsubst_aux_approx_star {o} :
  forall lib (t1 t2 : @NTerm o) sub1 sub2 l,
    wf_term t1
    -> wf_term t2
    -> approx_star lib (lsubst_aux t1 sub1) (lsubst_aux t2 sub1)
    -> subset (get_utokens t1) l
    -> subset (get_utokens t2) l
    -> nrut_sub l sub1
    -> nrut_sub l sub2
    -> dom_sub sub1 = dom_sub sub2
    -> approx_star lib (lsubst_aux t1 sub2) (lsubst_aux t2 sub2).
Proof.
  nterm_ind1s t1 as [v|op bs ind] Case;
  introv w1 s2 ap ss1 ss2 nrut1 nrut2 eqdoms; allsimpl.

Focus 2.
{
  destruct t2 as [v2|op2 bs2]; allsimpl.

Focus 2.
{

}

  - pose proof (sub_find_some_eq_doms_nrut_sub sub1 sub2 v2 l) as e.
    repeat (autodimp e hyp).
    remember (sub_find sub1 v2) as sf; symmetry in Heqsf; destruct sf.

(*
Focus 2.
{
  rw e.
  inversion ap as [? ? ? ao|]; subst; clear ap.
  constructor.
       apply approx_open_vterm_iff_reduces_to in ao;
       [|apply lsubst_aux_preserves_wf_term2; eauto with slow];
       apply approx_open_vterm_iff_reduces_to;
       [apply lsubst_aux_preserves_wf_term2; eauto with slow|];
       apply (reduces_to_vterm_nrut_sub_change lib t2 sub1 sub2 l); auto
}
*)

    + exrepnd; rw e0.
      applydup @sub_find_some in Heqsf.
      eapply in_nrut_sub in Heqsf0; eauto.
      exrepnd; subst.
      inversion ap as [|? ? ? ? ? len lift apo]; subst; allsimpl; cpx; clear ap.
      allrw map_length.
      apply approx_open_simpler_equiv in apo.
      unfold simpl_olift in apo; repnd.
      pose proof (apo (ax_sub (free_vars (oterm op lbt1')))) as ap; clear apo.
      repeat (autodimp ap hyp).
      { apply isprogram_lsubst_prog_sub; eauto 3 with slow.
        rw @dom_sub_ax_sub; auto. }
      { rw @cl_lsubst_lsubst_aux; eauto 1 with slow.
        simpl; repeat constructor; simpl; sp. }
      repeat (rw @cl_lsubst_lsubst_aux in ap; eauto 1 with slow).
      simpl in ap.
      allfold (@mk_utoken o a0).

SearchAbout dom_sub ax_sub.
}

  - Case "vterm".
    pose proof (sub_find_some_eq_doms_nrut_sub sub1 sub2 v l) as h.
    repeat (autodimp h hyp).
    remember (sub_find sub1 v) as sf1; symmetry in Heqsf1; destruct sf1; exrepnd;
    [|rw h;
       inversion ap as [? ? ? ao|]; subst; clear ap;
       constructor;
       apply approx_open_vterm_iff_reduces_to in ao;
       [|apply lsubst_aux_preserves_wf_term2; eauto with slow];
       apply approx_open_vterm_iff_reduces_to;
       [apply lsubst_aux_preserves_wf_term2; eauto with slow|];
       apply (reduces_to_vterm_nrut_sub_change lib t2 sub1 sub2 l); auto
    ].

    rw h0.
    apply (apso _ _ _ _ []); simpl; auto; fold_terms.
    { unfold lblift_sub; simpl; tcsp. }
    dup Heqsf1 as i.
    apply sub_find_some in Heqsf1.
    eapply in_nrut_sub in Heqsf1; eauto; exrepnd; subst.
    assert (!LIn a0 (get_utokens t2)) as ni by (intro k; apply ss2 in k; sp).
    inversion ap as [|? ? ? ? ? len lift apo]; subst; allsimpl; cpx; clear lift ap.
    fold_terms.

    apply approx_open_simpler_equiv in apo.
    unfold simpl_olift in apo; repnd.

    apply approx_open_simpler_equiv.
    apply lsubst_aux_nt_wf in apo1.
    unfold simpl_olift; dands; eauto 3 with slow.
    introv ps isp1 isp2.
    rw (cl_lsubst_trivial (mk_utoken a)); simpl; eauto 3 with slow.

    (* replace the [a]s in sub by [a0]s to build a sub' and instantiate apo using that? *)

    rw <- @cl_lsubst_lsubst_aux; eauto 2 with slow.
    rw <- @cl_lsubst_lsubst_aux in isp2; eauto 2 with slow.
    rw @cl_lsubst_swap_sub_filter; eauto 2 with slow.
    rw @cl_lsubst_swap_sub_filter in isp2; eauto 2 with slow.
    remember (sub_filter sub (dom_sub sub2)) as sub0.

Lemma pull_out_nrut_sub_from_term {o} :
  forall (t : @NTerm o) (sub : @Sub o) l,
    nrut_sub l sub
    -> {t' : NTerm
        & t = lsubst t' sub
        # disjoint (get_utokens t) (get_utokens_sub sub)}.
Proof.
  nterm_ind t as [v|op bs ind] Case; introv nrut; allsimpl.

  - exists ([] : @Sub o); simpl; dands; auto.
    unfold get_utokens_sub; simpl; auto.

  - destruct x as [v t].
    pose proof (IHsub1 sub2 l nrut) as h; exrepnd.
Qed.

Lemma pull_out_nrut_sub_from_sub {o} :
  forall (sub1 sub2 : @Sub o) l,
    nrut_sub l sub2
    -> {sub : Sub
        & sub1 = lsubst_sub sub sub2
        # disjoint (get_utokens_sub sub) (get_utokens_sub sub2)}.
Proof.
  induction sub1 as [|x sub1]; introv nrut.

  - exists ([] : @Sub o); simpl; dands; auto.
    unfold get_utokens_sub; simpl; auto.

  - destruct x as [v t].
    pose proof (IHsub1 sub2 l nrut) as h; exrepnd.
Qed.

      remember (ren_utokens_sub (nrut_subs_to_utok_ren sub2 sub1) sub0) as sub0'.

      pose proof (dom_sub_ren_utokens_sub (nrut_subs_to_utok_ren sub2 sub1) sub0) as eqdoms0.
      rw <- Heqsub0' in eqdoms0.

      pose proof (apo sub0') as h; clear apo.
      rw <- @cl_lsubst_lsubst_aux in h; eauto 2 with slow.

      assertdimp h hh.
      { subst; eauto with slow. }
      rw @cl_lsubst_swap_sub_filter in h; eauto 2 with slow.
      rw eqdoms in h.
      rw @sub_filter_disjoint1 in h;
        [|rw eqdoms0; rw Heqsub0; rw <- @dom_sub_sub_filter; complete (eauto with slow)].
      rw (cl_lsubst_trivial (mk_utoken a0)) in h; simpl; eauto 2 with slow.

      repeat (assertdimp h hh); eauto 2 with slow.
      { apply (prog_sub_change sub2 sub1); eauto 2 with slow.
        apply lsubst_program_implies in isp2.
        unfold isprogram; dands.
        - unfold closed.
          rw @free_vars_cl_lsubst; eauto 2 with slow.
          apply null_iff_nil.
          apply null_remove_nvars_subvars.
          eapply subvars_eqvars;[|apply eqvars_sym; apply eqvars_free_vars_disjoint].
          rw eqdoms0.
          apply subvars_eq in isp2.
          eapply subvars_eqvars in isp2;[|apply eqvars_free_vars_disjoint].
          rw Heqsub0'.
          rw @sub_keep_first_ren_utokens_sub.
          rw @sub_free_vars_ren_utokens_sub; auto.
        - apply lsubst_wf_if_eauto; eauto with slow. }

      apply approx_utoken_implies_reduces_to in h.
      apply reduces_to_implies_approx1; auto.

(* pull out the atoms from [lsubst t2 sub0'] in [h]
   and from [lsubst t2 sub0] in the conclusion.
   Something like that, maybe:
 *)

Lemma xxx {o} :
  forall (t : @NTerm o) (sub sub1 sub2 : @Sub o) l,
    let sub' := ren_utokens_sub (nrut_subs_to_utok_ren sub2 sub1) sub in
    nrut_sub l sub1
    -> nrut_sub l sub2
    -> dom_sub sub1 = dom_sub sub2
    -> {sub0 : Sub
        & sub' = lsubst_sub sub0 sub1
        # sub  = lsubst_sub sub0 sub2
        # disjoint (get_utokens_sub sub1) (get_utokens_sub sub0)
        # disjoint (get_utokens_sub sub2) (get_utokens_sub sub0)}.

Check reduces_in_atmost_k_steps_change_utok_sub.

XXXXXXX

      unfold reduces_to in h; exrepnd.

(*
      pose proof (reduces_in_atmost_k_steps_change_utok_sub
                    lib k t (mk_utoken a0) sub1 sub2) as h.
      repeat (autodimp h hyp); eauto 3 with slow.
*)

(*
XXXXXXXXXXXXXXXXXX

      pose proof (apo sub) as h; clear apo.
      rw (cl_lsubst_trivial (mk_utoken a0)) in h; simpl; eauto 3 with slow.
      repeat (autodimp h hyp); eauto 2 with slow.
      { rw <- @cl_lsubst_lsubst_aux; eauto 2 with slow.
        rw <- @cl_lsubst_lsubst_aux in isp2; eauto 2 with slow.
        rw @cl_lsubst_swap_sub_filter in isp2; eauto 2 with slow.
        rw @cl_lsubst_swap_sub_filter; eauto 2 with slow.
        rw eqdoms.
        eapply prog_sub_change; eauto with slow. }

      rw <- @cl_lsubst_lsubst_aux in h; eauto 2 with slow.
      rw @cl_lsubst_swap_sub_filter in h; eauto 2 with slow.
      rw eqdoms in h.

      remember (lsubst t2 (sub_filter sub (dom_sub sub2))) as t.

      apply approx_utoken_implies_reduces_to in h.
      unfold reduces_to in h; exrepnd.
      pose proof (reduces_in_atmost_k_steps_change_utok_sub
                    lib k t (mk_utoken a0) sub1 sub2) as h.
      repeat (autodimp h hyp); eauto 3 with slow.

      assert (subset (get_utokens t) l) as ss3.
      {
        subst; introv j; apply get_utokens_lsubst in j.
        allrw in_app_iff; repndors; tcsp.
        rw @sub_keep_first_sub_filter in j.
        apply in_get_utokens_sub in j; exrepnd.
        apply in_sub_filter in j0; repnd.
        apply in_sub_keep_first in j2; repnd.

      }
*)

Abort.
*)

Lemma isprogram_ren_utokens_iff {o} :
  forall (ren : @utok_ren o) (t : NTerm),
    isprogram (ren_utokens ren t) <=> isprogram t.
Proof.
  introv; split; intro k; try (apply isprogram_ren_utokens); auto.
  allunfold @isprogram; repnd; allunfold @closed.
  allrw @free_vars_ren_utokens; dands; auto.
  allrw @nt_wf_ren_utokens_iff; auto.
Qed.

Lemma prog_sub_ren_utokens_sub_iff {o} :
  forall (ren : @utok_ren o) (sub : Sub),
    prog_sub (ren_utokens_sub ren sub) <=> prog_sub sub.
Proof.
  induction sub; allsimpl; tcsp.
  destruct a as [v t]; allsimpl; allrw @prog_sub_cons.
  rw IHsub; rw @isprogram_ren_utokens_iff; sp.
Qed.

Lemma approx_open_change_utoks {o} :
  forall lib (t1 t2 : @NTerm o) ren,
    no_repeats (range_utok_ren ren)
    -> no_repeats (dom_utok_ren ren)
    -> disjoint (range_utok_ren ren) (diff (get_patom_deq o) (dom_utok_ren ren) (get_utokens t1))
    -> disjoint (range_utok_ren ren) (diff (get_patom_deq o) (dom_utok_ren ren) (get_utokens t2))
    -> approx_open lib t1 t2
    -> approx_open lib (ren_utokens ren t1) (ren_utokens ren t2).
Proof.
  introv norep1 norep2 disj1 disj2 apo.

  allrw <- @approx_open_simpler_equiv.
  allunfold @simpl_olift.
  repnd.
  allrw @nt_wf_ren_utokens_iff; dands; auto.
  introv ps isp1 isp2.

  pose proof (ex_ren_utokens_sub
                sub
                ren
                (get_utokens t1 ++ get_utokens t2)) as exren.
  autodimp exren hyp; exrepnd.

  pose proof (apo sub') as h.
  repeat (autodimp h hyp).
  { subst; allrw @prog_sub_ren_utokens_sub_iff; auto. }
  { subst; apply isprogram_lsubst_iff in isp1; repnd.
    apply isprogram_lsubst_iff.
    rw @nt_wf_ren_utokens_iff in isp0; dands; auto.
    introv j.
    rw @free_vars_ren_utokens in isp1.
    apply isp1 in j; exrepnd.
    allrw @sub_find_ren_utokens_sub.
    remember (sub_find sub' v) as sf; symmetry in Heqsf; destruct sf; ginv.
    eexists; dands; eauto.
    - apply nt_wf_ren_utokens_iff in j2; auto.
    - unfold closed in j0; rw @free_vars_ren_utokens in j0; auto. }
  { subst; apply isprogram_lsubst_iff in isp2; repnd.
    apply isprogram_lsubst_iff.
    rw @nt_wf_ren_utokens_iff in isp0; dands; auto.
    introv j.
    rw @free_vars_ren_utokens in isp2.
    apply isp2 in j; exrepnd.
    allrw @sub_find_ren_utokens_sub.
    remember (sub_find sub' v) as sf; symmetry in Heqsf; destruct sf; ginv.
    eexists; dands; eauto.
    - apply nt_wf_ren_utokens_iff in j2; auto.
    - unfold closed in j0; rw @free_vars_ren_utokens in j0; auto. }

  pose proof (approx_change_utoks lib (lsubst t1 sub') (lsubst t2 sub') (ren ++ ren')) as k.
  allrw @range_utok_ren_app.
  allrw @dom_utok_ren_app.
  allrw no_repeats_app.
  allrw disjoint_app_l.
  allrw disjoint_app_r.
  repnd.
  repeat (autodimp k hyp); dands; eauto 3 with slow.

    { introv a b; applydup disj1 in a.
      allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
      apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
      apply in_get_utokens_sub in b0; exrepnd.
      apply in_sub_keep_first in b2; repnd.
      pose proof (exren1 t) as hh.
      repeat (autodimp hh hyp).
      rw lin_flat_map; apply sub_find_some in b3; apply in_sub_eta in b3; repnd.
      eexists; dands; eauto.
    }

    { eapply subset_disjoint;[exact exren4|].
      apply disjoint_app_l; dands.
      { apply disjoint_diff_l; rw diff_nil_if_subset; eauto with slow. }
      { apply disjoint_diff_l; rw diff_nil_if_subset; eauto with slow. }
    }

    { introv a b; applydup disj2 in a.
      allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
      apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
      apply in_get_utokens_sub in b0; exrepnd.
      apply in_sub_keep_first in b2; repnd.
      pose proof (exren1 t) as hh.
      repeat (autodimp hh hyp).
      rw lin_flat_map; apply sub_find_some in b3; apply in_sub_eta in b3; repnd.
      eexists; dands; eauto.
    }

    { eapply subset_disjoint;[exact exren4|].
      apply disjoint_app_l; dands.
      { apply disjoint_diff_l; rw diff_nil_if_subset; eauto with slow. }
      { apply disjoint_diff_l; rw diff_nil_if_subset; eauto with slow. }
    }

    { repeat (rw @lsubst_ren_utokens in k).
      rw exren0 in k.
      repeat (rw @ren_utokens_app_weak_l in k; eauto 2 with slow).
    }
Qed.

Definition utok_ren_cond2 {o} atoms (ren ren' : @utok_ren o) :=
  forall a,
    LIn a atoms
    -> LIn a (range_utok_ren ren)
    -> !LIn a (dom_utok_ren ren)
    -> LIn a (dom_utok_ren ren').

Definition utok_ren_cond2_nil {o} :
  forall (ren1 ren2 : @utok_ren o),
    utok_ren_cond2 [] ren1 ren2.
Proof.
  introv i j k; allsimpl; tcsp.
Qed.
Hint Resolve utok_ren_cond2_nil : slow.

Definition utok_ren_cond2_app {o} :
  forall atoms1 atoms2 (ren1 ren2 : @utok_ren o),
    utok_ren_cond2 atoms1 ren1 ren2
    -> utok_ren_cond2 atoms2 ren1 ren2
    -> utok_ren_cond2 (atoms1 ++ atoms2) ren1 ren2.
Proof.
  introv c1 c2 i j k; allsimpl; tcsp.
  allrw in_app_iff; repndors.
  - apply c1 in i; repeat (autodimp i hyp).
  - apply c2 in i; repeat (autodimp i hyp).
Qed.
Hint Resolve utok_ren_cond2_app : slow.

Lemma ex_ren_atom2 {o} :
  forall (a : get_patom_set o) ren atoms,
    {ren' : utok_ren
     & disjoint (range_utok_ren ren') (a :: atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
     # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
     # subset (dom_utok_ren ren') (range_utok_ren ren)
     # subset (dom_utok_ren ren') [a]
     # no_repeats (dom_utok_ren ren')
     # no_repeats (range_utok_ren ren')
     # utok_ren_cond2 [a] ren ren' }.
Proof.
  introv.
  destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)) as [d|d].

  - exists ([] : @utok_ren o); allsimpl; dands; tcsp.
    introv i j k; allsimpl; repndors; subst; tcsp.

  - destruct (in_deq _ (get_patom_deq o) a (range_utok_ren ren)) as [r|r].

    + pose proof (fresh_atom o (a :: atoms ++ dom_utok_ren ren ++ range_utok_ren ren)) as h.
      exrepnd.
      exists [(a,x)]; simpl.
      allrw disjoint_singleton_l.
      rw singleton_subset.
      dands; auto.
      introv i j k; allsimpl; repndors; subst; tcsp.

    + exists ([] : @utok_ren o); allsimpl; dands; tcsp.
      introv i j k; allsimpl; repndors; subst; tcsp.
Qed.

Lemma ex_ren_utokens_o2 {o} :
  forall (op : @Opid o) ren atoms,
    {ren' : utok_ren
     & disjoint (range_utok_ren ren') (get_utokens_o op ++ atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
     # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
     # subset (dom_utok_ren ren') (range_utok_ren ren)
     # subset (dom_utok_ren ren') (get_utokens_o op)
     # no_repeats (dom_utok_ren ren')
     # no_repeats (range_utok_ren ren')
     # utok_ren_cond2 (get_utokens_o op) ren ren' }.
Proof.
  introv.
  remember (get_utok op) as guo; symmetry in Heqguo; destruct guo.
  - apply get_utok_some in Heqguo; subst; allsimpl.
    pose proof (ex_ren_atom2 g ren atoms) as h; exrepnd.
    exists ren'; dands; auto.
  - exists ([] : @utok_ren o); allsimpl; dands; auto.
    apply get_utok_none in Heqguo; allrw; eauto with slow.
Qed.

Lemma ex_ren_utokens2 {o} :
  forall (t : @NTerm o) ren atoms,
    {ren' : utok_ren
     & disjoint (range_utok_ren ren') (get_utokens t ++ atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
     # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
     # subset (dom_utok_ren ren') (range_utok_ren ren)
     # subset (dom_utok_ren ren') (get_utokens t)
     # no_repeats (dom_utok_ren ren')
     # no_repeats (range_utok_ren ren')
     # utok_ren_cond2 (get_utokens t) ren ren' }.
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv.

  - Case "vterm".
    exists ([] : @utok_ren o); simpl; dands; eauto with slow.

  - Case "sterm".
    exists ([] : @utok_ren o); simpl; dands; eauto with slow.

  - Case "oterm".

    assert
      (forall atoms ren,
         {ren' : utok_ren
          & disjoint (range_utok_ren ren') (get_utokens_bs bs ++ atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
          # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
          # subset (dom_utok_ren ren') (range_utok_ren ren)
          # subset (dom_utok_ren ren') (get_utokens_bs bs)
          # no_repeats (dom_utok_ren ren')
          # no_repeats (range_utok_ren ren')
          # utok_ren_cond2 (get_utokens_bs bs) ren ren' }) as ebs.
    { clear ren atoms.
      induction bs; introv.
      - exists ([] : @utok_ren o); simpl; dands; eauto with slow.
      - destruct a as [l t].
        autodimp IHbs hyp.
        { introv i; apply (ind nt lv); eauto; simpl; sp. }
        pose proof (IHbs (atoms ++ get_utokens t) ren) as ibs; clear IHbs; exrepnd; allsimpl.
        pose proof (ind t l) as h; clear ind; autodimp h hyp.
        pose proof (h (ren ++ ren') (get_utokens_bs bs ++ atoms)) as k; clear h; exrepnd.
        exists (ren' ++ ren'0); simpl.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw no_repeats_app.
        allrw disjoint_app_l.
        allrw subset_app.
        allrw disjoint_app_r.
        allrw app_assoc.
        repnd; dands; eauto 2 with slow.

        {
          introv i; applydup k3 in i as j; allrw in_app_iff; repndors; tcsp.
          apply k4 in i; apply ibs8 in j; sp.
        }

        {
          apply utok_ren_cond2_app; auto.
          - introv i j k.
            applydup k0 in i.
            allrw @range_utok_ren_app.
            allrw @dom_utok_ren_app.
            allrw in_app_iff; allrw not_over_or.
            destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')) as [d|d]; tcsp.
          - introv i j k.
            applydup ibs0 in i.
            allrw @dom_utok_ren_app; allrw in_app_iff.
            repeat (autodimp i0 hyp).
        }
    }

    pose proof (ebs (atoms ++ get_utokens_o op) ren) as ebs'; clear ebs; exrepnd.

    pose proof (ex_ren_utokens_o2 op (ren ++ ren') (get_utokens_bs bs ++ atoms)) as eop; exrepnd.
    allrw @range_utok_ren_app.
    allrw @dom_utok_ren_app.
    allrw disjoint_app_l; repnd.
    allrw disjoint_app_r; repnd.

    exists (ren' ++ ren'0); simpl.
    allrw @range_utok_ren_app.
    allrw @dom_utok_ren_app.
    allrw no_repeats_app.
    allrw subset_app.
    allrw disjoint_app_l; allrw disjoint_app_r.
    repeat (rw app_assoc).
    dands; eauto 3 with slow.

    {
      introv i; applydup eop3 in i as j; allrw in_app_iff; repndors; tcsp.
      apply eop4 in i; apply ebs'8 in j; sp.
    }

    {
      apply utok_ren_cond2_app; auto.
      - introv i j k.
        applydup eop0 in i.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw in_app_iff; allrw not_over_or.
        destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')) as [d|d]; tcsp.
      - introv i j k.
        applydup ebs'0 in i.
        allrw @dom_utok_ren_app; allrw in_app_iff.
        repeat (autodimp i0 hyp).
    }
Qed.

Lemma ex_ren_utokens_sub2 {o} :
  forall (sub : @Sub o) ren atoms,
    {ren' : utok_ren
     & disjoint (range_utok_ren ren') (get_utokens_sub sub ++ atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
     # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
     # subset (dom_utok_ren ren') (range_utok_ren ren)
     # subset (dom_utok_ren ren') (get_utokens_sub sub)
     # no_repeats (dom_utok_ren ren')
     # no_repeats (range_utok_ren ren')
     # utok_ren_cond2 (get_utokens_sub sub) ren ren' }.
Proof.
  induction sub; introv.
  - exists ([] : @utok_ren o); simpl; rw @get_utokens_sub_nil; dands; eauto with slow.
  - destruct a as [v t]; allsimpl.
    pose proof (IHsub ren (atoms ++ get_utokens t)) as ih; clear IHsub; exrepnd.

    pose proof (ex_ren_utokens2 t (ren ++ ren') (get_utokens_sub sub ++ atoms)) as h; exrepnd.

    exists (ren' ++ ren'0); simpl.
    repeat (rw app_assoc).
    allrw @range_utok_ren_app.
    allrw @dom_utok_ren_app.
    allrw no_repeats_app.
    allrw @get_utokens_sub_cons.
    allrw disjoint_app_l; allrw disjoint_app_r.
    allrw subset_app.

    repnd; dands; eauto 3 with slow.

    {
      introv i; applydup h3 in i as j; allrw in_app_iff; repndors; tcsp.
      apply h4 in i; apply ih8 in j; sp.
    }

    {
      apply utok_ren_cond2_app; auto.
      - introv i j k.
        applydup h0 in i.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw in_app_iff; allrw not_over_or.
        destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')) as [d|d]; tcsp.
      - introv i j k.
        applydup ih0 in i.
        allrw @dom_utok_ren_app; allrw in_app_iff.
        repeat (autodimp i0 hyp).
    }
Qed.

Lemma ren_utokens_o_app_weak_l {o} :
  forall (op : @Opid o) ren1 ren2,
    disjoint (dom_utok_ren ren2) (get_utokens_o op)
    -> ren_utok_op (ren1 ++ ren2) op
       = ren_utok_op ren1 op.
Proof.
  introv disj.
  destruct op; tcsp.
  destruct c; tcsp.
  allsimpl.
  allrw disjoint_cons_r; repnd.
  rw @ren_atom_app_weak_l; auto.
Qed.

Lemma length_ren_utokens_bs {o} :
  forall (bs : list (@BTerm o)) ren,
    length (ren_utokens_bs ren bs) = length bs.
Proof.
  induction bs; introv; allsimpl; tcsp.
Qed.

Lemma ren_utok_op_diff_fresh {o} :
  forall (op : @Opid o) ren,
    (ren_utok_op ren op = NCan NFresh) <=> (op = NCan NFresh).
Proof.
  introv; split; intro e; subst; tcsp.
  destruct op; tcsp.
  destruct c; tcsp.
  allsimpl; ginv.
Qed.

Lemma ut_sub_ren_utokens_sub {o} :
  forall (sub : @Sub o) ren,
    ut_sub sub
    -> ut_sub (ren_utokens_sub ren sub).
Proof.
  induction sub; introv uts; allsimpl; tcsp.
  destruct a as [v t]; allrw @ut_sub_cons; repnd; dands; tcsp.
  allunfold @isutoken; exrepnd; subst; allsimpl; fold_terms.
  eexists; dands; eauto.
Qed.
Hint Resolve ut_sub_ren_utokens_sub : slow.

Lemma nrut_sub_implies_ut_sub {o} :
  forall (sub : @Sub o) l,
    nrut_sub l sub -> ut_sub sub.
Proof.
  introv nrut; unfold nrut_sub in nrut; sp.
Qed.
Hint Resolve nrut_sub_implies_ut_sub : slow.

Lemma utok_ren_cond_app_iff {o} :
  forall (atoms1 atoms2 : list (get_patom_set o)) (ren : utok_ren),
    utok_ren_cond (atoms1 ++ atoms2) ren
    <=> (utok_ren_cond atoms1 ren # utok_ren_cond atoms2 ren).
Proof.
  introv; split; intro k; try (apply utok_ren_cond_app; tcsp).
  dands; introv i j; pose proof (k a) as h; allrw in_app_iff; tcsp.
Qed.

Lemma false_if_utok_ren_cond_on_eq_ren_atoms {o} :
  forall ren (a b : @get_patom_set o) atoms1 atoms2,
    no_repeats (range_utok_ren ren)
    -> utok_ren_cond atoms1 ren
    -> utok_ren_cond atoms2 ren
    -> disjoint atoms1 atoms2
    -> LIn a atoms1
    -> LIn b atoms2
    -> ren_atom ren a = ren_atom ren b
    -> False.
Proof.
  introv nrr cond1 cond2 disj ia ib e.
  destruct (get_patom_deq o a b) as [x|x]; subst; tcsp.
  { apply disj in ib; sp. }

  pose proof (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)) as [d1|d1];
    pose proof (in_deq _ (get_patom_deq o) b (dom_utok_ren ren)) as [d2|d2].

  + apply ren_atom_eq1 in e; sp.

  + rw (ren_atom_not_in ren b) in e; auto.

    pose proof (in_deq _ (get_patom_deq o) b (range_utok_ren ren)) as [r|r].

    * pose proof (cond2 b) as h; allsimpl; repeat (autodimp h hyp).

    * pose proof (in_dom_in_range ren a d1) as h.
      rw e in h; sp.

  + rw (ren_atom_not_in ren a) in e; auto.

    pose proof (in_deq _ (get_patom_deq o) a (range_utok_ren ren)) as [r|r].

    * pose proof (cond1 a) as h; allsimpl; repeat (autodimp h hyp).

    * pose proof (in_dom_in_range ren b d2) as h.
      rw <- e in h; sp.

  + rw (ren_atom_not_in ren a) in e; auto.
    rw (ren_atom_not_in ren b) in e; auto.
Qed.

Lemma no_repeats_get_utokens_ren_utokens {o} :
  forall (t : @NTerm o) ren,
    no_repeats (range_utok_ren ren)
    -> no_repeats (get_utokens t)
    -> utok_ren_cond (get_utokens t) ren
    -> no_repeats (get_utokens (ren_utokens ren t)).
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv nrr nrt cond; allsimpl; auto.
  Case "oterm".
  allrw no_repeats_app; repnd; dands; eauto 3 with slow.

  - destruct op; tcsp.
    destruct c; allsimpl; tcsp.

  - rw flat_map_map; unfold compose.

    induction bs; allsimpl; tcsp.
    allrw disjoint_app_r; repnd.
    allrw no_repeats_app; repnd.
    repeat (autodimp IHbs hyp).
    { introv i nr1 nr2; eapply ind; eauto. }
    { allrw @utok_ren_cond_app_iff; tcsp. }
    dands; eauto 3 with slow.

    + destruct a as [l t]; allsimpl.
      eapply ind; eauto.
      allrw @utok_ren_cond_app_iff; tcsp.

    + destruct a as [l1 t1]; allsimpl.
      allrw disjoint_flat_map_r.
      introv i; destruct x as [l2 t2]; allsimpl.
      applydup nrt1 in i; allsimpl.
      allrw @get_utokens_ren_utokens.
      apply disjoint_map_l; introv a b; allrw in_map_iff; exrepnd.

      allrw @utok_ren_cond_app_iff; repnd.
      pose proof (false_if_utok_ren_cond_on_eq_ren_atoms
                    ren x a0 (get_utokens t1) (get_utokens t2)) as h.
      repeat (autodimp h hyp).
      introv p q; apply cond; auto.
      rw lin_flat_map; eexists; dands; eauto.

  - destruct op; try (complete (allsimpl; tcsp)).
    destruct c; allsimpl; tcsp.
    allrw disjoint_singleton_l.
    intro i.
    allrw flat_map_map; allunfold @compose.
    allrw lin_flat_map; exrepnd.
    destruct x as [l t]; allsimpl.
    allrw @get_utokens_ren_utokens; allrw in_map_iff; exrepnd.

    rw cons_as_app in cond.
    allrw @utok_ren_cond_app_iff; repnd.

    pose proof (false_if_utok_ren_cond_on_eq_ren_atoms
                  ren g a [g] (get_utokens t)) as h.
    repeat (autodimp h hyp); allsimpl; tcsp.

    + introv p q; apply cond; auto.
      rw lin_flat_map; eexists; dands; eauto.

    + apply disjoint_singleton_l; intro i.
      destruct nrt; eexists; dands; eauto; simpl; auto.
Qed.

Lemma get_utokens_sub_ren_utokens_sub {o} :
  forall (sub : @Sub o) ren,
    get_utokens_sub (ren_utokens_sub ren sub)
    = map (ren_atom ren) (get_utokens_sub sub).
Proof.
  induction sub; introv; allsimpl; tcsp.
  destruct a as [v t]; allsimpl.
  allrw @get_utokens_sub_cons; allrw map_app.
  rw IHsub.
  rw @get_utokens_ren_utokens; auto.
Qed.

Lemma no_repeats_get_utokens_sub_ren_utokens_sub {o} :
  forall (sub : @Sub o) ren,
    no_repeats (range_utok_ren ren)
    -> no_repeats (get_utokens_sub sub)
    -> utok_ren_cond (get_utokens_sub sub) ren
    -> no_repeats (get_utokens_sub (ren_utokens_sub ren sub)).
Proof.
  induction sub; introv nrr nrs cond; allsimpl;
  allrw @get_utokens_sub_nil; auto.
  destruct a as [v t]; allrw @get_utokens_sub_cons.
  allrw @utok_ren_cond_app_iff; repnd.
  allrw no_repeats_app; dands; repnd; eauto 3 with slow.
  - apply no_repeats_get_utokens_ren_utokens; auto.
  - allrw @get_utokens_ren_utokens.
    allrw @get_utokens_sub_ren_utokens_sub.
    clear IHsub.
    remember (get_utokens t) as atoms1; clear Heqatoms1.
    remember (get_utokens_sub sub) as atoms2; clear Heqatoms2.
    introv i j.
    allrw in_map_iff; exrepnd; subst.
    pose proof (false_if_utok_ren_cond_on_eq_ren_atoms
                  ren a0 a atoms2 atoms1) as h.
    repeat (autodimp h hyp); eauto with slow.
Qed.
Hint Resolve no_repeats_get_utokens_sub_ren_utokens_sub : slow.

Lemma nrut_sub_implies_no_repeats {o} :
  forall (sub : @Sub o) l,
    nrut_sub l sub
    -> no_repeats (get_utokens_sub sub).
Proof.
  introv nr; unfold nrut_sub in nr; sp.
Qed.
Hint Resolve nrut_sub_implies_no_repeats : slow.

Lemma change_nr_ut_sub_in_lsubst_aux_approx_star {o} :
  forall lib (t1 t2 : @NTerm o) ren,
    no_repeats (range_utok_ren ren)
    -> no_repeats (dom_utok_ren ren)
    -> disjoint (range_utok_ren ren) (diff (get_patom_deq o) (dom_utok_ren ren) (get_utokens t1))
    -> disjoint (range_utok_ren ren) (diff (get_patom_deq o) (dom_utok_ren ren) (get_utokens t2))
    -> approx_star lib t1 t2
    -> approx_star lib (ren_utokens ren t1) (ren_utokens ren t2).
Proof.
  nterm_ind1s t1 as [v1|f1 ind1|op1 bs1 ind1] Case; introv norep1 norep2 disj1 disj2 apr.

  - Case "vterm".
    allsimpl.
    constructor.
    inversion apr as [? ? ? apo|?|]; subst; clear apr.

    pose proof (approx_open_change_utoks lib (vterm v1) t2 ren) as h.
    repeat (autodimp h hyp).

  - Case "sterm".
    allsimpl.
    inversion apr as [|? ? ? ? imp aop|]; subst; clear apr.
    econstructor; eauto.
    apply (approx_open_change_utoks _ _ _ ren) in aop; auto.

  - Case "oterm".
    inversion apr as [|?|? ? ? ? ? len lift apo]; subst.

    pose proof (ex_ren_utokens2
                  (oterm op1 lbt1')
                  ren
                  (get_utokens (oterm op1 bs1) ++ get_utokens t2))
      as extra_ren; exrepnd.
    allsimpl; allrw disjoint_app_r; repnd.

    pose proof (approx_open_change_utoks lib (oterm op1 lbt1') t2 (ren ++ ren')) as h.
    allrw @range_utok_ren_app.
    allrw @dom_utok_ren_app.
    allrw no_repeats_app.
    allrw disjoint_app_l; allrw disjoint_app_r.
    repeat (autodimp h hyp); dands; eauto 3 with slow.

    { introv i j; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
      pose proof (extra_ren0 t) as h; allrw in_app_iff; repeat (autodimp h hyp). }

    { introv i j; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
      applydup extra_ren12 in i.
      applydup extra_ren7 in i.
      repndors; tcsp. }

    { introv i j; apply disj2 in i; allrw in_diff; allrw in_app_iff; allrw not_over_or; tcsp. }

    { introv i j; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
      apply extra_ren8 in i; sp. }

    allsimpl.
    rw (ren_utokens_app_weak_l t2) in h;
      [|introv i j; applydup extra_ren3 in i;
        applydup disj2 in i0; allrw in_diff; tcsp].
    rw (ren_utokens_o_app_weak_l op1) in h;
      [|introv i j; applydup extra_ren3 in i;
        applydup disj1 in i0; allrw in_diff;
        allrw in_app_iff; tcsp].

    apply (apso _ _ _ _ (ren_utokens_bs (ren ++ ren') lbt1'));
    allrw map_length; allrw @length_ren_utokens_bs; auto.

    allunfold @lblift_sub;
    allrw map_length; allrw @length_ren_utokens_bs;
    repnd; dands; auto.

    introv i.
    applydup lift in i; clear lift.
    allunfold @blift_sub; exrepnd.
    exists lv (ren_utokens ren nt1) (ren_utokens (ren ++ ren') nt2).
    dands; auto;
    [|rw @selectbt_map; auto;
      apply (alpha_eq_bterm_ren_utokens_b _ _ ren) in i2;
      allsimpl; auto
     |unfold ren_utokens_bs; rw @selectbt_map; auto; try omega;
      apply (alpha_eq_bterm_ren_utokens_b _ _ (ren ++ ren')) in i1;
      allsimpl; auto].

    pose proof (selectbt_in n bs1) as in1; autodimp in1 hyp.
    pose proof (selectbt_in n lbt1') as in2; autodimp in2 hyp; try omega.
    remember (selectbt bs1 n) as b1.
    remember (selectbt lbt1' n) as b2.
    destruct b1 as [l1 u1]; destruct b2 as [l2 u2].
    applydup @alpha_eq_bterm_preserves_osize in i2 as sz1.
    applydup @alpha_eq_bterm_preserves_osize in i1 as sz2.

    assert (subset (get_utokens nt1) (get_utokens_bs bs1)) as ss1.
    { introv a; unfold get_utokens_bs.
      rw lin_flat_map; eexists; dands; eauto; simpl.
      apply alpha_eq_bterm_preserves_utokens in i2; allsimpl; rw i2; auto. }

    assert (subset (get_utokens nt2) (get_utokens_bs lbt1')) as ss2.
    { introv a; unfold get_utokens_bs.
      rw lin_flat_map; eexists; dands; eauto; simpl.
      apply alpha_eq_bterm_preserves_utokens in i1; allsimpl; rw i1; auto. }

    repndors;exrepnd;[left|right].

    + dands; auto;[intro e; apply ren_utok_op_diff_fresh in e; auto|].
      pose proof (ind1 u1 nt1 l1) as q; clear ind1.
      rw sz1 in q.
      repeat (autodimp q hyp); eauto 3 with slow.
      pose proof (q nt2 (ren ++ ren')) as aprs; clear q.
      allrw @range_utok_ren_app.
      allrw @dom_utok_ren_app.
      allrw no_repeats_app.
      allrw disjoint_app_l; allrw disjoint_app_r.
      repeat (autodimp aprs hyp); dands; eauto 3 with slow.

      { introv a b; apply disj1 in a; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd; tcsp. }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply extra_ren10 in a; sp. }

      { introv a b; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
        pose proof (extra_ren0 t) as q; allrw in_app_iff; repeat (autodimp q hyp). }

      { introv a b; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
        applydup extra_ren7 in a; tcsp. }

      rw (ren_utokens_app_weak_l nt1) in aprs; auto.

      introv a b.
      applydup extra_ren3 in a.
      applydup extra_ren2 in a.
      applydup disj1 in a0; allrw in_diff; destruct a2; dands; tcsp.
      rw in_app_iff; right; rw lin_flat_map; eexists; dands; eauto; simpl.
      apply alpha_eq_bterm_preserves_utokens in i2; allsimpl; rw i2; auto.

    + pose proof (ex_ren_utokens_sub2
                    sub
                    (ren ++ ren')
                    (get_utokens nt1
                                 ++ get_utokens nt2
                                 ++ get_utokens (lsubst nt1 sub)
                                 ++ get_utokens (lsubst nt2 sub)))
        as extra_ren'; exrepnd.
      allsimpl; allrw disjoint_app_r; repnd.

      pose proof (ind1 u1 (lsubst nt1 sub) l1) as ih; clear ind1.
      rw sz1 in ih; repeat (autodimp ih hyp).
      { rw @simple_osize_lsubst; eauto with slow. }
      pose proof (ih (lsubst nt2 sub) ((ren ++ ren') ++ ren'0)) as q; clear ih.

      allrw @range_utok_ren_app.
      allrw @dom_utok_ren_app.
      allrw no_repeats_app.
      allrw disjoint_app_l; allrw disjoint_app_r.
      repnd; repeat (autodimp q hyp); dands; eauto 3 with slow.

      { introv a b; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
        apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
        - applydup ss1 in b0.
          applydup disj1 in a.
          allrw in_diff; allrw in_app_iff; allrw not_over_or; sp.
        - apply in_get_utokens_sub in b0; exrepnd.
          apply in_sub_keep_first in b3; repnd.
          apply sub_find_some in b4.
          pose proof (extra_ren'0 t) as r.
          allrw @range_utok_ren_app; allrw @dom_utok_ren_app.
          allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
          apply in_get_utokens_sub.
          eexists; eexists; dands; eauto.
      }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
        - applydup ss1 in b0; tcsp.
          apply extra_ren10 in a; tcsp.
        - apply in_get_utokens_sub in b0; exrepnd.
          apply in_sub_keep_first in b3; repnd.
          apply sub_find_some in b4.
          pose proof (extra_ren'0 t) as r.
          allrw @range_utok_ren_app; allrw @dom_utok_ren_app.
          allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
          apply in_get_utokens_sub.
          eexists; eexists; dands; eauto.
      }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply extra_ren'12 in a; sp.
      }

      { introv a b; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
        apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
        - applydup ss2 in b0.
          pose proof (extra_ren0 t) as q; allrw in_app_iff.
          repeat (autodimp q hyp); tcsp.
        - apply in_get_utokens_sub in b0; exrepnd.
          apply in_sub_keep_first in b3; repnd.
          apply sub_find_some in b4.
          pose proof (extra_ren'0 t) as r.
          allrw @range_utok_ren_app; allrw @dom_utok_ren_app.
          allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
          apply in_get_utokens_sub.
          eexists; eexists; dands; eauto.
      }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
        - applydup ss2 in b0.
          apply extra_ren7 in a; tcsp.
        - apply in_get_utokens_sub in b0; exrepnd.
          apply in_sub_keep_first in b3; repnd.
          apply sub_find_some in b4.
          pose proof (extra_ren'0 t) as r.
          allrw @range_utok_ren_app; allrw @dom_utok_ren_app.
          allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
          apply in_get_utokens_sub.
          eexists; eexists; dands; eauto.
      }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply extra_ren'8 in a; sp.
      }

      repeat (rw @lsubst_ren_utokens in q).

      assert (disjoint (dom_utok_ren ren'0) (get_utokens nt1)) as disj'0nt1.
      { introv a b.
        applydup extra_ren'3 in a.
        applydup extra_ren'2 in a.
        allrw in_app_iff.
        repndors; tcsp.
        - applydup extra_ren'13 in a.
          applydup disj1 in a0; allrw in_diff; allrw in_app_iff; allrw not_over_or.
          destruct a3; dands; tcsp.
        - apply extra_ren10 in a0; tcsp.
      }

      pose proof (ren_utokens_app_weak_l nt1 (ren ++ ren') ren'0 disj'0nt1) as e1.
      rw e1 in q.

      assert (disjoint (dom_utok_ren ren') (get_utokens nt1)) as disj'nt1.
      { introv a b.
        applydup extra_ren3 in a.
        applydup extra_ren2 in a.
        applydup disj1 in a0; allrw in_diff; destruct a2; dands; tcsp.
        rw in_app_iff; right; rw lin_flat_map; eexists; dands; eauto; simpl.
        apply alpha_eq_bterm_preserves_utokens in i2; allsimpl; rw i2; auto.
      }

      pose proof (ren_utokens_app_weak_l nt1 ren ren' disj'nt1) as e2.
      rw e2 in q.

      assert (disjoint (dom_utok_ren ren'0) (get_utokens nt2)) as disj'0nt2.
      { introv a b.
        applydup extra_ren'3 in a.
        applydup extra_ren'2 in a.
        allrw in_app_iff.
        repndors; tcsp.
        - applydup extra_ren'13 in a.
          pose proof (extra_ren0 t) as r; allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
        - apply extra_ren7 in a0; tcsp.
      }

      pose proof (ren_utokens_app_weak_l nt2 (ren ++ ren') ren'0 disj'0nt2) as e3.
      rw e3 in q.

      exists (ren_utokens_sub ((ren ++ ren') ++ ren'0) sub).
      rw @ren_utok_op_diff_fresh.
      rw @dom_sub_ren_utokens_sub.
      dands; auto.

      assert (no_repeats (range_utok_ren ((ren ++ ren') ++ ren'0))) as norep_ren.
      { repeat (rw @range_utok_ren_app).
        repeat (rw no_repeats_app).
        rw disjoint_app_l; dands; eauto with slow. }

      assert (utok_ren_cond (get_utokens_sub sub) ((ren ++ ren') ++ ren'0)) as cond1.
      { introv x y.
        pose proof (extra_ren'0 a) as r.
        allrw @dom_utok_ren_app; allrw @range_utok_ren_app.
        allrw in_app_iff; allrw not_over_or.
        repndors.
        - destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)); tcsp.
          destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')); tcsp.
        - destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)); tcsp.
          destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')); tcsp.
        - apply extra_ren'7 in y; sp. }

      assert (utok_ren_cond (get_utokens nt1) ren) as cond2.
      { introv x y.
        applydup ss1 in x.
        applydup disj1 in y.
        rw in_diff in y0; rw in_app_iff in y0.
        destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)); tcsp.
        destruct y0; dands; tcsp.
      }

      assert (utok_ren_cond (get_utokens nt2) (ren ++ ren')) as cond3.
      { introv x y.
        applydup ss2 in x.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        pose proof (extra_ren0 a) as r.
        allrw in_app_iff.
        destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)); tcsp.
        repndors; tcsp.
        clear r.
        apply extra_ren7 in y; sp.
      }

      unfold nrut_sub; dands; eauto 3 with slow.

      rw <- e3; rw <- e2; rw <- e1.
      repeat (rw @get_utokens_ren_utokens).
      rw @get_utokens_sub_ren_utokens_sub.
      rw <- map_app.
      apply disjoint_map_l; introv u v.
      rw in_map_iff in v; exrepnd.

      pose proof (false_if_utok_ren_cond_on_eq_ren_atoms
                    ((ren ++ ren') ++ ren'0)
                    x a
                    (get_utokens nt1 ++ get_utokens nt2)
                    (get_utokens_sub sub)) as hh.
      allunfold @nrut_sub; repnd.
      repeat (autodimp hh hyp); tcsp.

      clear u.
      apply utok_ren_cond_app.

      { introv z w.
        applydup cond2 in z.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw in_app_iff.
        repndors; tcsp.
        - apply extra_ren10 in w.
          apply ss1 in z; sp.
        - apply extra_ren'10 in w; sp.
      }

      { introv z w.
        applydup cond3 in z.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw in_app_iff.
        repndors; tcsp.
        apply extra_ren'11 in w; sp.
      }
Qed.


Require Import String.
Require Import ExtLib.Data.Strings.
Require Import CoqCompile.Parse.
Require Import CoqCompile.Lambda.
Require Import CoqCompile.CpsKConvert.
Require Import CoqCompile.CpsCommon.
Require Import CoqCompile.Cps.
Require Import CoqCompile.CpsK.
Require Import CoqCompile.CpsKExamples.
Require Import CoqCompile.CloConvK.
Require Import CoqCompile.CpsK2Low.
Require Import CoqCompile.Low.

(*
Extraction Language Scheme.
Recursive Extraction fact.
*)

Definition lambda2low (e:option Lambda.exp) : string.
refine (
  match e with
    | Some e =>
      let cps_e := CpsKConvert.CPS_io e in
      match CPSK.exp_sane (m' := sum string) cps_e with
        | inl err => "CpsConv: " ++ err ++ (String Char.chr_newline (CPSK.exp2string cps_e))
        | inr _ =>
          match ClosureConvert.cloconv_exp cps_e with
            | inl ex => "CloConv: " ++ ex ++ (String Char.chr_newline (CPSK.exp2string cps_e))
            | inr (ds, e) => (* CPSK.exp2string e *)
              match @cpsk2low (sum string) _ _ ds e with
                | inl ex => "Lower: " ++ ex ++ (String Char.chr_newline (CPSK.exp2string cps_e)) (* (String Char.chr_newline (CPSK.exp2string (CPSK.Letrec_e ds e))) *)
                | inr prog => string_of_program prog
              end
          end
      end
    | None => "Parsing failed"%string
  end%string
).
Defined.

Eval compute in lambda2low (Some plus_lam).
Eval compute in lambda2low (Some mult_lam).
Eval compute in lambda2low (Some fact_lam).

Definition identity : string := "(define ident33 (lambda (x) x))"%string.
Definition identity_e := Parse.parse_topdecls identity.
Eval vm_compute in lambda2low identity_e.


Require Import Template.All.
Require Import List.
Import ListNotations.

(* Taken from the template-coq parametricity translation *)

Definition tsl_table := list (global_reference * term).

Fixpoint lookup_tsl_table (E : tsl_table) (gr : global_reference)
  : option term :=
  match E with
  | nil => None
  | hd :: tl =>
    if gref_eq_dec gr (fst hd) then Some (snd hd)
    else lookup_tsl_table tl gr
  end.

Definition default_term := tVar "constant_not_found".

Definition lookup_default (E : tsl_table) (gr : global_reference)
  : term :=
  match (lookup_tsl_table E gr) with
  | None => default_term
  | Some t => t
  end.

(* Partly taken from Template.Typing *)
Fixpoint it_mkLambda_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tLambda d.(decl_name) d.(decl_type) acc
       | Some b => tLetIn d.(decl_name) b d.(decl_type) acc
       end) l t.

Fixpoint it_mkProd_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tProd d.(decl_name) d.(decl_type) acc
       | Some b => tLetIn d.(decl_name) b d.(decl_type) acc
       end) l t.

Fixpoint fold_map_internal {A B C : Type} (f : A -> B -> A * C) (a : A)
         (cs : list C) (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, rev cs)
     | hd :: tl => let (a_, c_) := f a hd in fold_map_internal f a_ (c_ :: cs) tl
     end.

Definition fold_map {A B C : Type} (f : A -> B -> A * C) (a : A)
           (bs : list B) : A * (list C) := fold_map_internal f a [] bs.

Fixpoint fold_map' {A B C : Type} (f : A -> B -> A * C) (a : A)
         (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, [])
     | hd :: tl => let (a_, c_) := f a hd in
                   let (a__, cs) := fold_map' f a_ tl in
                   (a__, c_ :: cs)
     end.

Example ex_fold_map : fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = (6,[2;3;4]).
reflexivity.
Qed.

Example ex_fold_map_fold_map' :
  fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = fold_map' (fun x y => (x+y, y+1)) 0 [1;2;3].
reflexivity.
Qed.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Export Category.Lib.Setoid.
Require Export Category.Lib.Tactics.

Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.NArith.NArith.
Require Import Coq.omega.Omega.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Open Scope lazy_bool_scope.

Lemma K_dec_on_type A (x : A) (eq_dec : ∀ y : A, x = y \/ x ≠ y)
(P : x = x -> Type) :
P eq_refl -> forall p:x = x, P p.
Proof. hammer_hook "Equality" "Equality.K_dec_on_type".
intros.
elim (@Eqdep_dec.eq_proofs_unicity_on A _) with x eq_refl p.
trivial.
exact eq_dec.
Qed.

Lemma Nat_eq_dec' : ∀ (x y : nat), x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.Nat_eq_dec'". intros; destruct (Nat.eq_dec x y); auto. Qed.

Lemma Nat_eq_dec_refl (x : nat) :
Nat.eq_dec x x = left (@eq_refl (nat) x).
Proof. hammer_hook "Equality" "Equality.Nat_eq_dec_refl".
destruct (Nat.eq_dec x x); [| contradiction].
refine (K_dec_on_type (nat) x (Nat_eq_dec' x)
(fun H => @left _ _ H = @left _ _ (@eq_refl (nat) x)) _ _); auto.
Qed.

Lemma Nat_eqb_refl (x : nat) : Nat.eqb x x = true.
Proof. hammer_hook "Equality" "Equality.Nat_eqb_refl". now apply Nat.eqb_eq. Qed.

Lemma Pos_eq_dec' : ∀ x y : positive, x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.Pos_eq_dec'".
intros.
destruct (Pos.eq_dec x y); auto.
Qed.

Lemma Pos_eq_dec_refl n : Pos.eq_dec n n = left (@eq_refl positive n).
Proof. hammer_hook "Equality" "Equality.Pos_eq_dec_refl".
destruct (Pos.eq_dec n n).
refine (K_dec_on_type positive n (Pos_eq_dec' n)
(fun x => @left _ _ x = @left _ _ (@eq_refl positive n)) _ _).
reflexivity.
contradiction.
Qed.

Theorem Pos_eqb_eq (p q : positive) : (p =? q)%positive = true <-> p=q.
Proof. hammer_hook "Equality" "Equality.Pos_eqb_eq".
revert q. induction p; destruct q; simpl; rewrite ?IHp; split; congruence.
Qed.

Fixpoint Pos_eqb_refl (x : positive) : Pos.eqb x x = true :=
match x with
| xI x => Pos_eqb_refl x
| xO x => Pos_eqb_refl x
| xH => eq_refl
end.

Lemma N_eq_dec' : ∀ x y : N, x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.N_eq_dec'".
intros.
destruct (N.eq_dec x y); auto.
Qed.

Lemma N_eq_dec_refl n : N.eq_dec n n = left (@eq_refl N n).
Proof. hammer_hook "Equality" "Equality.N_eq_dec_refl".
destruct (N.eq_dec n n).
refine (K_dec_on_type N n (N_eq_dec' n)
(fun x => @left _ _ x = @left _ _ (@eq_refl N n)) _ _).
reflexivity.
contradiction.
Qed.

Definition nth_safe {a} (xs : list a) (n : nat) (H : (n < length xs)%nat) : a.
Proof. hammer_hook "Equality" "Equality.nth_safe".
induction xs; simpl in *; auto.
contradiction (Nat.nlt_0_r n).
Defined.

Definition nth_pos {a} (xs : list a) (n : positive) (default : a) : a.
Proof. hammer_hook "Equality" "Equality.nth_pos".
generalize dependent n.
induction xs; intros.
exact default.
destruct n using Pos.peano_rect.
exact a0.
exact (IHxs n).
Defined.

Definition within_bounds {A} (x : positive) (xs : list A) : Prop :=
(Nat.pred (Pos.to_nat x) < length xs)%nat.

Definition Pos_to_fin {n} (x : positive) :
(Nat.pred (Pos.to_nat x) < n)%nat -> Fin.t n := Fin.of_nat_lt.

Definition nth_pos_bounded {a} (xs : list a) (n : positive)
(H : within_bounds n xs) : a.
Proof. hammer_hook "Equality" "Equality.nth_pos_bounded".
generalize dependent n.
induction xs; intros.
unfold within_bounds in H; simpl in H; omega.
destruct n using Pos.peano_rect.
exact a0.
clear IHn.
apply IHxs with (n:=n).
unfold within_bounds in *.
simpl in H.
rewrite Pos2Nat.inj_succ in H.
simpl in H.
apply lt_S_n.
rewrite Nat.succ_pred_pos; auto.
apply Pos2Nat.is_pos.
Defined.

Lemma Nat_eqb_eq n m : Nat.eqb n m = true <-> n = m.
Proof. hammer_hook "Equality" "Equality.Nat_eqb_eq".
revert m.
induction n; destruct m; simpl; rewrite ?IHn; split; try easy.
- now intros ->.
- now injection 1.
Defined.

Lemma Fin_eqb_eq : forall n (p q : Fin.t n), Fin.eqb p q = true <-> p = q.
Proof. hammer_hook "Equality" "Equality.Fin_eqb_eq".
apply Fin.rect2; simpl; intros.
- split; intros ; [ reflexivity | now apply Nat_eqb_eq ].
- now split.
- now split.
- split; intros.
* f_equal.
now apply H.
* apply Fin.FS_inj in H0.
now apply H.
Defined.

Lemma Fin_eqb_eq' n (x y : Fin.t n) (H : Fin.eqb x y = true) : x = y.
Proof. hammer_hook "Equality" "Equality.Fin_eqb_eq'".
induction x.
revert H.
apply Fin.caseS with (p:=y); intros; eauto.
simpl in H; discriminate.
revert H.
apply Fin.caseS' with (p:=y); intros; eauto.
simpl in H; discriminate.
simpl in H.
f_equal.
now apply IHx.
Defined.

Lemma Fin_eq_dec {n} (x y : Fin.t n): {x = y} + {x <> y}.
Proof. hammer_hook "Equality" "Equality.Fin_eq_dec".
case_eq (Fin.eqb x y); intros.
- left; now apply Fin_eqb_eq.
- right. intros Heq. apply <- Fin_eqb_eq in Heq. congruence.
Defined.

Lemma Fin_eq_dec' : ∀ n (x y : Fin.t n), x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.Fin_eq_dec'". intros; destruct (Fin_eq_dec x y); auto. Qed.

Lemma Fin_eq_dec_refl n (x : Fin.t n) :
Fin_eq_dec x x = left (@eq_refl (Fin.t n) x).
Proof. hammer_hook "Equality" "Equality.Fin_eq_dec_refl".
destruct (Fin_eq_dec x x).
refine (K_dec_on_type (Fin.t n) x (Fin_eq_dec' n x)
(fun H => @left _ _ H = @left _ _ (@eq_refl (Fin.t n) x)) _ _).
reflexivity.
contradiction.
Qed.

Fixpoint Fin_eqb_refl n (x : Fin.t n) : Fin.eqb x x = true :=
match x with
| @Fin.F1 m'    => Nat_eqb_refl m'
| @Fin.FS n0 p' => Fin_eqb_refl n0 _
end.

Import EqNotations.

Fixpoint nth_fin {a} (xs : list a) (n : Fin.t (length xs)) : a :=
match xs as xs' return length xs = length xs' -> a with
| nil => fun H => Fin.case0 _ (rew H in n)
| cons x xs' => fun H =>
match n in Fin.t n' return length xs = n' -> a with
| Fin.F1 => fun _ => x
| @Fin.FS n0 x => fun H0 =>
nth_fin
xs' (rew (eq_add_S n0 (length xs')
(rew [fun n => n = S (length xs')] H0 in H)) in x)
end eq_refl
end eq_refl.

Class Equality (A : Type) := {
Eq_eq := @eq A;
Eq_eq_refl x := eq_refl;

Eq_eqb : A -> A -> bool;
Eq_eqb_refl x : Eq_eqb x x = true;

Eq_eqb_eq x y : Eq_eqb x y = true -> x = y;

Eq_eq_dec  (x y : A) : { x = y } + { x ≠ y };
Eq_eq_dec_refl x : Eq_eq_dec x x = left (@Eq_eq_refl x)
}.

Program Instance Pos_Eq : Equality positive := {
Eq_eqb         := Pos.eqb;
Eq_eqb_refl    := Pos_eqb_refl;

Eq_eqb_eq x y  := proj1 (Pos_eqb_eq x y);

Eq_eq_dec      := Pos.eq_dec;
Eq_eq_dec_refl := Pos_eq_dec_refl
}.

Program Instance Fin_Eq (n : nat) : Equality (Fin.t n) := {
Eq_eqb         := Fin.eqb;
Eq_eqb_refl    := Fin_eqb_refl n;

Eq_eqb_eq x y  := proj1 (Fin_eqb_eq n x y);

Eq_eq_dec      := Fin_eq_dec;
Eq_eq_dec_refl := Fin_eq_dec_refl n
}.

Fixpoint list_beq {A : Type} (eq_A : A -> A -> bool) (X Y : list A)
{struct X} : bool :=
match X with
| [] => match Y with
| [] => true
| _ :: _ => false
end
| x :: x0 =>
match Y with
| [] => false
| x1 :: x2 => eq_A x x1 &&& list_beq eq_A x0 x2
end
end.

Lemma list_beq_eq {A} (R : A -> A -> bool) xs ys :
(∀ x y, R x y = true -> x = y) ->
list_beq R xs ys = true -> xs = ys.
Proof. hammer_hook "Equality" "Equality.list_beq_eq".
generalize dependent ys.
induction xs; simpl; intros.
destruct ys; congruence.
destruct ys.
discriminate.
destruct (R a a0) eqn:Heqe.
apply H in Heqe; subst.
erewrite IHxs; eauto.
discriminate.
Qed.

Lemma list_beq_refl {A} (R : A -> A -> bool) xs :
(∀ x, R x x = true) -> list_beq R xs xs = true.
Proof. hammer_hook "Equality" "Equality.list_beq_refl".
intros.
induction xs; auto; simpl.
now rewrite H.
Qed.

Program Instance list_Eq `{Equality A} : Equality (list A) := {
Eq_eqb         := list_beq Eq_eqb;
Eq_eqb_refl x  := list_beq_refl Eq_eqb x Eq_eqb_refl;

Eq_eqb_eq x y  := list_beq_eq Eq_eqb x y Eq_eqb_eq;

Eq_eq_dec      := list_eq_dec Eq_eq_dec;
Eq_eq_dec_refl := _
}.
Next Obligation.
induction x; simpl; auto.
unfold sumbool_rec, sumbool_rect.
rewrite Eq_eq_dec_refl, IHx.
reflexivity.
Qed.

Definition prod_eqb {A B} (A_eqb : A -> A -> bool) (B_eqb : B -> B -> bool)
(x y : A * B) : bool :=
A_eqb (fst x) (fst y) && B_eqb (snd x) (snd y).

Program Definition prod_eq_dec {A B}
(A_eq_dec : forall x y : A, {x = y} + {x ≠ y})
(B_eq_dec : forall x y : B, {x = y} + {x ≠ y})
(x y : A * B) : {x = y} + {x ≠ y} :=
match A_eq_dec (fst x) (fst y) with
| in_left =>
match B_eq_dec (snd x) (snd y) with
| in_left  => in_left
| in_right => in_right
end
| in_right => in_right
end.
Next Obligation. simpl in *; congruence. Qed.

Lemma prod_eq_dec' :
∀ (A B : Type) (A_eq_dec : ∀ x y : A, x = y ∨ x ≠ y)
(B_eq_dec : ∀ x y : B, x = y ∨ x ≠ y)
(x y : A ∧ B), x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.prod_eq_dec'".
intros.
destruct x, y; simpl.
destruct (A_eq_dec a a0); subst.
destruct (B_eq_dec b b0); subst.
left; reflexivity.
right; congruence.
right; congruence.
Qed.

Lemma prod_eq_dec_refl (A B : Type) n
(A_eq_dec : ∀ x y : A, x = y ∨ x ≠ y)
(B_eq_dec : ∀ x y : B, x = y ∨ x ≠ y) :
prod_eq_dec A_eq_dec B_eq_dec n n = left (@eq_refl (A ∧ B) n).
Proof. hammer_hook "Equality" "Equality.prod_eq_dec_refl".
destruct (prod_eq_dec _ _ n n).
refine (K_dec_on_type (A ∧ B) n (prod_eq_dec' _ _ A_eq_dec B_eq_dec n)
(fun x => @left _ _ x = @left _ _ (@eq_refl (A ∧ B) n)) _ _).
reflexivity.
contradiction.
Qed.

Program Instance prod_Eq `{Equality A} `{Equality B} : Equality (prod A B) := {
Eq_eqb           := prod_eqb Eq_eqb Eq_eqb;
Eq_eqb_refl      := _;

Eq_eqb_eq x y    := _;

Eq_eq_dec        := prod_eq_dec Eq_eq_dec Eq_eq_dec;
Eq_eq_dec_refl x := prod_eq_dec_refl _ _ x Eq_eq_dec Eq_eq_dec
}.
Next Obligation.
unfold prod_eqb; simpl.
now rewrite !Eq_eqb_refl.
Defined.
Next Obligation.
unfold prod_eqb in H1; simpl in H1.
apply andb_true_iff in H1.
destruct H1.
apply Eq_eqb_eq in H1.
apply Eq_eqb_eq in H2.
now subst.
Defined.

Ltac equalities' :=
simplify;
match goal with
| [ H : (?X; _) = (?X; _) |- _ ] =>
try (apply Eqdep_dec.inj_pair2_eq_dec in H; [|apply Eq_eq_dec])

| [ H : context[Pos.eq_dec ?N ?M] |- _ ] =>
replace (Pos.eq_dec N M) with (Eq_eq_dec N M) in H
| [ |- context[Pos.eq_dec ?N ?M] ] =>
replace (Pos.eq_dec N M) with (Eq_eq_dec N M)
| [ H : context[(?N =? ?M)%positive] |- _ ] =>
replace ((N =? M)%positive) with (Eq_eqb N M) in H
| [ |- context[(?N =? ?M)%positive] ] =>
replace ((N =? M)%positive) with (Eq_eqb N M)

| [ H : context[@Fin_eq_dec ?N ?X ?Y] |- _ ] =>
replace (@Fin_eq_dec N X Y) with (Eq_eq_dec X Y) in H
| [ |- context[Fin_eq_dec ?N ?X ?Y] ] =>
replace (@Fin_eq_dec N X Y) with (Eq_eq_dec X Y)
| [ H : context[@Fin.eqb ?N ?X ?Y] |- _ ] =>
replace (@Fin.eqb ?N ?X ?Y) with (Eq_eqb X Y) in H
| [ |- context[@Fin.eqb ?N ?X ?Y] ] =>
replace (@Fin.eqb ?N ?X ?Y) with (Eq_eqb X Y)

| [ |- Eq_eqb ?X ?X = true ]     => apply Eq_eqb_refl
| [ H : Eq_eqb _ _ = true |- _ ] => apply Eq_eqb_eq in H
| [ |- Eq_eqb _ _ = true ]       => apply Eq_eqb_eq

| [ H : context[match Eq_eq_dec ?X ?X with _ => _ end] |- _ ] =>
rewrite (Eq_eq_dec_refl X) in H
| [ |- context[match Eq_eq_dec ?X ?X with _ => _ end] ] =>
rewrite (Eq_eq_dec_refl X)
| [ H : context[match Eq_eq_dec ?X ?Y with _ => _ end] |- _ ] =>
destruct (Eq_eq_dec X Y); subst
| [ |- context[match Eq_eq_dec ?X ?Y with _ => _ end] ] =>
destruct (Eq_eq_dec X Y); subst

| [ H : list_beq _ _ _ = true |- _ ] => apply list_beq_eq in H
| [ |- list_beq _ _ _ = true ]       => apply list_beq_eq
end.

Ltac equalities :=
try equalities';
repeat (
equalities';
subst; simpl; auto;
try discriminate;
try tauto;
try intuition idtac;
subst; simpl; auto).


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

(**********************************************************************)
(*                   Substitution.v                                   *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(* adapted from Substitution.v of Project Coq  to act on Tree-terms   *)
(**********************************************************************)

Require Import Arith Omega List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.Tree_Terms.
Require Import IntensionalLib.Tree_calculus.Tree_Tactics.
Require Import IntensionalLib.Tree_calculus.Tree_reduction.
Require Import IntensionalLib.Tree_calculus.Tree_Normal.
Require Import IntensionalLib.Tree_calculus.Tree_Closed.

(* Lifting *)

Definition relocate (i k n : nat) :=
  match test k i with
   (* k<=i *) | left _ => n+i
   (* k>i  *) | _ => i
  end.

Lemma relocate_null :
forall (n n0 : nat), relocate n n0 0 = n.
Proof. split_all. unfold relocate. case (test n0 n); intro; auto with arith. Qed.

Lemma relocate_lessthan : forall m n k, m<=k -> relocate k m n = (n+k).
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.
Lemma relocate_greaterthan : forall m n k, m>k -> relocate k m n = k.
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.

Ltac relocate_lt :=
try (rewrite relocate_lessthan; [| omega]; relocate_lt);
try (rewrite relocate_greaterthan; [| omega]; relocate_lt);
try(rewrite relocate_null).

Lemma relocate_zero_succ :
forall n k, relocate 0 (S n) k = 0.
Proof.  split_all. Qed.

Lemma relocate_succ :
forall n n0 k, relocate (S n) (S n0) k = S(relocate n n0 k).
Proof.
intros; unfold relocate. elim(test(S n0) (S n)); elim(test n0 n); split_all.
noway.
noway.
Qed.

Lemma relocate_mono : forall M N n k, relocate M n k = relocate N n k -> M=N.
Proof.
intros M N n k.
unfold relocate.
elim(test n M); elim(test n N); split_all; omega.
Qed.

Lemma relocate_null2 :
forall n k, relocate 0 (S n) k = 0.
Proof. split_all. Qed.

Fixpoint lift_rec (L : Tree) : nat -> nat -> Tree :=
  fun k n =>
  match L with
  | Ref i => Ref (relocate i k n)
  | Op o => Op o
  | App M N => App (lift_rec M k n) (lift_rec N k n)
   end.

Definition lift (n : nat) (N : Tree) := lift_rec N 0 n.

(* Lifting lemmas *)

Lemma lift_rec_null_term :
forall (U : Tree)(n: nat), lift_rec U n 0 = U.
Proof.
simple induction U; split_all.
relocate_lt; auto.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift1 :
 forall (U : Tree) (j i k : nat),
 lift_rec (lift_rec U i j) (j + i) k = lift_rec U i (j + k).
Proof.
simple induction U; simpl in |- *;  split_all.
unfold relocate.
elim (test i n); elim (test (j+i) (j+ n)); split_all; try noway.
assert(k + (j + n) = j + k + n) by omega. congruence.
elim (test (j + i) n); split_all; try noway. rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift_lift_rec :
 forall (U : Tree) (k p n i : nat),
 i <= n ->
 lift_rec (lift_rec U i p) (p + n) k = lift_rec (lift_rec U n k) i p.
Proof.
simple induction U; simpl in |- *;  split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i (k+n)); split_all; try noway.
assert(k+(p+n) = p+ (k+n)) by omega.
rewrite H0; auto.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) n); split_all; try noway.
elim(test i n); split_all; try noway.
(* Ap *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma lift_lift_term :
 forall (U : Tree) (k p n : nat),
 lift_rec (lift p U) (p+ n) k = lift p (lift_rec U n k).
Proof.
unfold lift in |- *; intros; apply lift_lift_rec; trivial with arith.
Qed.

Lemma liftrecO : forall (U : Tree) (n : nat), lift_rec U n 0 = U.
Proof.
simple induction U; simpl in |- *; intros; split_all; relocate_lt; congruence.
Qed.

Lemma liftO : forall (U : Tree) , lift 0 U = U.
Proof.
unfold lift in |- *; split_all; apply liftrecO.
Qed.

Lemma lift_rec_lift_rec :
 forall (U : Tree) (n p k i : nat),
 k <= i + n ->
 i <= k -> lift_rec (lift_rec U i n) k p = lift_rec U i (p + n).

Proof.
simple induction U; split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test k (n0 + n)); split_all; try noway.
replace (p+(n0+n)) with (p + n0 + n) by omega. auto.
elim(test k n); split_all; try noway.
(* Ap *)
rewrite H; split_all; rewrite H0; split_all; split_all.
Qed.

Lemma lift_rec_lift :
 forall (U : Tree)  (n p k i : nat),
 k <= n -> lift_rec (lift  n U)  k p = lift (p + n) U.
Proof.
unfold lift in |- *; intros; rewrite lift_rec_lift_rec; trivial with arith.
Qed.

Lemma lift_rec_lift2 :
forall M n k, lift_rec (lift 1 M) (S n) k = lift 1 (lift_rec M n k).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite lift_lift_rec; auto.
omega.
Qed.

Lemma lift_rec_app: forall M N n k, lift_rec (App M N) n k = App (lift_rec M n k) (lift_rec N n k).
Proof. split_all. Qed.
Lemma lift_rec_op: forall o n k, lift_rec (Op o) n k = Op o.
Proof. split_all. Qed.
Lemma lift_rec_ref: forall i n k, lift_rec (Ref i) n k = Ref (relocate i n k).
Proof. split_all. Qed.

Lemma lift_rec_not_ref_0 : forall M, lift_rec M 0 1 <> Ref 0.
Proof. induction M; split_all; try discriminate. case n; split_all; discriminate. Qed.

Lemma lift_rec_null :
forall (U : Tree) (n: nat), lift_rec U n 0 = U.
Proof. simple induction U; split_all.
 rewrite relocate_null; congruence.
rewrite H; auto. rewrite H0; auto.
Qed.

Ltac  lift_tac :=
unfold_op; rewrite ? lift_rec_app; rewrite ? lift_rec_op; rewrite ? lift_rec_ref; relocate_lt;
rewrite ? lift_rec_not_ref_0.

Lemma lift_rec_preserves_compound :
forall (M: Tree), compound M -> forall (n k : nat), compound(lift_rec M n k).
Proof.
intros M c; induction c; split_all.
Qed.
Hint Resolve lift_rec_preserves_compound.

Lemma lift_rec_preserves_status:
forall M n k, status (lift_rec M n k) = status M.
Proof.
match goal with
  | |- forall M, ?P  =>   cut (forall p M, p >= rank M -> P );
      [intros H M;  eapply2 H |
       intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
      ]
  end.

induction M; split_all.
rewrite IHM1. (* pepm 2: omega.  *)
gen_case H M1. gen_case H t. gen_case H t1. gen_case H o. eapply2 IHp; omega. omega.
Qed.

Lemma lift_rec_preserves_normal: forall M n k, normal M -> normal (lift_rec M n k).
Proof. induction M; intros. split_all. split_all.
inversion H. apply nf_active; fold lift_rec; auto.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
rewrite lift_rec_preserves_status. auto.
simpl. eapply2 nf_compound.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
eapply2 lift_rec_preserves_compound.
Qed.

Lemma lift_rec_closed: forall M n k, maxvar M = 0 -> lift_rec M n k = M.
Proof. induction M; split_all. omega. max_out. rewrite IHM1; auto;  rewrite IHM2; auto. Qed.

Lemma map_lift0 : forall Ms, map (lift 0) Ms = Ms.
Proof. induction Ms; split_all.   rewrite IHMs. unfold lift; rewrite lift_rec_null. auto. Qed.

Lemma lift_preserves_maxvar2:
  forall M, forall k, maxvar (lift k M) - k = maxvar M.
Proof.
  induction M; split_all. relocate_lt. induction k; split_all.
  rewrite max_minus. unfold lift in *; rewrite IHM1; rewrite IHM2; auto.
Qed.

Lemma lift_rec_reflects_compound : forall M n k, compound (lift_rec M n k) -> compound M.
Proof.
induction M; split_all; inversion H; subst; split_all.
gen_case H1 M1; try discriminate.  invsub.
gen_case H1 M1; try discriminate. inversion H1.
gen_case H2 t; try discriminate. case o; auto.
Qed.

Lemma lift_rec_reflects_normal : forall M n k, normal (lift_rec M n k) -> normal M.
Proof.
induction M; split_all. inversion H; split_all.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
rewrite lift_rec_preserves_status in *. eapply2 nf_active.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
eapply2 nf_compound. eapply2 lift_rec_reflects_compound.
Qed.

(* Substitution *)

Definition insert_Ref (N : Tree) (i k : nat) :=
  match compare k i with

   (* k<i *) | inleft (left _) => Ref (pred i)
   (* k=i *) | inleft _ => lift k N
   (* k>i *) | _ => Ref i
  end.

Fixpoint subst_rec (L : Tree) : Tree -> nat -> Tree :=
  fun (N : Tree) (k : nat) =>
  match L with
  | Ref i => insert_Ref N i k
  | Op o => Op o
  | App M M' => App (subst_rec M N k) (subst_rec M' N k)
  end.

Lemma subst_rec_op:
forall o N k, subst_rec (Op o) N k = Op o.
Proof.  split_all. Qed.

Lemma subst_rec_app:
forall M1 M2 N k, subst_rec (App M1 M2) N k = App (subst_rec M1 N k) (subst_rec M2 N k).
Proof.  split_all. Qed.

Lemma subst_rec_ref: forall i N k,  subst_rec (Ref i) N k = insert_Ref N i k.
Proof.  split_all. Qed.

Definition subst (M N : Tree) := subst_rec M N 0.

(* The three cases of substitution of U for (Ref n) *)

Lemma subst_eq :
 forall (M U : Tree) (n : nat), subst_rec (Ref n) U n = lift n U.
Proof.
simpl in |- *; unfold insert_Ref in |- *; split_all.
elim (compare n n); intro P; try noway.
elim P; intro Q; simpl in |- *; trivial with arith; try noway.
Qed.

Lemma subst_gt :
 forall (M U : Tree) (n p : nat),
 n > p -> subst_rec (Ref n) U p = Ref (pred n).
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P.
elim P; intro Q; trivial with arith.
absurd (n > p); trivial with arith; rewrite Q; trivial with arith.
absurd (n > p); auto with arith.
Qed.

Lemma subst_lt :
 forall (M U : Tree) (n p : nat), p > n -> subst_rec (Ref n) U p = Ref n.
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P; trivial with arith.
absurd (p > n); trivial with arith; elim P; intro Q; auto with arith.
rewrite Q; trivial with arith.
Qed.

(* Substitution lemma *)

Lemma lift_rec_subst_rec :
 forall (V U : Tree) (k p n : nat),
 lift_rec (subst_rec V U p) (p + n) k =
 subst_rec (lift_rec V (S (p + n)) k) (lift_rec U n k) p.
Proof.
simple induction V; split_all.
(* 1 Ref *)
unfold insert_Ref, relocate in |- *.
elim (test (S(p + n0)) n); elim (compare p n); split_all.
elim a; elim(compare p (k+n)); split_all.
unfold relocate.
elim(test (p+n0) (pred n)); elim a1; split_all; try noway.
replace (k + pred n) with (pred (k + n)) by omega; auto.
noway.
noway.
noway.
noway.
elim a; split_all.
unfold relocate. elim(test(p+n0) (pred n)); split_all.
noway.
unfold lift.
rewrite lift_lift_rec; auto; omega.
unfold relocate.
elim(test (p+n0) n); split_all.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

Lemma lift_subst :
 forall (U V : Tree) (k n : nat),
 lift_rec (subst U V) n k =
 subst (lift_rec U (S n) k) (lift_rec V n k).
Proof.
unfold subst in |- *; intros.
replace n with (0 + n).
rewrite lift_rec_subst_rec; trivial with arith.
auto.
Qed.

Lemma subst_rec_lift_rec1 :
 forall (U V : Tree) (n p k : nat),
 k <= n ->
 subst_rec (lift_rec U k p) V (p + n) =
 lift_rec (subst_rec U V n) k p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
(* Ref *)
unfold insert_Ref, relocate.
elim(test k n); split_all.
elim(compare n0 n); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (p+n0) (p+n)); split_all.
elim a2; split_all; try noway.
unfold relocate.
elim(test k (pred n)); split_all; try noway.
assert(pred (p+n) = p + pred n) by omega. auto.
noway.
elim(compare (p+n0) (p+n)); split_all.
elim a1; split_all; try noway.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
elim(compare (p+n0) (p+n)); split_all.
elim a0; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare n0 n); split_all; try noway.
elim a; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
(* 1 *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma subst_rec_lift1 :
 forall (U V : Tree) (n p : nat),
 subst_rec (lift p U) V (p + n) = lift p (subst_rec U V n).
Proof.
unfold lift in |- *; intros; rewrite subst_rec_lift_rec1;
 trivial with arith.
Qed.

Lemma subst_rec_lift_rec :
 forall (U V : Tree) (p q n : nat),
 q <= p + n ->
 n <= q -> subst_rec (lift_rec U n (S p)) V q = lift_rec U n p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
unfold relocate. elim(test n0 n); split_all.
unfold insert_Ref.
elim(compare q (S(p+n))); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare q n); split_all; try noway.
elim a; split_all; try noway.

(* 1 *)
rewrite H; split_all.
rewrite H0; auto.
Qed.

(* subst_rec_subst_rec *)

Lemma subst_rec_subst_rec :
 forall (V U W : Tree) (n p : nat),
 subst_rec (subst_rec V U p) W (p + n) =
 subst_rec (subst_rec V W (S (p + n))) (subst_rec U W n) p.
Proof.
simple induction V;  split_all.

unfold insert_Ref in |- *.
elim (compare p n); split_all.
elim a; split_all.
elim (compare (S (p + n0)) n); split_all.
elim a1; split_all; try noway.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a3; split_all; try noway.
elim (compare p (pred n)); split_all; try noway.
elim a5; split_all; try noway.
unfold lift; split_all.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a2; split_all; try noway.
subst. unfold lift.
rewrite subst_rec_lift_rec; split_all; try omega.
unfold insert_Ref.
elim(compare (p+n0) (pred n)); split_all; try noway.
elim a1; split_all; try noway.
elim(compare p n); split_all; try noway.
elim a1; split_all; try noway.
elim (compare (S (p + n0)) n); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a0; split_all; try noway.
unfold lift.
subst.
rewrite subst_rec_lift_rec1; split_all.  omega.

unfold insert_Ref.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare (S(p+n0)) n); split_all; try noway.
elim a; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a; split_all; try noway.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma subst_rec_subst_0 :
 forall (U V W : Tree) (n : nat),
 subst_rec (subst_rec V U 0) W n =
 subst_rec (subst_rec V W (S n)) (subst_rec U W n) 0.
Proof.
intros; pattern n at 1 3 in |- *.
replace n with (0 + n) by trivial with arith.
rewrite (subst_rec_subst_rec V U W n 0); trivial with arith.
Qed.

(**************************)
(* The Substitution Lemma *)
(**************************)

Lemma substitution :
 forall (U V W : Tree) (n : nat),
 subst_rec (subst U V) W n =
 subst (subst_rec U W (S n)) (subst_rec V W n).
Proof.
unfold subst in |- *; intros; apply subst_rec_subst_0; trivial with arith.
Qed.

(* to show (\ t)0 -> t  *)

Lemma subst_lift_null :
forall (W V : Tree)(n : nat), subst_rec (lift_rec W n 1) V n = W.
Proof.
simple induction W; split_all.
unfold insert_Ref.
unfold relocate.
elim(test n0 n); split_all.
elim(compare n0 (S n)); split_all.
elim a0; split_all; noway.
noway.
elim(compare n0 n); split_all.
elim a; split_all. noway.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

(* more  Properties *)

Lemma subst_rec_lift2 :
forall M N n , subst_rec (lift 1 M) N (S n)  = lift 1 (subst_rec M N n).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite subst_rec_lift_rec1; auto.
omega.
Qed.

Lemma insert_Ref_lt : forall M n k, n< k -> insert_Ref M n k = Ref n.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
Qed.

Lemma insert_Ref_eq : forall M n k, n= k -> insert_Ref M n k = lift k M.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Lemma insert_Ref_gt : forall M n k, n> k -> insert_Ref M n k = Ref (pred n).
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Ltac insert_Ref_out :=
try (rewrite insert_Ref_lt; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_eq; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_gt; [|unfold relocate; split_all; omega]; insert_Ref_out).

Lemma fold_subst :  forall M1 M2 N, App (subst_rec M1 N 0) M2 = subst (App M1 (lift 1 M2)) N.
Proof.
  unfold subst, lift, subst_rec; split_all; fold subst_rec.
  rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null; auto.
Qed.

Ltac  subst_tac :=
unfold_op; unfold subst;
rewrite ? subst_rec_app; rewrite ? subst_rec_op; rewrite ? subst_rec_ref;
rewrite ? subst_rec_lift_rec; try omega; rewrite ? lift_rec_null;
unfold subst_rec; fold subst_rec; insert_Ref_out; unfold pred.

Definition subst_preserves_l (red: termred) :=
forall (M M' N : Tree), red M M' -> red  (subst M N) (subst M' N).

Definition subst_preserves_r (red: termred) :=
forall (M N N' : Tree), red N N' -> red  (subst M N) (subst M N').

Definition subst_preserves (red: termred) :=
forall (M M' : Tree), red M M' -> forall N N', red N N' ->
red  (subst M N) (subst M' N').

Lemma subst_preserves_l_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_l (multi_step red).
Proof. unfold subst_preserves_l.
 induction 2; split_all.
apply succ_red with (subst N0 N); auto.
Qed.

Lemma subst_preserves_r_multi_step :
forall (red: termred), subst_preserves_r red -> subst_preserves_r (multi_step red).
Proof. unfold subst_preserves_r.
 induction 2; split_all.
apply succ_red with (subst M N); auto.
Qed.

Lemma subst_preserves_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_r red -> subst_preserves (multi_step red).
Proof.
unfold subst_preserves. split_all.
assert(transitive (multi_step red)) by eapply2 transitive_red.
unfold transitive in *.
apply X with  (subst M' N); auto.
eapply2 subst_preserves_l_multi_step.
eapply2 subst_preserves_r_multi_step.
Qed.

Lemma subst_preserves_compound:
forall (M: Tree), compound M -> forall N, compound(subst M N).
Proof. intros M c; induction c; unfold subst; split_all. Qed.
Hint Resolve subst_preserves_compound.

Lemma  subst_rec_preserves_components_l : forall (M : Tree) n k, compound M ->
  subst_rec(left_component M) n k = left_component(subst_rec M n k).
Proof. induction M; split_all; inv1 compound. Qed.

Lemma  subst_rec_preserves_components_r :
forall (M : Tree),  compound M -> forall n k,
subst_rec(right_component M) n k = right_component(subst_rec M n k).
Proof. induction M; split_all; inversion H; subst; split_all. Qed.
Lemma subst_rec_preserves_compounds:
forall M N k, compound M -> compound (subst_rec M N k).
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_left_component:
forall M N k, compound M ->
              subst_rec (left_component M) N k = left_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_right_component:
forall M N k, compound M ->
              subst_rec (right_component M) N k = right_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_preserves_sf_red1 : subst_preserves sf_red1.
Proof.
red.
intros M M' R; induction R; unfold subst; split_all.
(* 5 *)
unfold insert_Ref. elim(compare 0 i); split_all. elim a; split_all.
unfold lift. repeat rewrite lift_rec_null_term; auto.
(* 4 *)
eapply2 app_sf_red.
(* 3 *)
eapply2 s_red.
(* 2 *)
eapply2 k_red.
(* 1 *)
eapply2 f_red.
Qed.

Lemma subst_preserves_sf_red : subst_preserves sf_red.
Proof. eapply2 subst_preserves_multi_step. red; split_all.
eapply2 subst_preserves_sf_red1. red; split_all.
eapply2 subst_preserves_sf_red1.
Qed.

Lemma subst_rec_closed: forall M N k, maxvar M <= k -> subst_rec M N k = M.
Proof.
induction M; split_all.
unfold insert_Ref. elim(compare k n); split_all. elim a; split_all. noway. noway.
assert (max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert (max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega;  rewrite IHM2; try omega. auto.
Qed.

Lemma subst_decreases_maxvar :
forall M N,  max (pred (maxvar M)) (maxvar N) >= maxvar(subst M N).
Proof.
unfold subst; induction M; split_all.
unfold insert_Ref.
case n; split_all. unfold lift. rewrite lift_rec_null_term. auto.
case (maxvar N); split_all.
assert(max n0 n1  >= n0) by eapply2 max_is_max.
omega.
omega.
(* 1 *)
rewrite max_pred.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M1)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M2)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max(max (pred (maxvar M1)) (maxvar N)) (max (pred (maxvar M2)) (maxvar N))).
eapply2 max_max2.
assert(max (max (pred (maxvar M1)) (maxvar N))
         (max (pred (maxvar M2)) (maxvar N))>=
max (maxvar (subst_rec M1 N 0)) (maxvar (subst_rec M2 N 0))).
eapply2 max_monotonic.
omega.
Qed.

Lemma subst_closed : forall M, maxvar M = 0 -> forall N, subst M N = M.
Proof.
induction M; split_all; subst. omega.
max_out. unfold subst in *; simpl. rewrite IHM1; try omega; rewrite IHM2; try omega; split_all.
Qed.

Ltac closed_tac M := repeat (rewrite (subst_rec_closed M); [| auto]);
                     repeat (rewrite (lift_rec_closed M); [| auto]).

Lemma fold_subst_list:
  forall sigma M N,  App (fold_left subst sigma M) N =
                     fold_left subst sigma (App M (lift (length sigma) N)).
Proof.
  induction sigma; split_all.
  (* 2 *)
  unfold lift; rewrite lift_rec_null. auto.
  (* 1 *)
  rewrite IHsigma. unfold subst. simpl. unfold lift. rewrite subst_rec_lift_rec; try omega. auto.
Qed.

Lemma list_subst_preserves_op:
  forall sigma o, fold_left subst sigma (Op o) = Op o.
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_app:
  forall sigma M N, fold_left subst sigma (App M N) =
                    App (fold_left subst sigma M) (fold_left subst sigma N).
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_sf_red:
  forall sigma M N, sf_red M N -> sf_red (fold_left subst sigma M) (fold_left subst sigma N).
Proof.  induction sigma; split_all. eapply2 IHsigma. eapply2 subst_preserves_sf_red. Qed.

Lemma list_subst_lift: forall sigma M, fold_left subst sigma (lift (length sigma) M) = M.
Proof.
  induction sigma; split_all. unfold lift; rewrite lift_rec_null. auto.
unfold lift, subst. rewrite subst_rec_lift_rec; try omega. unfold lift in *. rewrite IHsigma. auto.
Qed.

Lemma lift_rec_preserves_variables: forall M n k, maxvar M >0 -> maxvar (lift_rec M n k) > 0.
Proof.
induction M; split_all.
omega.
assert((maxvar M1 > 0) \/ (maxvar M2 >0)).
gen_case H (maxvar M1). left; omega.
inversion H0; subst.
assert(Nat.max (maxvar (lift_rec M1 n k)) (maxvar (lift_rec M2 n k))  >= maxvar (lift_rec M1 n k)) by eapply2 max_is_max.
assert(maxvar(lift_rec M1 n k) >0) by eapply2 IHM1. omega.
assert(Nat.max (maxvar (lift_rec M1 n k)) (maxvar (lift_rec M2 n k))  >= maxvar (lift_rec M2 n k)) by eapply2 max_is_max.
assert(maxvar(lift_rec M2 n k) >0) by eapply2 IHM2. omega.
Qed.