(*

  Copyright 2014 Cornell University

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

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

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

*)

Require Export rules_useful.
Require Export per_props_equality.
Require Export per_props_union.
Require Export subst_tacs.

Unset Regular Subst Tactic.

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

(* begin hide *)

(* end hide *)

(**

  The following rule eliminates equalities between equality types:
<<
   H, x : (a1 = a2 in A) = (b1 = b2 in B) in U(i), J |- C ext e

     By equalityUniverseElim y z w

     H, x : (a1 = a2 in A) = (b1 = b2 in B) in U(i),
        [y : A = B in U(i)],
        [z : a1 = b1 in (A \/ Base)]
        [w : a2 = b2 in (A \/ Base)]
        J |- C ext t
>>
 *)
Definition rule_equality_universe_elim {o}
           (H J  : @barehypotheses o)
           (A B a1 a2 b1 b2 C e : NTerm)
           (x y z w : NVar)
           (i : nat) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality
                            (mk_equality a1 a2 A)
                            (mk_equality b1 b2 B)
                            (mk_uni i)))
             ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc (snoc (snoc H (mk_hyp x (mk_equality
                                               (mk_equality a1 a2 A)
                                               (mk_equality b1 b2 B)
                                               (mk_uni i))))
                          (mk_hhyp y (mk_equality A B (mk_uni i))))
                    (mk_hhyp z (mk_equality a1 b1 (mk_bunion A mk_base))))
              (mk_hhyp w (mk_equality a2 b2 (mk_bunion A mk_base)))
              ++ J)
        (mk_concl C e)
    ]
    [].

Lemma rule_equality_universe_elim_true {o} :
  forall lib (H J : @barehypotheses o)
         (A B a1 a2 b1 b2 C e : NTerm)
         (x y z w : NVar)
         (i : nat),
    rule_true lib (rule_equality_universe_elim H J A B a1 a2 b1 b2 C e x y z w i).
Proof.
  unfold rule_equality_universe_elim, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract
            (snoc H
                  (mk_hyp
                     x
                     (mk_equality
                        (mk_equality a1 a2 A)
                        (mk_equality b1 b2 B)
                        (mk_uni i))) ++ J)
            (mk_concl C e)) as cex.
  clear hyp1.
  unfold closed_extract; allsimpl.
  allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc; allsimpl; auto.

  exists cex.

  (* We prove some simple facts on our sequents *)
  assert (!LIn y (free_vars C)
          # !LIn z (free_vars C)
          # !LIn w (free_vars C)

          # !LIn y (free_vars e)
          # !LIn z (free_vars e)
          # !LIn w (free_vars e)

          # !LIn x (free_vars a1)
          # !LIn y (free_vars a1)
          # !LIn z (free_vars a1)
          # !LIn w (free_vars a1)

          # !LIn x (free_vars a2)
          # !LIn y (free_vars a2)
          # !LIn z (free_vars a2)
          # !LIn w (free_vars a2)

          # !LIn x (free_vars A)
          # !LIn y (free_vars A)
          # !LIn z (free_vars A)
          # !LIn w (free_vars A)

          # !LIn x (free_vars b1)
          # !LIn y (free_vars b1)
          # !LIn z (free_vars b1)
          # !LIn w (free_vars b1)

          # !LIn x (free_vars b2)
          # !LIn y (free_vars b2)
          # !LIn z (free_vars b2)
          # !LIn w (free_vars b2)

          # !LIn x (free_vars B)
          # !LIn y (free_vars B)
          # !LIn z (free_vars B)
          # !LIn w (free_vars B)

          # !LIn w (hyps_free_vars J)
          # !LIn z (hyps_free_vars J)
          # !LIn y (hyps_free_vars J)

          # !LIn w (free_vars_hyps J)
          # !LIn z (free_vars_hyps J)
          # !LIn y (free_vars_hyps J)

          # !LIn w (vars_hyps J)
          # !LIn z (vars_hyps J)
          # !LIn y (vars_hyps J)
         ) as vhyps.

  clear hyp1.
  dwfseq.
  sp; try (complete (discover; allrw in_app_iff; allrw in_snoc; sp;
                     allapply @subset_hs_vars_hyps; sp)).

  destruct vhyps as [ niyC vhyps ].
  destruct vhyps as [ nizC vhyps ].
  destruct vhyps as [ niwC vhyps ].

  destruct vhyps as [ niye vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ niwe vhyps ].

  destruct vhyps as [ nixa1 vhyps ].
  destruct vhyps as [ niya1 vhyps ].
  destruct vhyps as [ niza1 vhyps ].
  destruct vhyps as [ niwa1 vhyps ].

  destruct vhyps as [ nixa2 vhyps ].
  destruct vhyps as [ niya2 vhyps ].
  destruct vhyps as [ niza2 vhyps ].
  destruct vhyps as [ niwa2 vhyps ].

  destruct vhyps as [ nixA vhyps ].
  destruct vhyps as [ niyA vhyps ].
  destruct vhyps as [ nizA vhyps ].
  destruct vhyps as [ niwA vhyps ].

  destruct vhyps as [ nixb1 vhyps ].
  destruct vhyps as [ niyb1 vhyps ].
  destruct vhyps as [ nizb1 vhyps ].
  destruct vhyps as [ niwb1 vhyps ].

  destruct vhyps as [ nixb2 vhyps ].
  destruct vhyps as [ niyb2 vhyps ].
  destruct vhyps as [ nizb2 vhyps ].
  destruct vhyps as [ niwb2 vhyps ].

  destruct vhyps as [ nixB vhyps ].
  destruct vhyps as [ niyB vhyps ].
  destruct vhyps as [ nizB vhyps ].
  destruct vhyps as [ niwB vhyps ].

  destruct vhyps as [ niwJ1 vhyps ].
  destruct vhyps as [ nizJ1 vhyps ].
  destruct vhyps as [ niyJ1 vhyps ].

  destruct vhyps as [ niwJ2 vhyps ].
  destruct vhyps as [ nizJ2 vhyps ].
  destruct vhyps as [ niyJ2 vhyps ].

  destruct vhyps as [ niwJ3 vhyps ].
  destruct vhyps as [ nizJ3 niyJ3 ].
  (* done with proving these simple facts *)

  vr_seq_true.

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

  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  apply @equality_mkc_equality2_sp_in_uni in sim0; repnd.
  unfold equorsq2, equorsq in sim0; repnd.

  vr_seq_true in hyp1.
  pose proof (hyp1
                (snoc (snoc (snoc (snoc s1a0 (x,t1))
                                  (y,mkc_axiom))
                            (z,mkc_axiom))
                      (w,mkc_axiom)
                      ++ s1b)
                (snoc (snoc (snoc (snoc s2a0 (x,t2))
                                  (y,mkc_axiom))
                            (z,mkc_axiom))
                      (w,mkc_axiom)
                      ++ s2b)) as h; clear hyp1; rename h into hyp1.

  autodimp hyp1 hyp.

  (* we prove the hyps_functionality part *)

  introv sim'.
  rw @similarity_app in sim'; simpl in sim'; allrw length_snoc; exrepnd; subst; cpx; GC.
  apply app_split in sim'0; [| complete (allrw length_snoc; allrw; auto)].
  rw @similarity_snoc in sim'5; simpl in sim'5; exrepnd; subst; cpx.
  rw @similarity_snoc in sim'8; simpl in sim'8; exrepnd; subst; cpx.
  rw @similarity_snoc in sim'6; simpl in sim'6; exrepnd; subst; cpx.
  rw @similarity_snoc in sim'7; simpl in sim'7; exrepnd; subst; cpx.

  (* we bring in the eq_hyps from our main goal *)
  pose proof (eqh (snoc s2a (x,t6) ++ s2b0)) as eh.
  autodimp eh hyp.
  apply similarity_app; simpl.
  exists (snoc s1a (x, t0)) s1b0 (snoc s2a (x, t6)) s2b0; dands; auto;
  try (complete (repeat (rw length_snoc); allrw; auto)).
  apply similarity_snoc; simpl.
  exists s1a s2a t0 t6 w10 p3; dands; auto.
  rw @substitute_hyps_snoc_sub_weak in sim'1; auto.
  rw @substitute_hyps_snoc_sub_weak in sim'1; auto.
  rw @substitute_hyps_snoc_sub_weak in sim'1; auto.
  (* done *)

  (* we simplify eh *)
  apply eq_hyps_app in eh; simpl in eh; exrepnd.
  apply app_split in eh0; [| complete (allrw length_snoc; allrw; auto)].
  apply app_split in eh2; [| complete (allrw length_snoc; allrw; auto)].
  repnd; subst; cpx.
  dup eh5 as ehsnoc.
  apply eq_hyps_snoc in eh5; simpl in eh5; exrepnd; cpx.

  lsubst_tac.

  apply equality_in_mkc_equality in sim'6; repnd.
  apply equality_mkc_equality2_sp_in_uni in sim'0; repnd.
  apply equality_in_mkc_equality in sim'3; repnd; GC.
  apply equality_in_mkc_equality in sim'2; repnd; GC.
  apply equality_in_mkc_equality in sim'5; repnd; GC.

  lsubst_tac.

  rw @eq_hyps_app.
  exists (snoc (snoc (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom)) (z, mkc_axiom))
               (w, mkc_axiom))
         s1b
         (snoc (snoc (snoc (snoc s2a1 (x, t7)) (y, t5)) (z, t4)) (w, t3))
         s2b1;
    dands; auto; repeat (rw length_snoc); try (complete (allrw; auto)).

  assert (cover_vars
            (mk_equality a2 b2 (mk_bunion A mk_base))
            (snoc (snoc (snoc s2a1 (x, t7)) (y, t5)) (z, t4)))
    as cv1
      by (eapply cover_vars_change_sub;[|exact p0];
          repeat (rw @dom_csub_snoc); simpl; auto;
          allapply @similarity_dom; repnd; allrw; sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom)) (z, mkc_axiom))
         (snoc (snoc (snoc s2a1 (x, t7)) (y, t5)) (z, t4))
         (@mkc_axiom o) t3 w7 p0 cv1;
    dands; auto.

  assert (cover_vars
            (mk_equality a1 b1 (mk_bunion A mk_base))
            (snoc (snoc s2a1 (x, t7)) (y, t5)))
    as cv2
      by (eapply cover_vars_change_sub;[|exact p1];
          repeat (rw @dom_csub_snoc); simpl; auto;
          allapply @similarity_dom; repnd; allrw; sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom))
         (snoc (snoc s2a1 (x, t7)) (y, t5))
         (@mkc_axiom o) t4 w8 p1 cv2;
    dands; auto.

  assert (cover_vars (mk_equality A B (mk_uni i)) (snoc s2a1 (x, t7)))
    as cv3
      by (eapply cover_vars_change_sub;[|exact p2];
          repeat (rw @dom_csub_snoc); simpl; auto;
          allapply @similarity_dom; repnd; allrw; sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a0 (x, t1))
         (snoc s2a1 (x, t7))
         (@mkc_axiom o) t5 w9 p2 cv3;
    dands; auto.

  lsubst_tac.

  apply tequality_mkc_equality2_sp in eh0; repnd.
  apply tequality_mkc_equality2_sp; dands; auto.
  unfold equorsq2 in eh0; repnd.
  unfold equorsq2; dands.

  unfold equorsq in eh3; unfold equorsq; dorn eh3.
  left.
  apply equality_mkc_equality2_sp_in_uni in eh3; repnd; auto.
  right; spcast.
  apply cequivc_decomp_equality in eh3; repnd; auto.

  unfold equorsq in eh0; unfold equorsq; dorn eh0.
  left.
  apply equality_mkc_equality2_sp_in_uni in eh0; repnd; auto.
  right; spcast.
  apply cequivc_decomp_equality in eh0; repnd; auto.

  lsubst_tac.
  apply tequality_mkc_equality2_sp in eh0; repnd.
  unfold equorsq2, equorsq in eh0; repnd.
  apply tequality_mkc_equality2_sp; dands.

  lsubst_tac.

  apply tequality_bunion; dands; auto.
  dorn eh3.
  apply equality_mkc_equality2_sp_in_uni in eh3; repnd.
  apply equality_in_uni in eh5; auto.
  spcast.
  apply cequivc_decomp_equality in eh3; repnd.
  apply equality_in_uni in sim7; auto.
  apply tequality_refl in sim7.
  apply type_respects_cequivc_right; auto.

  unfold equorsq2; dands; lsubst_tac.

  dorn eh3.
  apply equality_mkc_equality2_sp_in_uni in eh3; repnd.
  destruct eh3 as [e1 e2].
  apply equorsq_in_bunion_left; auto.
  apply tequality_base.
  spcast.
  apply cequivc_decomp_equality in eh3; repnd.
  right; spcast; auto.

  dorn eh0.
  apply equality_mkc_equality2_sp_in_uni in eh0; repnd.
  destruct eh0 as [e1 e2].
  apply equorsq_in_bunion_left; auto.
  apply equality_in_uni in sim7.
  eapply equorsq_tequality; eauto.
  apply tequality_sym; auto.
  apply tequality_base.
  spcast.
  apply cequivc_decomp_equality in eh0; repnd.
  right; spcast; auto.

  apply tequality_mkc_equality in eh0; repnd.
  lsubst_tac.
  apply tequality_mkc_equality; dands; lsubst_tac.

  apply tequality_bunion; dands; auto.
  apply equality_in_uni in sim7.
  apply tequality_refl in sim7.
  dorn eh5.
  apply equality_in_uni in eh5.
  apply tequality_mkc_equality in eh5; repnd; auto.
  spcast.
  apply cequivc_decomp_equality in eh5; repnd.
  apply type_respects_cequivc_right; auto.

  split; intro k; lsubst_tac.

  apply equality_in_mkc_bunion in k; repnd.
  apply equality_in_mkc_bunion; dands; auto.
  dorn eh5.
  apply equality_in_uni in eh5.
  apply tequality_mkc_equality in eh5; repnd; auto.
  apply tequality_sym in eh6; apply tequality_refl in eh6; auto.
  spcast.
  apply cequivc_decomp_equality in eh5; repnd.
  apply type_respects_cequivc_left in eh5; auto.
  apply tequality_refl in eh5; auto.

  apply (equal_in_bunion_change2 lib
           (lsubstc A wT0 s1a0 cT0)
           mkc_base
           (lsubstc a2 w4 s1a0 c3)
           (lsubstc b2 w6 s1a0 c5)); auto.

  dorn eh5.
  apply equality_in_uni in eh5.
  apply tequality_mkc_equality in eh5; repnd; auto.
  spcast.
  apply cequivc_decomp_equality in eh5; repnd.
  apply type_respects_cequivc_left in eh5; auto.
  apply tequality_sym in eh5; auto.

  dorn eh5.
  apply equality_in_uni in eh5.
  apply tequality_mkc_equality in eh5; repnd; auto.
  spcast.
  apply cequivc_decomp_equality in eh5; repnd.
  rwg eh7.
  right; spcast; sp.

  dorn eh0.
  apply equality_in_uni in eh0.
  apply tequality_mkc_equality2 in eh0; repnd; auto.
  destruct eh0 as [e1 e2].
  apply (equorsq_tequality lib (lsubstc B wT1 s1a0 cT1)); auto.
  apply (tequality_trans _ _ (lsubstc A wT0 s1a0 cT0)); auto.
  apply equality_in_uni in sim7.
  apply tequality_sym; auto.
  dorn eh5.
  apply equality_mkc_equality2_sp_in_uni in eh5; repnd.
  apply equality_in_uni in eh0; auto.
  spcast.
  apply cequivc_decomp_equality in eh5; repnd.
  apply cequivc_sym in eh5; rwg eh5.
  apply equality_in_uni in sim7; apply tequality_refl in sim7; auto.

  spcast.
  apply cequivc_decomp_equality in eh0; repnd.
  rwg eh7; right; spcast; sp.

  apply equality_in_mkc_bunion in k; repnd.
  apply equality_in_mkc_bunion; dands; auto.
  apply equality_in_uni in sim7.
  apply tequality_refl in sim7; auto.

  apply (equal_in_bunion_change2 lib
           (lsubstc A wT0 s2a1 cT3)
           mkc_base
           (lsubstc a2 w4 s2a1 c9)
           (lsubstc b2 w6 s2a1 c11)); auto.

  apply tequality_sym.
  dorn eh5.
  apply equality_in_uni in eh5.
  apply tequality_mkc_equality in eh5; repnd; auto.
  spcast.
  apply cequivc_decomp_equality in eh5; repnd.
  apply cequivc_sym in eh5; rwg eh5.
  apply equality_in_uni in sim7.
  apply tequality_refl in sim7; auto.

  dorn eh5.
  apply equality_in_uni in eh5.
  apply tequality_mkc_equality2 in eh5; repnd; auto.
  destruct eh5 as [e1 e2].
  apply equorsq_sym.
  apply (equorsq_tequality lib (lsubstc A wT0 s1a0 cT0)); auto.
  spcast.
  apply cequivc_decomp_equality in eh5; repnd.
  rwg eh7; right; spcast; sp.

  dorn eh0.
  apply equality_in_uni in eh0.
  apply tequality_mkc_equality2 in eh0; repnd; auto.
  destruct eh0 as [e1 e2].
  apply equorsq_sym.
  apply (equorsq_tequality lib (lsubstc B wT1 s1a0 cT1)); auto.
  apply tequality_sym; auto.
  apply equality_in_uni in sim7; auto.
  spcast.
  apply cequivc_decomp_equality in eh0; repnd.
  rwg eh7; right; spcast; sp.

  dorn eh5.
  apply equality_in_uni in eh5.
  apply tequality_mkc_equality2 in eh5; repnd; auto.
  destruct eh5 as [e1 e2].
  dorn e2.
  left; lsubst_tac.
  apply equality_in_bunion_left; auto.
  apply tequality_base.
  right; sp.
  spcast.
  apply cequivc_decomp_equality in eh5; repnd.
  right; spcast; sp.

  dorn eh0.
  apply equality_in_uni in eh0.
  apply tequality_mkc_equality2 in eh0; repnd; auto.
  destruct eh0 as [e1 e2].
  dorn e2.
  left; lsubst_tac.
  apply equality_in_bunion_left; auto.
  eapply tequality_preserving_equality; eauto.
  apply tequality_sym; auto.
  apply equality_in_uni in sim7; auto.
  apply tequality_base.
  right; sp.
  spcast.
  apply cequivc_decomp_equality in eh0; repnd.
  right; spcast; sp.

  (* Now the sub_eq_hyps *)

  apply sub_eq_hyps_snoc_weak_iff; auto.
  apply sub_eq_hyps_snoc_weak_iff; auto.
  apply sub_eq_hyps_snoc_weak_iff; auto.

  (* Now we prove the similarity *)
  autodimp hyp1 hyp.

  apply similarity_app; simpl.
  exists (snoc (snoc (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom)) (z, mkc_axiom))
               (w, mkc_axiom))
         s1b
         (snoc (snoc (snoc (snoc s2a0 (x, t2)) (y, mkc_axiom)) (z, mkc_axiom))
               (w, mkc_axiom))
         s2b; repeat (rw length_snoc); dands; auto.

  assert (wf_term (mk_equality a2 b2 (mk_bunion A mk_base)))
  as wt1 by (apply wf_equality_iff; dands; auto;
             apply wf_bunion; dands; auto).

  assert (cover_vars (mk_equality a2 b2 (mk_bunion A mk_base))
                     (snoc (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom)) (z, mkc_axiom)))
    as cv1 by (repeat (apply cover_vars_snoc_weak);
               apply cover_vars_equality; dands; auto;
               apply cover_vars_bunion; sp).

  apply similarity_snoc; simpl.
  exists (snoc (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom)) (z, mkc_axiom))
         (snoc (snoc (snoc s2a0 (x, t2)) (y, mkc_axiom)) (z, mkc_axiom))
         (@mkc_axiom o) (@mkc_axiom o) wt1 cv1; dands; auto.

  assert (wf_term (mk_equality a1 b1 (mk_bunion A mk_base)))
  as wt2 by (apply wf_equality_iff; dands; auto;
             apply wf_bunion; dands; auto).

  assert (cover_vars (mk_equality a1 b1 (mk_bunion A mk_base))
                     (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom)))
    as cv2 by (repeat (apply cover_vars_snoc_weak);
               apply cover_vars_equality; dands; auto;
               apply cover_vars_bunion; sp).

  apply similarity_snoc; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom))
         (snoc (snoc s2a0 (x, t2)) (y, mkc_axiom))
         (@mkc_axiom o) (@mkc_axiom o) wt2 cv2; dands; auto.

  assert (wf_term (mk_equality A B (mk_uni i)))
    as wt3 by (apply wf_equality_iff; dands; auto).

  assert (cover_vars (mk_equality A B (mk_uni i)) (snoc s1a0 (x, t1)))
    as cv3
      by (repeat (apply cover_vars_snoc_weak);
          apply cover_vars_equality; dands; auto).

  apply similarity_snoc; simpl.
  exists (snoc s1a0 (x, t1))
         (snoc s2a0 (x, t2))
         (@mkc_axiom o) (@mkc_axiom o) wt3 cv3; dands; auto.

  apply similarity_snoc; simpl.
  exists s1a0 s2a0 t1 t2 w0 p; dands; auto.

  lsubst_tac.
  apply equality_in_mkc_equality; dands; auto.
  apply equality_mkc_equality2_sp_in_uni; dands; auto.
  split; auto.

  lsubst_tac.
  apply equality_in_mkc_equality; dands; auto;
  try (complete (spcast; apply computes_to_valc_refl; sp)).

  lsubst_tac.
  apply equality_in_mkc_equality; dands; auto;
  try (complete (spcast; apply computes_to_valc_refl; sp)).
  lsubst_tac.

  apply equality_in_mkc_bunion; dands; auto.
  apply equality_in_uni in sim7; auto.
  apply tequality_refl in sim7; auto.
  apply tequality_base.
  dorn sim8.
  apply @eq_in_bunion_eq1; auto.
  spcast.
  apply @eq_in_bunion_eq2; auto.
  apply equality_in_base_iff; spcast; sp.

  lsubst_tac.
  apply equality_in_mkc_equality; dands; auto;
  try (complete (spcast; apply computes_to_valc_refl; sp)).
  lsubst_tac.

  apply equality_in_mkc_bunion; dands; auto.
  apply equality_in_uni in sim7; auto.
  apply tequality_refl in sim7; auto.
  apply tequality_base.
  dorn sim0.
  apply @eq_in_bunion_eq1; auto.
  spcast.
  apply @eq_in_bunion_eq2; auto.
  apply equality_in_base_iff; spcast; sp.

  repeat (rw @substitute_hyps_snoc_sub_weak; auto).

  (* Now we can use our hypothesis *)

  exrepnd.
  lsubst_tac.
  repeat lsubstc_snoc_app.
  sp.
Qed.

(* begin hide *)

(**

  The following rule eliminates equalities between equality types:
<<
   H, x : (a1 = a2 in A) = (b1 = b2 in B) in U(i), J |- C ext e

     By equalityUniverseElim y z w

     H, x : (a1 = a2 in A) = (b1 = b2 in B) in U(i),
        [y : A = B in U(i)],
        [z : a1 = b1 in A \/ a1 = b1 in Base]
        [w : a2 = b2 in A \/ a2 = b2 in Base]
        J |- C ext t
>>
 *)
Definition rule_equality_universe_elim2 {o}
           (H J  : @barehypotheses o)
           (A B a1 a2 b1 b2 C e : NTerm)
           (x y z w : NVar)
           (i : nat) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality
                            (mk_equality a1 a2 A)
                            (mk_equality b1 b2 B)
                            (mk_uni i)))
             ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc (snoc (snoc H (mk_hyp x (mk_equality
                                               (mk_equality a1 a2 A)
                                               (mk_equality b1 b2 B)
                                               (mk_uni i))))
                          (mk_hhyp y (mk_equality A B (mk_uni i))))
                    (mk_hhyp z (mk_or (mk_equality a1 b1 A)
                                      (mk_equality a1 b1 mk_base))))
              (mk_hhyp w (mk_or (mk_equality a2 b2 A)
                                (mk_equality a2 b2 mk_base)))
              ++ J)
        (mk_concl C e)
    ]
    [].

Lemma rule_equality_universe_elim_true2 {o} :
  forall lib (H J : @barehypotheses o)
         (A B a1 a2 b1 b2 C e : NTerm)
         (x y z w : NVar)
         (i : nat),
    rule_true lib (rule_equality_universe_elim2 H J A B a1 a2 b1 b2 C e x y z w i).
Proof.
  unfold rule_equality_universe_elim2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract
            (snoc H
                  (mk_hyp
                     x
                     (mk_equality
                        (mk_equality a1 a2 A)
                        (mk_equality b1 b2 B)
                        (mk_uni i))) ++ J)
            (mk_concl C e)) as cex.
  clear hyp1.
  unfold closed_extract; allsimpl.
  allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc; allsimpl; auto.

  exists cex.

  (* We prove some simple facts on our sequents *)
  assert (!LIn y (free_vars C)
          # !LIn z (free_vars C)
          # !LIn w (free_vars C)

          # !LIn y (free_vars e)
          # !LIn z (free_vars e)
          # !LIn w (free_vars e)

          # !LIn x (free_vars a1)
          # !LIn y (free_vars a1)
          # !LIn z (free_vars a1)
          # !LIn w (free_vars a1)

          # !LIn x (free_vars a2)
          # !LIn y (free_vars a2)
          # !LIn z (free_vars a2)
          # !LIn w (free_vars a2)

          # !LIn x (free_vars A)
          # !LIn y (free_vars A)
          # !LIn z (free_vars A)
          # !LIn w (free_vars A)

          # !LIn x (free_vars b1)
          # !LIn y (free_vars b1)
          # !LIn z (free_vars b1)
          # !LIn w (free_vars b1)

          # !LIn x (free_vars b2)
          # !LIn y (free_vars b2)
          # !LIn z (free_vars b2)
          # !LIn w (free_vars b2)

          # !LIn x (free_vars B)
          # !LIn y (free_vars B)
          # !LIn z (free_vars B)
          # !LIn w (free_vars B)

          # !LIn w (hyps_free_vars J)
          # !LIn z (hyps_free_vars J)
          # !LIn y (hyps_free_vars J)

          # !LIn w (free_vars_hyps J)
          # !LIn z (free_vars_hyps J)
          # !LIn y (free_vars_hyps J)

          # !LIn w (vars_hyps J)
          # !LIn z (vars_hyps J)
          # !LIn y (vars_hyps J)
         ) as vhyps.

  clear hyp1.
  dwfseq.
  sp; try (complete (discover; allrw in_app_iff; allrw in_snoc; sp;
                     allapply @subset_hs_vars_hyps; sp)).

  destruct vhyps as [ niyC vhyps ].
  destruct vhyps as [ nizC vhyps ].
  destruct vhyps as [ niwC vhyps ].

  destruct vhyps as [ niye vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ niwe vhyps ].

  destruct vhyps as [ nixa1 vhyps ].
  destruct vhyps as [ niya1 vhyps ].
  destruct vhyps as [ niza1 vhyps ].
  destruct vhyps as [ niwa1 vhyps ].

  destruct vhyps as [ nixa2 vhyps ].
  destruct vhyps as [ niya2 vhyps ].
  destruct vhyps as [ niza2 vhyps ].
  destruct vhyps as [ niwa2 vhyps ].

  destruct vhyps as [ nixA vhyps ].
  destruct vhyps as [ niyA vhyps ].
  destruct vhyps as [ nizA vhyps ].
  destruct vhyps as [ niwA vhyps ].

  destruct vhyps as [ nixb1 vhyps ].
  destruct vhyps as [ niyb1 vhyps ].
  destruct vhyps as [ nizb1 vhyps ].
  destruct vhyps as [ niwb1 vhyps ].

  destruct vhyps as [ nixb2 vhyps ].
  destruct vhyps as [ niyb2 vhyps ].
  destruct vhyps as [ nizb2 vhyps ].
  destruct vhyps as [ niwb2 vhyps ].

  destruct vhyps as [ nixB vhyps ].
  destruct vhyps as [ niyB vhyps ].
  destruct vhyps as [ nizB vhyps ].
  destruct vhyps as [ niwB vhyps ].

  destruct vhyps as [ niwJ1 vhyps ].
  destruct vhyps as [ nizJ1 vhyps ].
  destruct vhyps as [ niyJ1 vhyps ].

  destruct vhyps as [ niwJ2 vhyps ].
  destruct vhyps as [ nizJ2 vhyps ].
  destruct vhyps as [ niyJ2 vhyps ].

  destruct vhyps as [ niwJ3 vhyps ].
  destruct vhyps as [ nizJ3 niyJ3 ].
  (* done with proving these simple facts *)

  vr_seq_true.

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

  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  apply @equality_mkc_equality2_sp_in_uni in sim0; repnd.
  destruct sim0 as [e1 e2].

Abort.

(**

  The following rule eliminates equalities between equality types:
<<
   H, x : (a1 = a2 in A) = (b1 = b2 in B) in U(i), J |- C ext e

     By equalityUniverseElim y z w

     H, x : (a1 = a2 in A) = (b1 = b2 in B) in U(i),
        [y : A = B in U(i)],
        [z : a1 = b1 in A \/ a1 ~ b1]
        [w : a2 = b2 in A \/ a2 ~ b2]
        J |- C ext t
>>
 *)
Definition rule_equality_universe_elim3 {o}
           (H J  : @barehypotheses o)
           (A B a1 a2 b1 b2 C e : NTerm)
           (x y z w : NVar)
           (i : nat) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality
                            (mk_equality a1 a2 A)
                            (mk_equality b1 b2 B)
                            (mk_uni i)))
             ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc (snoc (snoc H (mk_hyp x (mk_equality
                                               (mk_equality a1 a2 A)
                                               (mk_equality b1 b2 B)
                                               (mk_uni i))))
                          (mk_hhyp y (mk_equality A B (mk_uni i))))
                    (mk_hhyp z (mk_or (mk_equality a1 b1 A) (mk_cequiv a1 b1))))
              (mk_hhyp w (mk_or (mk_equality a2 b2 A) (mk_cequiv a2 b2)))
              ++ J)
        (mk_concl C e)
    ]
    [].

Lemma rule_equality_universe_elim_true3 {o} :
  forall lib (H J : @barehypotheses o)
         (A B a1 a2 b1 b2 C e : NTerm)
         (x y z w : NVar)
         (i : nat),
    rule_true lib (rule_equality_universe_elim3 H J A B a1 a2 b1 b2 C e x y z w i).
Proof.
  unfold rule_equality_universe_elim3, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract
            (snoc H
                  (mk_hyp
                     x
                     (mk_equality
                        (mk_equality a1 a2 A)
                        (mk_equality b1 b2 B)
                        (mk_uni i))) ++ J)
            (mk_concl C e)) as cex.
  clear hyp1.
  unfold closed_extract; allsimpl.
  allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc; allsimpl; auto.

  exists cex.

  (* We prove some simple facts on our sequents *)
  assert (!LIn y (free_vars C)
          # !LIn z (free_vars C)
          # !LIn w (free_vars C)

          # !LIn y (free_vars e)
          # !LIn z (free_vars e)
          # !LIn w (free_vars e)

          # !LIn x (free_vars a1)
          # !LIn y (free_vars a1)
          # !LIn z (free_vars a1)
          # !LIn w (free_vars a1)

          # !LIn x (free_vars a2)
          # !LIn y (free_vars a2)
          # !LIn z (free_vars a2)
          # !LIn w (free_vars a2)

          # !LIn x (free_vars A)
          # !LIn y (free_vars A)
          # !LIn z (free_vars A)
          # !LIn w (free_vars A)

          # !LIn x (free_vars b1)
          # !LIn y (free_vars b1)
          # !LIn z (free_vars b1)
          # !LIn w (free_vars b1)

          # !LIn x (free_vars b2)
          # !LIn y (free_vars b2)
          # !LIn z (free_vars b2)
          # !LIn w (free_vars b2)

          # !LIn x (free_vars B)
          # !LIn y (free_vars B)
          # !LIn z (free_vars B)
          # !LIn w (free_vars B)) as vhyps.

  clear hyp1.
  dwfseq.
  sp; try (complete (discover; allrw in_app_iff; allrw in_snoc; sp;
                     allapply @subset_hs_vars_hyps; sp)).

  destruct vhyps as [ niyC vhyps ].
  destruct vhyps as [ nizC vhyps ].
  destruct vhyps as [ niwC vhyps ].

  destruct vhyps as [ niye vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ niwe vhyps ].

  destruct vhyps as [ nixa1 vhyps ].
  destruct vhyps as [ niya1 vhyps ].
  destruct vhyps as [ niza1 vhyps ].
  destruct vhyps as [ niwa1 vhyps ].

  destruct vhyps as [ nixa2 vhyps ].
  destruct vhyps as [ niya2 vhyps ].
  destruct vhyps as [ niza2 vhyps ].
  destruct vhyps as [ niwa2 vhyps ].

  destruct vhyps as [ nixA vhyps ].
  destruct vhyps as [ niyA vhyps ].
  destruct vhyps as [ nizA vhyps ].
  destruct vhyps as [ niwA vhyps ].

  destruct vhyps as [ nixb1 vhyps ].
  destruct vhyps as [ niyb1 vhyps ].
  destruct vhyps as [ nizb1 vhyps ].
  destruct vhyps as [ niwb1 vhyps ].

  destruct vhyps as [ nixb2 vhyps ].
  destruct vhyps as [ niyb2 vhyps ].
  destruct vhyps as [ nizb2 vhyps ].
  destruct vhyps as [ niwb2 vhyps ].

  destruct vhyps as [ nixB vhyps ].
  destruct vhyps as [ niyB vhyps ].
  destruct vhyps as [ nizB niwB ].
  (* done with proving these simple facts *)

  vr_seq_true.

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

  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  apply equality_in_uni in sim0.

  rw @tequality_mkc_equality2_sp in sim0; repnd.
  unfold equorsq2, equorsq in sim0; repnd.

  dorn sim0; dorn sim8.

  - vr_seq_true in hyp1.
    pose proof (hyp1
                  (snoc (snoc (snoc (snoc s1a0 (x,t1))
                                    (y,mkc_axiom))
                              (z,tt))
                        (w,tt)
                        ++ s1b)
                  (snoc (snoc (snoc (snoc s2a0 (x,t2))
                                    (y,mkc_axiom))
                              (z,tt))
                        (w,tt)
                        ++ s2b)) as h; clear hyp1; rename h into hyp1.

    autodimp hyp1 hyp.

    (* we prove the hyps_functionality part *)

    introv sim'.
    rw @similarity_app in sim'; simpl in sim'; allrw length_snoc; exrepnd; subst; cpx; GC.
    apply app_split in sim'0; [| complete (allrw length_snoc; allrw; auto)].
    rw @similarity_snoc in sim'5; simpl in sim'5; exrepnd; subst; cpx.
    rw @similarity_snoc in sim'8; simpl in sim'8; exrepnd; subst; cpx.
    rw @similarity_snoc in sim'6; simpl in sim'6; exrepnd; subst; cpx.
    rw @similarity_snoc in sim'7; simpl in sim'7; exrepnd; subst; cpx.

    (* we bring in the eq_hyps from our main goal *)
    pose proof (eqh (snoc s2a (x,t6) ++ s2b)) as eh.
    autodimp eh hyp.
    apply similarity_app; simpl.
    exists (snoc s1a (x, t0)) s1b0 (snoc s2a (x, t6)) s2b; dands; auto;
    try (complete (repeat (rw length_snoc); allrw; auto)).
    apply similarity_snoc; simpl.
    exists s1a s2a t0 t6 w10 p3; dands; auto.
    (* done *)

    (* we simplify eh *)
    apply eq_hyps_app in eh; simpl in eh; exrepnd.
    apply app_split in eh0; [| complete (allrw length_snoc; allrw; auto)].
    apply app_split in eh2; [| complete (allrw length_snoc; allrw; auto)].
    repnd; subst; cpx.
    dup eh5 as ehsnoc.
    apply eq_hyps_snoc in eh5; simpl in eh5; exrepnd; cpx.

    lsubst_tac.

    rw @eq_hyps_app.
    exists (snoc (snoc (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom)) (z, tt))
              (w, tt))
           s1b
           (snoc (snoc (snoc (snoc s2a1 (x, t7)) (y, t5)) (z, t4)) (w, t3)) s2b0;
      dands; auto; repeat (rw length_snoc); try (complete (allrw; auto)).

    assert (cover_vars
              (mk_or (mk_equality a2 b2 A) (mk_cequiv a2 b2))
              (snoc (snoc (snoc s2a1 (x, t7)) (y, t5)) (z, t4)))
      as cv1
        by (eapply cover_vars_change_sub;[|exact p0];
            repeat (rw @dom_csub_snoc); simpl; auto;
            allapply @similarity_dom; repnd; allrw; sp).

    rw @eq_hyps_snoc; simpl.
    exists (snoc (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom)) (z, tt))
           (snoc (snoc (snoc s2a1 (x, t7)) (y, t5)) (z, t4))
           (@tt o) t3 w7 p0 cv1;
      dands; auto.

    assert (cover_vars
              (mk_or (mk_equality a1 b1 A) (mk_cequiv a1 b1))
              (snoc (snoc s2a1 (x, t7)) (y, t5)))
      as cv2
        by (eapply cover_vars_change_sub;[|exact p1];
            repeat (rw @dom_csub_snoc); simpl; auto;
            allapply @similarity_dom; repnd; allrw; sp).

    rw @eq_hyps_snoc; simpl.
    exists (snoc (snoc s1a0 (x, t1)) (y, mkc_axiom))
           (snoc (snoc s2a1 (x, t7)) (y, t5))
           (@tt o) t4 w8 p1 cv2;
      dands; auto.

    assert (cover_vars (mk_equality A B (mk_uni i)) (snoc s2a1 (x, t7)))
      as cv3
        by (eapply cover_vars_change_sub;[|exact p2];
            repeat (rw @dom_csub_snoc); simpl; auto;
            allapply @similarity_dom; repnd; allrw; sp).

    rw @eq_hyps_snoc; simpl.
    exists (snoc s1a0 (x, t1))
           (snoc s2a1 (x, t7))
           (@mkc_axiom o) t5 w9 p2 cv3;
      dands; auto.

    lsubst_tac.

    apply tequality_mkc_equality2_sp in eh0; repnd.
    apply tequality_mkc_equality2_sp; dands; auto.
    unfold equorsq2 in eh0; repnd.
    unfold equorsq2; dands.

    unfold equorsq in eh3; unfold equorsq; dorn eh3.
    left.
    apply equality_mkc_equality2_sp_in_uni in eh3; repnd; auto.
    right; spcast.
    apply cequivc_decomp_equality in eh3; repnd; auto.

    unfold equorsq in eh0; unfold equorsq; dorn eh0.
    left.
    apply equality_mkc_equality2_sp_in_uni in eh0; repnd; auto.
    right; spcast.
    apply cequivc_decomp_equality in eh0; repnd; auto.

    lsubst_tac.
    apply tequality_mkc_equality2_sp in eh0; repnd.
    unfold equorsq2, equorsq in eh0; repnd.
    apply tequality_mkc_or; dands.
    apply tequality_mkc_equality2_sp.
    dands.

    dorn eh3.
    apply equality_in_uni in eh3.
    apply tequality_mkc_equality2_sp in eh3; repnd; auto.
    spcast.
    apply cequivc_decomp_equality in eh3; repnd.
    apply equality_in_mkc_equality in sim'6; repnd.
    apply equality_mkc_equality2_sp_in_uni in sim'0; repnd.
    apply equality_in_uni in sim'9.
    apply tequality_respects_cequivc_right with (T2 := lsubstc A wT0 s1a0 cT0); auto.
    apply tequality_refl in sim'9; auto.

    unfold equorsq2; dands.

    dorn eh3.
    apply equality_in_uni in eh3.
    apply tequality_mkc_equality2_sp in eh3; repnd; auto.
    unfold equorsq2 in eh3; repnd; auto.
    spcast.
    apply cequivc_decomp_equality in eh3; repnd.
    right; spcast; auto.

    dorn eh0.
    apply equality_in_uni in eh0.
    apply tequality_mkc_equality2_sp in eh0; repnd; auto.
    unfold equorsq2 in eh0; repnd; auto.
    apply equality_in_mkc_equality in sim'6; repnd.
    apply equality_mkc_equality2_sp_in_uni in sim'0; repnd.
    apply equality_in_uni in sim'9.
    eapply equorsq_tequality; eauto.
    apply tequality_sym; auto.
    spcast.
    apply cequivc_decomp_equality in eh0; repnd.
    right; spcast; auto.

    apply tequality_mkc_cequiv.

Abort.

(* end hide *)


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import RobustTraceProperty.

(* Every time we can express a Class Ξ via an upper closed operator ξ
   we have that γRΞP is equivalent to (ξ ∘ τ)RTP.

   for instance we can express the class of Safety and Dense properties using
   the uco Cl.

*)

Section Closure_Operators_RobustPreservation.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Type.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition par__S := par Source.
  Local Definition par__T := par Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition rsat__S := rsat Source_Semantics.
  Local Definition rsat__T := rsat Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).
 (* CA: don't understand why this does not work

   Local Notation " C [ P ] " := (plug _  P C) (at level 50).
  *)
  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  Variable σ : prop__T -> prop__S.
  Variable τ : prop__S -> prop__T.

  Definition σRP := σRP compilation_chain
                        Source_Semantics Target_Semantics
                        σ.

  Variable ϕ_op : (@Uco trace__T).

  Local Definition ϕ := uco ϕ_op.

  (* ϕ ∘ τ *)
  Local Definition ϕ_τRP := τRP compilation_chain
                                Source_Semantics Target_Semantics
                                (ϕ ∘ τ).

  Local Definition ϕ_τRTP := forall P π__S, ϕ_τRP P π__S.

  Lemma uco_adjuncts' :
    Adjunction_law τ σ ->
    ( (forall P (π__T : prop__T),  σRP P (ϕ π__T)) <->
      ϕ_τRTP ).
  Proof.
    rewrite Galois_equiv. move => [mono_σ [mono_τ [G1 G2]]].
    split => H_p P π sat_src.
    + have H: rsat__S P (σ (ϕ (τ π))).
      { apply: rsat_upper_closed. exact: sat_src.
        apply: subset_trans. by apply: G1.
        apply: mono_τ. exact: (ext ϕ_op). }
      move: (H_p P (ϕ (τ π))). firstorder.
    + have H: rsat__T (P ↓) (ϕ π).
      { move: (H_p P _ sat_src) => H.
        apply: rsat_upper_closed. exact: H.
        have Hfoo : ϕ π = ϕ (ϕ π) by rewrite /ϕ (idmp ϕ_op).
        move => t Hfoo_t. rewrite Hfoo.
        move: t Hfoo_t.
        apply: mono. by apply: G2. }
      exact: H.
  Qed.

  Lemma uco_aux  :
    (forall P (π__T : prop__T),  σRP P (ϕ π__T)) <->
    (forall P (π__T : prop__T),  ((lift ϕ) (@h_true trace__T)) π__T -> σRP P π__T).
  Proof.
    split => H_p P π.
    + move => [b [hb Cb]] sat_src. subst.
        by move: (H_p P b sat_src).
    + move => sat_src.
      have H: (lift ϕ (@h_true trace__T)) (ϕ π) by now exists π.
       by move: (H_p P (ϕ π) H sat_src).
  Qed.

 Theorem uco_adjuncts :
  Adjunction_law τ σ ->
  ( (forall P (π__T : prop__T),  ((lift ϕ) (@h_true trace__T) π__T) -> σRP P π__T) <->
     ϕ_τRTP ).
 Proof.
  move => H_adj. rewrite -uco_adjuncts'.
    by rewrite -uco_aux. assumption.
Qed.

End Closure_Operators_RobustPreservation.


(*

  Copyright 2014 Cornell University

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

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

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

*)

Require Export substitution.
Require Export terms_props.

Definition mkcv_equality {p} vs (t1 t2 T : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
  let (c,z) := T in
    exist (isprog_vars vs) (mk_equality a b c) (isprog_vars_equality vs a b c x y z).

Definition mkcv_member {o} vs (t T : @CVTerm o vs) : CVTerm vs :=
  mkcv_equality vs t t T.

Definition mkcv_lam {o} vs (v : NVar) (t : @CVTerm o (v :: vs)) : CVTerm vs :=
  let (a,x) := t in
    exist (isprog_vars vs) (mk_lam v a) (isprog_vars_lam vs v a x).

Lemma isprog_vars_uand_if {o} :
  forall vs (t1 t2 : @NTerm o),
    isprog_vars vs t1
    -> isprog_vars vs t2
    -> isprog_vars vs (mk_uand t1 t2).
Proof.
  introv isp1 isp2.
  apply isprog_vars_uand; auto.
Qed.

Definition mkcv_uand {p} vs (t1 t2 : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_uand a b) (isprog_vars_uand_if vs a b x y).

Definition mk_natk_aux {p} vi n : @NTerm p :=
  mk_set
    mk_int
    vi
    (mk_prod (mk_le mk_zero (mk_var vi))
             (mk_less_than (mk_var vi) n)).

Definition mk_natk {p} n : @NTerm p :=
  let v := newvar n in mk_natk_aux v n.

Lemma isprog_vars_int {p} : forall vs, @isprog_vars p vs mk_int.
Proof.
  introv.
  apply isprog_vars_eq; simpl; dands; sp.
  repeat constructor; simpl; sp.
Qed.

Lemma isprog_vars_add {p} :
  forall (a b : @NTerm p) vs,
    isprog_vars vs (mk_add a b) <=> (isprog_vars vs a # isprog_vars vs b).
Proof.
  introv.
  repeat (rw @isprog_vars_eq; simpl).
  repeat (rw @remove_nvars_nil_l).
  rw @app_nil_r.
  rw subvars_app_l.
  allrw <- @wf_term_eq.
  allrw <- @wf_apply_iff; split; sp.
Qed.

Lemma isprog_vars_add_implies {p} :
  forall (a b : @NTerm p) vs,
    isprog_vars vs a
    -> isprog_vars vs b
    -> isprog_vars vs (mk_add a b).
Proof.
  introv ispa ispb.
  apply isprog_vars_add; sp.
Qed.

Lemma isprog_vars_apply_implies {p} :
  forall (a b : @NTerm p) vs,
    isprog_vars vs a
    -> isprog_vars vs b
    -> isprog_vars vs (mk_apply a b).
Proof.
  introv ispa ispb.
  apply isprog_vars_apply; sp.
Qed.

Lemma isprog_vars_tuni_implies {o} :
  forall (f : @NTerm o) vs, isprog_vars vs f -> isprog_vars vs (mk_tuni f).
Proof.
  introv k.
  apply isprog_vars_tuni; sp.
Qed.

Definition mkcv_tuni {o} (vs : list NVar) (R : @CVTerm o vs) : CVTerm vs :=
  let (a,x) := R in
    exist (isprog_vars vs) (mk_tuni a) (isprog_vars_tuni_implies a vs x).

Definition mkcv_le {o} (vs : list NVar) (t1 t2 : @CVTerm o vs) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_le a b) (isprog_vars_le_implies a b vs x y).

Lemma isprog_le {o} :
  forall a b : @NTerm o,
    isprog (mk_le a b) <=> (isprog a # isprog b).
Proof.
  introv.
  allrw @isprog_vars_nil_iff_isprog.
  apply isprog_vars_le.
Qed.

Lemma isprog_le_implies {o} :
  forall a b : @NTerm o,
    isprog a
    -> isprog b
    -> isprog (mk_le a b).
Proof.
  introv x y.
  apply isprog_le; sp.
Qed.

Definition mkc_le {o} (t1 t2 : @CTerm o) : CTerm :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist isprog (mk_le a b) (isprog_le_implies a b x y).

Definition mkc_less_than {o} (t1 t2 : @CTerm o) : CTerm :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist isprog (mk_less_than a b) (isprog_less_than_implies a b x y).

Lemma isprog_less {o} :
  forall a b c d : @NTerm o,
    isprog (mk_less a b c d)
    <=> (isprog a
         # isprog b
         # isprog c
         # isprog d).
Proof.
  introv.
  allrw @isprog_vars_nil_iff_isprog.
  apply isprog_vars_less.
Qed.

Lemma isprog_less_implies {o} :
  forall a b c d : @NTerm o,
    isprog a
    -> isprog b
    -> isprog c
    -> isprog d
    -> isprog (mk_less a b c d).
Proof.
  introv u v w z.
  apply isprog_less; sp.
Qed.

Definition mkc_less {o} (t1 t2 t3 t4 : @CTerm o) : CTerm :=
  let (a,x) := t1 in
  let (b,y) := t2 in
  let (c,z) := t3 in
  let (d,w) := t4 in
    exist isprog (mk_less a b c d) (isprog_less_implies a b c d x y z w).

Lemma mkc_less_than_eq {o} :
  forall a b : @CTerm o,
    mkc_less_than a b = mkc_less a b mkc_true mkc_false.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
Qed.

Lemma mkc_le_eq {o} :
  forall a b : @CTerm o, mkc_le a b = mkc_not (mkc_less_than b a).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
Qed.

Definition mkcv_zero {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_zero.

Lemma mkc_tnat_eq {o} :
  @mkc_tnat o = mkc_set mkc_int nvary (mkcv_le [nvary] (mkcv_zero [nvary]) (mkc_var nvary)).
Proof.
  apply cterm_eq; simpl; sp.
Qed.

Lemma mkcv_le_substc {o} :
  forall a b (c : @CTerm o),
    substc c nvary (mkcv_le [nvary] a b)
    = mkc_le (substc c nvary a) (substc c nvary b).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl.
  unfold subst.
  change_to_lsubst_aux4; simpl; sp; allrw app_nil_r;
  allrw @isprog_eq; destruct i as [c w]; rw c; sp.
Qed.

Lemma mkcv_tuni_substc {o} :
  forall v a (c : @CTerm o),
    substc c v (mkcv_tuni [v] a)
    = mkc_tuni (substc c v a).
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl.
  unfold subst.
  change_to_lsubst_aux4; simpl; sp; allrw app_nil_r;
  allrw @isprog_eq; destruct i as [c w]; rw c; sp.
Qed.

Lemma mkcv_zero_substc {o} :
  forall v (t : @CTerm o),
    substc t v (mkcv_zero [v]) = mkc_zero.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
Qed.

Lemma mkc_var_substc {o} :
  forall v (t : @CTerm o),
    substc t v (mkc_var v) = t.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
  unfold subst.
  change_to_lsubst_aux4; simpl; sp; boolvar; sp.
Qed.

Lemma isprog_vars_natk {p} :
  forall vs (n : @NTerm p),
    isprog_vars vs n
    -> isprog_vars vs (mk_natk n).
Proof.
  introv isp.
  apply isprog_vars_set.
  - apply isprog_vars_int.
  - apply isprog_vars_prod; dands; auto.
    + apply isprog_vars_le; dands; auto.
      * apply isprog_vars_zero.
      * apply isprog_vars_var_if; simpl; tcsp.
    + apply isprog_vars_less_than; dands; auto.
      * apply isprog_vars_var_if; simpl; tcsp.
      * apply isprog_vars_cons; auto.
Qed.

Lemma isprog_natk {p} :
  forall (n : @NTerm p),
    isprog n
    -> isprog (mk_natk n).
Proof.
  introv isp.
  apply isprog_vars_nil_iff_isprog.
  apply isprog_vars_natk.
  apply isprog_vars_nil_iff_isprog; auto.
Qed.

Definition mkc_natk {o} (n : @CTerm o) : CTerm :=
  let (t,x) := n in
  exist isprog (mk_natk t) (isprog_natk t x).

Definition mkcv_natk {o} vs (n : @CVTerm o vs) : CVTerm vs :=
  let (t,x) := n in
  exist (isprog_vars vs) (mk_natk t) (isprog_vars_natk vs t x).

Definition mkcv_int {o} vs : @CVTerm o vs :=
  exist (isprog_vars vs) mk_int (isprog_vars_int vs).

Lemma wf_minus {p} :
  forall (a : @NTerm p), wf_term a -> wf_term (mk_minus a).
Proof.
  intros a; repeat (rw <- @nt_wf_eq).
  intros nta; inversion nta; subst;
  constructor; allsimpl; sp; subst; auto; constructor; auto.
Qed.

Lemma wf_minus_iff {p} :
  forall a : @NTerm p, wf_term a <=> wf_term (mk_minus a).
Proof.
  introv; split; intro i.
  apply wf_minus; sp.
  allrw @wf_term_eq.
  inversion i as [|?| o lnt k e]; subst; allsimpl.
  generalize (k (nobnd a)); intros k1.
  repeat (dest_imp k1 hyp).
  inversion k1; subst; sp.
Qed.

Lemma isprog_vars_minus {p} :
  forall (a : @NTerm p) vs,
    isprog_vars vs (mk_minus a) <=> isprog_vars vs a.
Proof.
  introv.
  repeat (rw @isprog_vars_eq; simpl).
  repeat (rw @remove_nvars_nil_l).
  rw @app_nil_r.
  allrw <- @wf_term_eq.
  allrw <- @wf_minus_iff; split; sp.
Qed.

Lemma isprog_vars_minus_implies {p} :
  forall (a : @NTerm p) vs,
    isprog_vars vs a
    -> isprog_vars vs (mk_minus a).
Proof.
  introv ispa.
  apply isprog_vars_minus; sp.
Qed.

Lemma isprog_minus_implies {p} :
  forall (a : @NTerm p),
    isprog a
    -> isprog (mk_minus a).
Proof.
  introv ispa.
  apply isprog_vars_nil_iff_isprog; auto.
  apply isprog_vars_minus; sp.
Qed.

Definition mkc_minus {p} (t : @CTerm p) : CTerm :=
  let (a,x) := t in
  exist isprog (mk_minus a) (isprog_minus_implies a x).

Definition mkcv_function {p} vs (t1 : @CVTerm p vs) (v : NVar) (t2 : CVTerm (v :: vs)) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_function a v b) (isprog_vars_function vs a v b x y).

Definition mkcv_isect {p} vs (t1 : @CVTerm p vs) (v : NVar) (t2 : CVTerm (v :: vs)) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_isect a v b) (isprog_vars_isect vs a v b x y).

Definition mkcv_set {p} vs (t1 : @CVTerm p vs) (v : NVar) (t2 : CVTerm (v :: vs)) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_set a v b) (isprog_vars_set vs a v b x y).

Lemma isprog_vars_fun_implies {p} :
  forall vs (a b : @NTerm p),
    isprog_vars vs a
    -> isprog_vars vs b
    -> isprog_vars vs (mk_fun a b).
Proof.
  introv ispa ispb.
  apply isprog_vars_fun; sp.
Qed.

Definition mkcv_fun {p} vs (A B : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := A in
  let (b,y) := B in
  exist (isprog_vars vs) (mk_fun a b) (isprog_vars_fun_implies vs a b x y).

Lemma isprog_vars_ufun_implies {p} :
  forall vs (a b : @NTerm p),
    isprog_vars vs a
    -> isprog_vars vs b
    -> isprog_vars vs (mk_ufun a b).
Proof.
  introv ispa ispb.
  apply isprog_vars_ufun; sp.
Qed.

Definition mkcv_ufun {p} vs (A B : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := A in
  let (b,y) := B in
  exist (isprog_vars vs) (mk_ufun a b) (isprog_vars_ufun_implies vs a b x y).

Lemma cover_vars_upto_function {o} :
  forall vs (a : @NTerm o) v b sub,
    cover_vars_upto (mk_function a v b) sub vs
    <=> cover_vars_upto a sub vs
        # cover_vars_upto b (csub_filter sub [v]) (v :: vs).
Proof.
  sp; repeat (rw cover_vars_eq); unfold cover_vars_upto; simpl.
  allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw subvars_app_l.
  allrw subvars_remove_nvars; simpl.
  allrw @dom_csub_csub_filter.
  allrw subvars_prop; simpl; split; sp; apply_in_hyp pp;
  allrw in_app_iff; allrw in_remove_nvars; allrw in_single_iff; sp.
  generalize (deq_nvar v x); intro q; sp.
  right; right; sp.
Qed.

Lemma cover_vars_upto_fun {o} :
  forall vs (a b : @NTerm o) sub,
    cover_vars_upto (mk_fun a b) sub vs
    <=> cover_vars_upto a sub vs
        # cover_vars_upto b sub vs.
Proof.
  introv.
  rw @cover_vars_upto_function.
  split; intro k; repnd; dands; auto.
  - allunfold @cover_vars_upto.
    allrw subvars_prop; introv i.
    applydup k in i; allsimpl; allrw in_app_iff; repndors; subst; tcsp.
    + pose proof (newvar_prop b); sp.
    + rw @dom_csub_csub_filter in i0.
      rw in_remove_nvars in i0; sp.
  - allunfold @cover_vars_upto.
    allrw subvars_prop; introv i.
    applydup k in i; allsimpl; allrw in_app_iff; repndors; tcsp.
    rw @dom_csub_csub_filter.
    rw in_remove_nvars; simpl.
    destruct (deq_nvar (newvar b) x) as [j|j]; subst; tcsp.
    right; right; sp.
Qed.

Lemma cover_vars_upto_ufun {o} :
  forall vs (a b : @NTerm o) sub,
    cover_vars_upto (mk_ufun a b) sub vs
    <=> cover_vars_upto a sub vs
        # cover_vars_upto b sub vs.
Proof.
  introv.
  rw @cover_vars_upto_isect.
  split; intro k; repnd; dands; auto.
  - allunfold @cover_vars_upto.
    allrw subvars_prop; introv i.
    applydup k in i; allsimpl; allrw in_app_iff; repndors; subst; tcsp.
    + pose proof (newvar_prop b); sp.
    + rw @dom_csub_csub_filter in i0.
      rw in_remove_nvars in i0; sp.
  - allunfold @cover_vars_upto.
    allrw subvars_prop; introv i.
    applydup k in i; allsimpl; allrw in_app_iff; repndors; tcsp.
    rw @dom_csub_csub_filter.
    rw in_remove_nvars; simpl.
    destruct (deq_nvar (newvar b) x) as [j|j]; subst; tcsp.
    right; right; sp.
Qed.

Definition mkcv_add {p} vs (t1 t2 : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_add a b) (isprog_vars_add_implies a b vs x y).

Definition mkcv_apply {p} vs (t1 t2 : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_apply a b) (isprog_vars_apply_implies a b vs x y).

Lemma isprog_vars_cbv {p} :
  forall vs (a : @NTerm p) v b,
    isprog_vars vs a
    -> isprog_vars (v :: vs) b
    -> isprog_vars vs (mk_cbv a v b).
Proof.
  introv ipa ipb.
  allrw @isprog_vars_eq; allrw subvars_prop; allsimpl.
  allrw remove_nvars_nil_l; allrw app_nil_r; sp.
  allrw in_app_iff; allrw in_remove_nvars; allrw in_single_iff; sp.
  discover; sp.
  constructor; simpl; sp; subst; constructor; sp.
Qed.

Definition mkcv_cbv {p} vs (t1 : @CVTerm p vs) (v : NVar) (t2 : CVTerm (v :: vs)) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
    exist (isprog_vars vs) (mk_cbv a v b) (isprog_vars_cbv vs a v b x y).

Lemma isprog_vars_app_r {p} :
  forall (t : @NTerm p) vs1 vs2,
    isprog_vars vs1 t
    -> isprog_vars (vs1 ++ vs2) t.
Proof.
  sp; alltrewrite (@isprog_vars_eq p); sp.
  alltrewrite subvars_eq.
  apply subset_app_r; sp.
Qed.

Lemma mk_cv_app_r_pf {o} :
  forall vs2 vs1 (t : @CVTerm o vs1),
    isprog_vars (vs1 ++ vs2) (get_cvterm vs1 t).
Proof.
  introv; destruct_cterms; simpl.
  apply isprog_vars_app_r; auto.
Qed.

Lemma mk_cv_app_l_pf {o} :
  forall vs2 vs1 (t : @CVTerm o vs1),
    isprog_vars (vs2 ++ vs1) (get_cvterm vs1 t).
Proof.
  introv; destruct_cterms; simpl.
  apply isprog_vars_app_l; auto.
Qed.

Definition mk_cv_app_r {o} vs2 vs1 (t : @CVTerm o vs1) : @CVTerm o (vs1 ++ vs2) :=
  exist (isprog_vars (vs1 ++ vs2)) (get_cvterm vs1 t) (mk_cv_app_r_pf vs2 vs1 t).

Definition mk_cv_app_l {o} vs2 vs1 (t : @CVTerm o vs1) : @CVTerm o (vs2 ++ vs1) :=
  exist (isprog_vars (vs2 ++ vs1)) (get_cvterm vs1 t) (mk_cv_app_l_pf vs2 vs1 t).

Definition force_int_cv {o} vs (t : @CVTerm o vs) : CVTerm vs :=
  mkcv_add vs t (mkcv_zero vs).

Lemma isprog_vars_less_implies {p} :
  forall (a b c d : @NTerm p) vs,
    isprog_vars vs a
    -> isprog_vars vs b
    -> isprog_vars vs c
    -> isprog_vars vs d
    -> isprog_vars vs (mk_less a b c d).
Proof.
  introv ispa ispb ispc ispd.
  apply isprog_vars_less; sp.
Qed.

Definition mkcv_less {p} vs (t1 t2 t3 t4 : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t1 in
  let (b,y) := t2 in
  let (c,z) := t3 in
  let (d,w) := t4 in
    exist (isprog_vars vs) (mk_less a b c d) (isprog_vars_less_implies a b c d vs x y z w).

Lemma isprog_vars_nat {p} :
  forall vs n,
    @isprog_vars p vs (mk_nat n).
Proof.
  introv.
  apply isprog_vars_eq; simpl; dands; tcsp.
  constructor; simpl; tcsp.
Qed.

Definition mkcv_minus {p} vs (t : @CVTerm p vs) : CVTerm vs :=
  let (a,x) := t in
    exist (isprog_vars vs) (mk_minus a) (isprog_vars_minus_implies a vs x).

Definition mkcv_nat {p} vs (n : nat) : @CVTerm p vs :=
  exist (isprog_vars vs) (mk_nat n) (isprog_vars_nat vs n).

Lemma isvalue_mk_integer {o} :
  forall i, @isvalue o (mk_integer i).
Proof.
  introv; constructor; simpl; eauto 3 with slow.
Qed.
Hint Resolve isvalue_mk_integer : slow.

Lemma iscvalue_mkc_integer {o} :
  forall i, @iscvalue o (mkc_integer i).
Proof.
  introv; unfold iscvalue; simpl; eauto with slow.
Qed.
Hint Resolve iscvalue_mkc_integer : slow.

Ltac get_newvar_prop :=
  match goal with
    | [ H : ?v = newvar ?t |- _ ] =>
      let nv := fresh "nv" in
      pose proof (newvar_prop t) as nv;
        rewrite <- H in nv;
        clear H
    | [ H : ?v = newvarlst ?l |- _ ] =>
      let nv := fresh "nv" in
      pose proof (newvarlst_prop l) as nv;
        rewrite <- H in nv;
        clear H
  end.

Lemma fresh_var_not_in2 :
  forall vs1 vs2, subvars vs2 vs1 -> !LIn (fresh_var vs1) vs2.
Proof.
  induction vs2; introv sv i; allsimpl; tcsp.
  repndors; subst.
  - allrw subvars_cons_l; repnd; sp.
    apply fresh_var_not_in in sv0; sp.
  - allrw subvars_cons_l; repnd; sp.
Qed.

Lemma newvars3_prop {p} :
  forall v1 v2 v3 (terms : list (@NTerm p)),
    (v1, v2, v3) = newvars3 terms
    -> !LIn v1 (free_vars_list terms)
       # !LIn v2 (free_vars_list terms)
       # !LIn v3 (free_vars_list terms)
       # !v1 = v2
       # !v1 = v3
       # !v2 = v3.
Proof.
  introv eq.
  unfold newvars3 in eq; cpx.
  unfold newvarlst; simpl; allrw @free_vars_list_app; simpl.
  dands;
    try (apply fresh_var_not_in);
    try (apply fresh_var_not_in2); eauto with slow;
    try (complete (apply subvars_app_weak_l; auto));
    match goal with
      | [ |- context[fresh_var ?t = fresh_var ?u] ] =>
        intro k;
          remember (fresh_var t) as f;
          pose proof (fresh_var_not_in u) as h;
          rewrite <- Heqf in h;
          rewrite <- k in h;
          repeat (trw_h in_app_iff h);
          allsimpl; tcsp
    end.
Qed.

(* This is: {v:UAtom|v ~ a} (both the open and closed versions) *)

Definition mk_singleton_uatom {o} (a : @get_patom_set o) :=
  mk_set mk_uatom nvarx (mk_cequiv (mk_var nvarx) (mk_utoken a)).

Definition mkcv_utoken {o} vs (a : @get_patom_set o) : CVTerm vs :=
  mk_cv vs (mkc_utoken a).

Lemma isprog_vars_cequiv {p} :
  forall vs (a b : @NTerm p),
    isprog_vars vs a
    -> isprog_vars vs b
    -> isprog_vars vs (mk_cequiv a b).
Proof.
  introv ipa ipb.
  allrw @isprog_vars_eq; allsimpl.
  allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw subvars_app_l; sp.
  constructor; simpl; sp; subst; constructor; sp.
Qed.

Definition mkcv_cequiv {o} vs (a b : @CVTerm o vs) : CVTerm vs :=
  let (ta,pa) := a in
  let (tb,pb) := b in
    exist (isprog_vars vs) (mk_cequiv ta tb) (isprog_vars_cequiv vs ta tb pa pb).

Definition mkc_singleton_uatom {o} (a : @get_patom_set o) :=
  mkc_set
    mkc_uatom
    nvarx
    (mkcv_cequiv [nvarx] (mkc_var nvarx) (mkcv_utoken [nvarx] a)).

Definition mk_ntexc {o} a (E : @NTerm o) :=
  mk_texc (mk_singleton_uatom a) E.

Definition mkc_ntexc {o} a (E : @CTerm o) :=
  mkc_texc (mkc_singleton_uatom a) E.

Lemma csubst_mk_cv {p} :
  forall t v (u : @CTerm p), substc u v (mk_cv [v] t) = t.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl.
  apply lsubst_trivial; simpl; sp; cpx; allrw @isprog_eq; sp.
  allunfold @isprogram; repnd.
  allrw i1; sp.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.

Delimit Scope fun_scope with FUN.
Open Scope fun_scope.

(* Basic constructions for intuitionistic functions : extensional equality   *)
(* composition, override, update, inverse, and iteration, with some their    *)
(* identities, and reflected equalities.                                     *)

(* Miscellaneous notation bits for currrying and pairs *)

Notation "f ^~ y" := (fun x => f x y)
  (at level 10, y at level 8, no associativity, format "f ^~  y") : fun_scope.

Delimit Scope pair_scope with PAIR.
Open Scope pair_scope.

Notation "p .1" := (fst p) (at level 2, left associativity,
  format "p .1") : pair_scope.
Notation "p .2" := (snd p) (at level 2, left associativity,
  format "p .2") : pair_scope.

(* Complements on the option type constructor, used below to  *)
(* encode partial functions.                                  *)

Module Option.

Definition apply aT rT (f : aT -> rT) x u := if u is Some y then f y else x.

Definition default T := apply (fun x : T => x).

Definition bind aT rT (f : aT -> option rT) := apply f None.

Definition map aT rT (f : aT -> rT) := bind (fun x => Some (f x)).

End Option.

Notation oapp := Option.apply.
Notation odflt := Option.default.
Notation obind := Option.bind.
Notation omap := Option.map.
Notation some := (@Some _) (only parsing).

(* Reserved Notation "- 1" (at level 35). *)
Reserved Notation "x ^-1" (at level 2, left associativity, format "x ^-1").
Reserved Notation "x ^2" (at level 2, left associativity, format "x ^2").

(* Syntax for defining auxiliary recursive function.          *)
(*  Usage:                                                    *)
(* Section FooDefinition.                                     *)
(* Variables (g1 : T1) (g2 : T2).  (globals)                  *)
(* Fixoint foo_auxiliary (a3 : T3) ... :=                     *)
(*        body, using [rec e3, ...] for recursive calls       *)
(* where "[ 'rec' a3 , a4 , ... ]" := foo_auxiliary.          *)
(* Definition foo x y .. := [rec e1, ...].                    *)
(* + proofs about foo                                         *)
(* End FooDefinition.                                         *)

Reserved Notation "[ 'rec' a0 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]"
  (at level 0).
Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"
  (at level 0).

(* Definitions and notation for explicit functions with simplification,     *)
(* i.e., which simpl and /= beta expand (this is complementary to nosimpl). *)

Section SimplFun.

Variables aT rT : Type.

CoInductive simpl_fun : Type := SimplFun of aT -> rT.

Definition fun_of_simpl := fun f x => let: SimplFun lam := f in lam x.

Coercion fun_of_simpl : simpl_fun >-> Funclass.

End SimplFun.

Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E))
  (at level 0,
   format "'[hv' [ 'fun' :  T  => '/ '  E ] ']'") : fun_scope.

Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E))
  (at level 0, x ident,
   format "'[hv' [ 'fun'  x  => '/ '  E ] ']'") : fun_scope.

Notation "[ 'fun' x : T => E ]" := (SimplFun (fun x : T => E))
  (at level 0, x ident, only parsing) : fun_scope.

Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E])
  (at level 0, x ident, y ident,
   format "'[hv' [ 'fun'  x  y  => '/ '  E ] ']'") : fun_scope.

Notation "[ 'fun' x y : T => E ]" := (fun x : T => [fun y : T => E])
  (at level 0, x ident, y ident, only parsing) : fun_scope.

Notation "[ 'fun' ( x : T ) y => E ]" := (fun x : T => [fun y => E])
  (at level 0, x ident, y ident, only parsing) : fun_scope.

Notation "[ 'fun' x ( y : T ) => E ]" := (fun x => [fun y : T => E])
  (at level 0, x ident, y ident, only parsing) : fun_scope.

Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" :=
    (fun x : xT => [fun y : yT => E])
  (at level 0, x ident, y ident, only parsing) : fun_scope.

(* For delta functions in eqtype.v. *)
Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z].

(* Shorthand for some basic equality lemmas lemmas. *)

Definition erefl := refl_equal.
Definition esym := sym_eq.
Definition nesym := sym_not_eq.
Definition etrans := trans_eq.
Definition congr1 := f_equal.
Definition congr2 := f_equal2.
(* Force at least one implicit when used as a view. *)
Prenex Implicits esym nesym.

(* Extensional equality, for unary and binary functions, including syntactic *)
(* sugar.                                                                    *)

Section ExtensionalEquality.

Variables A B C : Type.

Definition eqfun (f g : B -> A) : Prop := forall x, f x = g x.

Definition eqrel (f g : C -> B -> A) : Prop := forall x y, f x y = g x y.

Lemma frefl : forall f, eqfun f f. Proof. split. Qed.
Lemma fsym : forall f g, eqfun f g -> eqfun g f. Proof. move=> f g H x; auto. Qed.

Lemma ftrans : forall f g (h:B -> A), eqfun f g -> eqfun g h -> eqfun f h.
Proof. by move=> f g h Hfg Hgh x; rewrite (Hfg x). Qed.

Lemma rrefl : forall f, eqrel f f. Proof. split. Qed.

End ExtensionalEquality.

Hint Resolve frefl rrefl.

Notation "f1 =1 f2" := (eqfun f1 f2)
  (at level 70, no associativity) : fun_scope.
Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A))
  (at level 70, f2 at next level, A at level 90) : fun_scope.
Notation "f1 =2 f2" := (eqrel f1 f2)
  (at level 70, no associativity) : fun_scope.
Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A))
  (at level 70, f2 at next level, A, B at level 90) : fun_scope.

Section Composition.

Variables A B C : Type.

Definition comp (f : B -> A) (g : C -> B) := [fun x => f (g x)].

Definition pcomp (f : B -> option A) (g : C -> option B) x := obind f (g x).

Lemma eq_comp : forall f f' g g', f =1 f' -> g =1 g' -> comp f g =1 comp f' g'.
Proof. by move=> f f' g g' Ef Eg x; rewrite /= Eg Ef. Qed.

End Composition.

Notation "[ 'eta' f ]" := (fun x => f x)
  (at level 0, format "[ 'eta'  f ]") : fun_scope.

Notation id := (fun x => x).
Notation "@ 'id' T " := (fun x : T => x)
  (at level 10, T at level 8, only parsing) : fun_scope.

Notation "f1 \o f2" := (fun_of_simpl (comp f1 f2))
  (at level 50) : fun_scope.

Section OperationProperties.

Variable T : Type.
Variables zero one: T.
Variable inv : T -> T.
Variables mul add : T -> T -> T.

Notation Local "1" := one.
Notation Local "0" := zero.
Notation Local "x ^-1" := (inv x).
Notation Local "x * y"  := (mul x y).
Notation Local "x + y"  := (add x y).

Definition left_unit          := forall x,     1 * x = x.
Definition right_unit         := forall x,     x * 1 = x.
Definition left_inverse       := forall x,     x^-1 * x = 1.
Definition right_inverse      := forall x,     x * x^-1 = 1.
Definition self_inverse       := forall x,     x * x = 1.
Definition idempotent         := forall x,     x * x = x.
Definition associative        := forall x y z, x * (y * z) = x * y * z.
Definition commutative        := forall x y,   x * y = y * x.
Definition left_commutative   := forall x y z, x * (y * z) = y * (x * z).
Definition right_commutative  := forall x y z, x * y * z = x * z * y.
Definition left_zero          := forall x,     0 * x = 0.
Definition right_zero         := forall x,     x * 0 = 0.
Definition left_distributive  := forall x y z, (x + y) * z = x * z + y * z.
Definition right_distributive := forall x y z, x * (y + z) = x * y + x * z.

End OperationProperties.

Section Morphism.

Variables (aT rT sT : Type) (f : aT -> rT).

Definition morphism_1 aF rF := forall x, f (aF x) = rF (f x).
Definition morphism_2 aOp rOp := forall x y, f (aOp x y) = rOp (f x) (f y).

End Morphism.

Notation "{ 'morph' f : x / a >-> r }" :=
  (morphism_1 f (fun x => a) (fun x => r))
  (at level 0, f at level 99, x ident,
   format "{ 'morph'  f  :  x  /  a  >->  r }") : type_scope.

Notation "{ 'morph' f : x / a }" :=
  (morphism_1 f (fun x => a) (fun x => a))
  (at level 0, f at level 99, x ident,
   format "{ 'morph'  f  :  x  /  a }") : type_scope.

Notation "{ 'morph' f : x y / a >-> r }" :=
  (morphism_2 f (fun x y => a) (fun x y => r))
  (at level 0, f at level 99, x ident, y ident,
   format "{ 'morph'  f  :  x  y  /  a  >->  r }") : type_scope.

Notation "{ 'morph' f : x y / a }" :=
  (morphism_2 f (fun x y => a) (fun x y => a))
  (at level 0, f at level 99, x ident, y ident,
   format "{ 'morph'  f  :  x  y  /  a }") : type_scope.

(* In an intuitionistic setting, we have two degrees of injectivity. The     *)
(* weaker one gives only simplification, and the strong one provides a left  *)
(* inverse (we show in `fintype' that they coincide for finite types).       *)
(* We also define an intermediate version where the left inverse is only a   *)
(* partial function.                                                         *)

Section Injections.

(* rT must come first so we can use @ to mitigate the Coq 1st order   *)
(* unification bug (e..g., Coq can't infer rT from a "cancel" lemma). *)
Variables (rT aT : Type) (f : aT -> rT).

Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2.

Definition cancel g := forall x, g (f x) = x.

Definition pcancel g := forall x, g (f x) = Some x.

Definition ocancel (g : aT -> option rT) h := forall x, oapp h x (g x) = x.

Lemma can_pcan : forall g, cancel g -> pcancel (fun y => Some (g y)).
Proof. by move=> g fK x; congr (Some _). Qed.

Lemma pcan_inj : forall g, pcancel g -> injective.
Proof. by move=> g fK x y; move/(congr1 g); rewrite !fK => [[]]. Qed.

Lemma can_inj : forall g, cancel g -> injective.
Proof. by move=> g; move/can_pcan; exact: pcan_inj. Qed.

Lemma canLR : forall g x y, cancel g -> x = f y -> g x = y.
Proof. by move=> g x y fK ->. Qed.

Lemma canRL : forall g x y, cancel g -> f x = y -> x = g y.
Proof. by move=> g x y fK <-. Qed.

End Injections.

Section InjectionsTheory.

Variables (A B C : Type) (f f' : B -> A) (g g' : A -> B).
Variables (h : C -> B) (k : B -> C).
Hypotheses (Hf : injective f) (Hfg : cancel f g) (Hg : injective g).
Hypotheses (Hh : injective h) (Hhk : cancel h k).

Lemma inj_can_sym : cancel g f.
Proof. move=> x; exact: Hg. Qed.

Lemma inj_comp : injective (f \o h).
Proof. move=> x y; move/Hf; exact: Hh. Qed.

Lemma inj_id : injective (@id A).
Proof. by []. Qed.

Lemma can_comp : cancel (f \o h) (k \o g).
Proof. by move=> x; rewrite /= Hfg Hhk. Qed.

Lemma eq_inj : f =1 f' -> injective f'.
Proof. move=> Ef x y; rewrite -2!Ef; exact: Hf. Qed.

Lemma eq_can : f =1 f' -> g =1 g' -> cancel f' g'.
Proof. by move=> Ef Eg x; rewrite -Ef -Eg. Qed.

Lemma inj_can_eq : cancel f' g -> f =1 f'.
Proof. by move=> Hf'g x; apply: Hg; rewrite Hfg. Qed.

End InjectionsTheory.

Section Bijections.

Variables (A B : Type) (f : B -> A).

Definition bijective : Prop := exists2 g, cancel f g & cancel g f.

Hypothesis Hf : bijective.

Lemma bij_inj : injective f.
Proof. by case: Hf => [h Ef _]; apply: can_inj Ef. Qed.

Lemma bij_can_sym : forall g, cancel g f <-> cancel f g.
Proof.
move=> g; split=> Eg; first exact: inj_can_sym Eg bij_inj.
by case: Hf => [h _ Eh] x; rewrite -[x]Eh Eg.
Qed.

Lemma bij_can_eq : forall g g', cancel f g -> cancel f g' -> g =1 g'.
Proof.
by move=> g g' Eg Eg'; apply: (inj_can_eq _ bij_inj); apply/bij_can_sym.
Qed.

End Bijections.

Section BijectionsTheory.

Variables (A B C : Type) (f : B -> A) (g : C -> B).

Lemma eq_bij : bijective f -> forall f', f =1 f' -> bijective f'.
Proof. by move=> [h Ef Eh] f' Eff'; exists h; eapply eq_can; eauto. Qed.

Lemma bij_comp : bijective f -> bijective g -> bijective (f \o g).
Proof.
move=> [h Ef Eh] [k Eg Ek]; exists (k \o h : _ -> _); apply can_comp; auto.
Qed.

Lemma bij_can_bij :
  bijective f -> forall h, cancel f h -> bijective h.
Proof. by move=> Hf; exists f; first by apply/(bij_can_sym Hf). Qed.

End BijectionsTheory.

Section Involutions.

Variables (A : Type) (f : A -> A).

Definition involutive := cancel f f.

Hypothesis Hf : involutive.

Lemma inv_inj : injective f. Proof. exact: can_inj Hf. Qed.
Lemma inv_bij : bijective f. Proof. by exists f. Qed.

End Involutions.


(** * Globals separated *)

(** globals_separate is an invariant enforcing
    that newly allocated blocks are NOT mapped
    to global blocks. It is used to re-establish
    meminj_preserves_globals in the after external
    diagram. In that sense it replaces
    sm_inject_separated (jan 2015).
*)

Require Import Events.
Require Import Coqlib.
Require Import Globalenvs.
Require Import structured_injections.
Require Import reach.
Require Import mem_lemmas.

Definition globals_separate {F V:Type} (ge: Genv.t F V) mu nu :=
    forall b1 b2 d, as_inj mu b1 = None ->
            as_inj nu b1 =Some(b2,d) ->
            isGlobalBlock ge b2 = false.

Lemma gsep_refl:
  forall {F V} mu (ge: Genv.t F V),
    globals_separate ge mu mu.
  intros ? ? mu ge b1 b2 d map1 map2.
  rewrite map1 in map2; discriminate.
Qed.

Lemma gsep_domain_eq:
  forall {F1 F2 V1 V2} mu mu' (ge1: Genv.t F1 V1) (ge2: Genv.t F2 V2),
    globals_separate ge1 mu mu' ->
    genvs_domain_eq ge1 ge2 ->
    globals_separate ge2 mu mu'.
  intros ? ? ? ? mu mu' ge1 ge2 gsep geq b1 b2 d map1 map2.
  rewrite <- (genvs_domain_eq_isGlobal _ _ geq).
  eapply gsep; eauto.
Qed.

Lemma gsep_trans:
  forall {F V} (ge:  Genv.t F V) mu mu' mu'',
      Values.inject_incr (as_inj mu') (as_inj mu'') ->
      globals_separate ge mu mu' ->
      globals_separate ge mu' mu'' ->
      globals_separate ge mu mu''.
  intros ? ? ge mu mu' mu'' incr gsep12 gsep23 b1 b3 d3 map1 map3.
  destruct (as_inj mu' b1) as [[b2 d2]|] eqn: map2.
  + eapply gsep12.
  - eassumption.
  - rewrite (incr b1 b2 d2 map2) in map3; inversion map3. subst; eassumption.
  + eapply gsep23; eauto.
Qed.

Lemma gsep_trans':
  forall {F V} (ge:  Genv.t F V) mu mu' mu'',
      SM_wd mu'' ->
      intern_incr mu' mu'' ->
      globals_separate ge mu mu' ->
      globals_separate ge mu' mu'' ->
      globals_separate ge mu mu''.
  intros ? ? ge mu mu' mu'' smwd incr gsep12 gsep23 b1 b3 d3 map1 map3.
  assert (INCR: Values.inject_incr (as_inj mu') (as_inj mu'')) by (apply intern_incr_as_inj; auto).
  eapply gsep_trans; eauto.
Qed.

    (*
Lemma gsep_compose:
  forall {F V} (ge:  Genv.t F V) mu12 mu23 mu12' mu23',
    SM_wd mu12 ->
    SM_wd mu23 ->
    SM_wd mu12' ->
    SM_wd mu23' ->
    Values.inject_incr (as_inj mu12) (as_inj mu12') ->
    (locBlocksTgt mu12 = locBlocksSrc mu23 /\
         extBlocksTgt mu12 = extBlocksSrc mu23) ->
    globals_separate ge mu12 mu12' ->
    globals_separate ge mu23 mu23' ->
    globals_separate ge (compose_sm mu12 mu23) (compose_sm mu12' mu23').
  intros ? ? ge mu12 mu23 mu12' mu23' WD12 WD23 WD12' WD23' INCR GLUE gsep12 gsep23 b1 b3 d3 map13 map13'.
  destruct (compose_sm_as_injD _ _ _ _ _ map13' WD12' WD23') as [b2 [d1 [d2 [map1 [map2 extra]]]]].
  destruct (compose_sm_as_injD_None _ _ _ WD12 WD23 GLUE map13) as [map12| [b2' [d [map12 map23]]]].
  - assert (isGlobalBlock ge b2 = false).
    eapply gsep12; eauto.
    destruct (isGlobalBlock ge b3) eqn:isglob; [ | reflexivity].
    assert (meminj_preserves_globals ge (extern_of mu12') /\
            (forall b, isGlobalBlock ge b = true -> frgnBlocksSrc mu12' b = true)).
      ad_it.
      destruct H0 as [A B].
      apply B in isglob.
      destruct A as [A1 [A2 A3]].

      ad_it.
  - assert (HH:as_inj mu12' b1 = Some (b2', d))
      by (eapply INCR; auto).
    rewrite HH in map1; inversion map1; subst.
    eapply gsep23; eauto.
Qed.
*)
Lemma meminj_preserves_globals_extern_incr_separate {F V:Type} (ge: Genv.t F V) mu nu:
  forall (INC: extern_incr mu nu)
         (PG: meminj_preserves_globals ge (as_inj mu))
         (WDnu: SM_wd nu)
         (GSep: globals_separate ge mu nu),
    meminj_preserves_globals ge (as_inj nu).
Proof. intros. destruct PG as [PGa [PGb PGc]].
       split; intros.
       apply PGa in H. eapply extern_incr_as_inj; eassumption.
       split; intros.
       apply PGb in H. eapply extern_incr_as_inj; eassumption.
       remember (as_inj mu b1) as q; apply eq_sym in Heqq.
       destruct q.
       destruct p.
       rewrite (extern_incr_as_inj _ _ INC WDnu _ _ _ Heqq) in H0.

       inv H0. apply (PGc _ _ _ _ H Heqq).
       specialize (GSep _ _ _ Heqq H0).
       rewrite (find_var_info_isGlobal _ _ _ H) in GSep; discriminate.
Qed.
Lemma meminj_preserves_globals_intern_incr_separate {F V:Type} (ge': Genv.t F V) mu nu:
  forall (INC: intern_incr mu nu)
         (PG: meminj_preserves_globals ge' (as_inj mu))
         (WDnu: SM_wd nu)
         (GSep: globals_separate ge' mu nu),
    meminj_preserves_globals ge' (as_inj nu).
Proof. intros. destruct PG as [PGa [PGb PGc]].
       split; intros.
       apply PGa in H. eapply intern_incr_as_inj; eassumption.
       split; intros.
       apply PGb in H. eapply intern_incr_as_inj; eassumption.
       remember (as_inj mu b1) as q; apply eq_sym in Heqq.
       destruct q.
       destruct p.
       rewrite (intern_incr_as_inj _ _ INC WDnu _ _ _ Heqq) in H0.

       inv H0. apply (PGc _ _ _ _ H Heqq).
       specialize (GSep _ _ _ Heqq H0).
       rewrite (find_var_info_isGlobal _ _ _ H) in GSep; discriminate.
Qed.

Lemma intern_incr_globals_separate
      {F V:Type} (ge: Genv.t F V) mu nu:
  forall (INC: intern_incr mu nu)
         (PG: meminj_preserves_globals ge (as_inj mu))
         (GF: forall b, isGlobalBlock ge b = true -> frgnBlocksSrc mu b = true)
         (WD: SM_wd mu) (WDnu: SM_wd nu),
    globals_separate ge mu nu.
Proof. intros. red; intros.
       remember (isGlobalBlock ge b2) as p; apply eq_sym in Heqp.
       destruct p; simpl; trivial.
       specialize (GF _ Heqp).
       destruct (frgnSrcAx _ WD _ GF) as [? [? [? ?]]].
       assert (EE: extern_of mu = extern_of nu) by eapply INC.
       destruct (joinD_Some _ _ _ _ _ H0) as [EXT | [EXT LOC]]; clear H0.
       rewrite <- EE in EXT.
       rewrite (extern_in_all _ _ _ _ EXT) in H; discriminate.
       destruct (local_DomRng _ WDnu _ _ _ LOC) as [lS lT].
       assert (lT': locBlocksTgt nu b2 = false).
       apply (meminj_preserves_globals_isGlobalBlock _ _ PG) in Heqp.
       rewrite (extern_in_all _ _ _ _ H1) in Heqp; inv Heqp.
       rewrite EE in H1.
       eapply extern_DomRng'; eassumption.
       rewrite lT' in lT; discriminate.
Qed.

Lemma exter_incr_globals_separate
      {F V:Type} (ge: Genv.t F V) mu nu:
  forall (EE: extern_of mu = extern_of nu)
         (PG: meminj_preserves_globals ge (as_inj mu))
         (GF: forall b, isGlobalBlock ge b = true -> frgnBlocksSrc mu b = true)
         (WD: SM_wd mu) (WDnu: SM_wd nu),
    globals_separate ge mu nu.
Proof. intros. red; intros.
       remember (isGlobalBlock ge b1) as p1; apply eq_sym in Heqp1.
       remember (isGlobalBlock ge b2) as p; apply eq_sym in Heqp.
       destruct p; simpl; trivial.
       destruct p1; simpl.
       specialize (GF _ Heqp1).
       destruct (frgnSrcAx _ WD _ GF) as [? [? [? ?]]].
       unfold as_inj, join in H.
       rewrite H1 in H; inversion H.
       (*eapply meminj_preserves_globals_isGlobalBlock in Heqp; eauto.*)

       specialize (GF _ Heqp).
       destruct (frgnSrcAx _ WD _ GF) as [? [? [? ?]]].
       destruct (joinD_Some _ _ _ _ _ H0) as [EXT | [EXT LOC]]; clear H0.
       rewrite <- EE in EXT.
       rewrite (extern_in_all _ _ _ _ EXT) in H. discriminate.
       destruct (local_DomRng _ WDnu _ _ _ LOC) as [lS lT].
       assert (lT': locBlocksTgt nu b2 = false).
       apply (meminj_preserves_globals_isGlobalBlock _ _ PG) in Heqp.
       rewrite (extern_in_all _ _ _ _ H1) in Heqp; inv Heqp.
       rewrite EE in H1.
       eapply extern_DomRng'; eassumption.
       rewrite lT' in lT; discriminate.
Qed.