Require Export LinF_Soundness.
Require Export ALinearF_Soundness.
Require Import LinF_ExtraLemmas.
Fixpoint from_genv_to_env (G : genv) {struct G} : env :=
  match G with
  | nil => empty
  | h :: t =>
    match h with
    | (A, gbind_kn K) => (A, bind_kn K) :: (from_genv_to_env t)
    | (A, gbind_typ T) => (A, bind_typ T) :: (from_genv_to_env t)
    end
  end.

Lemma dom_G_remain : forall G,
  dom G = dom (from_genv_to_env G).
Proof with eauto.
  intros G.
  induction G...
   destruct a...
    simpl. destruct g; rewrite IHG...
Qed.

Fixpoint from_denv_to_lenv (D : denv) {struct D} : lenv :=
  match D with
  | nil => lempty
  | h :: t =>
    match h with
    | (A, T) => (A, lbind_typ T) :: (from_denv_to_lenv t)
    end
  end.

Lemma dom_D_remain : forall D,
  dom D = dom (from_denv_to_lenv D).
Proof with eauto.
  intros D.
  induction D...
   destruct a...
    simpl. rewrite IHD...
Qed.

Fixpoint from_lenv_to_denv (D : lenv) {struct D} : denv :=
  match D with
  | nil => dempty
  | h :: t =>
    match h with
    | (A, m) =>
       match m with
       | lbind_typ T => (A, T) :: (from_lenv_to_denv t)
       end
    end
  end.

Lemma dom_D_remain_2 : forall D,
  dom D = dom (from_lenv_to_denv D).
Proof with eauto.
  intros D.
  induction D...
   destruct a... destruct l.
    simpl. rewrite IHD...
Qed.

Lemma uniq_genv_sound : forall G,
  uniq G ->
  uniq (from_genv_to_env G).
Proof with eauto.
  intros G H.
  induction G; simpl...
   destruct a...
    inversion H; subst...
     apply IHG in H2. destruct g; simpl_env;  apply uniq_push; try( rewrite <- dom_G_remain)...
Qed.
Hint Resolve uniq_genv_sound.

Lemma uniq_lenv_compl : forall D,
  uniq D ->
  uniq (from_lenv_to_denv D).
Proof with eauto.
  intros D Uniq.
  induction D; simpl...
   destruct a. destruct l.
   apply uniq_cons.
    apply IHD. solve_uniq.
    inversion Uniq...
    rewrite <- dom_D_remain_2...
Qed.

Theorem binds_kn_sound : forall X K G,
  binds X (gbind_kn K) G ->
  binds X (bind_kn K) (from_genv_to_env G)
 .
Proof with eauto.
  intros X K G H.
  induction G...
   destruct a...
    apply binds_cons_1 in H. inversion H; subst...
     destruct H0 as [H1 H2]; subst; simpl...
     apply IHG in H0. simpl. destruct g; apply binds_cons_3...
Qed.

Theorem binds_typ_sound : forall x T G,
  binds x (gbind_typ T) G ->
  binds x (bind_typ T) (from_genv_to_env G)
 .
Proof with eauto.
  intros x T G H.
  induction G...
   destruct a...
    apply binds_cons_1 in H. inversion H; subst...
     destruct H0 as [H1 H2]; subst; simpl...
     apply IHG in H0. simpl. destruct g; apply binds_cons_3...
Qed.

Lemma wf_atyp_sound : forall G T K,
 wf_atyp G T K ->
 wf_typ (from_genv_to_env G) T K
 .
Proof with eauto.
 intros G T K H.
 (wf_atyp_cases (induction H) Case)...
 Case "wf_atyp_var".
  apply binds_kn_sound in H0.
  destruct K; destruct K'; subst;
    try  (apply wf_typ)...
   inversion H1...
 Case "wf_atyp_arrow".
  destruct K; destruct K'; subst;
    try (apply wf_arrow)...
   inversion H1...
Qed.

Lemma wf_genv_sound : forall G,
 wf_genv G ->
 wf_env (from_genv_to_env G).
Proof with eauto.
 intros G H.
 (wf_genv_cases (induction H) Case); simpl; simpl_env...
 Case "wf_genv_kn".
  rewrite dom_G_remain in H0.
  apply wf_env_kn...
 Case "wf_genv_typ".
  rewrite dom_G_remain in H1.
  apply wf_atyp_sound in H0.
  apply wf_env_typ...
Qed.

Theorem uvar_sound : forall x T G,
  wf_genv G ->
  binds x (gbind_typ T) G ->
  typing (from_genv_to_env G) lempty x T
 .
Proof with eauto.
  intros x T G Wfg Binds.
  apply binds_typ_sound in Binds...
  apply typing_var...
   apply wf_genv_sound...
Qed.

Lemma perm_length_eq : forall A,
  (forall (x y:(atom * A)%type), {x = y}+{~x = y})->
  forall (D1 D2:list (atom*A)),
  permute  D1 D2 ->
  length D1 = length D2.
Proof with eauto.
  intros. induction H... simpl in *...
  rewrite app_length in *. simpl. rewrite IHpermute...
Qed.

Lemma perm_dempty : forall D2 D1,
  uniq D2 ->
  permute D2 (D2 ++ D1) ->
  D1 = dempty.
Proof with eauto; try (inversion 2).
  intros D2 D1 Uniq Perm.
  destruct D1...
  apply perm_length_eq in Perm.
  rewrite app_length in Perm.  simpl in *.
  assert (length D2 + O < length D2 + S (length D1)).
   apply plus_le_lt_compat... apply lt_O_Sn. rewrite plus_0_r in H.
   rewrite <- Perm in H. assert (~ (length D2 < length D2)).
    apply lt_irrefl. apply H0 in H.
    inversion H.
    decide equality. apply eq_typ_dec.
Qed.

Lemma card_eq_len : forall D,
  uniq D ->
  EMap.cardinal (<# D #>) = length D.
Proof with eauto.
  intros D Uniq.
  induction D...
  destruct a; simpl; simpl_env in *...
   assert (uniq D). solve_uniq.
   apply IHD in H.
   rewrite <- H.
   apply cardinal_2 with (x := a) (e := t).
   inversion Uniq; subst...
   apply notin_dom_implies_notIn...
   unfold Add...
Qed.

Lemma remove_notin_equiv : forall D3 x D2,
  (<# D3 #> [-] x) ~~ <# D2 #> ->
  x `notin` dom D2.
Proof with eauto.
  intros D3 x D2 Eq.
  assert (~ EMap.In x (<# D3 #> [-] x)) as NotIn.
   apply dmap_remove_clear.
  apply notIn_implies_notin_dom in NotIn.
  assert ((<# D3 #> [-] x) ~~ <# <@(<# D3 #> [-] x)@> #>).
   apply denv_to_from_dmap.
  assert (<# <@(<# D3 #> [-] x)@> #> ~~ <# D2 #>).
   eapply Equal_trans.
    apply Equal_sym in H. eauto. auto.
  assert (x `notin` dom D2).
   eapply denv_Equal_notin_dom. eauto. auto. auto.
Qed.

Lemma conc_after_minus_eq : forall x T D3 D2,
  (<# D3 #> [-] x) ~~ <# D2 #> ->
  <#[(x, T)] ++ <@ <# D3 #> [-] x @> #> ~~ <#[(x, T)] ++ D2 #>
 .
Proof with eauto.
  intros x T D3 D2 H.
  apply denv_add_preserves_Equal...
   assert (<# D3 #> [-] x ~~ <# <@ <# D3 #> [-] x @> #> ).
    apply denv_to_from_dmap.
   apply Equal_sym in H0.
   assert (<# <@ <# D3 #> [-] x @> #> ~~ <# D2 #>).
    eapply Equal_trans. eauto. auto. auto.
Qed.

Lemma conc_after_minus_eq_refl : forall D3 x T,
  binds x T D3 ->
  uniq D3 ->
  <# D3 #> ~~ <# [(x, T)] ++ <@<# D3 #> [-] x@> #>.
Proof with eauto.
  intros D3 x T Binds Uniq.
   unfold EMap.Equal.
   intros y.
   destruct (x == y); subst... (*simpl in *...*)
    Case "x = y".
     simpl in *.
     assert (binds y T D3 <-> EMap.find y <# D3 #> = Some T) as BFIso.
      apply denv_to_dmap_iso...
     inversion BFIso as [BTF FTB]. clear FTB.
     apply BTF in Binds. clear BFIso BTF. rewrite Binds.

     assert (EMap.find (elt:=typ) y
      (y ::: T[+]<# EMap.Raw.remove (elt:=typ) y <# D3 #> #>) = Some T) as FAA.
      apply EMap.find_1. apply EMap.add_1...
     rewrite FAA...
    Case "x <> y".
     remember (EMap.find (elt:=typ) y <# D3 #>) as e.
     destruct e.
     SCase "Some t".
     assert ( EMap.MapsTo y t
      ( EMap.add x T <# <@ <# D3 #>[-]x @> #>)).
      apply EMap.add_2...
      assert (EMap.MapsTo y t <# D3 #>).
       apply EMap.find_2. apply sym_eq...
      apply (EMap.remove_2 n) in H.
      assert ((<# D3 #>[-]x) ~~  <# <@ <# D3 #>[-]x @> #>) as Tr.
       apply denv_to_from_dmap.
      unfold EMap.Equal in Tr.
      apply EMap.find_1 in H.
      assert (       EMap.find (elt:=typ) y (<# D3 #>[-]x) =
       EMap.find (elt:=typ) y <# <@ <# D3 #>[-]x @> #>) as TrY...
      rewrite H in TrY. apply sym_eq in TrY.
      apply EMap.find_2...
      apply sym_eq.
      apply EMap.find_1...
     SCase "None".
      remember (EMap.find (elt:=typ) y <# [(x, T)] ++ <@ <# D3 #>[-]x @> #>) as e.
      destruct e...
      SSCase "Some t".
       assert (<# [(x, T)] ++ <@ <# D3 #>[-]x @> #>=(x:::T [+] <# <@ <# D3 #>[-]x @> #>)) as EQ...
       rewrite EQ in Heqe0. clear EQ.
       apply sym_eq in Heqe0.
       apply EMap.find_2 in Heqe0.
       apply (EMap.add_3 n) in Heqe0.

       assert (EMap.MapsTo y t (<# D3 #> [-] x)) as TAR.
        assert ((<# D3 #>[-]x) ~~ <# <@ <# D3 #>[-]x @> #>) as Tr.
         apply denv_to_from_dmap.
        assert (       EMap.find (elt:=typ) y (<# D3 #>[-]x) =
        EMap.find (elt:=typ) y <# <@ <# D3 #>[-]x @> #>) as TrY...
        apply EMap.find_1 in Heqe0.
        rewrite <- TrY in Heqe0. clear Tr TrY.
        apply EMap.find_2...
       apply EMap.remove_3 in TAR. apply EMap.find_1 in TAR.
       rewrite TAR in Heqe. inversion Heqe.
Qed.

Lemma lvar_case_lemma1 : forall D3 x T D2,
  uniq D3 ->
  binds x T D3 ->
  uniq D2 ->
  (<# D3 #> [-] x) ~~ <# D2 #> ->
  <# D3 #> ~~ <# D2 ++ [(x, T)] #>
 .
Proof with eauto.
  intros D3 x T D2 UD3 Binds UD2 Eq.
  assert (x `notin` dom D2) as notinD2.
   eapply remove_notin_equiv. eauto.

  assert (<#[(x, T)] ++ <@ <# D3 #> [-] x @> #> ~~ <#[(x, T)] ++ D2 #>) as HMid.
   apply conc_after_minus_eq...

  assert (<# D3 #> ~~ <# [(x, T)] ++ <@<# D3 #> [-] x@> #>) as HD3.
   apply conc_after_minus_eq_refl...

  eapply Equal_trans.
   eauto.
  eapply Equal_trans.
   eauto.
  apply disjoint_denv_cons_commut.
   solve_uniq.
Qed.

Lemma perm_uniq_implies_eq : forall D1 D2,
  permute D1 D2 ->
  uniq D1 ->
  D1 ~~~ D2.
Proof with eauto.
  intros D1 D2 Perm Uniq.
  induction Perm...
  Case "empty".
   rewrite_env (dempty ++ dempty ++ dempty).
   apply disjoint_denv_cons_3commut_aux...
  Case "cons".
   assert ([(x, b)] ++ D ~~~ [(x, b)] ++ DL ++ DR) as H.
    apply denv_add_preserves_Equal...
     apply IHPerm... inversion Uniq...
   assert (uniq ([(x, b)] ++ DL)) as UniqDL.
    assert (uniq D) as UniqD. inversion Uniq...
    assert (uniq (DL ++ DR)) as H1.
      apply uniq_env_permute with D...
    assert (uniq DL) as H2.
      solve_uniq.
    assert (x `notin` dom D).
      solve_uniq.
    assert (x `notin` dom D <-> x `notin` dom (DL ++ DR)).
      apply IHPerm in UniqD. apply denv_equal_notin_dom_iff...
    inversion H3 as [H4 H5]. clear H3 H5.
     apply H4 in H0. simpl_env in H0.
     assert (x `notin` dom DL). fsetdec.
     solve_uniq.
   assert ([(x, b)] ++ DL ~~~ DL ++ [(x, b)]) as H1.
    rewrite_env ([(x, b)] ++ DL ++ dempty).
    rewrite_env (dempty ++ DL ++ [(x, b)]).
    apply disjoint_denv_cons_3commut_aux...
     simpl_env...
   assert ([(x, b)] ++ DL ++ DR ~~~ DL ++ [(x, b)] ++ DR).
    rewrite_env (dempty ++ [(x, b)] ++ dempty ++ DL ++ DR).
    rewrite_env (dempty ++ DL ++ dempty ++ [(x, b)] ++ DR).
    apply disjoint_denv_cons_commut_aux.
     simpl_env.
     assert (uniq D). inversion Uniq...
     assert (uniq (DL ++ DR)).
      apply uniq_env_permute with D...
     assert (x `notin` dom D). inversion Uniq...
     assert (x `notin` dom D <-> x `notin` dom (DL ++ DR)).
      apply IHPerm in H0.
      apply denv_equal_notin_dom_iff...
     inversion H4. apply H5 in H3.
     solve_uniq.
   eapply Equal_trans. eauto. auto.
Qed.

Lemma eq_uniq_implies_perm : forall D1 D2,
  <# D1 #> ~~ <# D2 #> ->
  uniq D1 ->
  uniq D2 ->
  permute D1 D2.
Proof with eauto.
  intros D1 D2 EQ Uniq1 Uniq2.
  generalize dependent D2.
  induction D1; intros D2 EQ Uniq2...
  Case "empty".
   simpl in *...
   apply dmap_eq_empty_inv in EQ.
   apply denv_eq_empty_inv in EQ.
   subst. apply permute_empty.
  Case "cons".
   destruct a as [x T]. simpl_env in *.
   assert (forall x0 T0, binds x0 T0 ([(x, T)] ++ D1) <-> binds x0 T0 D2) as H.
    apply dmap_eq__binds_iff...
   assert (binds x T ([(x, T)] ++ D1) <-> binds x T D2) as H1...
   inversion H1 as [H2 H3]. clear H H1 H3.
   assert (binds x T ([(x, T)] ++ D1)) as H4...
   apply H2 in H4.
   apply binds_inv in H4. inversion H4 as [E1 [E2 H]]; subst. clear H4.
   apply permute_cons.
   apply IHD1...
    inversion Uniq1...
   assert ( (dempty ++ dempty ++ E2 ++ [(x, T)] ++ E1) ~~~
      (dempty ++ [(x, T)] ++ E2 ++ dempty ++ E1)) as H.
    apply disjoint_denv_cons_commut_aux. simpl_env...
   simpl_env in *.
   unfold denv_Equal in H.
   assert (<# [(x, T)] ++ D1 #> ~~ <# [(x, T)] ++ E2 ++ E1 #>) as H1.
   eapply Equal_trans. eauto.  auto.
   assert (uniq ([(x, T)] ++ E2 ++ E1)) as H3.
    solve_uniq.
   clear H H2 EQ Uniq2.
   unfold EMap.Equal in *.
   assert (x `notin` dom D1).
    inversion Uniq1; subst...
   assert (x `notin` dom (E2 ++ E1)).
    inversion H3; subst...
   intros y.
   destruct (y == x); subst...
    SCase "y = x".
     apply notin_dom_implies_notIn in H.
     apply notin_dom_implies_notIn in H0.
     apply not_find_in_iff in H. rewrite H.
     apply not_find_in_iff in H0. rewrite H0...
    SCase "y <> x".
     assert ( EMap.find (elt:=typ) y <# [(x, T)] ++ D1 #> =
       EMap.find (elt:=typ) y <# [(x, T)] ++ E2 ++ E1 #>) as HF...
      simpl in HF.
      assert (EMap.find (elt:=typ) y (x ::: T[+]<# D1 #>) =
        EMap.find (elt:=typ) y (<# D1 #>)) as HA1.
       apply add_neq_o... rewrite <- HA1.
      assert (EMap.find (elt:=typ) y (x ::: T[+]<# E2 ++ E1 #>) =
        EMap.find (elt:=typ) y <# E2 ++ E1 #>) as HA2.
       apply add_neq_o... rewrite <- HA2...
Qed.

Lemma lvar_case_lemma2 : forall D3 D2 D1 x T,
  permute D3 (D2 ++ D1) ->
  <# D3 #> ~~ <# D2 ++ [(x, T)] #> ->
  uniq D3 ->
  uniq (D2 ++ [(x, T)]) ->
  x `notin` dom D2 ->
  binds x T D3 ->
  D1 = [(x, T)].
Proof with eauto.
  intros D3 D2 D1 x T Perm Eq Uniq3 Uniq2 NotIn Binds.
  assert (x `in` dom D3) as H3.
   apply binds_In with T...
  assert (D3 ~~~ D2 ++ D1) as Eq2.
   apply perm_uniq_implies_eq...
  assert (x `in` dom D3 <-> x `in` dom (D2 ++ D1)) as H.
   apply denv_equal_in_dom_iff...
  inversion H as [H1 H2]. clear H H2.
  apply H1 in H3.
  assert (x `in` dom D1) as InD1.
   simpl_env in H3. fsetdec.
  assert (binds x T (D2 ++ D1)).
   apply binds_permutation with D3...
   apply uniq_env_permute with D3...
   assert (binds x T D2 \/ binds x T D1) as Bindsx.
    apply binds_app_1...
   inversion Bindsx. apply binds_In in H0. fsetdec.

  assert (permute D3 (D2 ++ [(x, T)])) as Perm2.
   apply eq_uniq_implies_perm...

  apply perm_length_eq in Perm.
  apply perm_length_eq in Perm2.
  rewrite Perm in Perm2.
  rewrite app_length in Perm2. rewrite app_length in Perm2.
  apply plus_reg_l in Perm2. simpl in *.

  destruct D1; simpl in Perm2; inversion Perm2...
   destruct p. destruct D1; simpl in H4; inversion H4...
   simpl_env in *.
   assert (x = a).
    eapply binds_one_1... subst.
   apply binds_one_2 in H0; subst...

  intros x0 y. decide equality.
  remember (beq_typ b t) as e.
  destruct e.
   apply sym_eq in Heqe.
   apply beq_typ_iff_eq in Heqe; subst...
   right. unfold not. intros contra.
    apply beq_typ_iff_eq in contra. rewrite contra in Heqe. inversion Heqe.

 intros x0 y. decide equality.
  remember (beq_typ b t) as e.
  destruct e.
   apply sym_eq in Heqe.
   apply beq_typ_iff_eq in Heqe; subst...
   right. unfold not. intros contra.
    apply beq_typ_iff_eq in contra. rewrite contra in Heqe. inversion Heqe.
Qed.

Lemma perm_trans : forall (D1 D2 D3 : denv),
 uniq D1 ->
 uniq D2 ->
 permute D1 D2 ->
 permute D2 D3 ->
 permute D1 D3.
Proof with eauto.
  intros.
  assert (D1 ~~~ D2) as Eq1.
   apply perm_uniq_implies_eq...
  assert (D2 ~~~ D3) as Eq2.
   apply perm_uniq_implies_eq...
  assert (D1 ~~~ D3) as Eq3.
   eapply Equal_trans.
    eauto. auto.
  assert (uniq D3).
   apply uniq_env_permute with D2...
  apply eq_uniq_implies_perm...
Qed.

Lemma eq_uniq_perm_dempty : forall D1 D2 D3,
  D3 ~~~ D2 ->
  uniq D3 ->
  uniq D2 ->
  permute D3 (D2 ++ D1) ->
  D1 = dempty.
Proof with eauto.
 intros D1 D2 D3 EQ Uniq3 Uniq2 Perm.
 apply Equal_sym in EQ.
 assert (permute D2 D3) as Perm2.
  apply eq_uniq_implies_perm...
 assert (permute D2 (D2 ++ D1)).
  eapply perm_trans.
   auto. apply Uniq3. auto. auto.
 apply perm_dempty  with D2...
Qed.

Lemma denv_conc_preserves_Equal_1 : forall D D' D1 : denv,
  D ~~~ D' ->
  D1 ++ D ~~~ D1 ++ D'.
Proof with eauto.
  intros D D' D1 EQ.
  induction D1...
  destruct a. simpl_env.
   apply denv_add_preserves_Equal...
Qed.

Lemma denv_conc_preserves_Equal_2 : forall D D' D1 : denv,
  D ~~~ D' ->
  uniq (D ++ D1) ->
  uniq (D' ++ D1) ->
  D ++ D1 ~~~ D' ++ D1.
Proof with eauto.
  intros D D' D1 Uniq1 Uniq2 EQ.
  assert (D1 ++ D ~~~ D1 ++ D') as H.
   apply denv_conc_preserves_Equal_1...
  assert (D ++ dempty ++ D1 ~~~ D1 ++ dempty ++ D) as H1.
   apply disjoint_denv_cons_3commut_aux...
  assert (D' ++ dempty ++ D1 ~~~ D1 ++ dempty ++ D') as H2.
   apply disjoint_denv_cons_3commut_aux...
  simpl_env in *.
  eapply Equal_trans.
   eauto.
  eapply Equal_trans.
   eauto.
  apply Equal_sym...
Qed.

Lemma perm_subst_1 : forall D1 D2 D3 D4 : denv,
  uniq D1 ->
  permute D1 (D2 ++ D3) ->
  permute D2 D4 ->
  permute D1 (D4 ++ D3).
Proof with eauto.
  intros D1 D2 D3 D4 Uniq Perm1 Perm2.
  assert (uniq (D2 ++ D3)) as H1.
   apply uniq_env_permute with D1...
  assert (uniq D2) as Uniq2.
   apply uniq_app_1 with D3...
  assert (uniq D3) as Uniq3.
   apply uniq_app_2 with D2...
  assert (uniq D4) as Uniq4.
   apply uniq_env_permute with D2...
  assert (D1 ~~~ D2 ++ D3) as Eq1.
   apply perm_uniq_implies_eq...
  assert (D2 ~~~ D4) as Eq2.
   apply perm_uniq_implies_eq...
  assert (uniq (D4 ++ D3)) as Uniq43.
   apply uniq_app_iff in H1. destruct H1 as [H2 [H3 H4]].
    assert (disjoint D4 D3) as Disj.
     apply dmap_denv_disjoint.
      eapply dmap_Equal_preserves_disjoint_left.
       apply denv_dmap_disjoint in H4...
       apply Equal_sym...
      apply uniq_app_4...
  assert (D2 ++ D3 ~~~ D4 ++ D3) as Eq3.
   apply denv_conc_preserves_Equal_2...

  assert (D1 ~~~ D4 ++ D3) as Eq4.
   eapply Equal_trans.
    eauto. auto.
  apply eq_uniq_implies_perm...
Qed.

Lemma perm_subst_2 : forall D1 D2 D3 D4 : denv,
  uniq D1 ->
  permute D1 (D2 ++ D3) ->
  permute D3 D4 ->
  permute D1 (D2 ++ D4).
Proof with eauto.
  intros D1 D2 D3 D4 Uniq Perm1 Perm2.
  generalize dependent D1.
  generalize dependent D2.
  induction Perm2; intros; simpl_env in *...
   assert (permute D1 ((D2 ++ [(x, b)]) ++ DL ++ DR)) as Perm3.
    apply IHPerm2... simpl_env...
   rewrite_env (D2 ++ [(x, b)] ++ dempty ++  DL ++ DR) in Perm3.
   assert (D1 ~~~ D2 ++ [(x, b)] ++ dempty ++  DL ++ DR) as H1.
    apply perm_uniq_implies_eq...
   assert (D2 ++ [(x, b)] ++ dempty ++  DL ++ DR ~~~ D2 ++ DL ++ dempty ++ [(x, b)] ++ DR) as H2.
    apply disjoint_denv_cons_commut_aux.
     apply uniq_env_permute with D1...
   assert (D1 ~~~ D2 ++ DL ++ dempty ++ [(x, b)] ++ DR) as H3.
     eapply Equal_trans. eauto. auto.
   apply eq_uniq_implies_perm...
    simpl_env in *.
    assert (uniq (D2 ++ [(x, b)] ++ DL ++ DR)) as H4.
     apply uniq_env_permute with D1...
    solve_uniq.
Qed.

Lemma perm_strengthening_head : forall (D1 D2 : denv) x T,
  uniq ([(x, T)] ++ D1) ->
  permute ([(x, T)] ++ D1) ([(x, T)] ++ D2) ->
  permute D1 D2.
Proof with eauto.
  intros D1 D2 x T Uniq Perm.
  remember ([(x, T)] ++ D1) as e1.
  remember ([(x, T)] ++ D2) as e2.
  generalize dependent D1.
  generalize dependent D2.
  generalize dependent x.
  generalize dependent T.
  induction Perm; intros; subst...
   inversion Heqe1.
   inversion Heqe1; subst...
    destruct DL; simpl_env in *.
      inversion Heqe2; subst...
      destruct p. inversion Heqe2; subst...
       assert (x0 `notin` dom D1) as Notin.
        inversion Uniq...
       assert (dom D1 [=] dom ([(x0, T)] ++ DL ++ DR)) as Domeq.
        apply dom_permute... rewrite Domeq in Notin.
        simpl_env in Notin. fsetdec.
Qed.

Lemma perm_strengthening_1 : forall D1 D2 D3 : denv,
  uniq (D1 ++ D2) ->
  permute (D1 ++ D2) (D1 ++ D3) ->
  permute D2 D3.
Proof with eauto.
  intros D1 D2 D3 Uniq Perm.
  assert (uniq (D1 ++ D3)) as H1.
   apply uniq_env_permute with (D1 ++ D2)...
  assert (uniq D1) as Uniq1.
   apply uniq_app_1 with D2...
  induction D1...
   destruct a in *. simpl_env in *.
   apply IHD1...
    inversion Uniq...
    eapply perm_strengthening_head.
     eauto. auto.
     inversion H1...
     inversion Uniq1...
Qed.

Lemma lenv_to_denv : forall D1 D2,
  D1 = from_denv_to_lenv D2 ->
  D2 = from_lenv_to_denv D1.
Proof with eauto.
  intros D1 D2 EQ.
  generalize dependent D1.
  induction D2; intros; subst...
   destruct a.
   simpl in *.
   assert (D2 = from_lenv_to_denv (from_denv_to_lenv D2)).
    apply IHD2... rewrite <- H...
Qed.

Lemma lenv_refl : forall D,
  D = from_denv_to_lenv (from_lenv_to_denv D).
Proof with eauto.
  intros D.
  induction D...
   destruct a. destruct l. simpl. rewrite <- IHD...
Qed.

Lemma denv_to_lenv_conc : forall D1 D2,
  from_denv_to_lenv (D1 ++ D2) = from_denv_to_lenv D1 ++ from_denv_to_lenv D2.
Proof with eauto.
  intros D1 D2.
  induction D1...
   destruct a. simpl in *. rewrite IHD1...
Qed.

Lemma lenv_to_denv_conc : forall D1 D2,
  from_lenv_to_denv (D1 ++ D2) = from_lenv_to_denv D1 ++ from_lenv_to_denv D2.
Proof with eauto.
  intros D1 D2.
  induction D1...
   destruct a. destruct l. simpl in *. rewrite IHD1...
Qed.

Lemma lempty_implies_lempty : forall D1 D2,
 lempty = D1 ++ D2 ->
 D1 = lempty /\ D2 = lempty.
Proof with eauto.
  intros. destruct D1; destruct D2...
  inversion H... inversion H.
Qed.

Lemma perm_denv_to_lenv : forall D1 D2,
  permute (from_denv_to_lenv D1) (from_denv_to_lenv D2) ->
  permute D1 D2.
Proof with eauto.
  intros D1 D2 H.
  remember (from_denv_to_lenv D1) as e1.
  remember (from_denv_to_lenv D2) as e2.
  generalize dependent D1.
  generalize dependent D2.
  induction H; intros; subst.
   destruct D2; destruct D1; simpl_env in *; subst;
    try (apply permute_empty);
    try (destruct p; simpl in *; inversion Heqe1);
    try (inversion Heqe2).
    destruct D1.
     simpl in Heqe1. inversion Heqe1.
     destruct p. simpl in Heqe1. inversion Heqe1; subst.
      apply lenv_to_denv in Heqe2.
      rewrite Heqe2.
    assert (permute D1 (from_lenv_to_denv  (DL ++ DR))) as HP.
     apply IHpermute...
      apply lenv_refl.
      rewrite lenv_to_denv_conc in *.
      rewrite lenv_to_denv_conc. simpl. simpl_env.
      apply permute_cons...
Qed.

Lemma denv_to_lenv : forall D1 D2,
  D1 = from_lenv_to_denv D2 ->
  D2 = from_denv_to_lenv D1.
Proof with eauto.
  intros.
  subst. apply lenv_refl.
Qed.

Lemma denv_refl : forall D,
  D = (from_lenv_to_denv (from_denv_to_lenv D)).
Proof with eauto.
  intros. apply lenv_to_denv...
Qed.

Lemma perm_lenv_to_denv : forall D1 D2,
  permute (from_lenv_to_denv D1) (from_lenv_to_denv D2) ->
  permute D1 D2.
Proof with eauto.
  intros D1 D2 H.
  remember (from_lenv_to_denv D1) as e1.
  remember (from_lenv_to_denv D2) as e2.
  generalize dependent D1.
  generalize dependent D2.
  induction H; intros; subst.
 destruct D2; destruct D1; simpl_env in *; subst;
    try (apply permute_empty);
    try (destruct p; destruct l; simpl in *; inversion Heqe1);
    try (inversion Heqe2).
    destruct D1.
     simpl in Heqe1. inversion Heqe1.
     destruct p. destruct l in *. simpl in *. inversion Heqe1; subst.
      apply denv_to_lenv in Heqe2.
      rewrite Heqe2.
    assert (permute D1 (from_denv_to_lenv  (DL ++ DR))) as HP.
     apply IHpermute...
      apply denv_refl.
      rewrite denv_to_lenv_conc in *. simpl_env.
      rewrite denv_to_lenv_conc. simpl. simpl_env.
      apply permute_cons...
Qed.

Lemma perm_lenv_to_denv_2 : forall D1 D2,
  permute D1 D2 ->
  permute (from_lenv_to_denv D1) (from_lenv_to_denv D2).
Proof with eauto.
  intros D1 D2 Perm.
  induction Perm...
   simpl. apply permute_empty.
   destruct b. simpl. simpl_env.
   rewrite lenv_to_denv_conc. rewrite lenv_to_denv_conc. simpl. simpl_env.
   apply permute_cons... rewrite <- lenv_to_denv_conc...
Qed.

Lemma perm_denv_to_lenv_2 : forall D1 D2,
  permute D1 D2 ->
  permute (from_denv_to_lenv D1) (from_denv_to_lenv D2).
Proof with eauto.
  intros D1 D2 Perm.
  generalize dependent D2.
  induction D1; intros...
   inversion Perm; simpl; subst...
    apply permute_empty.
   inversion Perm; simpl; subst...
   assert (permute (from_denv_to_lenv D1) (from_denv_to_lenv (DL ++ DR))).
    apply IHD1...
   rewrite denv_to_lenv_conc. simpl. simpl_env.
   apply permute_cons...
    rewrite <- denv_to_lenv_conc.
    apply IHD1...
Qed.

Lemma perm_to_lenv_split : forall G D1 D2 D3,
  wf_lenv G D1 ->
  permute D1 (D2 ++ D3) ->
  exists D22,
    exists D33,
      permute D2 D22 /\
      permute D3 D33 /\
      lenv_split G D22 D33 D1.
Proof with eauto.
  intros G D1 D2 D3 Wflenv Perm.
  remember D1 as e1.
  remember (D2 ++ D3) as e2.
  generalize dependent D1.
  generalize dependent D2.
  generalize dependent D3.
  induction Perm; intros; subst...
   exists (lempty). exists (lempty).
   apply lempty_implies_lempty in Heqe2.
   destruct Heqe2; subst...
   repeat split...
    apply permute_empty.
    apply permute_empty.

   assert (
   (exists F1, D2 = DL ++ [(x, b)] ++ F1 /\ DR = F1 ++ D3) \/
   (exists F2, DL = D2 ++ F2 /\ D3 = F2 ++ [(x, b)] ++ DR)) as Mid.
    apply uniq_eq_mid...
     apply eq_lbinding_dec.
     assert (permute ([(x, b)] ++ D) (DL ++ [(x, b)] ++ DR)) as Perm2.
      apply permute_cons...
     apply uniq_env_permute with ([(x, b)] ++ D).
      apply uniq_from_wf_lenv with G...
     auto.

   destruct Mid.
    destruct H as [F1 [EQD2 EQD3]].
    assert (exists D21,
             exists D31,
               permute (DL ++ F1) D21 /\ permute D3 D31 /\ lenv_split G D21 D31 D) as HP.
     apply IHPerm with D...
      inversion Wflenv...
      subst...
    destruct HP as [D21 [D31 [Perm2 [Perm3 Lsplit]]]].
    subst.
    exists ([(x, b)] ++ D21).
     exists D31.
     repeat split.
      assert (uniq ([(x, b)] ++ D)) as Uniq.
       apply uniq_from_wf_lenv with G...
      apply permute_sym...
       apply eq_lbinding_dec.
       assert (permute (lempty ++ [(x, b)] ++ D) (lempty ++ [(x, b)] ++ DL ++ F1 ++ D3)).
        apply permute_weakening. apply eq_lbinding_dec.
         simpl_env... simpl_env...
       simpl_env in H.
       assert (uniq ([(x, b)] ++ DL ++ F1 ++ D3)) as Uniq2.
        eapply uniq_env_permute. apply Uniq. auto.
       assert (uniq ([(x, b)] ++ DL ++ F1)) as Uniq3.
        apply uniq_app_1 with D3... simpl_env...
       assert (permute (lempty ++ [(x, b)] ++ DL ++ F1) (lempty ++ [(x, b)] ++ D21)) as Perm4.
        apply permute_weakening. apply eq_lbinding_dec.
         simpl_env... simpl_env...
       simpl_env in Perm4.
       apply uniq_env_permute with ([(x, b)] ++ DL ++ F1)...
      apply permute_cons.
       apply permute_sym. apply eq_lbinding_dec.
        assert (uniq (DL ++ F1 ++ D3)) as Uniq2.
         apply uniq_env_permute with D...
        apply uniq_app_1 with D3. simpl_env... auto. auto.

      destruct b.
      apply lenv_split_left...
       inversion Wflenv...
       inversion Wflenv...
       inversion Wflenv...

   destruct H as [F2 [EQD2 EQD3]].
    assert (exists D21,
             exists D31,
               permute D2 D21 /\ permute (F2 ++ DR) D31 /\ lenv_split G D21 D31 D) as HP.
     apply IHPerm with D...
      inversion Wflenv...
      subst...
    destruct HP as [D21 [D31 [Perm2 [Perm3 Lsplit]]]].
    subst.
    exists D21.
     exists ([(x, b)] ++ D31).
     repeat split.
      auto.
      assert (uniq ([(x, b)] ++ D)) as Uniq.
       apply uniq_from_wf_lenv with G...
      assert (uniq D) as Uniq2.
        inversion Uniq...
      apply permute_sym.
       apply eq_lbinding_dec.
       simpl_env in Perm.
       assert (uniq (D2 ++ F2 ++ DR)) as Uniq3.
        apply uniq_env_permute with D...
       assert (uniq (F2 ++ DR)) as Uniq4.
        apply uniq_app_2 with D2...
       assert (uniq D31) as Uniq5.
        apply uniq_env_permute with (F2 ++ DR)...
       destruct b. simpl.
       apply uniq_cons...
        assert (dom (F2 ++ DR) [=] dom D31) as Dom1.
         apply dom_permute...
        assert (dom D [=] dom (D2 ++ F2 ++ DR)) as Dom2.
         apply dom_permute...
        assert (x `notin` dom D).
         inversion Wflenv...
        simpl_env in *. fsetdec.

       assert (permute D31 (F2 ++ DR)) as Perm4.
        apply permute_sym. apply eq_lbinding_dec.
         assert (uniq (D2 ++ F2 ++ DR)) as Uniq3.
          simpl_env in Perm. apply uniq_env_permute with D...
         apply uniq_app_2 in Uniq3...
       auto.
       apply permute_cons...

      destruct b.
      apply lenv_split_right...
       inversion Wflenv...
       inversion Wflenv...
       inversion Wflenv...
Qed.

Lemma wf_lenv_env_permute : forall G D1 D2,
  wf_lenv G D1 ->
  permute D1 D2 ->
  wf_lenv G D2.
Proof with eauto.
  intros G D1 D2 Wflenv Perm.
  generalize dependent G.
  induction Perm; intros...
   assert (wf_lenv G (DL ++ DR)).
    apply IHPerm. rewrite_env ([(x, b)] ++ D ++ lempty) in Wflenv.
     eapply wf_lenv_lin_strengthening. eauto.
   destruct b. apply wf_lenv_lin_weakening...
    inversion Wflenv... inversion Wflenv...
    apply dom_permute in Perm. rewrite <- Perm.
    inversion Wflenv...
Qed.

Lemma permute_union : forall D0 D1 D2 D3 D21 D32 : denv,
  uniq D1 ->
  permute D1 (D3 ++ D0) ->
  permute D1 (D2 ++ D21) ->
  permute D2 (D3 ++ D32) ->
  permute D0 (D32 ++ D21).
Proof with eauto.
  intros D0 D1 D2 D3 D21 D32 Uniq Perm1 Perm2 Perm3.
  assert (permute D1 ((D3 ++ D32) ++ D21)) as Perm4.
   apply perm_subst_1 with D2...
  simpl_env in *.
  assert (permute (D3 ++ D0) D1) as Perm5.
   apply permute_sym.
    intros x0 y. decide equality.
    remember (beq_typ b t) as e.
    destruct e.
    apply sym_eq in Heqe.
    apply beq_typ_iff_eq in Heqe; subst...
    right. unfold not. intros contra.
    apply beq_typ_iff_eq in contra. rewrite contra in Heqe. inversion Heqe.
    auto. auto.
  assert (permute (D3 ++ D0) (D3 ++ D32 ++ D21)) as Perm6.
   eapply perm_trans.
    apply uniq_env_permute with D1... eauto.
    auto. auto.

  apply perm_strengthening_1 with D3...
   apply uniq_env_permute with D1...
Qed.

Lemma app_case_lemma : forall G D0 D1 D2 D3 D32 D21,
  wf_lenv G D1 ->
  permute D1 (D3 ++ D0) ->
  permute D1 (D2 ++ D21) ->
  permute D2 (D3 ++ D32) ->
  exists D11, exists D12,
    permute D1 (D2 ++ D11) /\
    permute D2 (D3 ++ D12) /\
    lenv_split G D12 D11 D0.
Proof with eauto.
  intros G D0 D1 D2 D3 D32 D21 Wflenv Perm1 Perm2 Perm3.
  assert (permute (from_lenv_to_denv D0) (from_lenv_to_denv D32 ++ from_lenv_to_denv D21)) as PermD0.
   apply permute_union with  (from_lenv_to_denv D1) (from_lenv_to_denv D2) (from_lenv_to_denv D3).
    assert (uniq D1).
     apply uniq_from_wf_lenv with G...
      apply uniq_lenv_compl...
   rewrite <- lenv_to_denv_conc.
   apply perm_lenv_to_denv_2...
   rewrite <-lenv_to_denv_conc.
   apply perm_lenv_to_denv_2...
    rewrite <-lenv_to_denv_conc.
   apply perm_lenv_to_denv_2...
   rewrite <- lenv_to_denv_conc in PermD0.
   apply perm_lenv_to_denv in PermD0.
   assert (exists D22,
            exists D33,
              permute D32 D22 /\
              permute D21 D33 /\
              lenv_split G D22 D33 D0) as HE.
     apply perm_to_lenv_split...
      assert (wf_lenv G (D3 ++ D0)) as Wf2.
       apply wf_lenv_env_permute with D1...
      rewrite_env (D3 ++ D0 ++ lempty) in Wf2.
       eapply wf_lenv_lin_strengthening. eauto.
  destruct HE as [D22 [D33 [Perm4 [Perm5 LSplit]]]].
  exists D33. exists D22.
  repeat split...
   assert (permute (from_lenv_to_denv D1) (from_lenv_to_denv D2 ++ from_lenv_to_denv D33)) as Perm6.
    apply perm_subst_2 with (from_lenv_to_denv D21).
     apply uniq_lenv_compl. apply uniq_from_wf_lenv with G...
     rewrite <- lenv_to_denv_conc.
     apply perm_lenv_to_denv_2...
     apply perm_lenv_to_denv_2...
   rewrite <- lenv_to_denv_conc in Perm6.
    apply perm_lenv_to_denv...
   assert (permute (from_lenv_to_denv D2) (from_lenv_to_denv D3 ++ from_lenv_to_denv D22)) as Perm6.
    apply perm_subst_2 with (from_lenv_to_denv D32).
     apply uniq_lenv_compl. apply uniq_from_wf_lenv with G...
      assert (wf_lenv G (D2 ++ D21)) as Wf1.
       apply wf_lenv_env_permute with D1...
      rewrite_env (lempty ++ D2 ++ D21) in Wf1.
      eapply wf_lenv_lin_strengthening. eauto.
     rewrite <- lenv_to_denv_conc.
     apply perm_lenv_to_denv_2...
     apply perm_lenv_to_denv_2...
   rewrite <- lenv_to_denv_conc in Perm6.
    apply perm_lenv_to_denv...
Qed.

Lemma dempty_implies_dempty : forall D1 D2,
 dempty = D1 ++ D2 ->
 D1 = dempty /\ D2 = dempty.
Proof with eauto.
  intros. destruct D1; destruct D2...
  inversion H... inversion H.
Qed.

Lemma perm_comm_right : forall D1 D2 D3 : denv,
  uniq D1 ->
  permute D1 (D2 ++ D3) ->
  permute D1 (D3 ++ D2).
Proof with eauto.
  intros D1 D2 D3 Uniq Perm.
  remember (D2 ++ D3) as e.
  remember D1 as e'.
  generalize dependent D2.
  generalize dependent D3.
  generalize dependent D1.
  induction Perm; intros; subst...
   apply dempty_implies_dempty in Heqe.
    destruct Heqe; subst... simpl_env. apply permute_empty.

   assert (
   (exists F1, D2 = DL ++ [(x, b)] ++ F1 /\ DR = F1 ++ D3) \/
   (exists F2, DL = D2 ++ F2 /\ D3 = F2 ++ [(x, b)] ++ DR)) as Mid.
    apply uniq_eq_mid...
  intros x0 y. decide equality.
  remember (beq_typ b0 t) as e.
  destruct e.
   apply sym_eq in Heqe0.
   apply beq_typ_iff_eq in Heqe0; subst...
   right. unfold not. intros contra.
    apply beq_typ_iff_eq in contra. rewrite contra in Heqe0. inversion Heqe0.
  assert (x `notin` dom D). inversion Uniq...
    assert (dom D [=] dom (DL ++ DR)).
      apply dom_permute...
    rewrite H0 in H. simpl_env in *.
  apply uniq_insert_mid.
   apply uniq_env_permute with D. inversion Uniq... auto.
   fsetdec. fsetdec.

  destruct Mid.
   destruct H as [F1 [EQ1 EQ2]].
    subst.
    assert (permute D (D3 ++ DL ++ F1)) as Perm1.
     apply IHPerm with D... inversion Uniq...
     rewrite_env ((D3 ++ DL) ++ [(x, b)] ++ F1).
     rewrite_env ((D3 ++ DL) ++ F1) in Perm1.
     apply permute_cons...
   destruct H as [F2 [EQ1 EQ2]].
    subst. simpl_env in *.
    assert (permute D ( (F2 ++ DR) ++ D2)) as Perm1.
     apply IHPerm with D... inversion Uniq...
     rewrite_env ((F2 ++ DR ++ D2)) in Perm1.
     apply permute_cons...
Qed.

Lemma atyping_denv_ex_eq : forall G D1 e T D2,
  atyping G D1 e T D2 ->
  exists D, permute D1 (D2 ++ D).
Proof with eauto.
  intros G D1 e T D2 ATyping.
  remember (<# D2 #>) as e2.
  remember (<# D1 #>) as e1.
  assert (e2 <<= e1) as Mono.
   subst. eapply denv_mono. eauto.

  assert (((e1 -- e2) |_| e2) ~~ e1) as Eq.
   apply dmap_diff_union_refl...
  assert (wf_genv G  /\ wf_denv G D1 /\ wf_denv G D2 /\ (exists K, wf_atyp G T K) /\ expr e) as H.
   apply atyping_regular... destruct H as [Wfg [Wfd1 [Wfd2 EX]]].
  assert (uniq D1) as Uniq1.
   apply uniq_from_wf_denv_lin with G...
  assert (uniq D2) as Uniq2.
   apply uniq_from_wf_denv_lin with G...
  assert (<# <@ (<#D1#> -- <#D2#>) @> ++ D2 #> ~~ (<# <@ (<#D1#> -- <#D2#>) @> #> |_| <#D2#>)) as Eq2.
   apply disjoint_denv_cons_union.
    apply uniq_app_4...
     apply dmap_to_denv_is_uniq.
     apply dmap_denv_disjoint.
     assert (<# D1 #> -- <# D2 #> ~~ <# <@<# D1 #> -- <# D2 #>@> #>) as Eq3.
      apply denv_to_from_dmap.
     apply dmap_Equal_preserves_disjoint_left with (<# D1 #> -- <# D2 #>)...
     apply diff_disjoint.
     apply Equal_sym...
   subst.
   assert (<# <@ <# D1 #> -- <# D2 #> @> ++ D2 #> ~~ <# D1 #>) as Eq3.
    eapply Equal_trans. eauto.
    apply Equal_sym in Eq. apply Equal_sym.
    apply dmap_Equal_rewrite_Union_left with (<# D1 #> -- <# D2 #>).
    apply denv_to_from_dmap. auto.
   apply Equal_sym in Eq3.
   assert (permute D1 (<@ <# D1 #> -- <# D2 #> @> ++ D2)) as Perm.
    apply eq_uniq_implies_perm...
     apply uniq_app_4...
      apply dmap_to_denv_is_uniq.
      apply dmap_denv_disjoint.
      assert (<# D1 #> -- <# D2 #> ~~ <# <@<# D1 #> -- <# D2 #>@> #>) as Eq4.
      apply denv_to_from_dmap.
     apply dmap_Equal_preserves_disjoint_left with (<# D1 #> -- <# D2 #>)...
     apply diff_disjoint.
     apply Equal_sym...
   exists (<@ <# D1 #> -- <# D2 #> @>).
   apply perm_comm_right...
Qed.

Lemma wf_lenv_permute : forall G D1 D2,
  wf_lenv G D1 ->
  permute D1 D2 ->
  wf_lenv G D2.
Proof with eauto.
  intros G D1 D2 Wfl Perm.
  generalize dependent D2.
  induction Wfl; intros...
   inversion Perm; subst...
   inversion Perm; subst...
   assert (wf_lenv E (DL ++ DR)) as Hwfl.
    apply IHWfl...
   apply wf_lenv_lin_weakening...
   assert (dom D [=] dom (DL ++ DR)).
    apply dom_permute... rewrite <- H2...
Qed.

Lemma wf_denv_sound : forall G D,
  wf_denv G D ->
  wf_lenv (from_genv_to_env G) (from_denv_to_lenv D).
Proof with eauto.
  intros G D Wfd.
  induction Wfd; intros; subst...
   simpl. apply wf_genv_sound in H.
   apply wf_lenv_empty...

   assert (permute ([(x, T)] ++ D) D') as Perm.
    apply eq_uniq_implies_perm...
     assert (uniq D).
      apply uniq_from_wf_denv_lin with G...
      solve_uniq.
   assert (wf_lenv (from_genv_to_env G) (from_denv_to_lenv ([(x, T)] ++ D))) as Wfl.
    simpl. simpl_env. apply wf_lenv_typ...
     rewrite <- dom_G_remain...
     rewrite <- dom_D_remain...
     apply wf_atyp_sound in H. destruct K...
   eapply wf_lenv_permute. eauto.
   apply perm_denv_to_lenv_2...
Qed.

Theorem Soundness : forall G D3 e T D2 D1,
  atyping G D3 e T D2 ->
  permute D3 (D2 ++ D1) ->
  typing (from_genv_to_env G) (from_denv_to_lenv D1) e T
 .
Proof with eauto.
  intros G D3 e T D2 D1 ATyp Perm.

  remember G as GG. remember D3 as DD3. remember e as ee. remember T as TT. remember D2 as DD2.
  generalize dependent G.
  generalize dependent D3.
  generalize dependent e.
  generalize dependent T.
  generalize dependent D2.
  generalize dependent D1.
  (atyping_cases (induction ATyp) Case); intros; subst; simpl_env in *.
  Case "atyping_uvar".
   assert (D1 = dempty).
    apply perm_dempty with D2...
     apply uniq_from_wf_denv_lin with G0...
   subst; simpl.
   apply typing_var...
   apply wf_genv_sound... apply wf_genv_from_wf_denv with D3...
   apply binds_typ_sound... auto.
  Case "atyping_lvar".
   assert (<# D3 #> ~~ <# D2 ++ [(x, T0)] #>).
    apply lvar_case_lemma1...
   apply uniq_from_wf_denv_lin with G0...
   assert (x `notin` dom D2) as xNotinD2.
    assert (~ EMap.In x (<# D3 #>[-]x)) as H4.
      apply dmap_remove_clear.
     apply notIn_implies_notin_dom in H4.
     assert (x `notin` dom <@ <# D3 #>[-]x @> <-> x `notin` dom D2) as H5.
      apply denv_equal_notin_dom_iff. unfold denv_Equal.
      eapply Equal_trans. apply Equal_sym. apply denv_to_from_dmap.
       auto.
    apply H5 in H4. solve_uniq.
   assert (D1 = [(x, T0)]) as HD1.
    eapply lvar_case_lemma2.
     eauto. auto. eapply uniq_from_wf_denv_lin. eauto.
     solve_uniq.
     auto.
     auto.

   subst. simpl.
   apply typing_lvar.
    rewrite_env ([(x, lbind_typ T0)] ++ lempty). apply wf_lenv_typ.
    apply wf_lenv_empty. apply wf_genv_sound.
     eapply wf_genv_from_wf_denv. eauto.
     rewrite <- dom_G_remain. eapply denv_dom_dinv. eauto.
      apply binds_In with T0... auto.
    apply wf_atyp_sound.
     destruct (wf_atyp_from_dbinds_typ x T0 G0 D3 H0 H) as [K WfAtyp].
      destruct K...
       eapply wf_atyp_sub. eauto. auto.

  Case "atyping_uabs".
   assert (wf_typ (from_genv_to_env G0) V kn_nonlin) as Wftyp.
    apply wf_atyp_sound...
   pick fresh x.
   assert ( atyping ([(x, gbind_typ V)] ++ G0) D3 (open_ee e1 x) T1 D2) as ATyping...
   apply atyping_regular in ATyping.
   destruct ATyping as [WfG [WfD3 [WfD2 [Wfatyp Expr]]]].
   assert (uniq D3) as Uniq3.
    apply uniq_from_wf_denv_lin with ([(x, gbind_typ V)] ++ G0)...
   assert (uniq D2) as Uniq2.
    apply uniq_from_wf_denv_lin with ([(x, gbind_typ V)] ++ G0)...

   assert (typing (from_genv_to_env ([(x, gbind_typ V)] ++ G0))
         (from_denv_to_lenv D1) (open_ee e1 x) T1) as Typing.
    apply H1 with D2 T1 (open_ee e1 x) D3 ([(x, gbind_typ V)] ++ G0)...
    (* simpl. rewrite_env (empty ++ [(x, bind_typ V)] ++ from_genv_to_env G0).
    apply lenv_split_weakening...
     simpl_env. rewrite_env (from_genv_to_env ([(x, gbind_typ V)] ++ G0)).
      apply wf_genv_sound...
      apply disjoint_one_2.
       rewrite <- dom_D_remain. auto. *)

   assert (D3 ~~~ D2 -> D1 = dempty) as H3.
    intros EQD3D2.
    eapply eq_uniq_perm_dempty.
     eauto. auto. auto. auto.
   assert (K = kn_nonlin -> D1 = dempty) as Imp.
    intros KEq.
    apply H2 in KEq.
    apply H3. auto.
   apply typing_abs with (union L
                 (union (fv_te e1)
                    (union (fv_ee e1)
                       (union (fv_tt V)
                          (union (fv_tt T1)
                             (union (dom G0)
                                (union (dom D1)
                                   (union (dom D2)
                                      (union (dom D3)
                                         (union (denv_fv_tt D1)
                                            (union
                                               (denv_fv_tt D2)
                                               (union
                                                  (denv_fv_tt D3)
                                                  (genv_fv_tt G0)))))))))))))...
    simpl in H1.
    intros x0 NotinL.
    rewrite_env ((x0, bind_typ V) :: (from_genv_to_env G0)).
    eapply H1.
     auto.
    (* simpl. rewrite_env (empty ++ [(x0, bind_typ V)] ++ from_genv_to_env G0).
    apply lenv_split_weakening...
     simpl_env. rewrite_env (from_genv_to_env ([(x0, gbind_typ V)] ++ G0)).
      apply wf_genv_sound... assert (atyping ([(x0, gbind_typ V)] ++ G0) D3 (open_ee e1 x0) T1 D2)...
      apply disjoint_one_2.
       rewrite <- dom_D_remain. auto.*) auto. eauto. eauto. eauto. eauto. eauto.
    intros Keq.
     apply Imp in Keq. subst...

  Case "atyping_labs".
   assert (wf_typ (from_genv_to_env G0) V Q) as Wftyp.
    apply wf_atyp_sound...

   pick fresh x.
   assert ( atyping G0 ([(x, V)] ++ D3) (open_ee e1 x) T1 D2) as ATyping...
   apply atyping_regular in ATyping.
   destruct ATyping as [WfG [WfD3 [WfD2 [Wfatyp Expr]]]].
   assert (uniq ([(x, V)] ++ D3)) as U3.
    apply uniq_from_wf_denv_lin with G0...
   assert (uniq D3) as Uniq3.
    inversion U3...
   assert (uniq D2) as Uniq2.
    apply uniq_from_wf_denv_lin with G0...
   assert (uniq (D2 ++ D1)) as Uniq12.
    apply uniq_env_permute with D3...

   assert (typing (from_genv_to_env G0)
         (from_denv_to_lenv ([(x, V)] ++ D1)) (open_ee e1 x) T1) as Typing.
    apply H1 with D2 T1 (open_ee e1 x) ([(x, V)] ++ D3) G0...
    (*simpl. simpl_env. apply lenv_split_right...
      rewrite <- dom_G_remain...
      rewrite <- dom_D_remain...
      destruct Q...*)

     assert (D3 ~~~ (D2 ++ D1)) as EQ.
      apply perm_uniq_implies_eq...
     assert (([(x, V)] ++ D3) ~~~ ([(x, V)] ++ D2 ++ D1)) as EQ2.
      apply denv_add_preserves_Equal...
     assert ( dempty ++ [(x, V)] ++ dempty ++ D2 ++ D1 ~~~
       dempty ++ D2 ++ dempty ++ [(x, V)] ++ D1) as EQ3.
      apply disjoint_denv_cons_commut_aux.
       simpl_env. rewrite_env((x, V) :: (D2 ++ D1)).
        apply uniq_cons...
     simpl_env in *.
     assert ([(x, V)] ++ D3 ~~~ D2 ++ [(x, V)] ++ D1) as EQ4.
      eapply Equal_trans. eauto. auto.
     apply eq_uniq_implies_perm...

   assert (D3 ~~~ D2 -> D1 = dempty) as H3.
    intros EQD3D2.
    eapply eq_uniq_perm_dempty.
     eauto. auto. auto. auto.
   assert (K = kn_nonlin -> D1 = dempty) as Imp.
    intros KEq.
    apply H2 in KEq.
    apply H3. auto.

   apply typing_labs with (union L
                 (union (fv_te e1)
                    (union (fv_ee e1)
                       (union (fv_tt V)
                          (union (fv_tt T1)
                             (union (dom G0)
                                (union (dom D1)
                                   (union (dom D2)
                                      (union (dom D3)
                                         (union (denv_fv_tt D1)
                                            (union
                                               (denv_fv_tt D2)
                                               (union
                                                  (denv_fv_tt D3)
                                                  (genv_fv_tt G0))))))))))))).
    destruct Q...
    intros x0 NotinL.
    rewrite_env (from_denv_to_lenv ([(x0, V)] ++ D1)).
    eapply H1.
     auto.
     (*simpl. simpl_env. apply lenv_split_right...
      rewrite <- dom_G_remain...
      rewrite <- dom_D_remain...
      destruct Q...*)
     assert (D3 ~~~ (D2 ++ D1)) as EQ.
      apply perm_uniq_implies_eq...
     assert (([(x0, V)] ++ D3) ~~~ ([(x0, V)] ++ D2 ++ D1)) as EQ2.
      apply denv_add_preserves_Equal...
     assert ( dempty ++ [(x0, V)] ++ dempty ++ D2 ++ D1 ~~~
       dempty ++ D2 ++ dempty ++ [(x0, V)] ++ D1) as EQ3.
      apply disjoint_denv_cons_commut_aux.
       simpl_env. rewrite_env((x0, V) :: (D2 ++ D1)).
        apply uniq_cons...

     simpl_env in *.
     assert ([(x0, V)] ++ D3 ~~~ D2 ++ [(x0, V)] ++ D1) as EQ4.
      eapply Equal_trans. eauto. auto.

     apply eq_uniq_implies_perm...
     auto. eauto. eauto. eauto. eauto.
    intros Keq.
     apply Imp in Keq. subst...
  Case "atyping_app".
   rename D5 into D1. rename D4 into D3.
   (*remember (from_genv_to_env G0) as g0.
   remember (from_denv_to_lenv D1) as d1.
   remember (from_denv_to_lenv D2) as d2.
   remember (from_denv_to_lenv D3) as d3.
   remember (from_denv_to_lenv D0) as d0.*)
   assert (exists D, permute D1 (D2 ++ D)) as EX1.
    eapply atyping_denv_ex_eq. apply ATyp1.
   assert (exists D, permute D2 (D3 ++ D)) as EX2.
    eapply atyping_denv_ex_eq. apply ATyp2.
   destruct EX1 as [D21 Perm1].
   destruct EX2 as [D32 Perm2].
   assert (exists D11, exists D12,
        permute (from_denv_to_lenv D1) ((from_denv_to_lenv D2) ++ D11) /\
        permute (from_denv_to_lenv D2) ((from_denv_to_lenv D3) ++ D12) /\
        lenv_split (from_genv_to_env G0)  D12 D11 (from_denv_to_lenv D0)) as HApp.
    apply app_case_lemma with (from_denv_to_lenv D32) (from_denv_to_lenv D21)...
    apply wf_denv_sound...
    rewrite <- denv_to_lenv_conc.
     apply perm_denv_to_lenv_2...
    rewrite <- denv_to_lenv_conc.
     apply perm_denv_to_lenv_2...
    rewrite <- denv_to_lenv_conc.
     apply perm_denv_to_lenv_2...
   destruct HApp as [D11 [D12 [Perm3 [Perm4 Lsplit]]]].
   assert (D11 = from_denv_to_lenv (from_lenv_to_denv D11)) as EQ1.
    apply lenv_refl.
   assert (D12 =  from_denv_to_lenv (from_lenv_to_denv D12) ) as EQ2.
    apply lenv_refl.
   rewrite EQ1 in Perm3. rewrite EQ2 in Perm4.
   rewrite <- denv_to_lenv_conc in Perm3.
   rewrite <- denv_to_lenv_conc in Perm4.
   apply perm_denv_to_lenv in Perm3.
   apply perm_denv_to_lenv in Perm4.
   assert (typing (from_genv_to_env G0) (from_denv_to_lenv (from_lenv_to_denv D11)) e1 (typ_arrow K T1 T)) as typing1.
    eapply IHATyp1...
   assert (typing (from_genv_to_env G0)
              (from_denv_to_lenv (from_lenv_to_denv D12)) e2 T1) as typing2.
     eapply IHATyp2...
   rewrite <- lenv_refl in typing1.
   rewrite <- lenv_refl in typing2.
   eapply typing_app... apply lenv_split_commute...
  Case "atyping_tabs".
   apply typing_tabs with L...
    intros X Notin. simpl in H1.
    rewrite_env ((X, bind_kn K) :: from_genv_to_env G0).
    eapply H1...
  Case "atyping_tapp".
   apply typing_tapp with K...
    apply wf_atyp_sound in H.
    destruct K';
     destruct K;
      try(inversion H0)...
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(************************************************************************)
(*                                                                      *)
(*                          Lift.v                                      *)
(*                                                                      *)
(*    Laurent.Thery @sophia.inria.fr        March 2002                  *)
(************************************************************************)
(** * Lift Quantifiers *)
Require Export Form.

Inductive prenex : form -> Prop :=
  | pExists : forall a : form, prenex a -> prenex (Exists a)
  | pForall : forall a : form, prenex a -> prenex (Forall a)
  | pNoBinder : forall a : form, noBinder a -> prenex a.
Hint Constructors prenex.

(** * Lift If
  - [((x:?)(P x) -> Q)] gives [(Ex [x:?] ((P x) -> Q)) )]
  - [(Ex [x:?](P x) -> Q)] gives [(x:?) ((P x) -> Q) )]
  - [Q->(x:?)(P x)] gives [(x:?) Q-> (P x)]
  - [Q->(Ex[x:?](P x)] gives [(Ex [x:?] Q->(P x)]
 *)
Fixpoint lift_if1 (n m : nat) (f1 f2 : form) {struct f2} : form :=
  match f2 with
  | Forall b => Forall (lift_if1 n (S m) f1 b)
  | Exists b => Exists (lift_if1 n (S m) f1 b)
  | _ => Imp (shiftForm n m m f1) (shiftForm m 0 n f2)
  end.

Fixpoint lift_if2 (n : nat) (f1 : form) {struct f1} :
 form -> form :=
  fun f2 : form =>
  match f1 with
  | Forall b => Exists (lift_if2 (S n) b f2)
  | Exists b => Forall (lift_if2 (S n) b f2)
  | _ => lift_if1 n 0 f1 f2
  end.

Definition lift_if (f1 f2 : form) := lift_if2 0 f1 f2.

Theorem noBinder_shift :
 forall (f : form) (th i o : nat),
 noBinder f -> noBinder (shiftForm th i o f).
intros f th i o H; generalize th i o; elim H; simpl in |- *; auto.
Qed.
Hint Resolve noBinder_shift.

Theorem lift_if1_noBinder :
 forall (n m : nat) (f1 f2 : form),
 noBinder f2 ->
 lift_if1 n m f1 f2 = Imp (shiftForm n m m f1) (shiftForm m 0 n f2).
intros n m f1 f2 H; elim H; simpl in |- *; auto.
Qed.

Theorem lift_if1_prenex :
 forall (n m : nat) (f1 f2 : form),
 noBinder f1 -> prenex f2 -> prenex (lift_if1 n m f1 f2).
intros n m f1 f2 H1 H2; generalize n m; elim H2; simpl in |- *; auto.
intros a H3; elim H3; simpl in |- *; auto.
Qed.
Hint Resolve lift_if1_prenex.
Require Import GroundN.
Require Import ArithRing.
Require Import Max.

Theorem lift_if1_groundN :
 forall f1 f2 n m p,
 prenex f2 ->
 noBinder f1 ->
 groundNForm (p + n) f1 ->
 groundNForm (p + m) f2 -> groundNForm (p + (m + n)) (lift_if1 n m f1 f2).
intros f1 f2 n m p H H1; generalize m p; elim H; clear H m p;
 unfold lift_if1 in |- *; lazy beta in |- *; fold lift_if1 in |- *;
 auto.
intros a H H0 m p H2 H3.
apply GNExists; auto.
replace (S (p + (m + n))) with (p + (S m + n)).
apply H0; auto.
replace (p + S m) with (S (p + m)).
inversion H3; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
intros a H H0 m p H2 H3.
apply GNForall; auto.
replace (S (p + (m + n))) with (p + (S m + n)).
apply H0; auto.
replace (p + S m) with (S (p + m)).
inversion H3; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
intros a H; elim H; unfold lift_if1 in |- *; lazy beta in |- *;
 fold lift_if1 in |- *; auto; intros;
 apply GNImp with (n := p + (m + n)) (m := p + (m + n));
 auto with arith;
 try
  (replace (p + (m + n)) with (max (n + m) (p + n + m));
    [ apply shiftForm_groundN; auto
    | replace (p + (m + n)) with (p + n + m); auto with arith; ring ]);
 try
  (replace (p + (m + n)) with (max (m + 0) (p + m + n));
    [ apply shiftForm_groundN; auto; replace (p + (m + n)) with (m + (p + n));
       auto with arith
    | ring_simplify; rewrite plus_comm; auto with arith]);
 try (replace (p + m + n) with (m + (n + p)); auto with arith; try ring).
Qed.

Theorem lift_if2_prenex :
 forall (n : nat) (f1 f2 : form),
 prenex f1 -> prenex f2 -> prenex (lift_if2 n f1 f2).
intros n f1 f2 H; generalize n f2; elim H; simpl in |- *; clear n f2 H; auto.
intros a H; elim H; clear H a; simpl in |- *; auto.
Qed.
Hint Resolve lift_if2_prenex.

Theorem lift_if2_groundN :
 forall f1 f2 n p,
 prenex f1 ->
 prenex f2 ->
 groundNForm (p + n) f1 ->
 groundNForm p f2 -> groundNForm (p + n) (lift_if2 n f1 f2).
intros f1 f2 n p H H1; generalize n p; elim H; clear H n p;
 unfold lift_if2 in |- *; lazy beta in |- *; fold lift_if2 in |- *.
intros a H0 H2 n p H3 H4.
apply GNForall; auto.
replace (S (p + n)) with (p + S n); auto with arith.
apply H2; auto.
replace (p + S n) with (S (p + n)); auto with arith.
inversion H3; auto.
intros a H0 H2 n p H3 H4.
apply GNExists; auto.
replace (S (p + n)) with (p + S n); auto with arith.
apply H2; auto.
replace (p + S n) with (S (p + n)); auto with arith.
inversion H3; auto.
intros a H; elim H; unfold lift_if2 in |- *; lazy beta in |- *;
 fold lift_if2 in |- *; auto; intros; replace (p + n) with (p + (0 + n));
 try apply lift_if1_groundN; auto with arith; rewrite plus_comm;
 simpl in |- *; auto.
Qed.

Theorem lift_if_prenex :
 forall f1 f2 : form, prenex f1 -> prenex f2 -> prenex (lift_if f1 f2).
intros; unfold lift_if in |- *; auto.
Qed.
Hint Resolve lift_if_prenex.

Theorem lift_if_groundN :
 forall f1 f2 p,
 prenex f1 ->
 prenex f2 ->
 groundNForm p f1 -> groundNForm p f2 -> groundNForm p (lift_if f1 f2).
intros f1 f2 p H H0 H1 H2; unfold lift_if in |- *.
replace p with (p + 0); auto with arith.
apply lift_if2_groundN; auto with arith; rewrite plus_comm; simpl in |- *;
 auto with arith.
Qed.

Definition iso_list (th i o : nat) (l1 l2 : list Z) :=
  forall n : nat,
  (n < th -> nth n l1 0%Z = nth (n + i) l2 0%Z) /\
  (th <= n -> nth n l1 0%Z = nth (n + o) l2 0%Z).

Theorem iso_shiftExp :
 forall (l1 l2 : list Z) (th i o : nat),
 iso_list th i o l1 l2 ->
 forall e : exp, exp2Z l1 e = exp2Z l2 (shiftExp th i o e).
intros l1 l2 th i o H e; elim e; simpl in |- *; auto.
intros n; generalize (H n); generalize (ltdec_correct n th);
 case (ltdec n th); intros H1 H2; case H2; auto.
intros e0 H0 e1 H1; rewrite H0; rewrite H1; auto.
Qed.
Hint Resolve iso_shiftExp.

Theorem iso_shiftForm :
 forall (th i o : nat) (l1 l2 : list Z),
 iso_list th i o l1 l2 ->
 forall f : form,
 noBinder f -> (form2Prop l1 f <-> form2Prop l2 (shiftForm th i o f)).
intros th i o l1 l2 H f H0; elim H0; simpl in |- *; auto; intros;
 repeat rewrite <- (iso_shiftExp l1); intuition; auto.
Qed.

Definition iso_list3 (n m : nat) (l1 l2 l3 : list Z) :=
  forall p : nat,
  ((p < m -> nth p l3 0%Z = nth p l2 0%Z) /\
   (m <= p -> nth (p + n) l3 0%Z = nth p l2 0%Z)) /\
  nth (p + m) l3 0%Z = nth p l1 0%Z.

Theorem iso_iso3_1 :
 forall l1 l2 l3 n m, iso_list3 n m l1 l2 l3 -> iso_list n m m l1 l3.
intros l1 l2 l3 n m H; red in |- *; intros p.
case (H p); intros H0 H1; intuition.
Qed.

Theorem iso_iso3_2 :
 forall l1 l2 l3 n m, iso_list3 n m l1 l2 l3 -> iso_list m 0 n l2 l3.
intros l1 l2 l3 n m H; red in |- *; intros p.
case (H p); intros H0 H1; rewrite plus_comm; simpl in |- *; intuition.
Qed.

Theorem iso3_1 :
 forall (n m : nat) (x : Z) l1 l2 l3,
 iso_list3 n m l1 l2 l3 -> iso_list3 n (S m) l1 (x :: l2) (x :: l3).
intros n m x l1 l2 l3 H; red in |- *; intros p; repeat split; try intros H1.
generalize H1; clear H1; case p; simpl in |- *; auto.
intros p' H1.
cut (p' < m); [ intros H2 | apply lt_S_n; auto ].
case (H p'); intros (H3, H4) H5; auto.
generalize H1; clear H1; case p; simpl in |- *; auto.
intros H1; inversion H1.
intros p' H1.
cut (m <= p'); [ intros H2 | apply le_S_n; auto ].
case (H p'); intros (H3, H4) H5; auto.
replace (p + S m) with (S (p + m)); simpl in |- *; [ idtac | auto ].
case (H p); intros (H3, H4) H5; auto.
Qed.
Hint Resolve iso3_1.

Theorem iso_lift_i1 :
 forall f1 f2 : form,
 noBinder f1 ->
 prenex f2 ->
 forall (n m : nat) (l1 l2 l3 : list Z),
 iso_list3 n m l1 l2 l3 ->
 ((form2Prop l1 f1 -> form2Prop l2 f2) <-> form2Prop l3 (lift_if1 n m f1 f2)).
intros f1 f2 H H0; elim H0.
simpl in |- *; intros a H1 H2 n m l1 l2 l3 H3; split.
intros H4.
case (classic (form2Prop l1 f1)); intros H5.
case (H4 H5); clear H4; intros x H4; exists x.
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
exists 0%Z.
case (H2 n (S m) l1 (0%Z :: l2) (0%Z :: l3)); auto.
intros H6 H7; apply H6; auto.
intros H8; case H5; auto.
intros H4 H5; case H4; clear H4; intros x H4; exists x.
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
simpl in |- *; intros a H1 H2 n m l1 l2 l3 H3; split.
intros H4 x.
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros H4 H5 x.
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros a H1 n m l1 l2 l3 H2.
rewrite lift_if1_noBinder; simpl in |- *; auto.
case (iso_shiftForm n m m l1 l3) with (f := f1); auto.
apply iso_iso3_1 with (l2 := l2); auto.
case (iso_shiftForm m 0 n l2 l3) with (f := a); auto.
apply iso_iso3_2 with (l1 := l1); auto.
intuition.
Qed.

Theorem iso3_2 :
 forall (n : nat) (x : Z) l1 l2 l3,
 iso_list3 n 0 l1 l2 l3 -> iso_list3 (S n) 0 (x :: l1) l2 (x :: l3).
intros n x l1 l2 l3 H; red in |- *; intros p; repeat split; try intros H1.
inversion H1.
replace (p + S n) with (S (p + n));
 [ simpl in |- * | repeat rewrite (plus_comm p); simpl in |- *; auto ].
case (H p); intros (H2, H3) H4; auto.
case p; simpl in |- *; auto.
intros p'; case (H p'); intros (H1, H2) H3; auto.
Qed.
Hint Resolve iso3_2.

Theorem iso_lift_i2 :
 forall f1 f2 : form,
 prenex f1 ->
 prenex f2 ->
 forall (n : nat) (l1 l2 l3 : list Z),
 iso_list3 n 0 l1 l2 l3 ->
 ((form2Prop l1 f1 -> form2Prop l2 f2) <-> form2Prop l3 (lift_if2 n f1 f2)).
intros f1 f2 H H1; elim H; clear H; simpl in |- *; auto.
intros a H H0 n l1 l2 l3 H2; split.
intros H3 x.
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros H4 H5; auto.
apply H4; auto.
intros H6; apply H3; exists x; auto.
intros H3 H4; case H4; clear H4; intros x H4.
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros a H H0 n l1 l2 l3 H2; split.
intros H3.
case (classic (forall x : Z, form2Prop (x :: l1) a)); intros H4.
exists 0%Z.
case (H0 (S n) (0%Z :: l1) l2 (0%Z :: l3)); auto.
case (classic (ex (fun x : Z => form2Prop (x :: l3) (lift_if2 (S n) a f2))));
 intros H5; auto.
elim H4; intros x.
case (classic (form2Prop (x :: l1) a)); intros H6; auto.
case H5; exists x.
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros H7 H8; apply H7; intros H9; case H6; auto.
intros H3 H4; case H3; clear H3; intros x H3.
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros a H; elim H; clear H; unfold lift_if2 in |- *; intros;
 apply iso_lift_i1; auto.
Qed.

Theorem correct_lift_if :
 forall f1 f2 : form,
 prenex f1 ->
 prenex f2 ->
 forall l : list Z,
 (form2Prop l f1 -> form2Prop l f2) <-> form2Prop l (lift_if f1 f2).
intros f1 f2 H H0 l; unfold lift_if in |- *; apply iso_lift_i2; auto.
red in |- *; repeat split; (repeat rewrite (plus_comm p); simpl in |- *);
 auto.
Qed.

(** * Lift And
  - [((x:?)(P x) /\ Q)] gives [(x:?) ((P x) /\ Q)) )]
  - [(Ex [x:?](P x) /\ Q)] gives [(Ex [x:?] ((P x) -> Q) )]
  - [Q/\(x:?)(P x)] gives [(x:?) Q/\ (P x)]
  - [Q/\(Ex[x:?](P x)] gives [(Ex [x:?] Q/\(P x)]
 *)

Fixpoint lift_andor1 (op : form -> form -> form) (n m : nat)
 (f1 f2 : form) {struct f2} : form :=
  match f2 with
  | Forall b => Forall (lift_andor1 op n (S m) f1 b)
  | Exists b => Exists (lift_andor1 op n (S m) f1 b)
  | _ => op (shiftForm n m m f1) (shiftForm m 0 n f2)
  end.

Fixpoint lift_andor2 (op : form -> form -> form) (n : nat)
 (f1 : form) {struct f1} : form -> form :=
  fun f2 : form =>
  match f1 with
  | Forall b => Forall (lift_andor2 op (S n) b f2)
  | Exists b => Exists (lift_andor2 op (S n) b f2)
  | _ => lift_andor1 op n 0 f1 f2
  end.

Definition lift_andor (op : form -> form -> form) (f1 f2 : form) :=
  lift_andor2 op 0 f1 f2.

Theorem lift_andor1_noBinder :
 forall op (n m : nat) (f1 f2 : form),
 noBinder f2 ->
 lift_andor1 op n m f1 f2 = op (shiftForm n m m f1) (shiftForm m 0 n f2).
intros op n m f1 f2 H; elim H; simpl in |- *; auto.
Qed.

Theorem lift_andor1_prenex :
 forall op,
 (forall f1 f2, noBinder f1 -> noBinder f2 -> noBinder (op f1 f2)) ->
 forall (n m : nat) (f1 f2 : form),
 noBinder f1 -> prenex f2 -> prenex (lift_andor1 op n m f1 f2).
intros op H n m f1 f2 H1 H2; generalize n m; elim H2; simpl in |- *; auto.
intros a H3; elim H3; simpl in |- *; auto.
Qed.
Hint Resolve lift_andor1_prenex.

Theorem lift_andor2_prenex :
 forall op,
 (forall f1 f2, noBinder f1 -> noBinder f2 -> noBinder (op f1 f2)) ->
 forall (n : nat) (f1 f2 : form),
 prenex f1 -> prenex f2 -> prenex (lift_andor2 op n f1 f2).
intros op Rec n f1 f2 H; generalize n f2; elim H; simpl in |- *; clear n f2 H;
 auto.
intros a H; elim H; clear H a; simpl in |- *; auto.
Qed.
Hint Resolve lift_andor2_prenex.

Theorem lift_andor_prenex :
 forall op,
 (forall f1 f2, noBinder f1 -> noBinder f2 -> noBinder (op f1 f2)) ->
 forall f1 f2 : form, prenex f1 -> prenex f2 -> prenex (lift_andor op f1 f2).
intros; unfold lift_andor in |- *; auto.
Qed.
Hint Resolve lift_andor_prenex.

Theorem lift_andor1_and_groundN :
 forall f1 f2 n m p,
 prenex f2 ->
 noBinder f1 ->
 groundNForm (p + n) f1 ->
 groundNForm (p + m) f2 ->
 groundNForm (p + (m + n)) (lift_andor1 ANd n m f1 f2).
intros f1 f2 n m p H H1; generalize m p; elim H; clear H m p;
 unfold lift_andor1 in |- *; lazy beta in |- *; fold lift_andor1 in |- *;
 auto.
intros a H H0 m p H2 H3.
apply GNExists; auto.
replace (S (p + (m + n))) with (p + (S m + n)).
apply H0; auto.
replace (p + S m) with (S (p + m)).
inversion H3; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
intros a H H0 m p H2 H3.
apply GNForall; auto.
replace (S (p + (m + n))) with (p + (S m + n)).
apply H0; auto.
replace (p + S m) with (S (p + m)).
inversion H3; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
intros a H; elim H; unfold lift_andor1 in |- *; lazy beta in |- *;
 fold lift_andor1 in |- *; auto; intros;
 apply GNAnd with (n := p + (m + n)) (m := p + (m + n));
 auto with arith;
 try
  (replace (p + (m + n)) with (max (n + m) (p + n + m));
    [ apply shiftForm_groundN; auto
    | replace (p + (m + n)) with (p + n + m); auto with arith; ring ]);
 try
  (replace (p + (m + n)) with (max (m + 0) (p + m + n));
    [ apply shiftForm_groundN; auto; replace (p + (m + n)) with (m + (p + n));
       auto with arith
    |  ring_simplify; rewrite plus_comm; auto with arith ]);
 try (replace (p + m + n) with (m + (n + p)); auto with arith; try ring).
Qed.

Theorem lift_andor1_or_groundN :
 forall f1 f2 n m p,
 prenex f2 ->
 noBinder f1 ->
 groundNForm (p + n) f1 ->
 groundNForm (p + m) f2 ->
 groundNForm (p + (m + n)) (lift_andor1 Or n m f1 f2).
intros f1 f2 n m p H H1; generalize m p; elim H; clear H m p;
 unfold lift_andor1 in |- *; lazy beta in |- *; fold lift_andor1 in |- *;
 auto.
intros a H H0 m p H2 H3.
apply GNExists; auto.
replace (S (p + (m + n))) with (p + (S m + n)).
apply H0; auto.
replace (p + S m) with (S (p + m)).
inversion H3; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
intros a H H0 m p H2 H3.
apply GNForall; auto.
replace (S (p + (m + n))) with (p + (S m + n)).
apply H0; auto.
replace (p + S m) with (S (p + m)).
inversion H3; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
repeat rewrite (plus_comm p); simpl in |- *; auto.
intros a H; elim H; unfold lift_andor1 in |- *; lazy beta in |- *;
 fold lift_andor1 in |- *; auto; intros;
 apply GNOr with (n := p + (m + n)) (m := p + (m + n));
 auto with arith;
 try
  (replace (p + (m + n)) with (max (n + m) (p + n + m));
    [ apply shiftForm_groundN; auto
    | replace (p + (m + n)) with (p + n + m); auto with arith; ring ]);
 try
  (replace (p + (m + n)) with (max (m + 0) (p + m + n));
    [ apply shiftForm_groundN; auto; replace (p + (m + n)) with (m + (p + n));
       auto with arith
    |  ring_simplify; rewrite plus_comm; auto with arith ]);
 try (replace (p + m + n) with (m + (n + p)); auto with arith; try ring).
Qed.

Theorem lift_andor2_and_groundN :
 forall f1 f2 n p,
 prenex f1 ->
 prenex f2 ->
 groundNForm (p + n) f1 ->
 groundNForm p f2 -> groundNForm (p + n) (lift_andor2 ANd n f1 f2).
intros f1 f2 n p H H1; generalize n p; elim H; clear H n p;
 unfold lift_andor2 in |- *; lazy beta in |- *; fold lift_andor2 in |- *.
intros a H0 H2 n p H3 H4.
apply GNExists; auto.
replace (S (p + n)) with (p + S n); auto with arith.
apply H2; auto.
replace (p + S n) with (S (p + n)); auto with arith.
inversion H3; auto.
intros a H0 H2 n p H3 H4.
apply GNForall; auto.
replace (S (p + n)) with (p + S n); auto with arith.
apply H2; auto.
replace (p + S n) with (S (p + n)); auto with arith.
inversion H3; auto.
intros a H; elim H; unfold lift_andor2 in |- *; lazy beta in |- *;
 fold lift_andor2 in |- *; auto; intros; replace (p + n) with (p + (0 + n));
 try apply lift_andor1_and_groundN; auto with arith;
 rewrite plus_comm; simpl in |- *; auto.
Qed.

Theorem lift_andor2_or_groundN :
 forall f1 f2 n p,
 prenex f1 ->
 prenex f2 ->
 groundNForm (p + n) f1 ->
 groundNForm p f2 -> groundNForm (p + n) (lift_andor2 Or n f1 f2).
intros f1 f2 n p H H1; generalize n p; elim H; clear H n p;
 unfold lift_andor2 in |- *; lazy beta in |- *; fold lift_andor2 in |- *.
intros a H0 H2 n p H3 H4.
apply GNExists; auto.
replace (S (p + n)) with (p + S n); auto with arith.
apply H2; auto.
replace (p + S n) with (S (p + n)); auto with arith.
inversion H3; auto.
intros a H0 H2 n p H3 H4.
apply GNForall; auto.
replace (S (p + n)) with (p + S n); auto with arith.
apply H2; auto.
replace (p + S n) with (S (p + n)); auto with arith.
inversion H3; auto.
intros a H; elim H; unfold lift_andor2 in |- *; lazy beta in |- *;
 fold lift_andor2 in |- *; auto; intros; replace (p + n) with (p + (0 + n));
 try apply lift_andor1_or_groundN; auto with arith;
 rewrite plus_comm; simpl in |- *; auto.
Qed.

Theorem lift_andor_and_groundN :
 forall f1 f2 p,
 prenex f1 ->
 prenex f2 ->
 groundNForm p f1 -> groundNForm p f2 -> groundNForm p (lift_andor ANd f1 f2).
intros f1 f2 p H H0 H1 H2; unfold lift_andor in |- *.
replace p with (p + 0); auto with arith.
apply lift_andor2_and_groundN; auto with arith; rewrite plus_comm;
 simpl in |- *; auto with arith.
Qed.

Theorem lift_andor_or_groundN :
 forall f1 f2 p,
 prenex f1 ->
 prenex f2 ->
 groundNForm p f1 -> groundNForm p f2 -> groundNForm p (lift_andor Or f1 f2).
intros f1 f2 p H H0 H1 H2; unfold lift_andor in |- *.
replace p with (p + 0); auto with arith.
apply lift_andor2_or_groundN; auto with arith; rewrite plus_comm;
 simpl in |- *; auto with arith.
Qed.

Theorem iso_lift_andor_and1 :
 forall f1 f2 : form,
 noBinder f1 ->
 prenex f2 ->
 forall (n m : nat) (l1 l2 l3 : list Z),
 iso_list3 n m l1 l2 l3 ->
 (form2Prop l1 f1 /\ form2Prop l2 f2 <->
  form2Prop l3 (lift_andor1 ANd n m f1 f2)).
intros f1 f2 H H0; elim H0.
simpl in |- *; intros a H1 H2 n m l1 l2 l3 H3; split.
intros (H4, (x, H5)); exists x.
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros (x, H4).
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros H5 H6; (split; [ idtac | exists x ]); case H6; auto.
simpl in |- *; intros a H1 H2 n m l1 l2 l3 H3; split.
intros (H4, H5) x.
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros H4; split.
case (H2 n (S m) l1 (0%Z :: l2) (0%Z :: l3)); auto.
intros H5 H6; case H6; auto.
intros x; case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros H5 H6; case H6; auto.
intros a H1 n m l1 l2 l3 H2.
rewrite lift_andor1_noBinder; simpl in |- *; auto.
case (iso_shiftForm n m m l1 l3) with (f := f1); auto.
apply iso_iso3_1 with (l2 := l2); auto.
case (iso_shiftForm m 0 n l2 l3) with (f := a); auto.
apply iso_iso3_2 with (l1 := l1); auto.
intuition.
Qed.

Theorem iso_lift_andor_or1 :
 forall f1 f2 : form,
 noBinder f1 ->
 prenex f2 ->
 forall (n m : nat) (l1 l2 l3 : list Z),
 iso_list3 n m l1 l2 l3 ->
 (form2Prop l1 f1 \/ form2Prop l2 f2 <->
  form2Prop l3 (lift_andor1 Or n m f1 f2)).
intros f1 f2 H H0; elim H0.
simpl in |- *; intros a H1 H2 n m l1 l2 l3 H3; split.
intros [H4| (x, H4)].
case (H2 n (S m) l1 (0%Z :: l2) (0%Z :: l3)); auto.
intros H5 H6; exists 0%Z; auto.
exists x.
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros (x, H4).
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros H5 H6; case H6; auto; intros H7.
right; exists x; auto.
simpl in |- *; intros a H1 H2 n m l1 l2 l3 H3; split.
intros [H4| H4] x; case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros H4; case (classic (form2Prop l1 f1)); intros H5; auto.
right; intros x.
case (H2 n (S m) l1 (x :: l2) (x :: l3)); auto.
intros H6 H7; case H7; auto.
intros H8; case H5; auto.
intros a H1 n m l1 l2 l3 H2.
rewrite lift_andor1_noBinder; simpl in |- *; auto.
case (iso_shiftForm n m m l1 l3) with (f := f1); auto.
apply iso_iso3_1 with (l2 := l2); auto.
case (iso_shiftForm m 0 n l2 l3) with (f := a); auto.
apply iso_iso3_2 with (l1 := l1); auto.
intuition.
Qed.

Theorem iso_lift_andor_and2 :
 forall f1 f2 : form,
 prenex f1 ->
 prenex f2 ->
 forall (n : nat) (l1 l2 l3 : list Z),
 iso_list3 n 0 l1 l2 l3 ->
 (form2Prop l1 f1 /\ form2Prop l2 f2 <->
  form2Prop l3 (lift_andor2 ANd n f1 f2)).
intros f1 f2 H H1; elim H; clear H; simpl in |- *; auto.
intros a H H0 n l1 l2 l3 H2; split.
intros ((x, H3), H4); exists x.
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros (x, H3); split; [ exists x | idtac ].
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros H4 H5; case H5; auto.
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros H4 H5; case H5; auto.
intros a H H0 n l1 l2 l3 H2; split.
intros (H3, H4) x.
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros H3; (split; [ intros | idtac ]).
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros H4 H5; case H5; auto.
case (H0 (S n) (0%Z :: l1) l2 (0%Z :: l3)); auto.
intros H4 H5; case H5; auto.
intros a H; elim H; clear H; unfold lift_andor2 in |- *; intros;
 apply iso_lift_andor_and1; auto.
Qed.

Theorem iso_lift_andor_or2 :
 forall f1 f2 : form,
 prenex f1 ->
 prenex f2 ->
 forall (n : nat) (l1 l2 l3 : list Z),
 iso_list3 n 0 l1 l2 l3 ->
 (form2Prop l1 f1 \/ form2Prop l2 f2 <->
  form2Prop l3 (lift_andor2 Or n f1 f2)).
intros f1 f2 H H1; elim H; clear H; simpl in |- *; auto.
intros a H H0 n l1 l2 l3 H2; split.
intros [(x, H3)| H4]; [ exists x | exists 0%Z ].
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
case (H0 (S n) (0%Z :: l1) l2 (0%Z :: l3)); auto.
intros (x, H3).
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros H4 H5; case H5; auto.
intros H6; left; exists x; auto.
intros a H H0 n l1 l2 l3 H2; split.
intros [H3| H3] x; case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros H3; case (classic (form2Prop l2 f2)); auto; left; intros x.
case (H0 (S n) (x :: l1) l2 (x :: l3)); auto.
intros H5 H6; case H6; auto.
intros H7; case H4; auto.
intros a H; elim H; clear H; unfold lift_andor2 in |- *; intros;
 apply iso_lift_andor_or1; auto.
Qed.

Theorem correct_lift_andor_and :
 forall f1 f2 : form,
 prenex f1 ->
 prenex f2 ->
 forall l : list Z,
 form2Prop l f1 /\ form2Prop l f2 <-> form2Prop l (lift_andor ANd f1 f2).
intros f1 f2 H H0 l; unfold lift_andor in |- *; apply iso_lift_andor_and2;
 auto.
red in |- *; repeat split; (repeat rewrite (plus_comm p); simpl in |- *);
 auto.
Qed.

Theorem correct_lift_andor_or :
 forall f1 f2 : form,
 prenex f1 ->
 prenex f2 ->
 forall l : list Z,
 form2Prop l f1 \/ form2Prop l f2 <-> form2Prop l (lift_andor Or f1 f2).
intros f1 f2 H H0 l; unfold lift_andor in |- *; apply iso_lift_andor_or2;
 auto.
red in |- *; repeat split; (repeat rewrite (plus_comm p); simpl in |- *);
 auto.
Qed.

(** * Lift Neg
  - [~((x:?)(P x))] gives  [(Ex [x:?] ~(P x))]
  - [~([x:?](P x))] gives [(x:?) ~(P x)]
 *)

Fixpoint lift_neg (f : form) : form :=
  match f with
  | Forall b => Exists (lift_neg b)
  | Exists b => Forall (lift_neg b)
  | b => Neg b
  end.

Theorem lift_neg_prenex : forall f : form, prenex f -> prenex (lift_neg f).
intros f H; elim H; simpl in |- *; auto.
intros a H1; elim H1; simpl in |- *; auto.
Qed.
Hint Resolve lift_neg_prenex.

Theorem lift_neg_groundN :
 forall f p, prenex f -> groundNForm p f -> groundNForm p (lift_neg f).
intros f p H; generalize p; elim H; clear H p; unfold lift_neg in |- *;
 lazy beta in |- *; fold lift_neg in |- *.
intros a H H0 p H1; inversion H1; auto.
intros a H H0 p H1; inversion H1; auto.
intros a H; elim H; simpl in |- *; auto.
Qed.

Theorem correct_lift_neg :
 forall f : form,
 prenex f -> forall l : list Z, ~ form2Prop l f <-> form2Prop l (lift_neg f).
intros f H; elim H; simpl in |- *; auto.
intros a H0 H1 l; split.
intros H2 x.
case (H1 (x :: l)); auto.
intros H3 H4; apply H3; auto; red in |- *; intros; case H2; exists x; auto.
intros H2; red in |- *; intros (x, H3).
case (H1 (x :: l)); auto.
intros H4 H5; apply H5; auto.
intros a H0 H1 l; split.
intros H2; case (classic (ex (fun x : Z => form2Prop (x :: l) (lift_neg a))));
 intros H3; auto.
elim H2; intros x.
case (classic (form2Prop (x :: l) a)); intros H4; auto.
case H3; exists x.
case (H1 (x :: l)); auto.
intros (x, H2); red in |- *; intros H3.
case (H1 (x :: l)); auto.
intros H4 H5; apply H5; auto.
intros a H1; elim H1; simpl in |- *; auto; intuition.
Qed.

(** Lift quantifier *)
Fixpoint lift_quant (f : form) : form :=
  match f with
  | Forall f1 => Forall (lift_quant f1)
  | Exists f1 => Exists (lift_quant f1)
  | Imp f1 f2 => lift_if (lift_quant f1) (lift_quant f2)
  | ANd f1 f2 => lift_andor ANd (lift_quant f1) (lift_quant f2)
  | Or f1 f2 => lift_andor Or (lift_quant f1) (lift_quant f2)
  | Neg f1 => lift_neg (lift_quant f1)
  | f1 => f1
  end.

Theorem lift_quant_prenex : forall f : form, prenex (lift_quant f).
intros f; elim f; simpl in |- *; auto.
Qed.
Hint Resolve lift_quant_prenex.

Theorem lift_quant_groundN :
 forall f p, groundNForm p f -> groundNForm p (lift_quant f).
intros f; elim f; clear f; unfold lift_quant in |- *; lazy beta in |- *;
 fold lift_quant in |- *; auto.
intros f H p H0; inversion H0; auto.
intros f H p H0; inversion H0; auto.
intros f H f0 H0 p H1; inversion H1; apply lift_andor_and_groundN; auto.
apply groundNForm_le with (2 := H4); auto.
apply groundNForm_le with (2 := H5); auto.
intros f H f0 H0 p H1; inversion H1; apply lift_andor_or_groundN; auto.
apply groundNForm_le with (2 := H4); auto.
apply groundNForm_le with (2 := H5); auto.
intros f H f0 H0 p H1; inversion H1; apply lift_if_groundN; auto.
apply groundNForm_le with (2 := H4); auto.
apply groundNForm_le with (2 := H5); auto.
intros f H p H0; inversion H0; apply lift_neg_groundN; auto.
Qed.

Theorem correct_lift_quant :
 forall (f : form) (l : list Z), form2Prop l f <-> form2Prop l (lift_quant f).
intros f; elim f; simpl in |- *; auto; try (intuition; fail).
intros f0 H l; split; intros H0 x; case (H (x :: l)); auto.
intros f0 H l; split; intros (x, H0); exists x; case (H (x :: l)); auto.
intros f1 H f2 H0 l; case (H l); intros H1 H2; case (H0 l); intros H3 H4;
 case (correct_lift_andor_and (lift_quant f1) (lift_quant f2)) with (l := l);
 intuition.
intros f1 H f2 H0 l; case (H l); intros H1 H2; case (H0 l); intros H3 H4;
 case (correct_lift_andor_or (lift_quant f1) (lift_quant f2)) with (l := l);
 intuition.
intros f1 H f2 H0 l; case (H l); intros H1 H2; case (H0 l); intros H3 H4;
 case (correct_lift_if (lift_quant f1) (lift_quant f2)) with (l := l);
 intuition.
intros f1 H l; case (H l); intros H1 H2;
 case (correct_lift_neg (lift_quant f1)) with (l := l);
 intuition.
Qed.


Require Import coqutil.Byte.
Require Import Rupicola.Lib.Api.
Require Import Crypto.Algebra.Hierarchy.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Field.Common.Arrays.MaxBounds.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Util.ZUtil.ModInv.
Local Open Scope Z_scope.
Import bedrock2.Memory.

Class FieldParameters :=
  { (** mathematical parameters **)
    M_pos : positive; (* modulus *)
    M : Z := Z.pos M_pos;
    a24 : F M_pos; (* (a+2) / 4 or (a-2) / 4, depending on the implementation *)

    (* special wrapper for copy so that compilation lemmas can recognize it *)
    fe_copy := (@id (F M_pos));

    (** function names **)
    mul : string; add : string; sub : string; opp : string;
    square : string; scmula24 : string; inv : string;
    from_bytes : string; to_bytes : string;
    select_znz : string;

    felem_copy : string;
    from_word : string;
  }.

Class FieldParameters_ok {field_parameters : FieldParameters} := {
  M_prime : Znumtheory.prime M
}.

Class FieldRepresentation
      {field_parameters : FieldParameters}
      {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}
       :=
  { felem := list word;
    feval : felem -> F M_pos;

    feval_bytes : list byte -> F M_pos;
    felem_size_in_words : nat;
    felem_size_in_bytes : Z := Z.of_nat felem_size_in_words * bytes_per_word width; (* for stack allocation *)
    encoded_felem_size_in_bytes : nat; (* number of bytes when serialized *)
    bytes_in_bounds : list byte -> Prop;

    (* Memory layout *)
    FElem : word -> list word -> mem -> Prop := Bignum felem_size_in_words;
    FElemBytes : word -> list byte -> mem -> Prop :=
      fun addr bs =>
        (emp (length bs = encoded_felem_size_in_bytes
              /\ bytes_in_bounds bs)
         * array ptsto (word.of_Z 1) addr bs)%sep;

    bounds : Type;
    bounded_by : bounds -> felem -> Prop;
    (* for saturated implementations, loose/tight bounds are the same *)
    loose_bounds : bounds;
    tight_bounds : bounds;
  }.

Definition Placeholder
           {field_parameters : FieldParameters}
           {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}
           {field_representation : FieldRepresentation(mem:=mem)}
           (p : word) : mem -> Prop :=
  Memory.anybytes(mem:=mem) p felem_size_in_bytes.

Class FieldRepresentation_ok
      {field_parameters : FieldParameters}
      {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}
      {field_representation : FieldRepresentation} := {
    relax_bounds :
      forall X : felem, bounded_by tight_bounds X
                        -> bounded_by loose_bounds X;
  }.

Section BignumToFieldRepresentationAdapterLemmas.
  Context
  {field_parameters : FieldParameters}
  {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}
  {field_representation : FieldRepresentation}.
  Context {word_ok : @word.ok width word} {map_ok : @map.ok word Init.Byte.byte mem}.

  Lemma felem_size_in_bytes_mod :
         felem_size_in_bytes mod Memory.bytes_per_word width = 0.
  Proof. apply Z_mod_mult. Qed.
  Lemma FElem_from_bytes p : Lift1Prop.iff1 (Placeholder p) (Lift1Prop.ex1 (FElem p)).
  Proof.
    cbv [Placeholder FElem felem_size_in_bytes].
    repeat intro.
    cbv [Lift1Prop.ex1]; split; intros;
      repeat match goal with
             | H : anybytes _ _ _ |- _ => eapply Array.anybytes_to_array_1 in H
             | H : exists _, _ |- _ => destruct H
             | H : _ /\ _ |- _ => destruct H
             end.
      all : repeat match goal with
             | H : anybytes _ _ _ |- _ => eapply Array.anybytes_to_array_1 in H
             | H : exists _, _ |- _ => destruct H
             | H : _ /\ _ |- _ => destruct H
             end.
    { eexists; eapply Bignum_of_bytes; try eassumption.
      destruct Bitwidth.width_cases; subst width; revert H0; cbn; lia. }
    { eapply Bignum_to_bytes in H; sepsimpl.
      let H := match goal with
               | H : Array.array _ _ _ _ _ |- _ => H end in
      eapply Array.array_1_to_anybytes in H.
      unshelve (erewrite (_:_*_=_); eassumption).
      rewrite H; destruct Bitwidth.width_cases as [W|W];
        symmetry in W; destruct W; cbn; clear; lia. }
  Qed.
End BignumToFieldRepresentationAdapterLemmas.

Section ToFromBytes.
  Definition nth_byte (x : Z) (n : nat) : byte :=
    byte.of_Z (Z.shiftr x (8 * Z.of_nat n)).
  Definition Z_to_bytes (x : Z) (n : nat) : list byte :=
    List.map (nth_byte x) (seq 0 n).
  Definition Z_from_bytes (bs : list byte) : Z :=
    List.fold_right
      (fun b acc => Z.shiftl acc 8 + byte.unsigned b) 0 bs.
End ToFromBytes.

Section FunctionSpecs.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Context {field_parameters : FieldParameters}
          {field_representation : FieldRepresentation}.

  Class UnOp (name: string) :=
    { un_model: F M_pos -> F M_pos;
      un_xbounds: bounds;
      un_outbounds: bounds }.

  Import WeakestPrecondition.

  Definition unop_spec {name} (op: UnOp name) :=
    fnspec! name (pout px : word) / (out x : felem) Rr,
    { requires tr mem :=
        bounded_by un_xbounds x
        /\ (exists Ra, (FElem px x * Ra)%sep mem)
        /\ (FElem pout out * Rr)%sep mem;
      ensures tr' mem' :=
        tr = tr' /\
        exists out,
          feval out = un_model (feval x)
          /\ bounded_by un_outbounds out
          /\ (FElem pout out * Rr)%sep mem' }.

  Instance spec_of_UnOp {name} (op: UnOp name) : spec_of name :=
    unop_spec op.

  Class BinOp (name: string) :=
    { bin_model: F M_pos -> F M_pos -> F M_pos;
      bin_xbounds: bounds;
      bin_ybounds: bounds;
      bin_outbounds: bounds }.

  Definition binop_spec  {name} (op: BinOp name) :=
    fnspec! name (pout px py : word) / (out x y : felem) Rr,
    { requires tr mem :=
        bounded_by bin_xbounds x
        /\ bounded_by bin_ybounds y
        /\ (exists Rx, (FElem px x * Rx)%sep mem)
        /\ (exists Ry, (FElem py y * Ry)%sep mem)
        /\ (FElem pout out * Rr)%sep mem;
      ensures tr' mem' :=
        tr = tr' /\
        exists out,
          feval out = bin_model (feval x) (feval y)
          /\ bounded_by bin_outbounds out
          /\ (FElem pout out * Rr)%sep mem' }.

  Instance spec_of_BinOp {name} (op: BinOp name) : spec_of name :=
    binop_spec op.

  Instance bin_mul : BinOp mul :=
    {| bin_model := F.mul; bin_xbounds := loose_bounds; bin_ybounds := loose_bounds; bin_outbounds := tight_bounds |}.
  Instance un_square : UnOp square :=
    {| un_model := fun x => F.pow x 2; un_xbounds := loose_bounds; un_outbounds := tight_bounds |}.
  Instance bin_add : BinOp add :=
    {| bin_model := F.add; bin_xbounds := tight_bounds; bin_ybounds := tight_bounds; bin_outbounds := loose_bounds |}.
  Instance bin_sub : BinOp sub :=
    {| bin_model := F.sub; bin_xbounds := tight_bounds; bin_ybounds := tight_bounds; bin_outbounds := loose_bounds |}.
  Instance un_scmula24 : UnOp scmula24 :=
    {| un_model := F.mul a24; un_xbounds := loose_bounds; un_outbounds := tight_bounds |}.
  Instance un_inv : UnOp inv := (* TODO: what are the bounds for inv? *)
    {| un_model := F.inv; un_xbounds := tight_bounds; un_outbounds := loose_bounds |}.
  Instance un_opp : UnOp opp :=
    {| un_model := F.opp; un_xbounds := tight_bounds; un_outbounds := loose_bounds |}.

  Instance spec_of_from_bytes : spec_of from_bytes :=
    fnspec! from_bytes (pout px : word) / out (bs : list byte) Rr,
    { requires tr mem :=
        (exists Ra, (FElemBytes px bs * Ra)%sep mem)
        /\ (FElem pout out * Rr)%sep mem;
      ensures tr' mem' :=
        tr = tr' /\
        exists X, feval X = feval_bytes bs
             /\ bounded_by tight_bounds X
             /\ (FElem pout X * Rr)%sep mem' }.

  Instance spec_of_to_bytes : spec_of to_bytes :=
    fnspec! to_bytes (pout px : word) / (out : list byte) (x : felem) Rr,
    { requires tr mem :=
        bounded_by tight_bounds x /\
        (exists Ra, (FElem px x * Ra)%sep mem)
        /\ (FElemBytes pout out * Rr)%sep mem;
      ensures tr' mem' :=
        tr = tr'
        /\ let bs := Z_to_bytes (F.to_Z (feval x))
                                encoded_felem_size_in_bytes in
           (FElemBytes pout bs * Rr)%sep mem' }.

  Instance spec_of_felem_copy : spec_of felem_copy :=
    fnspec! felem_copy (pout px : word) / (out x : felem) R,
    { requires tr mem :=
        (FElem px x * FElem pout out * R)%sep mem;
      ensures tr' mem' :=
        tr = tr' /\
        (FElem px x * FElem pout x * R)%sep mem' }.

  Instance spec_of_from_word : spec_of from_word :=
    fnspec! from_word (pout x : word) / out R,
    { requires tr mem :=
        (FElem pout out * R)%sep mem;
      ensures tr' mem' :=
        tr = tr' /\
        exists X, feval X = F.of_Z _ (word.unsigned x)
             /\ bounded_by tight_bounds X
             /\ (FElem pout X * R)%sep mem' }.

    Local Notation bit_range := {|ZRange.lower := 0; ZRange.upper := 1|}.

    Instance spec_of_selectznz  : spec_of select_znz :=
    fnspec! select_znz (pout pc px py : word) / out Rout Rx Ry x y,
    {
        requires tr mem :=
        (FElem pout out * Rout)%sep mem /\
        (FElem px x * Rx)%sep mem /\
        (FElem py y * Ry)%sep mem /\
        ZRange.is_bounded_by_bool (word.unsigned pc) bit_range = true;
        ensures tr' mem' :=
        if ((word.unsigned pc) =? 1)
            then ((FElem pout y * Rout)%sep mem')
            else ((FElem pout x * Rout)%sep mem')
    }.

    (*Parameters for word-by-word Montgomery arithmetic*)
    Definition r := 2 ^ width.
    Definition m' := Z.modinv (- M) r.
    Definition r' := Z.modinv (r) M.

    Definition from_mont_model x := F.mul x (@F.of_Z M_pos (r' ^ (Z.of_nat felem_size_in_words)%Z)).
    Definition to_mont_model x := F.mul x (@F.of_Z M_pos (r ^ (Z.of_nat felem_size_in_words)%Z)).

    Instance un_from_mont {from_mont : string} : UnOp from_mont :=
      {| un_model := from_mont_model; un_xbounds := tight_bounds; un_outbounds := loose_bounds |}.

    Instance un_to_mont {to_mont : string} : UnOp to_mont :=
      {| un_model := to_mont_model; un_xbounds := tight_bounds; un_outbounds := loose_bounds|}.

End FunctionSpecs.

Existing Instances spec_of_UnOp spec_of_BinOp bin_mul un_square bin_add bin_sub
         un_scmula24 un_inv spec_of_felem_copy spec_of_from_word.

Section SpecProperties.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Context {field_parameters : FieldParameters}
          {field_representation : FieldRepresentation}
          {field_representation_ok : FieldRepresentation_ok}.

  Lemma FElem_to_bytes px x :
    Lift1Prop.impl1 (FElem px x) (Placeholder px).
  Proof.
    rewrite FElem_from_bytes.
    repeat intro; eexists; eauto.
  Qed.

  Lemma M_nonzero : M <> 0.
  Proof. cbv [M]. congruence. Qed.
End SpecProperties.


Require Export
  Ty
  Exp
  Sem.

Inductive UnitT := TyUnit.

Derive NoConfusion for UnitT.

Definition Unit_HostTypes : HostTypes unit := {|
  HostTy := UnitT;
  HostTySem := λ 'UnitT, unit
|}.

Inductive UnitE : Ty → Type :=
  | EUnit : UnitE (@TyHost _ Unit_HostTypes TyUnit).

Derive NoConfusion for UnitE.

Definition Unit_HostExprs : HostExprs unit := {|
  has_host_types := Unit_HostTypes;
  HostExp := UnitE
|}.

Equations Unit_HostExpSem τ (e : HostExp (HostExprs:=Unit_HostExprs) τ) :
  SemTy τ := Unit_HostExpSem (TyHost TyUnit) EUnit := tt.

Program Definition Unit_HostLang : HostLang unit := {|
  has_host_exprs := Unit_HostExprs;
  HostExpSem := Unit_HostExpSem
|}.


Require Import include_frm.

Definition inline_function_code := (list expr) -> stmts.
Definition inline_function_asrt := (asrt ) -> (list logicvar) -> (list expr) -> asrt.
Definition make_inl_proof (code: inline_function_code) (pre post: inline_function_asrt) :=
  forall lexpr a b I e d o ll li tid,
    (o ==> EX lg : list logicvar, p_local li tid lg ** Atrue ) ->
    {|a, b, li, I, e, d|} |- tid {{o ** (pre o ll lexpr)}} code lexpr {{o ** (post o ll lexpr)}}.

Record Inline_record :=
  Inline_record_cons
    {
    inl_code : inline_function_code;
    inl_pre  : inline_function_asrt;
    inl_post : inline_function_asrt;
    inl_proof: make_inl_proof inl_code inl_pre inl_post
  }.

Definition inline_call inline_function_record lexpr :=
  (inl_code inline_function_record) lexpr.


Require Import Spec.Proc.
Require Import Spec.ProcTheorems.
Require Import Helpers.RelationAlgebra.
Require Import Tactical.ProofAutomation.

Import RelationNotations.

Section Dynamics.
  Context `(sem: Dynamics Op State).
  Notation proc := (proc Op).
  Notation step := sem.(step).
  Notation exec := (exec sem).
  Notation crash_step := sem.(crash_step).
  Notation exec_crash := (exec_crash sem).

  Definition precondition T := forall (post: T -> State -> Prop), State -> Prop.

  Record WPSetup :=
    { op_wp: forall T, Op T -> precondition T;
      op_wp_ok :
        forall T (op:Op T) post s, op_wp op post s ->
                              forall s' v, step op s s' v ->
                                      post v s'; }.

  Ltac cleanup :=
    simpl in *;
    unfold pure, and_then, test, rel_or in *;
    propositional.

  Context (wp: WPSetup).

  Fixpoint precond T (p: proc T)
    : precondition T :=
    fun post =>
      match p with
      | Ret v => post v
      | Call op => wp.(op_wp) op post
      | Bind p rx =>
        precond p (fun v s' => precond (rx v) post s')
      end.

  Theorem wp_ok :
    forall T (p: proc T) (post: T -> State -> Prop),
    forall s, precond p post s ->
         forall s' v, exec p s s' v ->
                 post v s'.
  Proof.
    intros Hop_wp.
    induction p; cleanup; eauto.
    - eapply wp.(op_wp_ok) in H; eauto.
    - eapply IHp in H1; eauto; cleanup.
      eapply H in H1; eauto.
  Qed.

  Definition crashpre := forall (crash: State -> Prop), State -> Prop.
  Definition after_crash (crash: State -> Prop) : State -> Prop :=
    fun s => forall s', crash_step s s' tt -> crash s'.

  Theorem after_crash_unfold : forall crash s,
      after_crash crash s ->
      forall s' u,
        crash_step s s' u ->
        crash s'.
  Proof.
    destruct u; firstorder.
  Qed.

  Ltac after_crash :=
    try match goal with
        | [ H: after_crash ?crash _ |- _ ] =>
          pose proof (@after_crash_unfold crash _ H);
          solve [ eauto ]
        end.

  Fixpoint crashcond T (p: proc T) : crashpre :=
    fun crash s =>
      match p with
      | Ret v => after_crash crash s
      | Call op => after_crash crash s /\
                  wp.(op_wp) op (fun v s => after_crash crash s) s
      | Bind p rx =>
        (* crashing at s is handled by wp_crash p (inductively; the other two
 rules includes this *)
        crashcond p crash s /\
        precond p (fun v s' => crashcond (rx v) crash s') s
      end.

  Theorem wp_crash_ok T (p: proc T) (crash: State -> Prop) :
    forall s, crashcond p crash s ->
         forall s' v, exec_crash p s s' v ->
                 crash s'.
  Proof.
    induction p; cleanup; after_crash.
    - repeat match goal with
             | [ H: _ \/ _ |- _ ] => destruct H; propositional;
                                    after_crash
             end.
      eapply wp.(op_wp_ok) in H1; eauto; after_crash.
    - repeat match goal with
             | [ H: _ \/ _ |- _ ] => destruct H; propositional;
                                    after_crash
             end.
      + eapply IHp; eauto.
      + eapply wp_ok in H2; eauto.
  Qed.

End Dynamics.

Arguments precondition State T : clear implicits.
Arguments crashpre State : clear implicits.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool Init.Nat Arith.Arith Arith.EqNat
     Init.Datatypes Strings.String Program.
Require Export Coq.Strings.String.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq.
From Coq_intermittent Require Export semantics lemmas_0.

(*relation determining what variables are read from when evaluating exp e
 *)
Inductive rd: exp -> warvars -> Prop :=
    RD: forall {e: exp} {N: nvmem} {V: vmem} {rs: readobs} {v: value},
      eeval N V e rs v -> rd e (readobs_wvs rs).

(*the following relations are described in more detail in the technical appendix of 'Towards a Formal Foundation'*)
Inductive WAR_ins: warvars -> warvars -> warvars -> instruction -> warvars -> warvars -> Prop :=
WAR_Skip: forall(N W R: warvars),
    WAR_ins N W R skip W R
| WAR_Vol: forall(N W R Re: warvars) (x: smallvar) (e: exp),
    (rd e Re) ->
             isV x ->
             (inl x) \notin W ->
             WAR_ins N W R (asgn_sv x e) W (Re ++ R)
| WAR_NoRd: forall(N W R Re: warvars)
             (x: smallvar) (e: exp),
             isNV x ->
             (rd e Re) ->
             not((inl x) \in (Re ++ R))
             -> WAR_ins N W R (asgn_sv x e) ((inl x)::W) (Re ++ R)
| WAR_Checkpointed: forall(N W R Re: warvars)
             (x: smallvar) (e: exp),
             (rd e Re) ->
             isNV x ->
             (inl x) \in (Re ++ R) ->
             not((inl x) \in W) ->
             ((inl x) \in N) ->
             WAR_ins N W R (asgn_sv x e) ((inl x)::W) (Re ++ R)
| WAR_WT: forall(N W R Re: warvars)
             (x: smallvar) (e: exp),
             (rd e Re) ->
             (inl x) \in (Re ++ R) ->
                         ((inl x) \in W) ->
             isNV x ->
             WAR_ins N W R (asgn_sv x e) ((inl x) ::W) (Re ++ R)
| WAR_NoRd_Arr: forall(N W R Re Rindex: warvars)
                 (a: array) (e index: exp),
    (rd e Re) ->
    (rd index Rindex) ->
    not(intersect (generate_locs a) (Re ++ Rindex ++ R)) ->
    WAR_ins N W R (asgn_arr a index e) ((generate_locs a) ++ W) (Re ++ Rindex ++ R)
| WAR_Checkpointed_Arr: forall(N W R Re Rindex: warvars)
                 (a: array) (e index: exp),
    (rd e Re) ->
    (rd index Rindex) ->
    (subseq (generate_locs a) (Re ++ Rindex ++ R)) ->
    (subseq (generate_locs a)  N) ->
    WAR_ins N W R (asgn_arr a index e) ((generate_locs a) ++ W) (Re ++ Rindex ++ R)
.

Inductive WARok: warvars -> warvars -> warvars -> command -> Prop:=
  WAR_I: forall(N W R W' R': warvars) (l: instruction),
    WAR_ins N W R l W' R' -> WARok N W R l
 | WAR_CP: forall(w N W R: warvars) (c: command),
       WARok w nil nil c ->
       WARok N W R ((incheckpoint w);;c)
 | WAR_Seq: forall(N W R W' R': warvars)
             (l: instruction) (c: command),
             WAR_ins N W R l W' R' ->
             WARok N W' R' c ->
             WARok N W R (l;;c)
 | WAR_If: forall(N W R Re: warvars)
            (e: exp)
            (c1 c2: command),
     (rd e Re) ->
     WARok N W (Re ++ R) c1 ->
     WARok N W (Re ++ R) c2 ->
     WARok N W R (TEST e THEN c1 ELSE c2)
.

(*relations modeling the DINO algorithm*)
Inductive DINO_ins: warvars -> warvars -> warvars -> instruction
                -> warvars -> warvars -> warvars -> Prop:=
  D_WAR_Skip: forall(N W R: warvars),
    DINO_ins N W R skip N W R
| D_WAR_Vol: forall(N W R Re: warvars) (x: smallvar) (e: exp),
    (rd e Re) ->
             isV x ->
             (inl x) \notin W ->
             DINO_ins N W R (asgn_sv x e) N W (Re ++ R)
| D_WAR_Written: forall(N W R Re: warvars)
                  (x: smallvar) (e: exp),
             (rd e Re) ->
             isNV x ->
             not((inl x) \in (Re ++ R))
             -> DINO_ins N W R (asgn_sv x e) N ((inl x)::W) (Re ++ R)
| D_WAR_CP_Asgn: forall(N W R Re: warvars) (x: smallvar) (e: exp),
    (rd e Re) ->
             isNV x ->
             (inl x) \in (Re ++ R) ->
             not((inl x) \in W) ->
             DINO_ins N W R (asgn_sv x e)
                  ((inl x)::N) ((inl x)::W) (Re ++ R)
| D_WAR_WtDom: forall(N W R Re: warvars)
             (x: smallvar) (e: exp),
             (rd e Re) ->
             (inl x) \in (Re ++ R) ->
                         ((inl x) \in W) ->
                         isNV x ->
             DINO_ins N W R (asgn_sv x e) N ((inl x) ::W) (Re ++ R)
| D_WAR_Wt_Arr: forall(N W R Re Rindex: warvars)
                 (a: array) (e index: exp),
    (rd e Re) ->
    (rd index Rindex) ->
    not(intersect (generate_locs a) (Re ++ Rindex ++ R)) ->
    DINO_ins N W R (asgn_arr a index e) N ((generate_locs a) ++ W) (Re ++ Rindex ++ R)
| D_WAR_CP_Arr: forall(N W R Re Rindex: warvars)
                 (a: array) (e index: exp),
    (rd e Re) ->
    (rd index Rindex) ->
                subseq (generate_locs a) (Re ++ Rindex ++ R) ->
                 DINO_ins N W R (asgn_arr a index e)
             ((generate_locs a) ++ N) ((generate_locs a)++ W) (Re ++ Rindex ++ R)
.

Inductive DINO: warvars -> warvars -> warvars -> command
                -> command -> warvars -> Prop:=
  D_WAR_Instr: forall(N N' W R W' R': warvars) (l: instruction),
    DINO_ins N W R l N' W' R' ->
    DINO N W R l l N'
| D_WAR_Seq: forall(N N' N'' W R W' R': warvars)
              (l: instruction) (c c': command),
    DINO_ins N W R l N' W' R' ->
    DINO N' W' R' c c' N''  ->
    DINO N W R (l;;c) (l;;c') N''
| D_WAR_If: forall(N N1 N2 W R Re: warvars) (c1 c1' c2 c2': command) (e: exp),
             (rd e Re) ->
     DINO N W (Re ++ R) c1 c1' N1 ->
     DINO N W (Re ++ R) c2 c2' N2 ->
     DINO N W R (TEST e THEN c1 ELSE c2) (TEST e THEN c1' ELSE c2') (N1 ++ N2)
| D_WAR_CP: forall(N N' W R: warvars) (c c': command),
    DINO nil nil nil c c' N' ->
    DINO N W R ((incheckpoint nil);;c) ((incheckpoint N');;c') N.