(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 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/>.

  Websites: http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_lib.
Require Export sequents_tacs2.
Require Export rules_useful.
Require Export subst_tacs_aeq.
Require Export cequiv_tacs.
Require Export per_can.
Require Export cequiv_util.
Require Export per_props_cequiv.

(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(* begin hide *)

(* !!MOVE *)
Lemma covered_subst_implies {o} :
  forall (t : @NTerm o) x u vs,
    covered (subst t x u) vs
    -> covered t (x :: vs).
Proof.
  introv cov.
  allunfold @covered.
  allrw subvars_eq.
  introv i.
  pose proof (eqset_free_vars_disjoint t [(x,u)]) as h.
  eapply subset_eqset_l in h;[|eauto]; allsimpl.
  rw subset_app in h; repnd.
  rw <- subvars_eq in h0.
  rw subvars_remove_nvars in h0.
  rw subvars_eq in h0.
  apply h0 in i.
  rw in_app_iff in i; allsimpl; repndors; tcsp.
Qed.

(* end hide *)

(**

  The following rule states that we can always replace an [a] for a
  [b] in the conclusion of a sequent if [a] and [b] are
  computationally equivalent:

<<
  H |- C[a] ext t

    By cequivSubstConcl

    H |- C[b] ext t
    H |- a ~ b
>>

 *)

Definition rule_cequiv_subst_hyp1 {o} (H : @bhyps o) x C a t :=
  mk_baresequent H (mk_concl (subst C x a) t).

Definition rule_cequiv_subst_hyp2 {o} (H : @bhyps o) a b :=
  mk_baresequent H (mk_conclax (mk_cequiv a b)).

Definition rule_cequiv_subst_concl {o}
           (H : @barehypotheses o)
           (x : NVar)
           (C a b t  : NTerm) :=
  mk_rule
    (rule_cequiv_subst_hyp1 H x C a t)
    [ rule_cequiv_subst_hyp1 H x C b t,
      rule_cequiv_subst_hyp2 H a b
    ]
    [].

Lemma rule_cequiv_subst_concl_true3 {o} :
  forall lib (H  : @barehypotheses o)
         (x : NVar)
         (C a b t  : NTerm),
    rule_true3 lib (rule_cequiv_subst_concl H x C a b t).
Proof.
  intros.
  unfold rule_cequiv_subst_concl, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [ws1 hyp1].
  destruct Hyp0 as [ws2 hyp2].

  assert (wf_csequent (rule_cequiv_subst_hyp1 H x C a t)) as wfs by prove_seq.
  exists wfs.
  unfold wf_csequent, wf_sequent, wf_bseq in wfs; allsimpl; repnd; proof_irr; GC.
  destseq; allsimpl; proof_irr; GC.

  vr_seq_true.
  vr_seq_true in hyp1.
  vr_seq_true in hyp2.

  pose proof (hyp1 s1 s2 eqh sim) as hh; clear hyp1; exrepnd.

  assert (wf_term a # wf_term b) as wfab.
  { clear hyp2; allrw <- @wf_cequiv_iff; auto. }
  repnd.

  assert (cover_vars a s1 # cover_vars b s1) as cov1.
  { clear hyp2.
    allrw @covered_cequiv; repnd.
    dands; eapply s_cover_typ1; eauto. }

  assert (cover_vars a s2 # cover_vars b s2) as cov2.
  { clear hyp2.
    allrw @covered_cequiv; repnd.
    dands; eapply s_cover_typ2; eauto. }

  repnd.
  dands.

  - repeat (lsubstc_subst_aeq2;[]).
    repeat (substc_lsubstc_vars3;[]).

    eapply tequality_respects_cequivc_left;
      [|eapply tequality_respects_cequivc_right;
         [|exact hh0]
      ].

    + pose proof (hyp2 s1 s1) as qq; clear hyp2.
      repeat (autodimp qq hyp); eauto 3 with slow.
      { apply similarity_refl in sim; auto. }
      exrepnd.
      lsubst_tac.
      allrw <- @member_cequiv_iff.
      apply cequiv_stable; spcast; proof_irr.

      apply cequivc_lsubstc.

      { apply isprogram_csubst; eauto 2 with slow. }
      { apply isprogram_csubst; eauto 2 with slow. }

      apply ceq_csub_cons; eauto 3 with slow.
      apply cequivc_sym; auto.

    + pose proof (hyp2 s2 s2) as qq; clear hyp2.
      repeat (autodimp qq hyp); eauto 3 with slow.
      { eapply similarity_hyps_functionality_trans; eauto. }
      { applydup @similarity_sym in sim as sim'; apply similarity_refl in sim'; auto. }
      exrepnd.
      lsubst_tac.
      allrw <- @member_cequiv_iff.
      apply cequiv_stable; spcast; proof_irr.

      apply cequivc_lsubstc.

      { apply isprogram_csubst; eauto 2 with slow. }
      { apply isprogram_csubst; eauto 2 with slow. }

      apply ceq_csub_cons; eauto 3 with slow.
      apply cequivc_sym; auto.

  - repeat (lsubstc_subst_aeq2;[]).
    repeat (substc_lsubstc_vars3;[]).
    proof_irr.

    eapply cequivc_preserving_equality;[eauto|].

    apply cequivc_lsubstc.

    { apply isprogram_csubst; eauto 2 with slow. }
    { apply isprogram_csubst; eauto 2 with slow. }

    apply ceq_csub_cons; eauto 3 with slow.
    apply cequivc_sym; auto.

    pose proof (hyp2 s1 s1) as qq; clear hyp2.
    repeat (autodimp qq hyp); eauto 3 with slow.
    { apply similarity_refl in sim; auto. }
    exrepnd.
    lsubst_tac.
    allrw <- @member_cequiv_iff.
    apply cequiv_stable; spcast; proof_irr; auto.
Qed.

Lemma rule_cequiv_subst_concl_true {o} :
  forall lib (H  : @barehypotheses o)
         (x : NVar)
         (C a b t  : NTerm),
    rule_true lib (rule_cequiv_subst_concl H x C a b t).
Proof.
  introv.
  apply rule_true3_implies_rule_true.
  apply rule_cequiv_subst_concl_true3.
Qed.

Lemma rule_cequiv_subst_concl_wf2 {o} :
  forall (H  : @barehypotheses o)
         (x : NVar)
         (C a b t  : NTerm),
    wf_term a
    -> wf_term b
    -> covered a (vars_hyps H)
    -> covered b (vars_hyps H)
    -> wf_rule2 (rule_cequiv_subst_concl H x C a b t).
Proof.
  introv wa wb cova covb wf i; allsimpl; repndors; subst; tcsp;
  allunfold @wf_bseq; repnd; wfseq; auto.

  - apply wf_term_subst; auto.
    apply lsubst_wf_term in wf1; auto.

  - apply covered_subst; auto.
    apply covered_subst_implies in wf; auto.

  - apply wf_cequiv; auto.
Qed.

Lemma rule_cequiv_subst_concl_true_ext_lib {o} :
  forall lib (H  : @barehypotheses o)
         (x : NVar)
         (C a b t  : NTerm),
    rule_true_ext_lib lib (rule_cequiv_subst_concl H x C a b t).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_cequiv_subst_concl_true3.
Qed.

(* same as above but we don't force the subgoals to have given extracts *)

Definition rule_cequiv_subst2_hyp2 {o} (H : @bhyps o) a b e :=
  mk_baresequent H (mk_concl (mk_cequiv a b) e).

Definition rule_cequiv_subst_concl2 {o}
           (H : @barehypotheses o)
           (x : NVar)
           (C a b t  : NTerm) e :=
  mk_rule
    (rule_cequiv_subst_hyp1 H x C a t)
    [ rule_cequiv_subst_hyp1 H x C b t,
      rule_cequiv_subst2_hyp2 H a b e
    ]
    [].

Lemma rule_cequiv_subst_concl2_true3 {o} :
  forall lib (H  : @barehypotheses o)
         (x : NVar)
         (C a b t  : NTerm) e,
    rule_true3 lib (rule_cequiv_subst_concl2 H x C a b t e).
Proof.
  intros.
  unfold rule_cequiv_subst_concl2, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [ws1 hyp1].
  destruct Hyp0 as [ws2 hyp2].

  assert (wf_csequent (rule_cequiv_subst_hyp1 H x C a t)) as wfs by prove_seq.
  exists wfs.
  unfold wf_csequent, wf_sequent, wf_bseq in wfs; allsimpl; repnd; proof_irr; GC.
  destseq; allsimpl; proof_irr; GC.

  vr_seq_true.
  vr_seq_true in hyp1.
  vr_seq_true in hyp2.

  pose proof (hyp1 s1 s2 eqh sim) as hh; clear hyp1; exrepnd.

  assert (wf_term a # wf_term b) as wfab.
  { clear hyp2; allrw <- @wf_cequiv_iff; auto. }
  repnd.

  assert (cover_vars a s1 # cover_vars b s1) as cov1.
  { clear hyp2.
    allrw @covered_cequiv; repnd.
    dands; eapply s_cover_typ1; eauto. }

  assert (cover_vars a s2 # cover_vars b s2) as cov2.
  { clear hyp2.
    allrw @covered_cequiv; repnd.
    dands; eapply s_cover_typ2; eauto. }

  repnd.
  dands.

  - repeat (lsubstc_subst_aeq2;[]).
    repeat (substc_lsubstc_vars3;[]).

    eapply tequality_respects_cequivc_left;
      [|eapply tequality_respects_cequivc_right;
         [|exact hh0]
      ].

    + pose proof (hyp2 s1 s1) as qq; clear hyp2.
      repeat (autodimp qq hyp); eauto 3 with slow.
      { apply similarity_refl in sim; auto. }
      exrepnd.
      lsubst_tac.
      allrw @equality_in_mkc_cequiv; repnd.
      apply cequiv_stable; spcast; proof_irr.

      apply cequivc_lsubstc.

      { apply isprogram_csubst; eauto 2 with slow. }
      { apply isprogram_csubst; eauto 2 with slow. }

      apply ceq_csub_cons; eauto 3 with slow.
      apply cequivc_sym; auto.

    + pose proof (hyp2 s2 s2) as qq; clear hyp2.
      repeat (autodimp qq hyp); eauto 3 with slow.
      { eapply similarity_hyps_functionality_trans; eauto. }
      { applydup @similarity_sym in sim as sim'; apply similarity_refl in sim'; auto. }
      exrepnd.
      lsubst_tac.
      allrw @equality_in_mkc_cequiv; repnd.
      apply cequiv_stable; spcast; proof_irr.

      apply cequivc_lsubstc.

      { apply isprogram_csubst; eauto 2 with slow. }
      { apply isprogram_csubst; eauto 2 with slow. }

      apply ceq_csub_cons; eauto 3 with slow.
      apply cequivc_sym; auto.

  - repeat (lsubstc_subst_aeq2;[]).
    repeat (substc_lsubstc_vars3;[]).
    proof_irr.

    eapply cequivc_preserving_equality;[eauto|].

    apply cequivc_lsubstc.

    { apply isprogram_csubst; eauto 2 with slow. }
    { apply isprogram_csubst; eauto 2 with slow. }

    apply ceq_csub_cons; eauto 3 with slow.
    apply cequivc_sym; auto.

    pose proof (hyp2 s1 s1) as qq; clear hyp2.
    repeat (autodimp qq hyp); eauto 3 with slow.
    { apply similarity_refl in sim; auto. }
    exrepnd.
    lsubst_tac.
    allrw @equality_in_mkc_cequiv; repnd.
    apply cequiv_stable; spcast; proof_irr; auto.
Qed.

Lemma rule_cequiv_subst_concl2_true {o} :
  forall lib (H  : @barehypotheses o)
         (x : NVar)
         (C a b t  : NTerm) e,
    rule_true lib (rule_cequiv_subst_concl2 H x C a b t e).
Proof.
  introv.
  apply rule_true3_implies_rule_true.
  apply rule_cequiv_subst_concl2_true3.
Qed.

Lemma rule_cequiv_subst_concl2_wf2 {o} :
  forall (H  : @barehypotheses o)
         (x : NVar)
         (C a b t  : NTerm) e,
    wf_term a
    -> wf_term b
    -> covered a (vars_hyps H)
    -> covered b (vars_hyps H)
    -> wf_rule2 (rule_cequiv_subst_concl2 H x C a b t e).
Proof.
  introv wa wb cova covb wf i; allsimpl; repndors; subst; tcsp;
  allunfold @wf_bseq; repnd; wfseq; auto.

  - apply wf_term_subst; auto.
    apply lsubst_wf_term in wf1; auto.

  - apply covered_subst; auto.
    apply covered_subst_implies in wf; auto.

  - apply wf_cequiv; auto.
Qed.

Lemma rule_cequiv_subst_concl2_true_ext_lib {o} :
  forall lib (H  : @barehypotheses o)
         (x : NVar)
         (C a b t e : NTerm),
    rule_true_ext_lib lib (rule_cequiv_subst_concl2 H x C a b t e).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_cequiv_subst_concl2_true3.
Qed.

(* begin hide *)

(* end hide *)

Lemma alpha_eq_lsubst_aux_trivial {o} :
  forall (t : @NTerm o) sub,
    disjoint (dom_sub sub) (free_vars t)
    -> disjoint (bound_vars t) (sub_free_vars sub)
    -> alpha_eq (lsubst_aux t sub) t.
Proof.
  nterm_ind t as [v|f|op bs ind] Case ; introv disj1 disj2; simpl in *; tcsp.

  - allrw disjoint_singleton_r.
    rewrite sub_find_none_if; auto.

  - apply alpha_eq_oterm_combine; autorewrite with list; dands; auto.
    introv i.
    rewrite combine_map_r in i.
    apply in_map_iff in i; exrepnd; ginv.
    destruct a as [l t]; simpl.
    apply alpha_eq_bterm_congr.
    eapply ind;[eauto| |].

    + rw <- @dom_sub_sub_filter.
      introv i j.
      apply in_remove_nvars in i; repnd.
      applydup disj1 in i0.
      destruct i2.
      apply lin_flat_map.
      eexists; dands; eauto; simpl.
      apply in_remove_nvars; dands; auto.

    + introv i j.
      pose proof (disj2 t0) as q; autodimp q hyp.
      { apply lin_flat_map; eexists; dands; eauto; simpl.
        apply in_app_iff; tcsp. }
      apply subset_sub_free_vars_sub_filter in j; tcsp.
Qed.

Lemma alpha_eq_lsubst_trivial {o} :
  forall (t : @NTerm o) sub,
    disjoint (dom_sub sub) (free_vars t)
    -> alpha_eq (lsubst t sub) t.
Proof.
  introv disj.
  pose proof (unfold_lsubst sub t) as q; exrepnd.
  allrw.
  eapply alpha_eq_trans;[|apply alpha_eq_sym;eauto].
  apply alphaeq_preserves_free_vars in q1.
  rewrite q1 in disj.
  clear dependent t.
  apply alpha_eq_lsubst_aux_trivial; auto.
Qed.

Hint Resolve alphaeq_preserves_wf_term : slow.

Lemma alpha_eq_preserves_cover_vars {o} :
  forall (t u : @NTerm o) s,
    alpha_eq t u
    -> cover_vars t s
    -> cover_vars u s.
Proof.
  introv aeq cov.
  unfold cover_vars, over_vars in *.
  apply alphaeq_preserves_free_vars in aeq.
  allrw <- ; auto.
Qed.
Hint Resolve alpha_eq_preserves_cover_vars : slow.

Lemma alpha_eq_preserves_similarity_middle {o} :
  forall lib s1 s2 H z (T U : @NTerm o) J,
    alpha_eq T U
    -> similarity lib s1 s2 (snoc H (mk_hyp z T) ++ J)
    -> similarity lib s1 s2 (snoc H (mk_hyp z U) ++ J).
Proof.
  introv aeq sim.

  allrw @similarity_app.
  exrepnd; subst.
  allrw length_snoc.

  apply similarity_snoc in sim5; simpl in sim5.
  exrepnd; subst.
  allrw length_snoc; cpx.

  exists (snoc s1a0 (z,t1)) s1b (snoc s2a0 (z,t2)) s2b.
  allrw length_snoc.
  dands; auto.

  assert (wf_term U) as wfu by eauto 2 with slow.

  assert (cover_vars U s1a0) as covu by eauto 2 with slow.

  sim_snoc2; dands; auto.
  eapply alphaeqc_preserving_equality;[eauto|].
  unfold alphaeqc; simpl.
  apply lsubst_alpha_congr2; auto.
Qed.

Lemma alpha_eq_preserves_eq_hyps_middle {o} :
  forall lib s1 s2 H z (T U : @NTerm o) J,
    alpha_eq T U
    -> eq_hyps lib s1 s2 (snoc H (mk_hyp z T) ++ J)
    -> eq_hyps lib s1 s2 (snoc H (mk_hyp z U) ++ J).
Proof.
  introv aeq sim.

  allrw @eq_hyps_app.
  exrepnd; subst.
  allrw length_snoc.

  apply eq_hyps_snoc in sim5; simpl in sim5.
  exrepnd; subst.
  allrw length_snoc; cpx.

  exists (snoc s1a0 (z,t1)) s1b (snoc s2a0 (z,t2)) s2b.
  allrw length_snoc.
  dands; auto.

  assert (wf_term U) as wfu by eauto 2 with slow.
  assert (cover_vars U s1a0) as covu1 by eauto 2 with slow.
  assert (cover_vars U s2a0) as covu2 by eauto 2 with slow.

  apply eq_hyps_snoc.
  exists s1a0 s2a0 t1 t2 wfu covu1 covu2; simpl; dands; auto.

  eapply tequality_respects_alphaeqc_left;
    [|eapply tequality_respects_alphaeqc_right;
      [|eauto] ];
    unfold alphaeqc; simpl;
      apply lsubst_alpha_congr2; auto.
Qed.

Lemma alpha_eq_preserves_hyps_functionality_middle {o} :
  forall lib s1 H z (T U : @NTerm o) J,
    alpha_eq T U
    -> hyps_functionality lib s1 (snoc H (mk_hyp z T) ++ J)
    -> hyps_functionality lib s1 (snoc H (mk_hyp z U) ++ J).
Proof.
  introv aeq hf sim.
  pose proof (hf s') as q.
  autodimp q hyp.

  {
    eapply alpha_eq_preserves_similarity_middle;[|eauto].
    apply alpha_eq_sym; auto.
  }

  {
    eapply alpha_eq_preserves_eq_hyps_middle;[|eauto]; auto.
  }
Qed.

(**

  The following rule states that we can always replace an [a] for a
  [b] in an hypothesis of a sequent if [a] and [b] are computationally
  equivalent:
<<
  H, z : T[a], J |- C ext t

    By cequivSubstHyp

    H, z : T[b], J |- C ext t
    H, z : T[a], J |- a ~ b
>>
 *)

Definition rule_cequiv_subst_hyp_concl {o} (H : @bhyps o) z T x a J C t :=
  mk_baresequent (snoc H (mk_hyp z (subst T x a)) ++ J) (mk_concl C t).

Definition rule_cequiv_subst_hyp_hyp1 {o} (H : @bhyps o) z T x b J C t :=
  mk_baresequent (snoc H (mk_hyp z (subst T x b)) ++ J) (mk_concl C t).

Definition rule_cequiv_subst_hyp_hyp2 {o} (H : @bhyps o) z T x a J b e :=
  mk_baresequent (snoc H (mk_hyp z (subst T x a)) ++ J) (mk_concl (mk_cequiv a b) e).

Definition rule_cequiv_subst_hyp {o}
           (H J : @barehypotheses o)
           (x z : NVar)
           (C T a b t e : NTerm) :=
  mk_rule
    (rule_cequiv_subst_hyp_concl H z T x a J C t)
    [ rule_cequiv_subst_hyp_hyp1 H z T x b J C t,
      rule_cequiv_subst_hyp_hyp2 H z T x a J b e
    ]
    [].

Lemma rule_cequiv_subst_hyp_true3 {o} :
  forall lib (H J : @barehypotheses o)
         (x z : NVar)
         (C T a b t e : NTerm),
    rule_true3 lib (rule_cequiv_subst_hyp H J x z C T a b t e).
Proof.
  intros.
  unfold rule_cequiv_subst_hyp, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destruct Hyp0 as [wf2 hyp2].
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  {
    clear hyp1 hyp2.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    prove_seq; eauto 3 with slow.
  }
  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  assert (!LIn z (vars_hyps H)
          # !LIn z (vars_hyps J)
          # disjoint (vars_hyps H) (vars_hyps J)) as vhyps.
  {
    clear hyp1 hyp2.
    dwfseq.
    sp.
  }

  destruct vhyps as [ nizH vhyps].
  destruct vhyps as [ nizJ disjHJ ].
  (* done with proving these simple facts *)

  vr_seq_true.
  vr_seq_true in hyp1.
  vr_seq_true in hyp2.

  assert (wf_term T) as wT.
  {
    clear hyp1 hyp2.
    allapply @vswf_hypotheses_nil_implies.
    allrw @wf_hypotheses_app; repnd.
    allrw @wf_hypotheses_snoc; repnd; allsimpl.
    allrw @isprog_vars_eq; repnd.
    allrw @nt_wf_eq.
    allapply @lsubst_wf_term; auto.
  }

  (* first we check whether or not x is in the free variables of T
   * because to know that a and b only depend on H, we first have to
   * know that x is in T.  We don't get that a and b only depend on
   * H from hyp2 because hyp2 can use the other hypotheses too. *)
  generalize (in_deq NVar deq_nvar x (free_vars T)); introv i.
  destruct i as [i | i].

  {
    (* First, we assume that x is in the free variables of T.
     * We can now prove that a and b depend on H only. *)

    assert (covered a (vars_hyps H)) as cvah.
    {
      clear hyp1 hyp2.
      allapply @vswf_hypotheses_nil_implies.
      allrw @wf_hypotheses_app; repnd.
      allrw @wf_hypotheses_snoc; repnd; allsimpl.
      allrw @isprog_vars_eq; repnd.
      unfold covered.
      generalize (eqvars_free_vars_disjoint T [(x,a)]).
      introv xx; rw @fold_subst in xx; simpl in xx.
      apply subvars_eqvars with (s2 := vars_hyps H) in xx; auto.
      rw subvars_prop in xx.
      rw subvars_prop; introv j.
      revert xx; boolvar; try (complete sp); simpl; intro xx.
      apply xx; rw in_app_iff; rw app_nil_r; sp.
    }

    assert (covered b (vars_hyps H)) as cvbh.
    {
      clear hyp1 hyp2.
      allapply @vswf_hypotheses_nil_implies.
      allrw @wf_hypotheses_app; repnd.
      allrw @wf_hypotheses_snoc; repnd; allsimpl.
      allrw @isprog_vars_eq; repnd.
      unfold covered.
      pose proof (eqvars_free_vars_disjoint T [(x,b)]) as xx.
      rw @fold_subst in xx; simpl in xx.
      apply subvars_eqvars with (s2 := vars_hyps H) in xx; auto.
      rw subvars_prop in xx.
      rw subvars_prop; introv j.
      revert xx; boolvar; try (complete sp); simpl; intro xx.
      apply xx; rw in_app_iff; rw app_nil_r; sp.
    }

    assert (covered T (snoc (vars_hyps H) x)) as covT.
    {
      clear hyp1 hyp2.
      allapply @vswf_hypotheses_nil_implies.
      allrw @wf_hypotheses_app; repnd.
      allrw @wf_hypotheses_snoc; repnd; allsimpl.
      allrw @isprog_vars_eq; repnd.
      unfold covered.
      pose proof (eqvars_free_vars_disjoint T [(x,b)]) as xx.
      rw @fold_subst in xx; simpl in xx.
      apply subvars_eqvars with (s2 := vars_hyps H) in xx; auto.
      rw subvars_prop in xx.
      rw subvars_prop; introv j.
      revert xx; boolvar; try (complete sp); simpl; intro xx.
      rw in_snoc.
      destruct (deq_nvar x0 x); subst; sp.
      left; apply xx; rw in_app_iff; rw app_nil_r; rw in_remove_nvars; rw in_single_iff; sp.
    }

    assert (!LIn z (free_vars a))
      as niza
        by (intro j; unfold covered in cvah;
            rw subvars_prop in cvah; apply cvah in j; sp).

    assert (!LIn z (free_vars b))
      as nizb
        by (intro j; unfold covered in cvbh;
            rw subvars_prop in cvbh; apply cvbh in j; sp).

    assert (disjoint (free_vars a) (vars_hyps J))
      as daj
        by (introv j k; unfold covered in cvah;
            rw subvars_prop in cvah; apply cvah in j; sp;
            apply disjHJ in j; sp).

    assert (disjoint (free_vars b) (vars_hyps J))
      as dbj
        by (introv j k; unfold covered in cvbh;
            rw subvars_prop in cvbh; apply cvbh in j; sp;
            apply disjHJ in j; sp).

    assert (subvars (free_vars (subst T x a)) (vars_hyps H)) as svaH.
    {
      pose proof (eqvars_free_vars_disjoint T [(x,a)]) as xx.
      apply eqvars_sym in xx.
      apply subvars_eqvars with (s2 := vars_hyps H) in xx; auto.
      rw subvars_prop; introv; simpl.
      rw in_app_iff; rw in_remove_nvars; rw in_single_iff.
      boolvar; simpl; try (complete sp).
      rw app_nil_r; intro j; repdors; repnd.
      try (complete (unfold covered in covT; rw subvars_prop in covT;
                     apply covT in j1; rw in_snoc in j1; allrw; sp)).
      try (complete (unfold covered in cvah; rw subvars_prop in cvah;
                     apply cvah in j; sp)).
    }

    assert (subvars (free_vars (subst T x b)) (vars_hyps H)) as svbH.
    {
      pose proof (eqvars_free_vars_disjoint T [(x,b)]) as xx.
      apply eqvars_sym in xx.
      apply subvars_eqvars with (s2 := vars_hyps H) in xx; auto.
      rw subvars_prop; introv; simpl.
      rw in_app_iff; rw in_remove_nvars; rw in_single_iff.
      boolvar; simpl; try (complete sp).
      rw app_nil_r; intro j; repdors; repnd.
      try (complete (unfold covered in covT; rw subvars_prop in covT;
                     apply covT in j1; rw in_snoc in j1; allrw; sp)).
      try (complete (unfold covered in cvbh; rw subvars_prop in cvbh;
                     apply cvbh in j; sp)).
    }

    assert (subvars (free_vars T) (x :: vars_hyps H))
      as svTH
        by (rw subvars_prop in covT; rw subvars_prop; introv j;
            apply covT in j; rw in_snoc in j; simpl; sp).

    generalize (hyp1 s1 s2); clear hyp1; intro hyp1.

    autodimp hyp1 hyp.

    {
      (* First, we prove that the hypotheses of the first sequent are functional *)
      introv sim'.
      rw @similarity_app in sim'; simpl in sim'; exrepnd; subst; allrw length_snoc; cpx.
      rw @similarity_snoc in sim'5; simpl in sim'5; exrepnd; subst; allrw length_snoc; cpx.

      rw @eq_hyps_app.
      exists (snoc s1a0 (z, t1)) s1b (snoc s2a0 (z, t2)) s2b.
      allrw length_snoc; dands; try (complete sp).

      {
        assert (cover_vars (subst T x b) s2a0)
          as cov2
            by (apply cover_vars_change_sub with (sub1 := s1a0); sp;
                allapply @similarity_dom; repnd; allrw; sp).

        rw @eq_hyps_snoc; simpl.
        exists s1a0 s2a0 t1 t2 w p cov2.
        dands; try (complete sp).

        {
          assert (wf_term (subst T x a)) as wfsa.
          {
            clear hyp2.
            apply @lsubst_preserves_wf_term; simpl; auto.
            unfold wf_sub, sub_range_sat; simpl; sp; cpx; rw @nt_wf_eq; sp.
            allrw <- @wf_cequiv_iff; tcsp.
          }

          assert (cover_vars (subst T x a) s1a0)
            as cova1 by (rw @cover_vars_eq; allapply @similarity_dom; repnd; allrw; sp).

          dup eqh as hf.

          apply hyps_functionality_init_seg
            with (s3 := s2b) in eqh; auto.
          apply @hyps_functionality_init_seg_snoc2
            with (t' := t2) (w := wfsa) (c := cova1) in eqh.
          apply eqh in sim'6; auto.

          generalize (hyp2 (snoc s1a0 (z,t1) ++ s1b) s2 hf sim); clear hyp2; intro hyp2; exrepnd.
          lsubst_tac.
          apply equality_in_mkc_cequiv in hyp1; repnd.
          clear hyp2 hyp3.
          spcast.

          assert (cover_vars_upto T (csub_filter s1a0 [x]) [x])
            as covT1
              by (unfold cover_vars_upto; unfold covered in covT;
                  rw @dom_csub_csub_filter;
                  rw subvars_app_remove_nvars_r; simpl;
                  allapply @similarity_dom; repnd; allrw; sp).

          repeat (lsubstc_subst_aeq2;[]).

          apply cequivc_preserving_equality
            with (A := substc (lsubstc b wt0 s1a0 c6) x
                              (lsubstc_vars T wT (csub_filter s1a0 [x]) [x] covT1));
            proof_irr; auto;
            try (complete (apply cequivc_sym; eauto with cequivc)).
        }

        {
          (* now we prove the tequality of T[x\b] *)
          assert (wf_term (subst T x a)) as wfsa.
          {
            clear hyp2.
            apply @lsubst_preserves_wf_term; sp.
            unfold wf_sub, sub_range_sat; simpl; sp; cpx; rw @nt_wf_eq; sp.
            allrw <- @wf_cequiv_iff; tcsp.
          }

          assert (cover_vars (subst T x a) s1a0)
            as covsa1 by (rw @cover_vars_eq; allapply @similarity_dom; repnd; allrw; sp).

          generalize (eqh (snoc s2a0 (z,t1) ++ s1b)); intro eqhy.
          autodimp eqhy hyp.
          rw @similarity_app; simpl.
          exists (snoc s1a0 (z, t1)) s1b (snoc s2a0 (z, t1)) s1b; allrw length_snoc; sp.
          rw @similarity_snoc; simpl.
          exists s1a0 s2a0 t1 t1 wfsa covsa1; sp.

          {
            rw @similarity_app in sim; simpl in sim; exrepnd.
            apply app_split in sim0; allrw length_snoc; repnd; subst;
              try (complete (allapply @similarity_dom; repnd; allrw; sp)).
            rw @similarity_snoc in sim5; simpl in sim5; exrepnd; cpx; proof_irr.
            apply equality_refl in sim2; sp.
          }

          {
            apply @similarity_refl in sim'1; sp.
          }

          {
            rw @eq_hyps_app in eqhy; simpl in eqhy; exrepnd.
            apply app_split in eqhy0; allrw length_snoc; repnd; subst; cpx;
              try (complete (allapply @similarity_dom; repnd; allrw; sp)).
            apply app_split in eqhy2; allrw length_snoc; repnd; subst; cpx;
              try (complete (allapply @similarity_dom; repnd; allrw; sp)).
            rw @eq_hyps_snoc in eqhy5; simpl in eqhy5; exrepnd; cpx.

            (* now we prove the tequality from eqhy0 *)

            generalize (hyp2 (snoc s1a (z,t0) ++ s2b0)
                             (snoc s2a (z,t0) ++ s2b0)
                             eqh); clear hyp2; intro hyp2.
            (* before using hyp2 we have to prove a few things *)
            autodimp hyp2 hyp.

            {
              rw @similarity_app; simpl.
              exists (snoc s1a (z,t0)) s2b0 (snoc s2a (z,t0)) s2b0; allrw length_snoc; sp.
              rw @similarity_snoc; simpl.
              exists s1a s2a t0 t0 w0 p1; sp.

              {
                rw @similarity_app in sim; simpl in sim; exrepnd.
                apply app_split in sim0; allrw length_snoc; repnd; subst;
                  try (complete (allapply @similarity_dom; repnd; allrw; sp)).
                rw @similarity_snoc in sim5; simpl in sim5; exrepnd; cpx; proof_irr.
                apply equality_refl in sim2; sp.
              }

              {
                apply @similarity_refl in sim'1; sp.
              }
            }

            (* now we start using hyp2 *)
            exrepnd.
            lsubst_tac.
            rw @tequality_mkc_cequiv in hyp0.
            apply equality_in_mkc_cequiv in hyp1; repnd.
            clear hyp2 hyp3.
            appdup hyp0 hyp1.
            spcast.

            assert (cover_vars_upto T (csub_filter s1a [x]) [x])
              as cvuT1
                by (unfold cover_vars_upto; unfold covered in covT;
                    rw @dom_csub_csub_filter;
                    rw subvars_app_remove_nvars_r; simpl;
                    allapply @similarity_dom; repnd; allrw; sp).

            assert (cover_vars_upto T (csub_filter s2a [x]) [x])
              as cvuT2
                by (unfold cover_vars_upto; unfold covered in covT;
                    rw @dom_csub_csub_filter;
                    rw subvars_app_remove_nvars_r; simpl;
                    allapply @similarity_dom; repnd; allrw; sp).

            repeat (lsubstc_subst_aeq2;[]).
            proof_irr.

            apply tequality_respects_cequivc_left
              with (T1 := substc (lsubstc a wt1 s1a ct3) x
                                 (lsubstc_vars T wT (csub_filter s1a [x]) [x] cb3));
              try (complete (eauto with cequivc)).

            apply tequality_respects_cequivc_right
              with (T2 := substc (lsubstc a wt1 s2a ct4) x
                                 (lsubstc_vars T wT (csub_filter s2a [x]) [x] cb2));
              auto;
              try (complete (eauto with cequivc)).
          }
        }
      }

      (* Now we prove the sub_eq_hyps *)

      assert (wf_term (subst T x a)) as wfsa.
      {
        clear hyp2.
        apply @lsubst_preserves_wf_term; sp.
        unfold wf_sub, sub_range_sat; simpl; sp; cpx; rw @nt_wf_eq; sp.
        allrw <- @wf_cequiv_iff; tcsp.
      }

      assert (cover_vars (subst T x a) s1a0)
        as covsa1 by (rw @cover_vars_eq; allapply @similarity_dom; repnd; allrw; sp).

      generalize (hyp2 (snoc s1a0 (z,t1) ++ s1b)
                       (snoc s2a0 (z,t1) ++ s1b)
                       eqh); clear hyp2; intro hyp2.
      (* before using hyp2 we have to prove a few things *)
      autodimp hyp2 hyp.

      {
        rw @similarity_app; simpl.
        exists (snoc s1a0 (z,t1)) s1b (snoc s2a0 (z,t1)) s1b; allrw length_snoc; sp.

        {
          rw @similarity_snoc; simpl.
          exists s1a0 s2a0 t1 t1 wfsa covsa1; sp.

          rw @similarity_app in sim; simpl in sim; exrepnd.
          apply app_split in sim0; allrw length_snoc; repnd; subst;
            try (complete (allapply @similarity_dom; repnd; allrw; sp)).
          rw @similarity_snoc in sim5; simpl in sim5; exrepnd; cpx; proof_irr.
          apply equality_refl in sim2; sp.
        }

        apply @similarity_refl in sim'1; sp.
      }

      (* now we start using hyp2 *)
      exrepnd.
      lsubst_tac.
      rw @tequality_mkc_cequiv in hyp0.
      apply equality_in_mkc_cequiv in hyp1; repnd.
      clear hyp2 hyp3.
      appdup hyp0 hyp1.
      spcast.

      generalize (eqh (snoc s2a0 (z,t2) ++ s2b)); intro eqhy.
      autodimp eqhy hyp.
      rw @similarity_app; simpl.
      exists (snoc s1a0 (z,t1)) s1b (snoc s2a0 (z,t2)) s2b; allrw length_snoc; sp.

      {
        rw @similarity_snoc; simpl.
        exists s1a0 s2a0 t1 t2 wfsa covsa1; sp.

        assert (cover_vars_upto T (csub_filter s1a0 [x]) [x])
          as cvuT1
            by (unfold cover_vars_upto; unfold covered in covT;
                rw @dom_csub_csub_filter;
                rw subvars_app_remove_nvars_r; simpl;
                allapply @similarity_dom; repnd; allrw; sp).

        repeat (lsubstc_subst_aeq2;[]).
        proof_irr.

        apply cequivc_preserving_equality
          with (A := substc (lsubstc b wt0 s1a0 ct2) x
                            (lsubstc_vars T wT (csub_filter s1a0 [x]) [x] cb0));
          auto;
          try (complete (apply cequivc_sym; eauto with cequivc)).
      }

      rw @eq_hyps_app in eqhy; exrepnd.
      apply app_split in eqhy0; allrw length_snoc; repnd; subst; cpx;
        try (complete (allapply @similarity_dom; repnd; allrw; sp)).
      apply app_split in eqhy2; allrw length_snoc; repnd; subst; cpx;
        try (complete (allapply @similarity_dom; repnd; allrw; sp)).
    }

    (* We're done proving the hyps_functionality part of hyp1.
     * We now prove the similarity part of hyp1 *)
    autodimp hyp1 hyp.

    {
      rw @similarity_app in sim; exrepnd; subst; cpx.
      rw @similarity_snoc in sim5; simpl in sim5; exrepnd; subst; cpx.

      generalize (hyp2 (snoc s1a0 (z,t1) ++ s1b)
                       (snoc s2a0 (z,t1) ++ s1b)
                       eqh); clear hyp2; intro hyp2.
      (* before using hyp2 we have to prove a few things *)
      autodimp hyp2 hyp.

      {
        rw @similarity_app; simpl.
        exists (snoc s1a0 (z,t1)) s1b (snoc s2a0 (z,t1)) s1b; allrw length_snoc; sp.

        {
          rw @similarity_snoc; simpl.
          exists s1a0 s2a0 t1 t1 w p; sp.

          apply equality_refl in sim2; sp.
        }

        apply @similarity_refl in sim1; sp.
      }

      (* now we start using hyp2 *)
      exrepnd.
      lsubst_tac.
      rw @tequality_mkc_cequiv in hyp0.
      apply equality_in_mkc_cequiv in hyp1; repnd.
      clear hyp2 hyp3.
      appdup hyp0 hyp1.
      spcast.

      assert (wf_term (subst T x b))
        as wfsb
          by (apply @lsubst_preserves_wf_term; sp;
              unfold wf_sub, sub_range_sat; simpl; sp; cpx; rw @nt_wf_eq; sp).

      assert (cover_vars (subst T x b) s1a0)
        as covb1 by (rw @cover_vars_eq; allapply @similarity_dom; repnd; allrw; sp).

      rw @similarity_app.
      exists (snoc s1a0 (z, t1)) s1b (snoc s2a0 (z, t2)) s2b; allrw length_snoc; sp.
      rw @similarity_snoc; simpl.
      exists s1a0 s2a0 t1 t2 wfsb covb1; sp.

      assert (cover_vars_upto T (csub_filter s1a0 [x]) [x])
        as cvuT1
          by (unfold cover_vars_upto; unfold covered in covT;
              rw @dom_csub_csub_filter;
              rw subvars_app_remove_nvars_r; simpl;
              allapply @similarity_dom; repnd; allrw; sp).

      repeat (lsubstc_subst_aeq2;[]).
      proof_irr.

      apply cequivc_preserving_equality
        with (A := substc (lsubstc a wt0 s1a0 ct2) x
                          (lsubstc_vars T wT (csub_filter s1a0 [x]) [x] cb0));
        auto;
        try (complete (eauto with cequivc)).
    }

    (* now we use hyp1 *)
    exrepnd; proof_irr; GC; sp.
  }

  assert (alpha_eq (subst T x a) T) as e1.
  { apply alpha_eq_lsubst_trivial; simpl; apply disjoint_singleton_l; auto. }

  assert (alpha_eq (subst T x b) T) as e2.
  { apply alpha_eq_lsubst_trivial; simpl; apply disjoint_singleton_l; auto. }

  pose proof (hyp1 s1 s2) as hyp1.
  repeat (autodimp hyp1 hyp).

  {
    eapply alpha_eq_preserves_hyps_functionality_middle;[|eauto].
    eapply alpha_eq_trans;[eauto|].
    apply alpha_eq_sym; auto.
  }

  {
    eapply alpha_eq_preserves_similarity_middle;[|eauto].
    eapply alpha_eq_trans;[eauto|].
    apply alpha_eq_sym; auto.
  }

  exrepnd; proof_irr; sp.
Qed.

Lemma rule_cequiv_subst_hyp_true {o} :
  forall lib (H J : @barehypotheses o)
         (x z : NVar)
         (C T a b t e : @NTerm o),
    rule_true lib (rule_cequiv_subst_hyp H J x z C T a b t e).
Proof.
  introv.
  apply rule_true3_implies_rule_true.
  apply rule_cequiv_subst_hyp_true3.
Qed.

Lemma rule_cequiv_subst_hyp_true_ext_lib {o} :
  forall lib (H J : @barehypotheses o)
         (x z : NVar)
         (C T a b t e : NTerm),
    rule_true_ext_lib lib (rule_cequiv_subst_hyp H J x z C T a b t e).
Proof.
  introv.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_cequiv_subst_hyp_true3.
Qed.

Lemma rule_cequiv_subst_hyp_wf2 {o} :
  forall (H J : @barehypotheses o)
         (x z : NVar)
         (C T a b t e : NTerm),
    wf_term a
    -> wf_term b
    -> covered a (vars_hyps H)
    -> covered b (vars_hyps H)
    -> wf_rule2 (rule_cequiv_subst_hyp H J x z C T a b t e).
Proof.
  introv wa wb cova covb wf i; allsimpl; repndors; subst; tcsp;
    allunfold @wf_bseq; repnd; wfseq; auto.

  - allrw @vswf_hypotheses_nil_eq.
    allrw @wf_hypotheses_app; repnd.
    allrw @wf_hypotheses_snoc; repnd.
    simpl in *.
    allrw @vars_hyps_snoc; simpl in *.
    dands; auto.

    allrw @isprog_vars_eq; repnd; dands; auto.

    + apply covered_subst_implies in wf5.
      apply covered_subst; auto.

    + allrw @nt_wf_eq.
      apply wf_term_subst; auto.
      apply lsubst_wf_term in wf3; auto.

  - apply wf_cequiv; auto.

  - apply covered_app_weak_l.
    apply covered_snoc_weak; auto.

  - apply covered_app_weak_l.
    apply covered_snoc_weak; auto.
Qed.

(* begin hide *)

(* end hide *)


From Utils    Require Import Defns.
From CompCert Require Import Lattice.
From PIPE     Require Import TagDomain.
From RTLT     Require Import Language Policy Semantics.

Create HintDb deaddomDB.

(* Adapted from Leroy's NeedDomain.v *)

Module Functor (Import Tags  : TagDomain.MiddleEnd)
               (Import Rules : RTLT.Policy.Sig Tags)
               (Import Lang  : RTLT.Language.Sig Tags)
               (Import Sem   : RTLT.Semantics.Sig Tags Rules Lang).

Inductive nval : Type :=
  | Dead
  | Live.

Definition eq_nval (x y: nval) : {x = y} + {x <> y}.
Proof. decide equality. Defined.

(* agreement between two values relative to a need *)
Definition vagree (v w: atom) (x: nval) : Prop :=
  match x with
  | Dead => True
  | Live => v = w
  end.

Lemma vagree_same: forall v x, vagree v v x.
Proof. intros v []; red; auto. Qed.
Hint Resolve vagree_same : deaddomDB.

Inductive nge: nval -> nval -> Prop :=
  | nge_dead : forall x, nge Live x
  | nge_Live : forall x, nge x Dead.

Lemma nge_refl: forall x, nge x x.
Proof.
  intros []; constructor.
Qed.

Hint Constructors nge: deaddomDB.
Hint Resolve nge_refl: deaddomDB.

Lemma nge_trans: forall x y, nge x y -> forall z, nge y z -> nge x z.
Proof with auto with deaddomDB.
  intros [] [] **... inversion H.
Qed.

Lemma nge_agree: forall v w x y,
  nge x y -> vagree v w x -> vagree v w y.
Proof.
  induction 1; simpl;
  [ intros <-; destruct x; simpl
  | ]; auto.
Qed.

Definition nlub (x y: nval) : nval :=
  match x, y with
  | Dead, _ => y
  | _, Dead => x
  | _, _    => Live
  end.

Lemma nge_lub_l:
  forall x y, nge (nlub x y) x.
Proof with auto with deaddomDB.
  intros [] []...
Qed.

Lemma nge_lub_r:
  forall x y, nge (nlub x y) y.
Proof with auto with deaddomDB.
  intros [] []...
Qed.

(* Properties of agreement between integers *)

(* The default abstraction: if the result is unused, the arguments are unused; otherwise, the arguments are needed in full. *)
Definition default (x: nval) :=
  match x with
  | Dead => Dead
  | _ => Live
  end.

Module NVal <: SEMILATTICE.

  Definition t := nval.
  Definition eq (x y: t) := (x = y).
  Definition eq_refl: forall x, eq x x := (@eq_refl t).
  Definition eq_sym: forall x y, eq x y -> eq y x := (@eq_sym t).
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z :=
    (@eq_trans t).
  Definition beq (x y: t) : bool := proj_sumbool (eq_nval x y).
  Lemma beq_correct: forall x y, beq x y = true -> eq x y.
  Proof.
    intros [] [].
    - unfold eq. auto.
    - unfold beq. simpl. inversion 1.
    - unfold beq. simpl. inversion 1.
    - unfold eq. auto.
  Qed.
  Definition ge := nge.
  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge; intros * <-.
    apply nge_refl.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge; intros.
    eapply nge_trans; eauto.
  Qed.
  Definition bot : t := Dead.
  Lemma ge_bot: forall x, ge x bot.
  Proof. constructor. Qed.
  Definition lub := nlub.
  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof nge_lub_l.
  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof nge_lub_r.
End NVal.

Module NB <: SEMILATTICE := LPMap1(NVal).

Definition nbank := NB.t.
Definition nreg (nB: nbank) (r: reg) := NB.get r nB.
Hint Unfold nreg : deaddomDB.

Module NA <: SEMILATTICE := NB.

End Functor.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^221 - 3
Base: 55.25
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 55 + 1/4;
    bitwidth := 64;
    s := 2^221;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Lia.
Require Import Bool.
Require Import RelationClasses.
Require Import Program.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Require Import Single.
Require Import JoinedView.

Require Import LocalDRFPFView.

Require Import OrdStep.
Require Import Stable.
Require Import WStep.
Require Import PFtoRA.
Require Import RARace.

Set Implicit Arguments.

(* LDRF-RA theorem *)
Theorem local_drf_ra L
        s
        (RACEFREE: RARace.racefree_syn L s):
  behaviors SConfiguration.machine_step (Configuration.init s) <2=
  behaviors (@OrdConfiguration.machine_step L Ordering.acqrel Ordering.acqrel) (Configuration.init s).
Proof.
  hexploit RARace.racefree_implies; eauto. i.
  specialize (PFtoRA.init_sim_conf L s). intro SIM.
  specialize (PFtoRA.init_wf_pf L s). intro WF_PF.
  specialize (PFtoRA.init_wf_j s). intro WF_J.
  specialize (PFtoRA.init_wf_ra L s). intro WF_APF.
  specialize (PFtoRA.init_wf_ra L s). intro WF_RA.
  ii. exploit (@local_drf_pf_view L); eauto.
  { eapply PFtoRA.sim_conf_racefree; eauto. }
  eapply PFtoRA.sim_conf_behavior; eauto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C AB BC ABC Cprime Bprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Bprime O /\ (wd_ BC O /\ (wd_ ABC O /\ (wd_ Eprime A /\ (wd_ Bprime AB /\ (wd_ C Cprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime Cprime /\ (col_ O Eprime Bprime /\ col_ O Eprime ABC)))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ A C /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ (col_ O B Cprime /\ col_ A B C))))))))))))))) -> col_ O A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

(******************************************************************************)
(* This file defines ordType - the structure for types with a decidable       *)
(* (strict) order relation.                                                   *)
(* ordType is a subclass of mathcomp's eqType                                 *)
(* This file also defines some important instances of ordType                 *)
(******************************************************************************)

From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path fintype.
From pcm Require Import options.

Module Ordered.

Section RawMixin.

Structure mixin_of (T : eqType) :=
  Mixin {ordering : rel T;
         _ : irreflexive ordering;
         _ : transitive ordering;
         _ : forall x y, x != y -> ordering x y || ordering y x}.

End RawMixin.

(* the class takes a naked type T and returns all the *)
(* related mixins; the inherited ones and the added ones *)
Section ClassDef.

Record class_of (T : Type) := Class {
   base : Equality.class_of T;
   mixin : mixin_of (EqType T base)}.

Local Coercion base : class_of >-> Equality.class_of.

(* The polymorphism annotations here and below are needed for storing *)
(* ordType instances in finMaps which have an ordType constraint of *)
(* their own. An example of this is KVMap from HTT. *)
Polymorphic Cumulative Structure type : Type := Pack {sort : Type; _ : class_of sort}.
Local Coercion sort : type >-> Sortclass.

Polymorphic Universe ou.
Polymorphic Variables (T : Type@{ou}) (cT : type@{ou}).
Polymorphic Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Polymorphic Definition clone c of phant_id class c := @Pack T c.

(* produce an ordered type out of the inherited mixins *)
(* equalize m0 and m by means of a phantom; will be exploited *)
(* further down in the definition of OrdType *)
Polymorphic Definition pack b (m0 : mixin_of (EqType T b)) :=
  fun m & phant_id m0 m => Pack (@Class T b m).

Polymorphic Definition eqType := Eval hnf in EqType cT class.

End ClassDef.

Module Exports.
Coercion base : class_of >-> Equality.class_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Canonical Structure eqType.
Notation ordType := Ordered.type.
Notation OrdMixin := Mixin.
Notation OrdType T m := (@pack T _ m _ id).
Definition ord T : rel (sort T) := (ordering (mixin (class T))).
Notation "[ 'ordType' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
  (at level 0, format "[ 'ordType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'ordType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'ordType'  'of'  T ]") : form_scope.
End Exports.
End Ordered.
Export Ordered.Exports.

Definition oleq (T : ordType) (t1 t2 : T) := ord t1 t2 || (t1 == t2).

Prenex Implicits ord oleq.

Section Lemmas.
Variable T : ordType.
Implicit Types x y : T.

Lemma irr : irreflexive (@ord T).
Proof. by case: T=>s [b [m]]. Qed.

Lemma trans : transitive (@ord T).
Proof. by case: T=>s [b [m]]. Qed.

Lemma semiconnex x y : x != y -> ord x y || ord y x.
Proof. by case: T x y=>s [b [m]]. Qed.

Lemma ord_total x y : [|| ord x y, x == y | ord y x].
Proof.
case E: (x == y)=>/=; first by rewrite orbT.
by apply: semiconnex; rewrite negbT.
Qed.

Lemma nsym x y : ord x y -> ~ ord y x.
Proof. by move=>E1 E2; move: (trans E1 E2); rewrite irr. Qed.

Lemma orefl x : oleq x x.
Proof. by rewrite /oleq eq_refl orbT. Qed.

Lemma otrans : transitive (@oleq T).
Proof.
move=>x y z /=; case/orP; last by move/eqP=>->.
rewrite /oleq; move=>T1; case/orP; first by move/(trans T1)=>->.
by move/eqP=><-; rewrite T1.
Qed.

Lemma oantisym : antisymmetric (@oleq T).
Proof.
move=>x y; rewrite /oleq (eq_sym x).
case: eqP=>// _; rewrite !orbF=>/andP [H1 H2].
by move: (trans H1 H2); rewrite irr.
Qed.

Lemma subrel_ord : subrel (@ord T) oleq.
Proof. exact: subrelUl. Qed.

Lemma sorted_oleq s : sorted (@ord T) s -> sorted (@oleq T) s.
Proof. by case: s=>//= x s; apply/sub_path/subrel_ord. Qed.

Lemma path_filter (r : rel T) (tr : transitive r) s (p : pred T) x :
        path r x s -> path r x (filter p s).
Proof. exact: (subseq_path tr (filter_subseq p s)). Qed.

Lemma ord_sorted_eq (s1 s2 : seq T) :
        sorted ord s1 -> sorted ord s2 -> s1 =i s2 -> s1 = s2.
Proof. by exact/irr_sorted_eq/irr/trans. Qed.

Lemma oleq_ord_trans (n m p : T) :
        oleq m n -> ord n p -> ord m p.
Proof. by case/orP; [apply: trans | move/eqP=>->]. Qed.

Lemma ord_oleq_trans (n m p : T) :
        ord m n -> oleq n p -> ord m p.
Proof. by move=>H /orP [|/eqP <- //]; apply: trans. Qed.

End Lemmas.

#[export]
Hint Resolve orefl irr trans otrans oantisym oleq_ord_trans : core.

Section Totality.
Variable K : ordType.

Variant total_spec (x y : K) : bool -> bool -> bool -> Type :=
| total_spec_lt of ord x y : total_spec x y true false false
| total_spec_eq of x == y : total_spec x y false true false
| total_spec_gt of ord y x : total_spec x y false false true.

Lemma ordP x y : total_spec x y (ord x y) (x == y) (ord y x).
Proof.
case H1: (x == y).
- by rewrite (eqP H1) irr; apply: total_spec_eq.
case H2: (ord x y); case H3: (ord y x).
- by case: (nsym H2 H3).
- by apply: total_spec_lt H2.
- by apply: total_spec_gt H3.
by move: (ord_total x y); rewrite H1 H2 H3.
Qed.
End Totality.

Lemma eq_oleq (K : ordType) (x y : K) : (x == y) = oleq x y && oleq y x.
Proof. by rewrite /oleq (eq_sym x); case: ordP. Qed.

(* Monotone (i.e. strictly increasing) functions for Ord Types *)
Section Mono.
Variables (A B :ordType).

Definition strictly_increasing f x y := @ord A x y -> @ord B (f x) (f y).

Structure mono : Type := Mono
           {fun_of: A -> B; _: forall x y, strictly_increasing fun_of x y}.

End Mono.
Arguments strictly_increasing {A B} f x y.
Arguments Mono {A B _} _.

Section Weakening.
Variable T : ordType.
Implicit Types x y : T.

Lemma ordW x y: ord x y -> oleq x y.
Proof. by rewrite /oleq =>->//. Qed.

Lemma oleqNord x y: oleq x y = ~~ (ord y x).
Proof. by rewrite /oleq; case:(ordP x y)=>//. Qed.

Lemma oleq_eqVord x y : oleq x y = (x == y) || ord x y.
Proof. by rewrite /oleq orbC. Qed.

Variant oleq_spec x y : bool -> bool -> Type :=
| oleq_spec_le of oleq x y : oleq_spec x y true false
| oleq_spec_gt of ord y x : oleq_spec x y false true.

Lemma oleqP x y : oleq_spec x y (oleq x y) (ord y x).
Proof.
case:(ordP x y).
- by move=>/ordW O; rewrite O; apply: oleq_spec_le.
- by move=>/eqP E; rewrite E orefl; apply: oleq_spec_le; apply: orefl.
by move=>O; rewrite oleqNord O //=; apply: oleq_spec_gt.
Qed.

Lemma oleq_total x y: oleq x y || oleq y x.
Proof. by case:oleqP=>// /ordW ->//. Qed.

End Weakening.

(* A trivial total ordering for Unit *)
Section unitOrd.
Let ordtt (x y : unit) := false.

Lemma irr_tt : irreflexive ordtt.
Proof. by []. Qed.

Lemma trans_tt : transitive ordtt.
Proof. by []. Qed.

Lemma semiconn_tt x y : x != y -> ordtt x y || ordtt y x.
Proof. by []. Qed.

Let unit_ordMixin := OrdMixin irr_tt trans_tt semiconn_tt.
Canonical Structure unit_ordType := Eval hnf in OrdType unit unit_ordMixin.
End unitOrd.

Section NatOrd.
Lemma irr_ltn_nat : irreflexive ltn. Proof. by move=>x; rewrite /= ltnn. Qed.
Lemma trans_ltn_nat : transitive ltn. Proof. by apply: ltn_trans. Qed.
Lemma semiconn_ltn_nat x y : x != y -> (x < y) || (y < x).
Proof. by case: ltngtP. Qed.

Definition nat_ordMixin := OrdMixin irr_ltn_nat trans_ltn_nat semiconn_ltn_nat.
Canonical Structure nat_ordType := Eval hnf in OrdType nat nat_ordMixin.
End NatOrd.

Section ProdOrd.
Variables K T : ordType.

(* lexicographic ordering *)
Definition lex : rel (K * T) :=
  fun x y => if x.1 == y.1 then ord x.2 y.2 else ord x.1 y.1.

Lemma irr_lex : irreflexive lex.
Proof. by move=>x; rewrite /lex eq_refl irr. Qed.

Lemma trans_lex : transitive lex.
Proof.
move=>[x1 x2][y1 y2][z1 z2]; rewrite /lex /=.
case: ifP=>H1; first by rewrite (eqP H1); case: eqP=>// _; apply: trans.
case: ifP=>H2; first by rewrite (eqP H2) in H1 *; rewrite H1.
case: ifP=>H3; last by apply: trans.
by rewrite (eqP H3)=>R1; move/(nsym R1).
Qed.

Lemma semiconn_lex : forall x y, x != y -> lex x y || lex y x.
Proof.
move=>[x1 x2][y1 y2]; rewrite /lex /=.
by case: ifP=>H1 H2; rewrite eq_sym H1 semiconnex //; move: H2; rewrite -pair_eqE /= H1 //.
Qed.

Definition prod_ordMixin := OrdMixin irr_lex trans_lex semiconn_lex.
Canonical Structure prod_ordType := Eval hnf in OrdType (K * T) prod_ordMixin.
End ProdOrd.

Section FinTypeOrd.
Variable T : finType.

Definition ordf : rel T :=
  fun x y => index x (enum T) < index y (enum T).

Lemma irr_ordf : irreflexive ordf.
Proof. by move=>x; rewrite /ordf ltnn. Qed.

Lemma trans_ordf : transitive ordf.
Proof. by move=>x y z; rewrite /ordf; apply: ltn_trans. Qed.

Lemma semiconn_ordf x y : x != y -> ordf x y || ordf y x.
Proof.
rewrite /ordf; case: ltngtP=>//= H.
have [H1 H2]: x \in enum T /\ y \in enum T by rewrite !mem_enum.
by rewrite -(nth_index x H1) -(nth_index x H2) H eq_refl.
Qed.

Definition fin_ordMixin := OrdMixin irr_ordf trans_ordf semiconn_ordf.
End FinTypeOrd.

(* notation to let us write I_n instead of (ordinal_finType n) *)
Notation "[ 'fin_ordMixin' 'of' T ]" :=
  (fin_ordMixin _ : Ordered.mixin_of [eqType of T]) (at level 0).

Definition ordinal_ordMixin n := [fin_ordMixin of 'I_n].
Canonical Structure ordinal_ordType n := Eval hnf in OrdType 'I_n (ordinal_ordMixin n).

Section SeqOrd.
Variable (T : ordType).

Fixpoint ords x : pred (seq T) :=
  fun y => match x , y with
                 | [::] , [::] => false
                 | [::] ,  t :: ts => true
                 | x :: xs , y :: ys => if x == y then ords xs ys
                                        else ord x y
                 | _ :: _ , [::] => false
             end.

Lemma irr_ords : irreflexive ords.
Proof. by elim=>//= a l ->; rewrite irr; case:eqP=> //=. Qed.

Lemma trans_ords : transitive ords.
Proof.
elim=>[|y ys IHy][|x xs][|z zs]//=.
case:eqP=>//[->|H0];case:eqP=>//H; first by move/IHy; apply.
- by case:eqP=>//; rewrite -H; first (by move/H0).
case:eqP=>//[->|H1] H2; first by move/(nsym H2).
by move/(trans H2).
Qed.

Lemma semiconn_ords : forall x y, x != y -> ords x y || ords y x.
Proof.
elim=>[|x xs IH][|y ys]//=.
case:ifP => H1 H2; rewrite eq_sym H1.
- by apply: IH; move: H2; rewrite -eqseqE /= H1 andTb.
by rewrite semiconnex // H1.
Qed.

Definition seq_ordMixin := OrdMixin irr_ords trans_ords semiconn_ords.
Canonical Structure seq_ordType := Eval hnf in OrdType (seq T) seq_ordMixin.
End SeqOrd.

#[deprecated(since="fcsl-pcm 1.4.0", note="Use ord_sorted_eq instead.")]
Notation eq_sorted_ord := ord_sorted_eq (only parsing).


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Transitivity.

Lemma wf_env_map_free: forall E1 E2 X C B,
    wf_env (E1 ++ X~B++ E2) ->
    WF (X ~ B ++ E2) C ->
    wf_env ((map (subst_tb X C) E1)++ X~B++E2).
Proof with auto.
  induction E1;intros...
  destruct a.
  rewrite_env ((a, b) :: E1 ++ X~B++ E2) in H.
  simpl...
  rewrite_env  ((a, subst_tb X C b) :: (map (subst_tb X C) E1 ++ (X,B)::E2)).
  destruct b;simpl...
  -
    dependent destruction H.
    constructor...
    apply IHE1...
    rewrite_env (map (subst_tb X C) E1 ++ [(X, B)] ++ E2).
    apply subst_tb_wf2 with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1...
    rewrite_env (map (subst_tb X C) E1 ++ [(X, B)] ++ E2).
    apply subst_tb_wf2 with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1...
    rewrite_env (map (subst_tb X C) E1 ++ [(X, B)] ++ E2).
    apply subst_tb_wf2 with (Q:=B)...
Qed.

Lemma wf_env_map_free2: forall E1 E2 X C B,
    wf_env (E1 ++ X~B++ E2) ->
    WF  E2 C ->
    wf_env ((map (subst_tb X C) E1)++ E2).
Proof with auto.
  induction E1;intros;simpl...
  dependent destruction H...
  destruct a.
  rewrite_env ((a, b) :: E1 ++ X~B++ E2) in H.
  simpl...
  rewrite_env  ((a, subst_tb X C b) :: (map (subst_tb X C) E1 ++ E2)).
  destruct b;simpl...
  -
    dependent destruction H.
    constructor...
    apply IHE1 with (B:=B)...
    apply subst_tb_wf with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1 with (B:=B)...
    apply subst_tb_wf with (Q:=B)...
  -
    dependent destruction H.
    constructor...
    apply IHE1 with (B:=B)...
    apply subst_tb_wf with (Q:=B)...
Qed.

Lemma binds_map_free_env: forall E1 E2 X Y U T S,
    Y \notin {{X}}  ->
    wf_env (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub U) (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub (subst_tt Y S U)) (map (subst_tb Y S) E1 ++ (Y, bind_sub T) :: E2).
Proof with auto.
  intros.
  unfold binds in *.
  apply binds_map_free with (Y:=Y) (P:=S) in H1...
  apply notin_from_wf_env in H0.
  rewrite_env (map (subst_tb Y S) E1 ++ map (subst_tb Y S) [(Y, bind_sub T)] ++ map (subst_tb Y S) E2) in H1.
  simpl in H1...
  assert (map (subst_tb Y S) E2 = E2).
  rewrite maps_subst_tb_free ...
  rewrite H2 in H1...
  assert (subst_tt Y S T = T).
  rewrite <- subst_tt_fresh...
  rewrite H3 in H1...
Qed.

Lemma binds_map_free_env_lb: forall E1 E2 X Y U T S,
    Y \notin {{X}}  ->
    wf_env (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub_lb U) (E1 ++ (Y, bind_sub T) :: E2) ->
    binds X (bind_sub_lb (subst_tt Y S U)) (map (subst_tb Y S) E1 ++ (Y, bind_sub T) :: E2).
Proof with auto.
  intros.
  unfold binds in *.
  apply binds_map_free_lb with (Y:=Y) (P:=S) in H1...
  apply notin_from_wf_env in H0.
  rewrite_env (map (subst_tb Y S) E1 ++ map (subst_tb Y S) [(Y, bind_sub T)] ++ map (subst_tb Y S) E2) in H1.
  simpl in H1...
  assert (map (subst_tb Y S) E2 = E2).
  rewrite maps_subst_tb_free ...
  rewrite H2 in H1...
  assert (subst_tt Y S T = T).
  rewrite <- subst_tt_fresh...
  rewrite H3 in H1...
Qed.

Lemma equiv_subst_refl: forall E A,
    WF E A -> forall C D X,
    equiv E C D ->
    equiv E (subst_tt X C A) (subst_tt X D A).
Proof with auto.
  intros E A H.
  unfold equiv.
  assert (type A).
  get_type...
  apply type_to_rec in H0.
  generalize dependent E.
  dependent induction H0;intros;simpl;try solve [destruct_hypos;get_well_form;split;auto]...
  -
    destruct_hypos.
    split.
    +
      destruct (X==X0);subst...
      get_well_form.
      constructor...
    +
      destruct (X==X0);subst...
      get_well_form.
      constructor...
  -
    dependent destruction H.
    destruct_hypos.
    split.
    +
      constructor...
      apply IHtype4rec1...
      apply IHtype4rec2...
    +
      constructor...
      apply IHtype4rec1...
      apply IHtype4rec2...
  -
    dependent destruction H3.
    destruct_hypos.
    split.
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E);intros...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite <- subst_tt_open_tt_twice...
        rewrite <- subst_tt_open_tt_twice...
        apply H0...
        split.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      apply sa_rec with (L:=L \u L0 \u {{X}} \u dom E);intros...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite subst_tt_open_tt_var...
        apply subst_tt_wf...
        get_well_form.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply WF_weakening...
      *
        rewrite <- subst_tt_open_tt_twice...
        rewrite <- subst_tt_open_tt_twice...
        apply H0...
        split.
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub typ_top ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
  -
    dependent destruction H2.
    destruct_hypos.
    split.
    +
      apply sa_all with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ E).
        apply WF_narrowing with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
    +
      apply sa_all with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X C T1) ++ E).
        apply WF_narrowing with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
  -
    dependent destruction H2.
    destruct_hypos.
    split.
    +
      apply sa_all_lb with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ E).
        apply WF_narrowing_lb with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
    +
      apply sa_all_lb with (L:=L \u L0 \u {{X}} \u dom E);intros...
      apply IHtype4rec...
      apply IHtype4rec...
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H1...
      *
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X C T1) ++ E).
        apply WF_narrowing_lb with (V:=T1)...
        apply H3...
      *
        split.
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
        rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X C T1) ++ E).
        apply Sub_weakening...
        constructor...
        get_well_form...
        apply subst_tt_wf...
        get_well_form...
      *
        get_type...
      *
        get_type...
  -
    dependent destruction H.
    destruct_hypos.
    split.
    +
      constructor...
      apply IHtype4rec...
    +
      constructor...
      apply IHtype4rec...
Qed.

Lemma WF_narrowing_env_subst: forall E1 E2 X T S,
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) T ->
    wf_env (E1 ++ X ~ bind_sub typ_top ++ E2) ->
    WF (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2) T.
Proof with auto.
  intros.
  assert (type T).
  get_type...
  apply type_to_rec in H1.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent X.
  induction H1;intros;try solve [dependent destruction H;auto]...
  -
    dependent destruction H.
    * analyze_binds_uniq H.
      apply uniq_from_wf_env...
      +
        apply WF_var with (U:=subst_tt X0 S U).
        apply binds_map_free_env...
      +
        apply WF_var with (U:=typ_top)...
      +
        apply WF_var with (U:=U)...
    * analyze_binds_uniq H.
      apply uniq_from_wf_env...
      +
        apply WF_var_lb with (U:=subst_tt X0 S U).
        apply binds_map_free_env_lb...
      +
        apply WF_var_lb with (U:=U)...

  -
    dependent destruction H3...
    apply WF_rec with (L:=L \u L0 \u dom E1 \u dom E2 \u {{X}});intros...
    +
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub typ_top ++ E2).
      apply H2...
      apply H3...
      constructor...
    +
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub typ_top ++ E2).
      apply H0...
      apply H4...
      constructor...
  -
    dependent destruction H2...
    apply WF_all with (L:=L \u L0 \u dom E1 \u dom E2 \u {{X}});intros...
    rewrite_env (nil ++ X0 ~ bind_sub T1 ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
    apply WF_narrowing with (V:=subst_tt X S T1).
    rewrite_env (map (subst_tb X S) (X0 ~ bind_sub T1 ++ E1) ++ X ~ bind_sub typ_top ++ E2).
    apply H0...
    apply H3...
    constructor...
  -
    dependent destruction H2...
    apply WF_all_lb with (L:=L \u L0 \u dom E1 \u dom E2 \u {{X}});intros...
    rewrite_env (nil ++ X0 ~ bind_sub_lb T1 ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
    apply WF_narrowing_lb with (V:=subst_tt X S T1).
    rewrite_env (map (subst_tb X S) (X0 ~ bind_sub_lb T1 ++ E1) ++ X ~ bind_sub typ_top ++ E2).
    apply H0...
    apply H3...
    constructor...
Qed.

Lemma equiv_sub_subst_refl: forall A X E1 E2 C D S,
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) A ->
    wf_env (E1 ++ X ~ bind_sub typ_top ++ E2) ->
    equiv (X ~ bind_sub typ_top ++ E2) C D ->
    equiv (X ~ bind_sub typ_top ++ E2) C S ->
    equiv (X ~ bind_sub typ_top ++ E2) S D ->
    sub (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2) (subst_tt X C A) (subst_tt X D A).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  assert (type A) as Hq.
  get_type...
  apply type_to_rec in Hq.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent X.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction Hq;intros;simpl...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    destruct (X==X0);subst...
    +
      rewrite_env (nil ++ map (subst_tb X0 S) E1 ++ (X0, bind_sub typ_top) :: E2).
      apply Sub_weakening...
      apply wf_env_map_free...
      get_well_form...
    +
      constructor...
      apply wf_env_map_free...
      get_well_form...
      dependent destruction H.
      * analyze_binds H...
        apply WF_var with (U:=subst_tt X0 S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free...
        apply WF_var with (U:= U)...
      * analyze_binds H...
        apply WF_var_lb with (U:=subst_tt X0 S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free_lb...
        apply WF_var_lb with (U:= U)...
  -
    dependent destruction H.
    constructor...
    apply IHHq1...
    apply IHHq2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H9.
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2 \u L0);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply subst_tt_wf...
      rewrite_env (nil ++ map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
      apply WF_weakening...
      get_well_form...
      apply WF_narrowing_env_subst...
      apply H9...
      constructor...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply subst_tt_wf...
      rewrite_env (nil ++ map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ (X~ bind_sub typ_top) ++ E2).
      apply WF_weakening...
      get_well_form...
      apply WF_narrowing_env_subst...
      apply H9...
      constructor...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H0...
      apply H10...
      constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      apply IHHq...
    +
      apply IHHq...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2);
        split;apply Sub_weakening...
        apply wf_env_map_free...
        get_well_form...
        apply wf_env_map_free...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub T1 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H0...
        apply H8...
        constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all_lb with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      apply IHHq...
    +
      apply IHHq...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing_lb with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2);
        split;apply Sub_weakening...
        apply wf_env_map_free...
        get_well_form...
        apply wf_env_map_free...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub_lb T1 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H0...
        apply H8...
        constructor...
  -
    dependent destruction H.
    constructor...
    apply IHHq...
Qed.

Lemma equiv_sub_subst_refl_no_var: forall A X E1 E2 C D S,
    WF (E1 ++ X ~ bind_sub typ_top ++ E2) A ->
    wf_env (E1 ++ X ~ bind_sub typ_top ++ E2) ->
    equiv E2 C D ->
    equiv E2 C S ->
    equiv E2 S D ->
    sub (map (subst_tb X S) E1 ++  E2) (subst_tt X C A) (subst_tt X D A).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  assert (type A) as Hq.
  get_type...
  apply type_to_rec in Hq.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent X.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction Hq;intros;simpl...
  -
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    get_well_form...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
  -
    destruct (X==X0);subst...
    +
      rewrite_env (nil ++ map (subst_tb X0 S) E1 ++ E2).
      apply Sub_weakening...
      apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
    +
      constructor...
      apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
      dependent destruction H.
      * analyze_binds H...
        apply WF_var with (U:=subst_tt X0 S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free...
        apply WF_var with (U:= U)...
      * analyze_binds H...
        apply WF_var_lb with (U:=subst_tt X0 S U)...
        unfold binds in *.
        apply In_lemmaL.
        apply binds_map_free_lb...
        apply WF_var_lb with (U:= U)...
  -
    dependent destruction H.
    constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H9.
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2 \u L0);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++  E2).
      apply subst_tb_wf3...
      apply WF_narrowing with (V:=typ_top)...
      apply H9...
      get_well_form...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++  E2).
      apply subst_tb_wf3...
      apply WF_narrowing with (V:=typ_top)...
      apply H9...
      get_well_form...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top ++ E1) ++ E2).
      apply H0...
      apply H10...
      constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top) ++ E2);
          split;apply Sub_weakening...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub T1 ++ E1) ++  E2).
        apply H0...
        apply H8...
        constructor...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    dependent destruction H7.
    apply sa_all_lb with (L:=L \u L0 \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env ( nil ++ X0 ~ bind_sub_lb (subst_tt X D T1) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing_lb with (Q:=subst_tt X S T1).
      *
        assert (Hv:=H7).
        apply WF_narrowing_env_subst with (S:=S) in H7...
        apply equiv_subst_refl with (C:=D) (D:=S) (X:=X) in H7...
        apply IHHq...
        get_well_form;apply Reflexivity...
        get_well_form;apply Reflexivity...
        unfold equiv;rewrite_env (nil ++ (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top) ++ E2);
          split;apply Sub_weakening...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
        rewrite_env (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2).
        apply wf_env_map_free...
        rewrite_env (nil ++ X ~ bind_sub typ_top ++ E2).
        apply WF_weakening...
        get_well_form...
      *
        rewrite_env (map (subst_tb X S) (X0 ~ bind_sub_lb T1 ++ E1) ++  E2).
        apply H0...
        apply H8...
        constructor...
  -
    dependent destruction H.
    constructor...
Qed.

Lemma wf_env_binds_not_fv_tt: forall F Z E Q,
    wf_env (F ++ Z ~ bind_sub Q ++ E) ->
    Z \notin fv_tt Q.
Proof with auto.
  intros.
  apply wf_env_cons in H.
  dependent destruction H...
  apply WF_imply_dom in H0...
Qed.

Lemma wf_env_subst_tb : forall F Q Z P E,
  wf_env (F ++ Z ~ bind_sub Q ++ E) ->
  WF E P ->
  wf_env (map (subst_tb Z P) F ++ E).
Proof with eauto.
  induction F; intros ;simpl in *...
  -
    dependent destruction H...
  -
    destruct a.
    dependent destruction H;simpl in *.
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub Q)...
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub Q)...
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub Q)...
Qed.

Lemma wf_env_subst_tb_lb : forall F Q Z P E,
  wf_env (F ++ Z ~ bind_sub_lb Q ++ E) ->
  WF E P ->
  wf_env (map (subst_tb Z P) F ++ E).
Proof with eauto.
  induction F; intros ;simpl in *...
  -
    dependent destruction H...
  -
    destruct a.
    dependent destruction H;simpl in *.
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub_lb Q)...
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub_lb Q)...
    +
      constructor...
      apply subst_tb_wf with (Q:=bind_sub_lb Q)...
Qed.

Lemma sub_through_subst_tt: forall Z Q T S F E P,
    sub (F ++ Z ~ bind_sub Q ++ E) T S ->
    sub E P Q ->
    sub (map (subst_tb Z P) F ++ E) (subst_tt Z P T) (subst_tt Z P S).
Proof with auto.
  intros.
  assert (WF E P) as Hq.
    get_well_form...
  dependent induction H;simpl...
  -
    constructor...
    apply wf_env_subst_tb with (Q:=Q)...
  -
    destruct (X==Z);subst...
    + apply Reflexivity...
      add_nil.
      apply WF_weakening...
      apply wf_env_subst_tb with (Q:=Q)...
    + dependent destruction H0.
      { constructor...
        apply wf_env_subst_tb with (Q:=Q)...
        apply WF_var with (U:=subst_tt Z P U)...
        apply binds_map_free_sub with (Q:=Q)... }
      { constructor...
        apply wf_env_subst_tb with (Q:=Q)...
        apply WF_var_lb with (U:=subst_tt Z P U)...
        apply binds_map_free_sub2 with (Q:=Q)... }
  -
    constructor...
    apply wf_env_subst_tb with (Q:=Q)...
    apply subst_tb_wf with (Q:=bind_sub Q)...
  -
    constructor...
    apply wf_env_subst_tb with (Q:=Q)...
    apply subst_tb_wf with (Q:=bind_sub Q)...
  -
    destruct (X==Z);subst...
    +
      apply sub_transitivity with (Q:=Q).
      *
        add_nil.
        apply Sub_weakening...
        apply wf_env_subst_tb with (Q:=Q)...
        get_well_form...
      *
        assert (Q = subst_tt Z P Q).
        rewrite <- subst_tt_fresh ...
        get_well_form.
        apply wf_env_binds_not_fv_tt in H0...
        rewrite H2.
        analyze_binds_uniq H...
        apply uniq_from_wf_env...
        get_well_form...
        inversion BindsTacVal;subst.
        apply IHsub with (Q0:=Q)...
    +
      apply sa_trans_tvar with (U:=subst_tt Z P U)...
      apply binds_map_free_sub with (Q:=Q)...
      get_well_form...
      apply IHsub with (Q0:=Q)...

  -
    destruct (X==Z);subst...
    + apply binds_mid_eq in H...
      inversion H. apply uniq_from_wf_env.
      get_well_form...
    +
      apply sa_trans_tvar_lb with (U:=subst_tt Z P U)...
      apply binds_map_free_sub2 with (Q:=Q)...
      get_well_form...
      apply IHsub with (Q0:=Q)...
  -
    constructor...
    apply IHsub1 with (Q0:=Q)...
    apply IHsub2 with (Q0:=Q)...
  -
    assert (type P). get_type...
    apply sa_all with (L:=L \u {{Z}});intros...
    + apply IHsub1 with (Q0:=Q)...
    + apply IHsub2 with (Q0:=Q)...
    (* + apply subst_tb_wf with (Q:=bind_sub Q)... *)
    + rewrite_env ( map (subst_tb Z P) (X~bind_sub S2 ++ F) ++ E).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H2 with (Q0:=Q)...
  -
    assert (type P). get_type...
    apply sa_all_lb with (L:=L \u {{Z}});intros...
    + apply IHsub1 with (Q0:=Q)...
    + apply IHsub2 with (Q0:=Q)...
    (* + apply subst_tb_wf with (Q:=bind_sub Q)... *)
    + rewrite_env ( map (subst_tb Z P) (X~bind_sub_lb S2 ++ F) ++ E).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      apply H2 with (Q0:=Q)...
  -
    assert (type P). get_type...
    apply sa_rec with (L:=L \u {{Z}});intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb Z P) (X~bind_sub typ_top ++ F) ++ E).
      apply subst_tb_wf with (Q:=bind_sub Q)...
      apply H...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb Z P) (X~bind_sub typ_top ++ F) ++ E).
      apply subst_tb_wf with (Q:=bind_sub Q)...
      apply H0...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb Z P) (X~bind_sub typ_top ++ F) ++ E).
      apply H2 with (Q0:=Q)...
  -
    constructor...
    apply IHsub with (Q0:=Q)...
  (* -
    apply sa_rcd...
    +
      apply wf_env_subst_tb with (Q:=Q)...
    +
      apply subst_tt_rt_type with (E:=F ++ Z ~ bind_sub Q ++ E)...
      add_nil. apply WF_weakening... apply WF_weakening...
    +
      apply subst_tt_rt_type with (E:=F ++ Z ~ bind_sub Q ++ E)...
      add_nil. apply WF_weakening... apply WF_weakening...
    +
      apply label_equiv_reserve with (E:=F ++ Z ~ bind_sub Q ++ E)...
      reflexivity.
    +
      apply subst_tb_wf with (Q:=bind_sub Q)...
    +
      apply subst_tb_wf with (Q:=bind_sub Q)...
    +
      intros. apply Tlookup_subst with (E:=(F ++ Z ~ bind_sub Q ++ E) )in H8 ...
      apply Tlookup_subst with (E:=(F ++ Z ~ bind_sub Q ++ E) )in H9...
      destruct_hypos. subst.
      apply H6 with (i:=i) (Q0:=Q)... *)
Qed.

Lemma equiv_sub_subst_not_var: forall A B X E1 E2 C D S,
    sub (E1 ++ X ~ bind_sub typ_top ++ E2) A B ->
    equiv E2 C D ->
    equiv E2 C S ->
    equiv E2 S D ->
    sub (map (subst_tb X S) E1 ++ E2) (subst_tt X C A) (subst_tt X D B).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction H;intros;simpl...
  -
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    get_well_form...
  -
    destruct (X0==X);subst...
    +
      rewrite_env (nil ++ map (subst_tb X S) E1 ++ E2).
      apply Sub_weakening...
      apply wf_env_map_free2 with (B:=bind_sub typ_top)...
      get_well_form...
    +
      constructor...
      *
        apply wf_env_map_free2 with (B:=bind_sub typ_top)...
        get_well_form...
      *
        dependent destruction H0.
        { analyze_binds H0...
          apply WF_var with (U:=subst_tt X S U)...
          unfold binds in *.
          apply In_lemmaL.
          apply binds_map_free...
          apply WF_var with (U:= U)... }
        { analyze_binds H0...
          apply WF_var_lb with (U:=subst_tt X S U)...
          unfold binds in *.
          apply In_lemmaL.
          apply binds_map_free_lb...
          apply WF_var_lb with (U:= U)... }
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    apply subst_tb_wf3...
    apply WF_narrowing with (V:=typ_top)...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free2 with (B:=bind_sub typ_top)...
    apply subst_tb_wf3...
    apply WF_narrowing with (V:=typ_top)...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...
      dependent destruction BindsTacVal.
      dependent destruction H0.
      * simpl...
        constructor...
        apply wf_env_map_free2 with (B:=bind_sub typ_top)...
        get_well_form...
        get_well_form.
        rewrite_env (nil ++ map (subst_tb X S) E1 ++  E2).
        apply WF_weakening...
      * simpl... destruct (X0 ==X)...
        { add_nil. apply Sub_weakening...
          apply wf_env_map_free2 with (B:=bind_sub typ_top)...
          get_well_form... get_well_form... }
        { apply sa_trans_tvar_lb with (U:=subst_tt X S U)...
          apply binds_map_free_sub2 with (S:=S) in H...
          get_well_form...
          eapply sub_transitivity with (Q:=typ_top).
            {
              constructor...
              apply wf_env_map_free2 with (B:=bind_sub typ_top)...
              get_well_form...
              get_well_form...
              rewrite_env (nil ++ map (subst_tb X S) E1 ++  E2).
              apply WF_weakening... get_well_form...
            }
            { replace typ_top with (subst_tt X S typ_top)...
              apply sub_through_subst_tt with (Q:=typ_top)...
              constructor;get_well_form... }
        }
    +
      apply sa_trans_tvar with (U:=subst_tt X S U)...
      *
        apply binds_map_free_sub with (Q:=typ_top)...
        get_well_form...
      *
        apply IHsub...
        get_well_form.
        apply Reflexivity...
        get_well_form.
        apply Reflexivity...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...

    +
      apply sa_trans_tvar_lb with (U:=subst_tt X S U)...
      *
        apply binds_map_free_sub2 with (Q:=typ_top)...
        get_well_form...
      *
        apply IHsub...
        get_well_form.
        apply Reflexivity...
        get_well_form.
        apply Reflexivity...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_all with (L:=L \u {{X}});intros...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl_no_var;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub S2 ++ E1) ++ E2).
        apply H2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_all_lb with (L:=L \u {{X}});intros...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ E2).
      apply sub_narrowing_lb with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl_no_var;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub_lb S2 ++ E1) ++ E2).
        apply H2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ E2).
      apply subst_tb_wf3...
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub S ++ E2).
      apply WF_narrowing with (V:=typ_top)...
      apply H...
      get_well_form...
    +
      rewrite subst_tt_open_tt_var...
      rewrite_env (map (subst_tb X S) (X0 ~ bind_sub typ_top ++ E1) ++ E2).
      apply subst_tb_wf3...
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ X ~ bind_sub S ++ E2).
      apply WF_narrowing with (V:=typ_top)...
      apply H0...
      get_well_form...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++  E2).
      apply H2...
Qed.

Lemma equiv_sub_subst: forall A B X E1 E2 C D S,
    sub (E1 ++ X ~ bind_sub typ_top ++ E2) A B ->
    equiv (X ~ bind_sub typ_top ++ E2) C D ->
    equiv (X ~ bind_sub typ_top ++ E2) C S ->
    equiv (X ~ bind_sub typ_top ++ E2) S D ->
    sub (map (subst_tb X S) E1 ++ X ~ bind_sub typ_top ++ E2) (subst_tt X C A) (subst_tt X D B).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  generalize dependent C.
  generalize dependent D.
  generalize dependent S.
  dependent induction H;intros;simpl...
  -
    constructor...
    apply wf_env_map_free...
    get_well_form...
  -
    destruct (X0==X);subst...
    +
      rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply Sub_weakening...
      apply wf_env_map_free...
      get_well_form...
    +
      constructor...
      *
        apply wf_env_map_free...
        get_well_form...
      *
        dependent destruction H0.
        { analyze_binds H0...
          + apply WF_var with (U:=subst_tt X S U)...
            unfold binds in *.
            apply In_lemmaL.
            apply binds_map_free...
          + apply WF_var with (U:= U)... }
        { analyze_binds H0...
          + apply WF_var_lb with (U:=subst_tt X S U)...
            unfold binds in *.
            apply In_lemmaL.
            apply binds_map_free_lb...
          + apply WF_var_lb with (U:= U)... }
  -
    get_well_form...
    constructor...
    apply wf_env_map_free...
    apply subst_tt_wf...
    rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
    apply WF_weakening...
    apply WF_narrowing_env_subst...
  -
    get_well_form...
    constructor...
    apply wf_env_map_free...
    apply subst_tt_wf...
    rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
    apply WF_weakening...
    apply WF_narrowing_env_subst...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...
      inversion BindsTacVal.
      subst. clear IHsub.
      dependent induction H0.
      * simpl...
        constructor...
        apply wf_env_map_free...
        get_well_form...
        get_well_form.
        rewrite_env (nil ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
        apply WF_weakening...
      *
        simpl... destruct (X0 == X)...
        { add_nil. apply Sub_weakening...
          apply wf_env_map_free;get_well_form... }
        { apply sa_trans_tvar_lb with (U:= subst_tt X S U)...
          * apply binds_map_free_sub2 with (S:=S) in H...
            2:{ get_well_form... }
            apply binds_app_iff in H. destruct H.
            apply binds_app_iff... apply binds_app_iff.
            right. apply binds_cons...
          * apply IHsub...
            apply Reflexivity;get_well_form...
            apply Reflexivity;get_well_form...
        }
    + apply sa_trans_tvar with (U:= subst_tt X S U)...
      * apply binds_map_free_sub with (S:=S) in H...
        2:{ get_well_form... }
        apply binds_app_iff in H. destruct H.
        apply binds_app_iff... apply binds_app_iff.
        right. apply binds_cons...
      * apply IHsub...
        apply Reflexivity;get_well_form...
        apply Reflexivity;get_well_form...
  -
    destruct (X0==X);subst...
    +
      analyze_binds_uniq  H.
      get_well_form.
      apply uniq_from_wf_env...
    + apply sa_trans_tvar_lb with (U:= subst_tt X S U)...
      * apply binds_map_free_sub2 with (S:=S) in H...
        2:{ get_well_form... }
        apply binds_app_iff in H. destruct H.
        apply binds_app_iff... apply binds_app_iff.
        right. apply binds_cons...
      * apply IHsub...
        apply Reflexivity;get_well_form...
        apply Reflexivity;get_well_form...
  -
    constructor...
    apply IHsub1...
    apply IHsub2...
  -
    apply sa_all with (L:=L \u {{X}});intros...
    +
      apply IHsub1...
    +
      apply IHsub2...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub S2 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H2...
  -
    apply sa_all_lb with (L:=L \u {{X}});intros...
    +
      apply IHsub1...
    +
      apply IHsub2...
    +
      assert (type C) by (get_type;auto).
      assert (type D) by (get_type;auto).
      rewrite subst_tt_open_tt_var...
      rewrite subst_tt_open_tt_var...
      rewrite_env (nil ++ X0 ~ bind_sub_lb (subst_tt X D S2) ++ map (subst_tb X S) E1 ++ (X, bind_sub typ_top) :: E2).
      apply sub_narrowing_lb with (Q:=subst_tt X S S2).
      *
        apply equiv_sub_subst_refl;try solve [get_well_form;auto|unfold equiv;auto]...
        unfold equiv;get_well_form;split;apply Reflexivity...
      *
        rewrite_env  (map (subst_tb X S) (X0 ~ bind_sub_lb S2 ++ E1) ++ (X, bind_sub typ_top) :: E2).
        apply H2...
  -
    assert (type C) by (get_type;auto).
    assert (type D) by (get_type;auto).
    apply sa_rec with (L:=L \u {{X}} \u dom E1 \u dom E2);intros...
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wf...
      rewrite_env (nil ++ (X0 ~ bind_sub typ_top ++ map (subst_tb X S) E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_weakening...
      get_well_form...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_narrowing_env_subst...
      apply H...
      specialize_x_and_L X0 L.
      get_well_form...
    +
      rewrite subst_tt_open_tt_var...
      apply subst_tt_wf...
      rewrite_env (nil ++ (X0 ~ bind_sub typ_top ++ map (subst_tb X S) E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_weakening...
      get_well_form...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++ (X, bind_sub typ_top) :: E2).
      apply WF_narrowing_env_subst...
      apply H0...
      specialize_x_and_L X0 L.
      get_well_form...
    +
      rewrite <- subst_tt_open_tt_twice...
      rewrite <- subst_tt_open_tt_twice...
      rewrite_env (map (subst_tb X S) (X0~bind_sub typ_top++E1) ++ (X, bind_sub typ_top) :: E2).
      apply H2...
  -
    constructor...
    apply IHsub...
Qed.

Lemma equiv_unfolding: forall E C D X,
    equiv E (typ_mu C) (typ_mu D) ->
    X \notin fv_tt C \u fv_tt D \u dom E ->
    equiv (X~bind_sub typ_top ++ E) (typ_label X (open_tt C X)) (typ_label X (open_tt D X)).
Proof with auto.
  intros.
  unfold equiv in *.
  destruct_hypos.
  dependent destruction H.
  dependent destruction H2.
  split.
  constructor...
  pick fresh Y.
  apply sub_replacing_var with (X:=Y)...
  apply sub_nominal_inversion...
  constructor...
  specialize_x_and_L Y L.
  get_well_form...
  dependent destruction H1...
  constructor...
  pick fresh Y.
  apply sub_replacing_var with (X:=Y)...
  apply sub_nominal_inversion...
  constructor...
  specialize_x_and_L Y L.
  get_well_form...
  dependent destruction H1...
Qed.

Lemma equiv_reflexivity: forall E C,
    wf_env E ->
    WF E C ->
    equiv E C C.
Proof with auto.
  intros.
  unfold equiv;split;apply Reflexivity...
Qed.

Lemma equiv_sub_unfolding: forall C D Y E,
      sub (Y ~ bind_sub typ_top ++ E) (open_tt C Y) (open_tt D Y) ->
      sub (Y ~ bind_sub typ_top ++ E) (open_tt D Y) (open_tt C Y) ->
      Y \notin fv_tt C \u fv_tt D \u fl_tt C \u fl_tt D \u dom E \u fl_env E->
      sub E (typ_mu C) (typ_mu D).
Proof with auto.
  intros.
  apply sa_rec with (L:=dom E \u {{Y}} \u fv_tt C \u fv_tt D \u fl_tt C \u fl_tt D);intros.
  -
    get_well_form.
    apply WF_replacing_var with (X:=Y)...
  -
    get_well_form.
    apply WF_replacing_var with (X:=Y)...
  -
    apply sub_renaming_unfolding with (X:=Y)...
    +
      rewrite subst_tt_intro with (X:=Y)...
      remember (subst_tt Y (typ_label Y (open_tt C Y)) (open_tt C Y)).
      rewrite subst_tt_intro with (X:=Y)...
      rewrite_env (map (subst_tb Y (typ_label Y (open_tt C Y))) nil ++ Y ~ bind_sub typ_top ++ E).
      subst.
      apply equiv_sub_subst...
      unfold equiv;split...
      get_well_form.
      unfold equiv;split;apply Reflexivity...
      unfold equiv;split...
    +
      constructor...
      get_well_form...
      dependent destruction H...
Qed.