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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj28synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (mult lv0 lv1) (plus lv1 lv0))) (plus lv2 (plus Zero (Succ lv1)))).
Admitted.
QuickChick conj28synthconj5.


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.


(** * Testcases for [sets_automation_tactics.v]
Authors:
    - Cosmin Manea (1298542)

Creation date: 09 June 2021

Testcases for the [sets_automation_tactics.v] file.
Tests pass if they can be run without unhandled errors.
--------------------------------------------------------------------------------

This file is part of Waterproof-lib.

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

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

You should have received a copy of the GNU General Public License
along with Waterproof-lib.  If not, see <https://www.gnu.org/licenses/>.
*)

From Ltac2 Require Import Ltac2.
Require Import Sets.Ensembles.
Require Import Sets.Classical_sets.
Require Import Logic.
Require Import ClassicalFacts.
Require Import Sets.Powerset.
Require Import Rbase.
Require Import Qreals.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo.
Require Import Ranalysis.
Require Import Integration.
Require Import micromega.Lra.
Require Import Max.
Require Import Coq.Arith.Wf_nat.
Require Import Waterproof.set_intuition.Enabled.
Require Import Waterproof.set_search_depth.To_5.
Require Import Waterproof.load_database.Sets.

Load sets_automation_tactics.

Local Parameter U : Type.
Local Parameter A B : (Ensemble U).

Open Scope nat.

(** Test 0: U \ U = ∅ *)
Goal (Empty_set U) = (Setminus _ (Full_set U) (Full_set U)).
Proof.
    This set equality is trivial.
Qed.

(** Test 1: U \ ∅ = U *)
Goal (Full_set U) = (Setminus _ (Full_set U) (Empty_set U)).
Proof.
    This set equality is trivial.
Qed.

(** Test 2: A and ∅ are disjoint *)
Goal (Disjoint _ A (Empty_set U)).
Proof.
    This set equality is trivial.
Qed.

(** Test 3: A ∩ B = B ∩ A *)
Goal (Intersection _ A B) = (Intersection _ B A).
Proof.
    This set equality is trivial.
Qed.

(** Test 4: A ∪ B = B ∪ A *)
Goal (Union _ A B) = (Union _ B A).
Proof.
    This set equality is trivial.
Qed.

(** Test 5: ∅ ∩ A = ∅ *)
Goal (Intersection _ (Empty_set U) A) = (Empty_set U).
Proof.
    This set equality is trivial.
Qed.

(** Test 6: U ∩ A = A if A ⊂ U *)
Goal ((Intersection _ (Full_set U) A) = A).
Proof.
    This set equality is trivial.
Qed.

(** Test 7: A = A *)
Goal (A = A).
Proof.
    We prove equality by proving two inclusions.
    This set equality is trivial.
    This set equality is trivial.
Qed.


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.