Require Export high_mods SO_sem_mods.
Require Import vsSahlq_proof1 vsS_syn_sem SO_facts3 Monotonicity_lP_SO.
Require Import consistent FunctionalExtensionality.

Fixpoint change {A : Type} (l : list A) (n : nat) (a : A) :=
  match l, n with
  | nil, _ => nil
  | l, 0 => l
  | cons b l', 1 => cons a l'
  | cons b l', S m => cons b (change l' m a)
  end.

Fixpoint change_ln {A : Type} (l : list A) (ln : list nat) (a : A) :=
  match ln with
  | nil => l
  | cons n ln' => change (change_ln l ln' a) n a
  end.

Lemma change_ln_nil : forall W l pa,
  @change_ln W nil l pa = nil.
Proof.
  induction l; intros pa. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Lemma change_ln_cons_n : forall  lP n P (W : Set) lpa (pa pa2 : W -> Prop),
   ~ lP = nil ->
  change_ln (cons pa lpa) (indicies_l2_pre lP P (S n)) pa2 =
  cons pa (change_ln lpa (indicies_l2_pre lP P n) pa2).
Proof.
  induction lP; intros n P W lpa pa pa2 Hnil. contradiction.
  case_eq lP. intros HlP. subst. simpl in *.
      destruct (predicate_dec P a); subst; auto.
  intros T lT HlT. rewrite <- HlT.
  assert (~ lP = nil) as Hnil2.
  rewrite HlT. discriminate. simpl.
  destruct (predicate_dec P a); simpl; rewrite IHlP; auto.
Qed.

Lemma lem_a2 : forall lP P Q W Ip pa lpa',
~ P = Q ->
@alt_Ip_list W Ip (change_ln lpa' (indicies_l2 lP P) pa) lP Q
 = alt_Ip_list Ip lpa' lP Q.
Proof.
  induction lP; intros P Q W Ip pa lpa' Hneq. auto.
  unfold indicies_l2. simpl.
  destruct lpa'.
  + simpl. rewrite change_ln_nil. auto.
  + rename P0 into pa2.  simpl.
    destruct (predicate_dec P a); subst; simpl in *.
    ++ rewrite alt_Ip_neq; auto.
       case_eq lP. intros HlP. simpl.
       destruct lpa'; simpl; rewrite alt_Ip_neq; auto.
       intros U lU HlU. rewrite <- HlU.
       assert (~ lP = nil) as Hnil2.
         rewrite HlU. discriminate.
       rewrite <- IHlP with (P := a) (pa := pa).
       rewrite change_ln_cons_n. simpl.
       rewrite alt_Ip_neq. all : auto.
    ++ case_eq lP. intros HlP. auto.
       intros U lU HlU. rewrite <- HlU.
       rewrite change_ln_cons_n. simpl.
       unfold indicies_l2 in IHlP.
       destruct (predicate_dec a Q). subst.
       do 2 rewrite alt_Ip_eq.  auto.
       do 2 (rewrite alt_Ip_neq; auto).
       rewrite HlU. discriminate.
Qed.

Lemma lem_a1 : forall lP P W Ip pa lpa',
@alt_Ip W (alt_Ip_list Ip lpa' lP) pa P =
alt_Ip (alt_Ip_list Ip (change_ln lpa' (indicies_l2 lP P) pa) lP)
  pa P.
Proof.
  intros. apply functional_extensionality.
  intros Q. destruct (predicate_dec P Q). subst.
  do 2 rewrite alt_Ip_eq. auto.
  do 2 (rewrite alt_Ip_neq; auto).
  symmetry. apply lem_a2. auto.
Qed.

Lemma lem_a7 : forall (lP : list predicate) (W : Set) (lpa : list (W -> Prop)) (pa pa2 : W -> Prop)
  (P Q : predicate),
~ P = Q ->
@is_constant (W -> Prop)
  (@ind_gen (W -> Prop) pa2 (indicies_l2 (P :: lP) Q)
     (@change_ln (W -> Prop) (pa :: lpa) (indicies_l2 (P :: lP) P) pa)) <->
@is_constant (W -> Prop)
  (@ind_gen (W -> Prop) pa2 (indicies_l2 lP Q)
     (@change_ln (W -> Prop) lpa (indicies_l2 lP P) pa)).
Proof.
  unfold is_constant. unfold indicies_l2.
  intros lP W lpa pa pa2 P Q Hneq.
  split; intros H.
  + destruct H as [a [ n H]].
    simpl in H. destruct (predicate_dec Q P); subst.
    contradiction. pred_dec_l_rep. simpl in *.
    destruct lP. simpl in *. exists a, 0. auto.
    remember (p :: lP) as lP'.
    rewrite change_ln_cons_n in H.
    simpl in H.
    rewrite ind_gen_pre_cons in H.
    exists a. exists n. auto. subst. discriminate.
  + destruct H as [a [ n H]].
    simpl in *. destruct (predicate_dec Q P); subst.
    contradiction. pred_dec_l_rep. simpl in *.
    destruct lP. simpl in *. exists a, 0. auto.
    remember (p :: lP) as lP'.
    rewrite change_ln_cons_n. simpl.
    rewrite ind_gen_pre_cons.
    exists a. exists n. auto. subst. discriminate.
Qed.

Lemma length_indicies_l2_pre : forall lP n m P,
  length (indicies_l2_pre lP P n) =
  length (indicies_l2_pre lP P m).
Proof.
  induction lP; intros n m P; auto. simpl.
  destruct (predicate_dec P a); subst; simpl; auto.
Qed.

Lemma lem_a8_eq : forall (lP : list predicate) (W : Set) (lpa : list (W -> Prop)) (pa pa2 : W -> Prop)
  (P : predicate),
  length lP = length lpa ->
  (@ind_gen (W -> Prop) pa2 (indicies_l2 lP P)
     (@change_ln (W -> Prop) lpa (indicies_l2 lP P) pa)) =
    repeat pa (length (indicies_l2 lP P)).
Proof.
  unfold indicies_l2. induction lP;
  intros W lpa pa p2 P Hlength. auto.
  simpl. case_eq lP.
  + intros HlP. simpl. destruct (predicate_dec P a).
    simpl. destruct lpa. discriminate.
    simpl. all : try reflexivity.
  + intros PP lPP HlP.
    rewrite <- HlP.
    assert (~ lP = nil) as HH.
      rewrite HlP. discriminate.
    destruct (predicate_dec P a).
    ++ destruct lpa. discriminate.
       simpl. rewrite change_ln_cons_n. simpl.
       rewrite ind_gen_pre_cons. rewrite IHlP.
       rewrite length_indicies_l2_pre with (m := 1).
       all : auto.
    ++ destruct lpa. discriminate.
       simpl. rewrite change_ln_cons_n.
       rewrite ind_gen_pre_cons. rewrite IHlP.
       rewrite length_indicies_l2_pre with (m := 1).
       all : auto.
Qed.

Lemma lem_a8 : forall (lP : list predicate) (W : Set) a n (lpa : list (W -> Prop)) (pa pa2 : W -> Prop)
  (P Q : predicate),
~ P = Q ->
 (@ind_gen (W -> Prop) pa2 (indicies_l2_pre lP Q 0) lpa) = repeat a n ->
  (@ind_gen (W -> Prop) pa2 (indicies_l2 lP Q)
     (@change_ln (W -> Prop) lpa (indicies_l2 lP P) pa)) = repeat a n.
Proof.
  induction lP; intros W b n lpa pa pa2 P Q Hneq Hn. auto.
  unfold indicies_l2 in *. simpl in *.
  case_eq lP.
  + intros HlP; rewrite HlP in *.
    simpl in *. destruct (predicate_dec Q a);
                destruct (predicate_dec P a); subst;
                  simpl in *; auto.
    contradiction.
  + intros PP lPP HlP. rewrite <- HlP.
    assert (~ lP = nil) as HlPnil.
      rewrite HlP. discriminate.
    destruct (predicate_dec Q a).
    ++ subst a.
       simpl in *. case_eq lpa. intros Hlpa. rewrite Hlpa in *.
       rewrite change_ln_nil. assumption.
       intros pa3 lpa3 Hlpa. rewrite <- Hlpa.
       destruct (predicate_dec P Q). subst Q.
       contradiction.
       simpl in *.
       rewrite Hlpa in *. simpl in Hn.
       rewrite change_ln_cons_n. simpl.
       rewrite ind_gen_pre_cons in Hn.
       rewrite ind_gen_pre_cons. destruct n. simpl in *. discriminate.
       rewrite IHlP with (a := b) (n := n). inversion Hn as [[H1 H2]].
       rewrite H2. all : auto.
       inversion Hn. reflexivity.
    ++ simpl in *. case_eq lpa. intros Hlpa. rewrite Hlpa in *.
       rewrite change_ln_nil. assumption.
       intros pa3 lpa3 Hlpa. rewrite <- Hlpa.
       destruct (predicate_dec P a). subst a. simpl.
       * simpl. rewrite Hlpa in *. simpl in *.
         rewrite change_ln_cons_n in *. simpl.
         rewrite ind_gen_pre_cons in *.
         rewrite IHlP with (a := b) (n := n).
         reflexivity. all : try assumption.
       * rewrite Hlpa in *. rewrite change_ln_cons_n.
         rewrite ind_gen_pre_cons.
         rewrite ind_gen_pre_cons in Hn.
         apply IHlP. all : assumption.
Qed.

Lemma lem_a10 : forall (lP : list predicate) (W : Set) (lpa : list (W -> Prop)) (pa pa2 : W -> Prop)
  (P Q : predicate),
~ P = Q ->
@is_constant (W -> Prop) (@ind_gen (W -> Prop) pa2 (indicies_l2_pre lP Q 0) lpa) ->
@is_constant (W -> Prop)
  (@ind_gen (W -> Prop) pa2 (indicies_l2 lP Q)
     (@change_ln (W -> Prop) lpa (indicies_l2 lP P) pa)).
Proof.
  unfold is_constant. intros until 0. intros Hneq Hcon.
  destruct Hcon as [a [n H]].
  exists a. exists n. apply lem_a8; assumption.
Qed.

Lemma lem_a10_eq : forall (lP : list predicate) (W : Set) (lpa : list (W -> Prop)) (pa pa2 : W -> Prop)
  (P : predicate),
  length lP = length lpa ->
@is_constant (W -> Prop)
  (@ind_gen (W -> Prop) pa2 (indicies_l2 lP P)
     (@change_ln (W -> Prop) lpa (indicies_l2 lP P) pa)).
Proof.
  unfold is_constant. intros until 0. intros Hlength.
  exists pa. exists (length (indicies_l2 lP P)).
  unfold indicies_l2. apply lem_a8_eq.
  assumption.
Qed.

Lemma lem_a6 : forall (lP : list predicate) (W : Set) (lpa : list (W -> Prop)) (pa pa2 : W -> Prop)
  (P Q : predicate),
~ P = Q ->
@is_constant (W -> Prop) (@ind_gen (W -> Prop) pa2 (indicies_l2 lP Q) lpa) ->
@is_constant (W -> Prop)
  (@ind_gen (W -> Prop) pa2 (indicies_l2 (P :: lP) Q)
     (@change_ln (W -> Prop) (pa :: lpa) (indicies_l2 (P :: lP) P) pa)).
Proof.
  unfold indicies_l2.
  intros. apply lem_a7. assumption.
  apply lem_a10; assumption.
Qed.

Lemma lem_a5 : forall lP W lpa pa pa2 P Q,
length lP = length lpa ->
@consistent_lP_lpa_P W pa2 lP lpa Q ->
@consistent_lP_lpa_P W pa2 (P :: lP)
  (@change_ln (W -> Prop) (cons pa lpa) (indicies_l2 (cons P lP) P) pa) Q.
Proof.
  unfold consistent_lP_lpa_P. intros until 0. intros Hlength Hcon.
  destruct (predicate_dec P Q). subst. apply lem_a10_eq. simpl. auto.
  apply lem_a6; auto.
Qed.

Lemma lem_a4 : forall lP W lpa pa pa2 P,
length lP = length lpa ->
@consistent_lP_lpa W pa2 lP lpa ->
@consistent_lP_lpa W pa2 (P :: lP)
  (@change_ln (W -> Prop) (cons pa lpa) (indicies_l2 (cons P lP) P) pa).
Proof.
  unfold consistent_lP_lpa.
  intros until 0. intros H1 H2 Q. apply lem_a5. assumption.
  apply H2.
Qed.

Lemma lem_a11 : forall lP P (W : Set) lpa pa pa2,
(@change_ln (W -> Prop) (cons pa lpa) (indicies_l2 (cons P lP) P) pa2) =
(cons pa2 (@change_ln (W -> Prop) lpa (indicies_l2 lP P) pa2)).
Proof.
  intros. unfold indicies_l2. simpl.
  pred_dec_l_rep. simpl.
  destruct lP. simpl. reflexivity.
  rewrite change_ln_cons_n. simpl. reflexivity.
  discriminate.
Qed.

Lemma length_change : forall (W : Set) l n pa,
  length (@change (W -> Prop) l n pa) = length l.
Proof.
 induction l; intros n pa. reflexivity.
  simpl. destruct n. reflexivity.
  destruct n. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Lemma length_change_ln : forall (W : Set) ln lpa pa,
  length (@change_ln (W -> Prop) lpa ln pa) =
  length lpa.
Proof.
  induction ln; intros lpa pa. reflexivity.
  simpl. rewrite length_change. apply IHln.
Qed.

Lemma alt_Ip_list_consistent_lP_lpa' : forall lP (W : Set) Ip lpa pa2,
  length lP = length lpa ->
  exists lpa',
    @consistent_lP_lpa W pa2 lP lpa' /\
    length lP = length lpa' /\
    alt_Ip_list Ip lpa lP =
    alt_Ip_list Ip lpa' lP.
Proof.
  induction lP; intros W Ip lpa pa2 Hlength.
    exists nil. simpl. apply conj.
      apply consistent_lP_lpa_nil_l.
      apply conj. reflexivity.

      apply alt_Ip_list_nil.

    destruct lpa. discriminate.
    simpl. destruct (IHlP W Ip lpa pa2) as [lpa' [Hcon [Hl Halt]]].
inversion Hlength. reflexivity.
    rewrite Halt.
    rename P into pa. rename a into P.
    exists (cons pa (change_ln lpa' (indicies_l2 lP P) pa)).
    simpl. apply conj.
      rewrite <- lem_a11 with (pa := pa).
      apply lem_a4. inversion Hlength. assumption.
      assumption.

      apply conj.
pose proof length_change_ln.
        rewrite length_change_ln. rewrite Hl. reflexivity.

      apply lem_a1.
Qed.

Lemma lem_a15_pre_pre_pre_pre_pre_stronger : forall l P Q R W lpa2 pa pa0 pa1 pa2 n,
  @ind_gen (W -> Prop) pa2 (indicies_l2 (cons P (cons Q l)) R) (cons pa0 (cons pa1 lpa2)) = repeat pa n ->
  @ind_gen _ pa2 (indicies_l2 (cons Q (cons P l)) R) (cons pa1 (cons pa0 lpa2)) = repeat pa n.
Proof.
  unfold indicies_l2.
  intros l P Q R W lpa2 pa pa0 pa1 pa2 n  H.
    simpl in *. destruct (predicate_dec R Q);
    destruct (predicate_dec R P); subst; simpl in *;
        do 2 rewrite ind_gen_pre_cons;
        do 2 rewrite ind_gen_pre_cons in H;
        destruct n; try discriminate; auto.
    destruct n. discriminate.
    inversion H as [[H1 H2]]. rewrite H0. reflexivity.
Qed.

Lemma lem_a15_pre_pre_pre_pre_pre_stronger_rev : forall l P Q R W lpa2 pa pa0 pa1 pa2 n,
  @ind_gen _ pa2 (indicies_l2 (cons Q (cons P l)) R) (cons pa1 (cons pa0 lpa2)) = repeat pa n ->
  @ind_gen (W -> Prop) pa2 (indicies_l2 (cons P (cons Q l)) R) (cons pa0 (cons pa1 lpa2)) = repeat pa n.
Proof.
  unfold indicies_l2.
  intros l P Q R W lpa2 pa pa0 pa1 pa2 n  H.
    simpl in *. destruct (predicate_dec R Q);
      destruct (predicate_dec R P); subst; simpl in *;
        do 2 rewrite ind_gen_pre_cons;
        do 2 rewrite ind_gen_pre_cons in H;
        destruct n; try discriminate; auto.
    destruct n. discriminate.
    inversion H as [[H1 H2]]. rewrite H0. reflexivity.
Qed.

Lemma lem_a15_pre_pre_pre_pre_pre : forall l P Q R W lpa2 pa pa0 pa1 pa2 n,
  length l = length lpa2 ->
  @ind_gen (W -> Prop) pa2 (indicies_l2 (cons P (cons Q l)) R) (cons pa0 (cons pa1 lpa2)) = repeat pa n ->
  @ind_gen _ pa2 (indicies_l2 (cons Q (cons P l)) R) (cons pa1 (cons pa0 lpa2)) = repeat pa n.
Proof.
  unfold indicies_l2.
  intros l P Q R W lpa2 pa pa0 pa1 pa2 n Hlength H.
  simpl in *. destruct (predicate_dec R P);
      destruct (predicate_dec R Q); subst; simpl in *;
        do 2 rewrite ind_gen_pre_cons;
        do 2 rewrite ind_gen_pre_cons in H;
        destruct n; try discriminate; auto.
  destruct n. discriminate.
  inversion H as [[H1 H2]]. rewrite H0. reflexivity.
Qed.

Lemma consistent_lP_lpa_cons_cons_same : forall lP P W lpa pa1 pa2 pa3,
  @consistent_lP_lpa W pa3 (cons P (cons P lP)) (cons pa1 (cons pa2 lpa)) ->
  pa1 = pa2.
Proof.
  unfold consistent_lP_lpa.
  unfold consistent_lP_lpa_P.
  unfold is_constant. unfold indicies_l2.
  intros lP P W lpa pa1 pa2 pa3 H.
  specialize (H P). simpl in *. pred_dec_l_rep.
  destruct H as [pa4 [n H]].
  destruct n. discriminate. destruct n. discriminate.
  inversion H as [[H1 H2]]. reflexivity.
Qed.

Lemma alt_Ip_alt_list_alt_same : forall lP W Ip lpa pa pa2 P,
  @alt_Ip W (alt_Ip_list (alt_Ip Ip pa P) lpa lP) pa2 P =
  alt_Ip (alt_Ip_list Ip lpa lP) pa2 P.
Proof.
  induction lP; intros W Ip lpa pa pa2 P.
    do 2 rewrite alt_Ip_list_nil.
    rewrite alt_Ip_rem. auto.
  destruct lpa. simpl. rewrite alt_Ip_rem. auto.
  simpl. destruct (predicate_dec P a); subst.
  + rewrite IHlP. auto.
  + rewrite <- alt_Ip_switch; auto. rewrite IHlP.
    rewrite <- alt_Ip_switch; auto.
Qed.

Lemma consistent_lP_lpa_cons_cons_switch : forall lP P Q W lpa pa1 pa2 pa0,
  @consistent_lP_lpa W pa0 (cons P (cons Q lP)) (cons pa1 (cons pa2 lpa)) ->
  @consistent_lP_lpa W pa0 (cons Q (cons P lP)) (cons pa2 (cons pa1 lpa)).
Proof.
  unfold consistent_lP_lpa.
  unfold consistent_lP_lpa_P.
  unfold is_constant.
  intros lP P Q W lpa pa1 pa2 p0 H R.
  specialize (H R).
  destruct H as [pa3 [n H]].
  exists pa3. exists n.
  apply lem_a15_pre_pre_pre_pre_pre_stronger.
  assumption.
Qed.

Lemma alt_Ip__list_consistent_lP_lpa : forall lP P W Ip lpa pa pa2,
  @consistent_lP_lpa W pa2 (cons P lP) (cons pa lpa) ->
  alt_Ip (alt_Ip_list Ip lpa lP) pa P =
  alt_Ip_list (alt_Ip Ip pa P) lpa lP.
Proof.
  induction lP; intros P W Ip lpa pa pa2 Hcon .
    do 2 rewrite alt_Ip_list_nil. reflexivity.

    destruct lpa. simpl. reflexivity.
    simpl. destruct (predicate_dec P a); subst.
      apply consistent_lP_lpa_cons_cons_same in Hcon.
      subst. rewrite alt_Ip_rem.
      rewrite alt_Ip_alt_list_alt_same. auto.

      specialize (IHlP P W Ip lpa pa pa2).
      rewrite <- IHlP. rewrite alt_Ip_switch; auto.

      apply consistent_lP_lpa_cons_cons_switch in Hcon.
      apply consistent_lP_lpa_cons_rem in Hcon. assumption.
Qed.

Lemma lem_a15_pre_pre_pre_pre : forall l2 Q P W lpa2 (pa pa1 pa2: W -> Prop) n,
  length l2 = length lpa2 ->
  @ind_gen _ pa2 (indicies_l2 (app l2 (cons Q nil)) P) (app lpa2 (cons pa1 nil)) = repeat pa n <->
  @ind_gen _ pa2 (indicies_l2 (cons Q l2) P) (cons pa1 lpa2) = repeat pa n.
Proof.
  induction l2; intros Q P W lpa2 pa pa1 pa2 n Hlength; simpl in *.
  destruct lpa2. simpl in *. apply iff_refl. discriminate.
  split; intros H.
  + destruct lpa2. discriminate. simpl in *.
    apply lem_a15_pre_pre_pre_pre_pre. inversion Hlength. reflexivity.
    unfold indicies_l2 in H. unfold indicies_l2.
    simpl in *.  destruct (predicate_dec P a).
      simpl in *. rewrite ind_gen_pre_cons in H.
      unfold indicies_l2 in IHl2.
      destruct n. discriminate. inversion H as [[H1 H2]].
      apply  IHl2 in H2. simpl in H2.
      destruct (predicate_dec P Q).
        simpl in *. rewrite ind_gen_pre_cons. rewrite H2.
        reflexivity.

        rewrite ind_gen_pre_cons. rewrite H2. reflexivity.
          inversion Hlength. reflexivity.

      rewrite ind_gen_pre_cons in H. apply IHl2 in H.
      unfold indicies_l2 in H.
      simpl in H. destruct (predicate_dec P Q). simpl in *.
        rewrite ind_gen_pre_cons. assumption.

        rewrite ind_gen_pre_cons. assumption.
          inversion Hlength. reflexivity.
  + simpl in *. destruct lpa2. discriminate. simpl in *.
    apply lem_a15_pre_pre_pre_pre_pre in H.
      2 : (inversion Hlength; reflexivity).
    unfold indicies_l2 in H. unfold indicies_l2. simpl in *.
    destruct (predicate_dec P a). simpl in*.
    ++ simpl in *. rewrite ind_gen_pre_cons .
       unfold indicies_l2 in IHl2.
       destruct n. discriminate. inversion H as [[H1 H2]].
       destruct (predicate_dec P Q).
       simpl in *. rewrite ind_gen_pre_cons in H2.
       destruct n. discriminate. inversion H2 as [[H3 H4]].
       rewrite ind_gen_pre_cons in H4.
       specialize (IHl2 Q P W lpa2 pa pa1 pa2 (S n)).
       simpl in IHl2. subst. simpl in *.
       pred_dec_l_rep. simpl in *. apply IHl2 in H2.
       rewrite H2. auto. lia.

       rewrite ind_gen_pre_cons in H2.
       specialize (IHl2 Q P W lpa2 pa pa1 pa2 n).
       simpl in IHl2. subst. simpl in *.
       rewrite predicate_dec_r in IHl2; auto.
       apply IHl2 in H2.  rewrite H2.  auto. lia.

    ++ unfold indicies_l2. simpl.
       destruct (predicate_dec P Q); subst.
       * simpl in *. rewrite ind_gen_pre_cons in H.
         destruct n. discriminate. inversion H as [[H1 H2]].
         simpl in *. subst.
         rewrite ind_gen_pre_cons.
         rewrite ind_gen_pre_cons in H2.
         assert ( @ind_gen _ pa2 (indicies_l2 (l2 ++ Q :: nil) Q) (lpa2 ++ pa :: nil) = repeat pa (S n)) as Hass.
         apply IHl2. auto. simpl. unfold indicies_l2. simpl.
         pred_dec_l_rep. simpl in *. auto.
       * rewrite ind_gen_pre_cons. apply IHl2. auto.
         unfold indicies_l2. simpl. rewrite predicate_dec_r; auto.
         rewrite ind_gen_pre_cons in H. auto.
Qed.

Lemma lem_a15_pre_pre_pre : forall (lP1 lP2 : list predicate) a (W : Type) pa n
   (lpa1 lpa2 : list (W -> Prop))
  (pa2 pa1 : W -> Prop) (P : predicate),
length lP1 = length lpa1 ->
length lP2 = length lpa2 ->
@ind_gen _ pa2 (indicies_l2 ((a :: lP1) ++ lP2) P ) ((cons pa1 lpa1) ++ lpa2) = repeat pa n ->
@ind_gen _ pa2 (indicies_l2 (lP1 ++ a :: lP2) P ) (lpa1 ++ (cons pa1 lpa2)) = repeat pa n.
Proof.
   induction lP1; intros lP2 Q W pa n lpa1 lpa2 pa2 pa1 P Hl1 Hl2 H.
   + destruct lpa1. simpl in *. assumption. discriminate.
   + simpl in H. destruct lpa1. discriminate.
     apply (lem_a15_pre_pre_pre_pre_pre (app lP1 lP2)) in H.
     fold (app lpa1 lpa2) in H. simpl.
     unfold indicies_l2. unfold indicies_l2 in H.
     simpl in *.  destruct (predicate_dec P a).
     ++ simpl in *. destruct n. discriminate.
        inversion H as [[H1 H2]].
        simpl in *. destruct (predicate_dec P Q).
        destruct n. discriminate. inversion H2.
        rewrite ind_gen_pre_cons in H4.
        rewrite ind_gen_pre_cons in H4.
        rewrite ind_gen_pre_cons. unfold indicies_l2 in IHlP1.
        rewrite IHlP1 with (pa := pa) (n := (S n)). reflexivity.
        all : try assumption. auto.
        simpl. subst. pred_dec_l_rep. simpl. rewrite ind_gen_pre_cons.
        rewrite H4. auto.

        unfold indicies_l2 in IHlP1.  rewrite ind_gen_pre_cons.
        rewrite IHlP1 with (pa := pa) (n := n). reflexivity.
        inversion Hl1. reflexivity.
        all : try assumption.

        do 2 rewrite ind_gen_pre_cons in H2.
        simpl. rewrite predicate_dec_r; auto.
        rewrite ind_gen_pre_cons. assumption.
     ++ destruct (predicate_dec P Q). simpl in *.
        rewrite ind_gen_pre_cons.
        do 2 rewrite ind_gen_pre_cons in H.
        apply IHlP1; try assumption.
        inversion Hl1. reflexivity.
        unfold indicies_l2.
        simpl in *. rewrite predicate_dec_l; auto. simpl.
        rewrite ind_gen_pre_cons. auto.

        do 2 rewrite ind_gen_pre_cons in H.
        rewrite ind_gen_pre_cons. apply IHlP1; auto.
        unfold indicies_l2. simpl. rewrite predicate_dec_r; auto.
        rewrite ind_gen_pre_cons. auto.

     ++ fold (app lpa1 lpa2). simpl in *.
      do 2 rewrite app_length. lia.
Qed.

Lemma lem_a15_pre_pre_pre_stronger : forall (lP1 lP2 : list predicate) a (W : Type) pa n
   (lpa1 lpa2 : list (W -> Prop))
  (pa2 pa1 : W -> Prop) (P : predicate),
length lP1 = length lpa1 ->
@ind_gen _ pa2 (indicies_l2 ((a :: lP1) ++ lP2) P ) ((cons pa1 lpa1) ++ lpa2) = repeat pa n ->
@ind_gen _ pa2 (indicies_l2 (lP1 ++ a :: lP2) P ) (lpa1 ++ (cons pa1 lpa2)) = repeat pa n.
Proof.
  induction lP1; intros lP2 Q W pa n lpa1 lpa2 pa2 pa1 P Hl1 H.
    destruct lpa1; auto. discriminate.
  simpl in H. destruct lpa1. discriminate.
  apply (lem_a15_pre_pre_pre_pre_pre_stronger (app lP1 lP2)) in H.
  fold (app lpa1 lpa2) in H.
  unfold indicies_l2. unfold indicies_l2 in H. simpl in *.
  destruct (predicate_dec P a); subst.
  + simpl in *. destruct n. discriminate.
    inversion H as [[H1 H2]].
    simpl in *.
    destruct (predicate_dec a Q); subst.
    ++ simpl in *.
       destruct n. discriminate. inversion H2.
       rewrite ind_gen_pre_cons in H3.
       rewrite ind_gen_pre_cons in H3.
       rewrite ind_gen_pre_cons. unfold indicies_l2 in IHlP1.
       rewrite IHlP1 with (pa := pa) (n := (S n)). reflexivity.
        all : try assumption.
        inversion Hl1. reflexivity.

        simpl. pred_dec_l_rep. simpl. rewrite ind_gen_pre_cons.
        rewrite H3. auto.
    ++ unfold indicies_l2 in IHlP1.  rewrite ind_gen_pre_cons.
       rewrite IHlP1 with (pa := pa) (n := n). reflexivity.
       inversion Hl1. reflexivity.

       do 2 rewrite ind_gen_pre_cons in H2.
       simpl. rewrite predicate_dec_r; auto.
       rewrite ind_gen_pre_cons. assumption.

  + rewrite ind_gen_pre_cons.
    apply IHlP1; try assumption.
    inversion Hl1. reflexivity.
    unfold indicies_l2. simpl.
    destruct (predicate_dec P Q); subst; simpl in *.
    ++ rewrite ind_gen_pre_cons.
       do 2 rewrite ind_gen_pre_cons in H.
       assumption.
    ++ rewrite ind_gen_pre_cons in H. assumption.
Qed.

Lemma lem_a15_pre_pre_pre' : forall (lP1 lP2 : list predicate) (W : Type) pa n
   (lpa1 lpa2 : list (W -> Prop))
  (pa2 : W -> Prop) (P : predicate),
length lP1 = length lpa1 ->
length lP2 = length lpa2 ->
   @ind_gen _ pa2 (indicies_l2_pre (lP1 ++ lP2) P 0) (lpa1 ++ lpa2) = repeat pa n ->
  @ind_gen _ pa2 (indicies_l2_pre (lP2 ++ lP1) P 0) (lpa2 ++ lpa1) = repeat pa n.
Proof.
  induction lP1; intros lP2 W pa n lpa1 lpa2 pa2 P Hl1 Hl2 H.
    simpl in *. rewrite List.app_nil_r. destruct lpa1. 2 : discriminate.
    rewrite List.app_nil_r. simpl in *. assumption.

    destruct lpa1. discriminate.
    apply lem_a15_pre_pre_pre. assumption. inversion Hl1. reflexivity.
    unfold indicies_l2.  simpl in *.
    destruct (predicate_dec P a).
      simpl in *. rewrite ind_gen_pre_cons in H. destruct n.
      discriminate. simpl in H.
      inversion H as [[H1 H2]].
      rewrite ind_gen_pre_cons.
      rewrite IHlP1 with (pa := pa) (n := n). reflexivity.
        inversion Hl1. reflexivity. assumption.
      assumption.

      rewrite ind_gen_pre_cons.
      simpl in H.
      rewrite ind_gen_pre_cons in H.
      apply IHlP1; try assumption.
      inversion Hl1. reflexivity.
Qed.

Lemma lem_a15_pre_pre : forall lP1 lP2 W lpa1 lpa2 (pa2 : W -> Prop) P,
length lP1 = length lpa1 ->
length lP2 = length lpa2 ->
is_constant (@ind_gen _ pa2 (indicies_l2 (app lP1 lP2) P) (app lpa1 lpa2)) ->
is_constant (@ind_gen _ pa2 (indicies_l2 (app lP2 lP1) P) (app lpa2  lpa1)).
Proof.
  unfold is_constant. unfold indicies_l2.
  intros until 0. intros H1 H2 H3.
  destruct H3 as [pa [n H3]].
  exists pa. exists n. apply lem_a15_pre_pre_pre';
  assumption.
Qed.

Lemma lem_a15_pre : forall lP1 lP2 W lpa1 lpa2 pa2 P,
  length lP1 = length lpa1 ->
  length lP2 = length lpa2 ->
  (@consistent_lP_lpa_P W pa2 (app lP1 lP2) (app lpa1 lpa2) P ->
  @consistent_lP_lpa_P _ pa2 (app lP2 lP1) (app lpa2 lpa1) P).
Proof.
  unfold consistent_lP_lpa_P.
  intros until 0. apply lem_a15_pre_pre.
Qed.

Lemma lem_a15 : forall lP1 lP2 W lpa1 lpa2 pa2,
  length lP1 = length lpa1 ->
  length lP2 = length lpa2 ->
  (@consistent_lP_lpa W pa2 (app lP1 lP2) (app lpa1 lpa2) ->
  @consistent_lP_lpa _ pa2 (app lP2 lP1) (app lpa2 lpa1)).
Proof.
  unfold consistent_lP_lpa.
  intros until 0. intros H1 H2 H P.
  apply lem_a15_pre; try assumption. apply H.
Qed.

Lemma lem_a16_pre_pre : forall lP1 lP2 (W : Set) lpa1 lpa2 (pa2 : W -> Prop) Q pa n,
  length lP1 = length lpa1 ->
   @ind_gen _ pa2 (indicies_l2 (lP1 ++ lP2) Q) (lpa1 ++ lpa2) = repeat pa n ->
exists m, @ind_gen _ pa2 (indicies_l2 lP1 Q) lpa1 = repeat pa m.
Proof.
  induction lP1; intros lP2 W lpa1 lpa2 pa2 Q pa n Hlength Hind.
    simpl in *. exists 0. reflexivity.

    unfold indicies_l2 in *.
    destruct lpa1. discriminate. simpl in *.
    inversion Hlength as [Hl].
    destruct (predicate_dec Q a).
      simpl in *. rewrite ind_gen_pre_cons in *.
      destruct n. discriminate.
      simpl in Hind. inversion Hind as [[H1 H2]].
      destruct (IHlP1 lP2 W lpa1 lpa2 pa2 Q pa n Hl H2)
        as [m H].
      exists (S m). rewrite H. reflexivity.

      simpl in *. rewrite ind_gen_pre_cons in *.
      destruct (IHlP1 lP2 W lpa1 lpa2 pa2 (Q) pa n Hl Hind)
        as [m H].
      exists (m). rewrite H. reflexivity.
Qed.

Lemma lem_a16_pre : forall lP1 lP2 W lpa1 lpa2 pa2 Q,
  length lP1 = length lpa1 ->
  @consistent_lP_lpa_P W pa2 (app lP1 lP2) (app lpa1 lpa2) Q->
  @consistent_lP_lpa_P W pa2 lP1 lpa1 Q.
Proof.
  unfold consistent_lP_lpa_P.
  unfold is_constant.
  induction lP1; intros lP2 W lpa1 lpa2 pa2 Q Hlength H.
    simpl. apply is_constant_nil. apply pa2.

    destruct H as [pa [n H]]. unfold indicies_l2 in *.
    simpl in *. destruct (predicate_dec Q a).
      simpl in *. destruct lpa1. discriminate. simpl in *.
      rewrite ind_gen_pre_cons in *.
      destruct n.
      discriminate. simpl in H. inversion H as [[H1 H2]].
      inversion Hlength as [Hlength'].
      destruct (lem_a16_pre_pre lP1 lP2 W lpa1 lpa2 pa2 Q pa n Hlength' H2)
        as [m H3].
      exists pa. exists (S m). unfold indicies_l2 in H3. rewrite H3.
      reflexivity.

      destruct lpa1. discriminate. rewrite ind_gen_pre_cons.
      inversion Hlength.
      apply IHlP1 with (lP2 := lP2) (lpa2 := lpa2);
        try assumption.
      simpl in H. rewrite ind_gen_pre_cons in H.
      exists pa. exists n. assumption.
Qed.

Lemma lem_a16 : forall lP1 lP2 W lpa1 lpa2 pa2,
  length lP1 = length lpa1 ->
  @consistent_lP_lpa W pa2 (app lP1 lP2) (app lpa1 lpa2) ->
  @consistent_lP_lpa W pa2 lP1 lpa1.
Proof.
  unfold consistent_lP_lpa.
  intros until 0. intros H1 H2 P.
  specialize (H2 P). apply lem_a16_pre in H2;
  assumption.
Qed.

Lemma lem_a13 : forall lP W Ip pa lpa P,
  length lP = length lpa ->
  In P lP ->
  @alt_Ip_list W (alt_Ip Ip pa P) lpa lP =
  alt_Ip_list Ip lpa lP.
Proof.
  induction lP; intros W Ip pa lpa P Hlength Hin. contradiction.
  simpl in *.
  destruct lpa. discriminate.
  inversion Hlength as [Hl].
  destruct (predicate_dec a P).
  + subst.
    do 2 rewrite alt_Ip_list_cons.
    destruct (in_dec predicate_dec P lP).
    ++ rewrite IHlP; auto.
    ++ rewrite alt_Ip__list_occ_f.
       rewrite alt_Ip_rem. auto. auto.
  + do 2 rewrite alt_Ip_list_cons.
    rewrite IHlP; auto. firstorder.
Qed.

Lemma lem_a14_pre_pre_pre_pre : forall lP1 lP2 P W lpa1 lpa2 (pa0 pa2 : W -> Prop),
  length lP1 = length lpa1 ->
  ~@ind_gen _ pa0 (indicies_l2 (app lP1 (cons P lP2)) P) (app lpa1 (cons pa2 lpa2))
       = nil.
Proof.
  induction lP1; intros lP2 P W lpa1 lpa2 pa0 pa Hl H.
  + destruct lpa1. unfold indicies_l2 in *. simpl in *.
    pred_dec_l_rep. all : discriminate.
  + simpl in *. unfold indicies_l2 in *. simpl in *.
    destruct (predicate_dec P a);
    destruct lpa1; try discriminate.
    simpl in H. rewrite ind_gen_pre_cons in H.
    apply IHlP1 in H; auto.
Qed.

Lemma lem_a14_pre_pre_pre_rev: forall (lP1 lP2 : list predicate) n (P Q : predicate)
   (W : Set) (lpa1 lpa2 : list (W -> Prop)) (pa pa1 pa2 : W -> Prop),
length lP1 = length lpa1 ->
(@ind_gen _ pa2 (indicies_l2 (lP1 ++ P :: lP2) Q) (lpa1 ++ pa :: lpa2)) = repeat pa1 n ->
(@ind_gen _ pa2 (indicies_l2 (P :: (lP1 ++ lP2)%list) Q)
    (pa :: (lpa1 ++ lpa2)%list)) = repeat pa1 n.
Proof.
   induction lP1; intros lP2 n P Q W lpa1 lpa2 pa pa1 pa2 Hl H.
     destruct lpa1. simpl in *. assumption. discriminate.
  simpl in H. destruct lpa1. discriminate.
  apply (lem_a15_pre_pre_pre_pre_pre_stronger_rev (app lP1 lP2)).
  fold (app lpa1 lpa2).  simpl in *.
  unfold indicies_l2 in *. simpl in *.
  destruct (predicate_dec Q a).
  + simpl in *. destruct n. discriminate.
    destruct (predicate_dec Q P).
    ++ simpl in *. rewrite ind_gen_pre_cons in H.
       do 2 rewrite ind_gen_pre_cons.
       inversion H.  rewrite H2. apply IHlP1 in H2.
       subst. pred_dec_l_rep. simpl in *. destruct n. discriminate.
       simpl in H2. inversion H2. subst. rewrite ind_gen_pre_cons in H3.
       rewrite H3. auto. auto.
    ++ simpl in *. subst. rewrite ind_gen_pre_cons in H.
       inversion H. subst. rewrite H2. do 2 rewrite ind_gen_pre_cons.
       apply IHlP1 in H2. rewrite predicate_dec_r in H2; auto.
       rewrite ind_gen_pre_cons in H2. rewrite H2. auto. auto.
  + rewrite ind_gen_pre_cons in H. destruct (predicate_dec Q P).
    simpl in *. do 2 rewrite ind_gen_pre_cons. destruct n.
    ++ apply IHlP1 in H. subst. pred_dec_l_rep.
       simpl in *. discriminate. auto.
    ++ subst. apply IHlP1 in H. pred_dec_l_rep.
       simpl in *. rewrite ind_gen_pre_cons in H. auto.
       auto.
    ++ do 2 rewrite ind_gen_pre_cons.
       apply IHlP1 in H; auto. rewrite predicate_dec_r in H.
       rewrite ind_gen_pre_cons in H. auto. auto.
Qed.

Lemma lem_a14_pre_pre : forall (lP1 lP2 : list predicate) (P Q : predicate) (W : Set)
  (lpa1 lpa2 : list (W -> Prop)) (pa pa2 : W -> Prop),
length lP1 = length lpa1 ->
is_constant (@ind_gen _ pa2 (indicies_l2 (P :: (lP1 ++ lP2)%list) Q) (pa :: (lpa1 ++ lpa2)%list)) <->
is_constant (@ind_gen _ pa2 (indicies_l2 (lP1 ++ P :: lP2) Q) (lpa1 ++ pa :: lpa2)).
Proof.
  unfold is_constant. intros until 0. intros Hlength.
  split; intros [pa1 [n H]]; exists pa1; exists n.
    apply lem_a15_pre_pre_pre_stronger; assumption.

    apply lem_a14_pre_pre_pre_rev; assumption.
Qed.

Lemma lem_a14_pre: forall lP1 lP2 P Q W lpa1 lpa2 pa pa2,
  length lP1 = length lpa1 ->
  (@consistent_lP_lpa_P W pa2 (cons P (app lP1 lP2)) (cons pa (app lpa1 lpa2)) Q <->
  @consistent_lP_lpa_P _ pa2 (app lP1 (cons P lP2)) (app lpa1 (cons pa lpa2)) Q).
Proof.
  unfold consistent_lP_lpa_P.
  apply lem_a14_pre_pre.
Qed.

 Lemma lem_a14  : forall lP1 lP2 P W lpa1 lpa2 pa pa2,
  length lP1 = length lpa1 ->
  (@consistent_lP_lpa W pa2 (cons P (app lP1 lP2)) (cons pa (app lpa1 lpa2)) <->
  @consistent_lP_lpa _ pa2 (app lP1 (cons P lP2)) (app lpa1 (cons pa lpa2))).
Proof.
  unfold consistent_lP_lpa.
  intros. split; intros HH Q;
    (apply lem_a14_pre; [ assumption| apply HH]).
Qed.

Lemma lemma_try7_again : forall lP atm W Ip Iv Ir pa_l x pa2 lP0 pa_l0,
  AT atm = true ->
  incl lP (preds_in atm)->
  ex_FOvar_var_ll x (FOv_att_P_l atm lP) = false ->
  SOturnst W Iv (alt_Ip_list Ip pa_l0 lP0) Ir atm ->
  incl lP lP0 ->
  @consistent_lP_lpa _ pa2 (app lP lP0) (app pa_l pa_l0) ->
  length lP0 = length pa_l0 ->
  length lP = length pa_l ->
  @consistent_lP_lpa _ pa2 lP pa_l ->
Ip_extends_l W
  (alt_Ip_list Ip
     (vsS_pa_l Iv (FOv_att_P_l atm lP) (list_var (length lP) x)) lP)
  (alt_Ip_list Ip pa_l lP) lP.
Proof.
  induction lP; intros atm W Ip Iv Ir lpa x pa2 lP0 lpa0 Hat Hin Hex
                       SOt Hin4 Hcon4 Hlength4 Hlength Hcon.
    simpl in *. rewrite alt_Ip_list_nil. apply Ip_extends_l_refl.
  destruct lpa. discriminate. simpl in *.
  unfold Ip_extends_l. rename P into pa. rename a into P.
  if_then_else_hyp_dep.
  assert (@consistent_lP_lpa _ pa2 lP lpa) as Hcon2.
    apply consistent_lP_lpa_cons_rem in Hcon. assumption.
  intros Q. apply conj; intros Hpocc.
  ++ intros w Halt. simpl in Hpocc.
     destruct (predicate_dec P Q); subst.
     * rewrite alt_Ip_eq in *.
       apply lemma17' with (Ip := (alt_Ip_list Ip lpa0 lP0))
                           (Ir := Ir) (pa := pa) in Halt; auto.
       inversion Hlength.
       apply incl_hd in Hin. firstorder.
       rewrite alt_Ip__list_consistent_lP_lpa with (pa2 := pa2).
       rewrite lem_a13; auto.
       apply lem_a14 in Hcon4.
       apply lem_a15 in Hcon4.
       apply lem_a16 in Hcon4. all : simpl; auto.
     * inversion Hlength as [Hlength'].
       pose proof (consistent_lP_lpa_cons_rem _ _ _ _ _ _ Hcon4) as Hcon5.
       pose proof (incl_hd _ _ _ _ Hin4) as Hin4'.
       apply incl_lcons in Hin4.
       pose proof (incl_hd _ _ _ _ Hin) as Hin'.
       apply incl_lcons in Hin.
       specialize (IHlP _ _ _ _ _ _ x pa2 lP0 lpa0 Hat Hin Hex SOt Hin4
                        Hcon5 Hlength4 Hlength' Hcon2 Q).
        destruct IHlP as [IH1 IH2]. destruct Hpocc as [?|Hpocc]. contradiction.
        specialize (IH1 Hpocc w). rewrite alt_Ip_neq in *.
        specialize (IH1 Halt); auto. auto. auto.
  ++ simpl in Hpocc. apply not_or_and in Hpocc. destruct Hpocc as [Hp1 Hp2].
     inversion Hlength as [Hlength'].
     pose proof (consistent_lP_lpa_cons_rem _ _ _ _ _ _ Hcon4) as Hcon5.
       pose proof (incl_hd _ _ _ _ Hin4) as Hin4'.
       apply incl_lcons in Hin4.
       pose proof (incl_hd _ _ _ _ Hin) as Hin'.
       apply incl_lcons in Hin.
     specialize (IHlP _ _ _ _ _ _ x pa2 lP0 lpa0 Hat Hin Hex SOt Hin4
                      Hcon5 Hlength4 Hlength' Hcon2 Q).
     destruct IHlP as [IH1 IH2]. do 2 (rewrite alt_Ip_neq; auto).
Qed.

Lemma is_repeatist_var : forall (lP : list predicate) (P : predicate) (x : FOvariable),
exists m, (ind_FOv (indicies_l2_pre lP P 0) (list_var (length lP) x)) = repeat x m.
Proof.
  induction lP; intros P x. exists 0. reflexivity.
  simpl. destruct (predicate_dec P a); try subst a; simpl;
  destruct (IHlP P x) as [m Hm]; [exists (S m) | exists m];
  simpl; rewrite ind_FOv_ind_l2_pre_cons; auto; rewrite Hm; auto.
Qed.

Lemma consistent_lP_lx_P_list_var : forall lP P x,
  consistent_lP_lx_P lP (list_var (length lP) x) P.
Proof.
  unfold consistent_lP_lx_P. unfold indicies_l2.
  unfold is_constant. intros lP P x.
  destruct (is_repeatist_var lP P x) as [m H].
  exists x. exists m. assumption.
Qed.

Lemma consistent_lP_lx_list_var : forall lP x,
  consistent_lP_lx lP (list_var (length lP) x).
Proof.
  unfold consistent_lP_lx.
  intros. apply consistent_lP_lx_P_list_var.
Qed.

Lemma AT_passing_predSO_ll : forall lP llx,
  ~ lP = nil ->
  ~ llx = nil ->
  ex_nil_in_llv llx = false ->
  AT (passing_conj (passing_predSO_ll lP llx)) = true.
Proof.
  induction lP; intros llx H1 H2 Hex.
    contradiction (H1 eq_refl).

    simpl. case_eq llx. intros Hllx. rewrite Hllx in *.
      contradiction (H2 eq_refl).
    intros lx llx' Hllx.
    simpl.
    case_eq (passing_predSO_ll lP llx').
      intros Hp. rewrite <- lem4. apply AT_passing_conj_atm.
      rewrite Hllx in Hex. destruct lx; discriminate.
    intros beta lbeta Hp. rewrite <- Hp.
    simpl. rewrite <- lem4. rewrite AT_passing_conj_atm.
    apply IHlP.
    destruct lP. discriminate. discriminate.
    destruct llx'. destruct lP; discriminate. discriminate.
    rewrite Hllx in Hex. destruct lx. discriminate. simpl in Hex.
    assumption.
    rewrite Hllx in Hex. destruct lx; discriminate.
Qed.

Lemma lP_is_pos_SO_uni : forall lP beta,
  pos_SO beta ->
  ~ lP = nil ->
  (forall P, In P lP -> (Pred_in_SO beta P )) ->
  lP_is_pos_SO beta lP.
Proof.
  induction lP; intros beta Hun Hnil Hpocc.
    simpl in *. contradiction (Hnil eq_refl).

    simpl. destruct lP.
    apply Hun. apply Hpocc. firstorder.
    apply conj. apply Hun.
    apply Hpocc. firstorder.

    apply IHlP; try assumption. discriminate.
    intros P Hin. apply Hpocc. simpl in *.
    clear -Hin.  firstorder.
Qed.

Fixpoint cap_pred_lpa {W : Set} (lpa : list (W -> Prop)) l1 l2 :=
  match l1, lpa with
  | nil, _ => nil
  | _, nil => nil
  | cons P l1', cons pa lpa' => if in_predicate_dec P l2
                                then cons pa (cap_pred_lpa lpa' l1' l2)
          else cap_pred_lpa lpa' l1' l2
  end.

Lemma incl_cap_pred_refl : forall l1 l2,
  incl (cap_pred l1 l2) l1.
Proof.
  induction l1; intros l2. firstorder.
  simpl. dest_in_pred_dec_blind.
  + apply incl_cons_cons. auto.
  + apply incl_rcons. auto.
Qed.

Lemma ind_gen_nil : forall l W (pa0 : W -> Prop),
  @ind_gen _ pa0 l nil = repeat pa0 (length l).
Proof.
  induction l; intros W pa. reflexivity.
  simpl. rewrite IHl. simpl. destruct a. simpl.
  reflexivity. simpl. destruct a; reflexivity.
Qed.

Lemma length_cap_pred__lpa : forall lP l2 (W : Set) (lpa : list (W -> Prop)),
  length lP = length lpa ->
  length (cap_pred lP l2) = length (cap_pred_lpa lpa lP l2).
Proof.
  induction lP; intros l2 W lpa H. destruct lpa; auto.
  destruct lpa. discriminate. inversion H.
  simpl. dest_in_pred_dec_blind; simpl; auto.
Qed.

Lemma ind_gen_ind_l2_cap_pred_app : forall l1 l2 P (W : Set) lpa ( pa pa0 : W -> Prop) n,
length l1 =  length lpa ->
@ind_gen _ pa0 (indicies_l2 l1 P) lpa = repeat pa n ->
exists (n' : nat),
@ind_gen _ pa0 (indicies_l2 (app (cap_pred l1 l2) l1) P) (app (cap_pred_lpa lpa l1 l2) lpa) =
  repeat pa n'.
Proof.
  induction l1; intros l2 P W lpa pa pa0 n Hl Hind. exists 0. auto.
  unfold indicies_l2 in *.
  simpl in *.
  dest_in_pred_dec_blind; simpl.
  + destruct (predicate_dec P a); simpl in *; subst.
    ++ destruct lpa; simpl.
       * rewrite ind_gen_nil. simpl.
         exists (S(length (indicies_l2_pre
                           (cap_pred l1 l2 ++ a :: l1) a 1))).
         destruct n. discriminate. inversion Hind as [[H1 H2]].
         rewrite <- H1.  reflexivity.
       * simpl. rewrite in_predicate_dec_l; auto.
         simpl. rewrite ind_gen_pre_cons in *.
         destruct n. discriminate. unfold indicies_l2 in IHl1.
         inversion Hind as [[H1 H2]].
         inversion Hl as [Hl'].
         specialize (IHl1 l2 _ _ _ _ _ _ Hl' H2).
         destruct IHl1 as [n' IH].
         pose proof lem_a15_pre_pre_pre_stronger as Hlem.
         unfold indicies_l2 in Hlem.
         rewrite (Hlem (cap_pred l1 l2)
            l1 a W pa (S n')).
         exists (S (S n')). reflexivity.
         apply length_cap_pred__lpa. assumption.
         clear Hlem. simpl. pred_dec_l_rep. simpl. rewrite ind_gen_pre_cons.
         rewrite IH. auto.
    ++ destruct lpa. discriminate. simpl in *.
       rewrite ind_gen_pre_cons in Hind.
       rewrite in_predicate_dec_l; auto. simpl. rewrite ind_gen_pre_cons.
        inversion Hl as [Hl'].
        specialize (IHl1 l2 _ _ _ _ _ _ Hl' Hind).
        destruct IHl1 as [n' IH].
        pose proof lem_a15_pre_pre_pre_stronger as Hlem.
        unfold indicies_l2 in Hlem.
        rewrite (Hlem (cap_pred l1 l2)
            l1 a W pa (n')).
        exists ( n'). reflexivity.
        apply length_cap_pred__lpa. assumption.
        clear Hlem. simpl. rewrite predicate_dec_r; auto.
        rewrite ind_gen_pre_cons. rewrite IH. auto.
  + destruct lpa. discriminate. simpl in *.
    inversion Hl as [Hl']. destruct (predicate_dec P a).
    ++ rewrite in_predicate_dec_r; auto. simpl in *. destruct n. discriminate.
       inversion Hind as [[H1 H2]].
       rewrite ind_gen_pre_cons in H2.
       specialize (IHl1 l2 _ _ _ _ _ _ Hl' H2).
       destruct IHl1 as [n' IH].
       pose proof lem_a15_pre_pre_pre_stronger as Hlem.
       unfold indicies_l2 in Hlem.
       rewrite (Hlem (cap_pred l1 l2)
                     l1 a W pa (S n')).
       exists ((S n')). reflexivity.
       apply length_cap_pred__lpa. assumption.
       clear Hlem. simpl. rewrite predicate_dec_l; auto. simpl.
       rewrite ind_gen_pre_cons. rewrite IH. auto.
    ++ rewrite ind_gen_pre_cons in Hind.
       rewrite in_predicate_dec_r; auto.
       specialize (IHl1 l2 _ _ _ _ _ _ Hl' Hind).
       destruct IHl1 as [n' IH].
       pose proof lem_a15_pre_pre_pre_stronger as Hlem.
        unfold indicies_l2 in Hlem.
        rewrite (Hlem (cap_pred l1 l2)
            l1 a W pa (n')).
        exists ( n'). reflexivity.
        apply length_cap_pred__lpa. assumption.
        clear Hlem. simpl.
        rewrite predicate_dec_r; auto.
        simpl. rewrite ind_gen_pre_cons.
        rewrite IH. reflexivity.
Qed.

Lemma is_constant_ind_gen_cap_pred_lpa_app : forall l1 l2 P (W : Set) (lpa : list (W -> Prop))
    (pa2 : W -> Prop),
length l1 = length lpa ->
is_constant (@ind_gen _ pa2 (indicies_l2 l1 P) lpa) ->
is_constant
  (@ind_gen _ pa2 (indicies_l2 (cap_pred l1 l2 ++ l1) P) (@cap_pred_lpa W lpa l1 l2 ++ lpa)).
Proof.
  unfold is_constant. intros until 0. intros Hl [pa [n H]].
  apply ind_gen_ind_l2_cap_pred_app with (l2 := l2) in H.
  destruct H as [n' H]. exists pa. exists n'. assumption.
  assumption.
Qed.

Lemma consistent_lP_lpa_P_cap_pred_lpa_app : forall l1 l2 P W lpa pa2,
  length l1 = length lpa ->
  @consistent_lP_lpa_P W pa2 l1 lpa P ->
  @consistent_lP_lpa_P W pa2 (app (cap_pred l1 l2) l1)
      (app (cap_pred_lpa lpa l1 l2) lpa) P.
Proof.
  unfold consistent_lP_lpa_P.
  intros until 0. intros Hl H.
  apply is_constant_ind_gen_cap_pred_lpa_app; assumption.
Qed.

Lemma consistent_lP_lpa_cap_pred_lpa_app : forall l1 l2 W lpa pa2,
  length l1 = length lpa ->
  @consistent_lP_lpa W pa2 l1 lpa ->
  @consistent_lP_lpa W pa2 (app (cap_pred l1 l2) l1)
      (app (cap_pred_lpa lpa l1 l2) lpa).
Proof.
  unfold consistent_lP_lpa.
  intros until 0. intros Hl H P. apply consistent_lP_lpa_P_cap_pred_lpa_app.
  assumption.
  apply H.
Qed.

Lemma ind_gen_indicies_l2_cap_pred : forall (lP : list predicate) n (P : predicate) (l2 : list predicate)
  (W : Set) (lpa : list (W -> Prop)) (pa2 : W -> Prop) pa,
length lP = length lpa ->
(@ind_gen _ pa2 (indicies_l2 lP P) lpa) = repeat pa n ->
(exists (n' : nat),
@ind_gen _ pa2 (indicies_l2 (cap_pred lP l2) P) (cap_pred_lpa lpa lP l2) =
  repeat pa n').
Proof.
  induction lP; intros n P l2 W lpa pa2 pa Hl Hind. exists 0. auto.
  simpl in *. unfold indicies_l2 in *. simpl in *.
  destruct lpa. discriminate.
  destruct (in_predicate_dec a l2);
    destruct (predicate_dec P a); simpl in *; subst;
      pred_dec_l_rep; simpl in *.
  + simpl.  rewrite in_predicate_dec_l; auto.
    rewrite ind_gen_pre_cons.
    rewrite ind_gen_pre_cons in Hind.
    destruct n. discriminate.
    inversion Hind as [[H1 H2]].
    inversion Hl as [Hl'].
    specialize (IHlP _ _ l2 _ _ _ _  Hl' H2).
    destruct IHlP as [n' IH].  rewrite IH.
    exists (S n'). reflexivity.
  + rewrite predicate_dec_r; auto.
    rewrite in_predicate_dec_l; auto.
    rewrite ind_gen_pre_cons in *.
    apply IHlP with (n := n); auto.
  + simpl. rewrite in_predicate_dec_r; auto.
    destruct n. discriminate.
    inversion Hind as [[H1 H2]]. rewrite ind_gen_pre_cons in H2.
    apply (IHlP) with (n := n); auto.
  + rewrite in_predicate_dec_r; auto.
    rewrite ind_gen_pre_cons in Hind.
    apply IHlP with (n := n); auto.
Qed.

Lemma is_constant_ind_gen_cap_pred : forall (lP : list predicate) (P : predicate) (l2 : list predicate)
  (W : Set) (lpa : list (W -> Prop)) (pa2 : W -> Prop),
length lP = length lpa ->
is_constant (@ind_gen _ pa2 (indicies_l2 lP P) lpa) ->
is_constant (@ind_gen _ pa2 (indicies_l2 (cap_pred lP l2) P) (cap_pred_lpa lpa lP l2)).
Proof.
  unfold is_constant.
  intros until 0. intros Hl [pa [n H]].
  apply ind_gen_indicies_l2_cap_pred with (l2 := l2) in H.
  destruct H as [n' H].
  exists pa. exists n'. assumption.
  assumption.
Qed.

Lemma consistent_lP_lpa_P_cap_pred : forall lP P l2 W lpa pa2,
length lP = length lpa ->
@consistent_lP_lpa_P W pa2 lP lpa P ->
@consistent_lP_lpa_P W pa2 (cap_pred lP l2) (cap_pred_lpa lpa lP l2) P.
Proof.
  unfold consistent_lP_lpa_P.
  intros until 0. apply is_constant_ind_gen_cap_pred.
Qed.

Lemma consistent_lP_lpa_cap_pred : forall lP l2 W lpa pa2,
length lP = length lpa ->
@consistent_lP_lpa W pa2 lP lpa ->
@consistent_lP_lpa W pa2 (cap_pred lP l2) (cap_pred_lpa lpa lP l2).
Proof.
  unfold consistent_lP_lpa. intros until 0.
  intros Hl H P. specialize (H P).
  apply consistent_lP_lpa_P_cap_pred; assumption.
Qed.

Lemma lem_a19 : forall lP W Iv Ip Ir pa_l beta pa2,
  length lP = length pa_l ->
  @consistent_lP_lpa W pa2 lP pa_l ->
  SOturnst W Iv (alt_Ip_list Ip pa_l lP) Ir beta <->
  SOturnst W Iv (alt_Ip_list Ip (cap_pred_lpa pa_l lP (preds_in beta))
     (cap_pred lP (preds_in beta))) Ir beta.
Proof.
  induction lP; intros W Iv Ip Ir pa_l beta pa2 Hl Hcon.
    simpl in *. do 2 rewrite alt_Ip_list_nil.
    apply iff_refl.
  destruct pa_l. simpl. apply iff_refl.
  inversion Hl as [Hl'].
  pose proof Hcon as Hcon'.
  apply consistent_lP_lpa_cons_rem in Hcon.
  simpl. destruct (in_predicate_dec a (preds_in beta)).
  + simpl. rewrite alt_Ip__list_consistent_lP_lpa with (pa2:=pa2).
    rewrite alt_Ip__list_consistent_lP_lpa with (pa2:=pa2).
    apply IHlP with (pa2 := pa2); auto.
    pose proof (consistent_lP_lpa_cap_pred (cons a lP) (preds_in beta)  W (cons P pa_l) pa2) as H.
    simpl in H. do 2 rewrite in_predicate_dec_l in H; auto. auto.
  + split; intros SOt.
    ++ apply P_not_occ_alt in SOt; auto.
       apply (IHlP W Iv Ip Ir pa_l beta pa2); auto.
    ++ apply P_not_occ_alt; auto.
       apply (IHlP W Iv Ip Ir pa_l beta pa2); auto.
Qed.

Lemma lem_a26 : forall (lP : list predicate) (Q : predicate) (atm : SecOrder)
  (W : Set) (Iv : FOvariable -> W) (x : FOvariable) (pa2 : W -> Prop),
exists (n : nat),
  @ind_gen (W -> Prop) pa2 (indicies_l2_pre lP Q 0)
    (vsS_pa_l Iv (FOv_att_P_l atm lP) (list_var (length lP) x)) =
  repeat (pa_l_disj_gen Iv (FOv_att_P atm Q) x) n.
Proof.
  induction lP; intros Q atm W Iv x pa2. exists 0. auto.
  simpl. destruct (IHlP Q atm W Iv x pa2) as [n H].
  destruct (predicate_dec Q a). subst.
  + exists (S n). simpl. rewrite ind_gen_pre_cons.
    rewrite H. auto.
  + exists n. rewrite ind_gen_pre_cons. auto.
Qed.

Lemma lem_a25 : forall lP Q atm W Iv x pa2,
  @consistent_lP_lpa_P W pa2 lP
    (vsS_pa_l Iv (FOv_att_P_l atm lP)
      (list_var (length lP) x)) Q.
Proof.
  unfold consistent_lP_lpa_P. unfold is_constant.
  unfold indicies_l2.
  intros lP Q atm W Iv x pa2. exists (pa_l_disj_gen Iv (FOv_att_P atm Q) x).
  apply lem_a26.
Qed.

Lemma lem_a27 : forall lP atm W Iv x pa2,
  @consistent_lP_lpa W pa2 lP
    (vsS_pa_l Iv (FOv_att_P_l atm lP)
      (list_var (length lP) x)).
Proof.
  unfold consistent_lP_lpa. intros.
  apply lem_a25.
Qed.

Lemma lem_a31 : forall lP l Q (W : Set) Iv atm x (pa2 : W -> Prop),
exists (n : nat),
   @ind_gen _ pa2 (indicies_l2_pre (cap_pred lP l) Q 0)
     (vsS_pa_l Iv (FOv_att_P_l atm (cap_pred lP l))
        (list_var (length (cap_pred lP l)) x)) =
   repeat (pa_l_disj_gen Iv (FOv_att_P atm Q) x) n.
Proof.
  induction lP; intros l Q W Iv atm x pa2. exists 0. auto.
  simpl. destruct (IHlP l Q W Iv atm x pa2) as [n H].
  destruct (in_predicate_dec a l); simpl;
  destruct (predicate_dec Q a); subst; auto.
  + simpl. rewrite ind_gen_pre_cons.
    exists (S n). rewrite H. auto.
  + exists n. rewrite ind_gen_pre_cons. auto.
Qed.

Lemma lem_a30 : forall lP l Q (W : Set) Iv atm x (pa2 : W -> Prop),
is_constant (@ind_gen _ pa2 (indicies_l2 (cap_pred lP l) Q)
  (vsS_pa_l Iv (FOv_att_P_l atm (cap_pred lP l))
  (list_var (length (cap_pred lP l)) x))).
Proof.
  unfold is_constant.
  unfold indicies_l2.
  intros. exists (pa_l_disj_gen Iv (FOv_att_P atm Q) x).
  apply lem_a31.
Qed.

Lemma lem_a29 : forall lP Q l atm (W : Set) Iv pa2 x ,
@consistent_lP_lpa_P W pa2 (cap_pred lP l)
 (vsS_pa_l Iv (FOv_att_P_l atm (cap_pred lP l))
        (list_var (length (cap_pred lP l)) x)) Q.
Proof.
  unfold consistent_lP_lpa_P.
  intros.
  apply lem_a30.
Qed.

Lemma lem_a28 : forall lP l atm (W : Set) Iv pa2 x ,
@consistent_lP_lpa W pa2 (cap_pred lP l)
 (vsS_pa_l Iv (FOv_att_P_l atm (cap_pred lP l))
        (list_var (length (cap_pred lP l)) x)).
Proof.
  unfold consistent_lP_lpa.
  intros. apply lem_a29.
Qed.

Lemma lem_a21 : forall lP atm beta x W Iv Ip Ir,
AT atm = true ->
SOturnst W Iv (alt_Ip_list Ip
   (vsS_pa_l Iv (FOv_att_P_l atm lP) (list_var (length lP) x)) lP) Ir beta ->
SOturnst W Iv
  (alt_Ip_list Ip
     (vsS_pa_l Iv (FOv_att_P_l atm (cap_pred lP (preds_in beta)))
        (list_var (length (cap_pred lP (preds_in beta))) x))
     (cap_pred lP (preds_in beta))) Ir beta.
Proof.
  induction lP; intros atm beta x W Iv Ip Ir Hat SOt. auto.
  simpl in *. destruct (in_predicate_dec a (preds_in beta)).
  + simpl.
    rewrite alt_Ip__list_consistent_lP_lpa with (pa2 := pa_t).
    rewrite alt_Ip__list_consistent_lP_lpa with (pa2 := pa_t) in SOt.
    apply IHlP; try assumption.
    pose proof (lem_a27 (cons a lP)) as H. simpl in H.
    apply H.
    pose proof (lem_a28 (cons a lP) (preds_in beta) atm W Iv pa_t x) as H. simpl in H.
    rewrite in_predicate_dec_l in H; auto.
  + apply P_not_occ_alt in SOt. apply IHlP; auto. auto.
Qed.

Lemma lem_a23 : forall lP l2 atm x,
  ex_FOvar_var_ll x (FOv_att_P_l atm lP) = false ->
  ex_FOvar_var_ll x (FOv_att_P_l atm (cap_pred lP l2)) = false.
Proof.
  induction lP; intros l2 atm x Hex. auto.
  simpl in *. if_then_else_hyp_dep.
  destruct (in_predicate_dec a l2). simpl.
  dest_in_dec_blind. contradiction.
  apply IHlP; auto. apply IHlP; auto.
Qed.

Lemma alt_Ip_list_cap_pred_nil :  forall lP beta W Iv Ip Ir lpa,
  cap_pred lP (preds_in beta) = nil ->
  (SOturnst W Iv (alt_Ip_list Ip lpa lP) Ir beta <->
  SOturnst W Iv Ip Ir beta).
Proof.
  induction lP; intros beta W Iv Ip Ir lpa H.
  + rewrite alt_Ip_list_nil. apply iff_refl.
  + destruct lpa. simpl. apply iff_refl.
    simpl in H. destruct (in_predicate_dec a (preds_in beta)).
      discriminate.
    simpl. split; intros SOt.
    ++ apply P_not_occ_alt in SOt.
       apply IHlP in SOt. all : try assumption.
    ++ apply P_not_occ_alt. auto.
       apply IHlP; auto.
Qed.

Lemma length_nlist_list_pa : forall n W pa_l,
length (nlist_list_pa W n pa_l) = n.
Proof.
  induction n; intros W pa_l.
    rewrite (nlist_nil W pa_l). reflexivity.

    destruct (nlist_cons W n pa_l) as [pa [pa_l2 H2]].
    rewrite H2. simpl. rewrite IHn. reflexivity.
Qed.

Lemma lem_is_in : forall l beta,
incl
  (preds_in
     (replace_pred_l beta (list_rel_compl (preds_in beta) l)
        (nlist_list (length (list_rel_compl (preds_in beta) l))
           (nlist_var (length (list_rel_compl (preds_in beta) l)) (Var 1)))
        (nlist_list (length (list_rel_compl (preds_in beta) l))
           (nlist_empty (length (list_rel_compl (preds_in beta) l)))))) l.
Proof.
  intros l beta. intros P H.
  destruct (in_dec predicate_dec P l). auto.
 apply jj7 in H; auto. contradiction.
Qed.

Lemma is_in_pred_passing_predSO_l : forall l Q,
  ~ l = nil ->
  In Q (preds_in (passing_conj (passing_predSO_l Q l))).
Proof.
  destruct l; intros Q Hnil. contradiction.
  simpl in *. destruct (passing_predSO_l Q l); firstorder.
Qed.

Lemma in_pred_passing_predSO_l2:
  forall (l : list FOvariable) (P Q : predicate),
  l <> nil -> In P (preds_in (passing_conj (passing_predSO_l Q l))) -> P = Q.
Proof.
  induction l; intros P Q H1 H2. contradiction.
  simpl in *. destruct l; firstorder.
Qed.

Lemma lem_is_in5 : forall lP llx P,
  length lP = length llx ->
  ex_nil_in_llv llx = false ->
  In P (preds_in (passing_conj (passing_predSO_ll lP llx))) <->
  In P lP.
Proof.
  induction lP; intros llx P Hnil Hex. reflexivity.
  simpl. destruct llx. discriminate.
  simpl in *. destruct l. discriminate.
  assert (f :: l <> nil) as Hass. discriminate.
  remember (f :: l) as l'.
  destruct (predicate_dec P a). subst a.
  * split; intros H. firstorder. simpl.
    destruct (passing_predSO_ll lP llx); [|simpl; apply in_or_app;left];
    apply is_in_pred_passing_predSO_l; auto.
  * case_eq (passing_predSO_ll lP llx).
    + intros Hp. simpl. split ;intros H. right.
      apply lem_try35 in H; auto. contradiction.
       destruct H. subst. firstorder.
       eapply IHlP in H; auto. rewrite Hp in H. all : auto.
       contradiction.
    + intros beta lbeta Hlbeta.
      rewrite <- Hlbeta. simpl. rewrite Hlbeta. rewrite <- Hlbeta.
      simpl. split; intros H. apply in_app_or in H. right.
      destruct H. apply in_pred_passing_predSO_l2 in H. firstorder. auto.
      apply IHlP in H; auto.
      apply in_or_app. right. apply IHlP; auto.
      simpl in Hex.  destruct H. symmetry in H. firstorder.
      auto.
Qed.

Lemma lem_is_in4 : forall l lP llx,
  length lP = length llx ->
  ex_nil_in_llv llx = false ->
  incl l (preds_in (passing_conj (passing_predSO_ll lP llx))) <->
  incl l lP.
Proof.
  induction l; intros lP llx Hnil Hex. firstorder.
  split; intros H; apply incl_cons.
  apply incl_hd in H. apply lem_is_in5 in H; auto.
  apply incl_lcons in H. apply IHl in H; auto.
  apply incl_hd in H. apply lem_is_in5; auto.
  apply incl_lcons in H. apply IHl; auto.
Qed.

Lemma list_rel_compl_passing_predSO_ll : forall l lP llx,
length lP = length llx ->
ex_nil_in_llv llx = false ->
(list_rel_compl l (preds_in (passing_conj (passing_predSO_ll lP llx)))) =
(list_rel_compl l lP).
Proof.
  induction l; intros lP llx Hl Hex. simpl. reflexivity.
  simpl. destruct (in_predicate_dec a lP). eapply lem_is_in5 in i.
  rewrite (in_predicate_dec_l); auto. apply i.
  all : auto.
  dest_in_pred_dec_blind. apply lem_is_in5 in i; auto. contradiction.
  rewrite IHl; auto.
Qed.

Lemma lem_a32 : forall lP rel atm,
REL rel = true ->
AT atm = true ->
~ ex_att_allFO_llvar (conjSO rel atm) (FOv_att_P_l (conjSO rel atm) lP) .
Proof.
  induction lP; intros rel atm Hrel Hat H. inversion H.
  apply ex_att_allFO_llvar_conjSO in H; auto; intros H2.
  eapply ex_att_allFO_llvar_REL in H2; auto.
  eapply ex_att_allFO_llvar_AT in H2; auto.
Qed.

Lemma ex_att_exFO_lvar_REL : forall lv rel,
  REL rel = true ->
  ~ ex_att_exFO_lvar rel lv.
Proof.
  induction lv; intros rel Hrel H;
    inversion H; subst.
  apply att_exFO_var_REL in H2; auto.
  apply IHlv in H2; auto.
Qed.

Lemma ex_att_exFO_lvar_AT : forall lv rel,
  AT rel = true ->
  ~ ex_att_exFO_lvar rel lv.
Proof.
  induction lv; intros rel Hrel H;
    inversion H; subst.
  apply att_exFO_var_AT in H2; auto.
  apply IHlv in H2; auto.
Qed.

Lemma lem_a33 : forall lP rel atm,
REL rel = true ->
AT atm = true ->
~ ex_att_exFO_llvar (conjSO rel atm) (FOv_att_P_l (conjSO rel atm) lP).
Proof.
  induction lP; intros rel atm Hrel Hat HH; inversion HH;
    subst. apply ex_att_exFO_lv_conjSO_f_rev in H1; auto.
  apply ex_att_exFO_lvar_REL. assumption.
  apply ex_att_exFO_lvar_AT. assumption.
  apply IHlP in H1; auto.
Qed.


(** * Facts about default values of H-VHDL types *)

Require Import common.CoqLib.

Require Import hvhdl.SemanticalDomains.
Require Import hvhdl.DefaultValue.

Lemma ArrIsOfType_create_arr:
  forall (n : nat) (t : type) (v : value) (gt_n_O : (n > 0)%nat),
    IsOfType v t -> ArrIsOfType (create_arr n v gt_n_O) n t.
Proof.
  destruct n.
  inversion gt_n_O.
  cbn; induction n.
  constructor; assumption.
  constructor;
    [ assumption
    | apply IHn; [ lia | assumption ] ].
Qed.

Lemma DefaultV_is_well_typed :
  forall t v,
    DefaultV t v -> IsOfType v t.
Proof.
  induction 1.
  constructor.
  constructor; [assumption | inversion H; lia ].
  constructor; [assumption | ].
  revert size.
  cbv zeta.
  generalize (u - l).
  intro.
  generalize (Nat.lt_0_succ (N.to_nat n)).
  rewrite <- N2Nat.inj_succ with (a := n).
  intro.
  eapply ArrIsOfType_create_arr; assumption.
Qed.


(** * Exponential laws about the initial category *)
Require Import Category.Core Functor.Core FunctorCategory.Core Functor.Identity.
Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors InitialTerminalCategory.NaturalTransformations.
Require Import HoTT.Basics HoTT.Types.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.

(** In this file, we prove that

      - [x⁰ ≅ 1]
      - [0ˣ ≅ 0] if [x ≠ 0]
      - [0⁰ ≅ 1]
 *)

(** ** x⁰ ≅ 1 *)
Section law0.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Context `{IsTerminalCategory one}.
  Local Notation "0" := zero : category_scope.
  Local Notation "1" := one : category_scope.

  Variable C : PreCategory.

  Global Instance IsTerminalCategory_functors_from_initial
  : IsTerminalCategory (0 -> C) := {}.

  (** There is only one functor to the terminal category [1]. *)
  Definition functor : Functor (0 -> C) 1
    := center _.

  (** We have already proven in [InitialTerminalCategory.v] that [0 -> C] is a terminal category, so there is only one functor to it. *)
  Definition inverse : Functor 1 (0 -> C)
    := center _.

  (** Since the objects and morphisms in terminal categories are contractible, functors to a terminal category are also contractible, by [trunc_functor]. *)
  Definition law
  : functor o inverse = 1
    /\ inverse o functor = 1
    := center _.
End law0.

(** ** [0ˣ ≅ 0] if [x ≠ 0] *)
Section law0'.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Context `{IsTerminalCategory one}.
  Local Notation "0" := zero : category_scope.
  Local Notation "1" := one : category_scope.

  Variable C : PreCategory.
  Variable c : C.

  Local Instance IsInitialCategory_functors_to_initial_from_inhabited
  : IsInitialCategory (C -> 0)
    := fun P F => @Functors.to_initial_category_empty C _ _ F P c.

  (** There is exactly one functor from an initial category, and we proved above that if [C] is inhabited, then [C -> 0] is initial. *)
  Definition functor' : Functor (C -> 0) 0
    := center _.

  (** There is exactly one functor from the initial category [0]. *)
  Definition inverse' : Functor 0 (C -> 0)
    := center _.

  (** Since objects and morphisms in an initial category are -1-truncated, so are functors to an initial category. *)
  Definition law'
  : functor' o inverse' = 1
    /\ inverse' o functor' = 1
    := center _.
End law0'.

(** ** [0⁰ ≅ 1] *)
Section law00.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Context `{IsInitialCategory zero'}.
  Context `{IsTerminalCategory one}.
  Local Notation "0" := zero : category_scope.
  Local Notation "00" := zero' : category_scope.
  Local Notation "1" := one : category_scope.

  (** This is just a special case of the first law above. *)

  Definition functor00 : Functor (0 -> 0) 1
    := functor _.

  Definition inverse00 : Functor 1 (0 -> 0)
    := inverse _.

  Definition law00
  : functor00 o inverse00 = 1
    /\ inverse00 o functor00 = 1
    := law _.
End law00.


(** Authors Floris van Doorn, December 2017 *)

Require Import UniMath.MoreFoundations.Subtypes.
Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.Modules.Core.

(** ** Contents
- Subobjects of modules
- Kernels
- Images
*)

Definition issubsetwithsmul {R : hSet} {M : hSet} (smul : R → M → M) (A : hsubtype M) : UU :=
  ∏ r m, A m → A (smul r m).

Definition issubmodule {R : ring} {M : module R} (A : hsubtype M) : UU :=
  issubgr A × issubsetwithsmul (module_mult M) A.

Definition make_issubmodule {R : ring} {M : module R} {A : hsubtype M}
           (H1 : issubgr A) (H2 : issubsetwithsmul (module_mult M) A) : issubmodule A :=
  make_dirprod H1 H2.

Definition issubmodule_is {R : ring} {M : module R} (A : hsubtype M) : UU :=
  issubgr A × issubsetwithsmul (module_mult M) A.

Lemma isapropissubmodule {R : ring} {M : module R} (A : hsubtype M) : isaprop (issubmodule A).
Proof.
  intros. apply (isofhleveldirprod 1).
  - apply isapropissubgr.
  - apply impred. intro x.
    apply impred. intro m.
    apply impred. intro a.
    apply (pr2 (A _)).
Defined.

(* Submodules *)

Definition submodule {R : ring} (M : module R) : UU := total2 (λ A : hsubtype M, issubmodule A).

Definition make_submodule {R : ring} {M : module R} :
  ∏ (t : hsubtype M), (λ A : hsubtype M, issubmodule A) t → ∑ A : hsubtype M, issubmodule A :=
  tpair (λ A : hsubtype M, issubmodule A).

Definition submoduletosubabgr {R : ring} {M : module R} : submodule M -> @subabgr M :=
  λ A : _, make_subgr (pr1 A) (pr1 (pr2 A)).
Coercion submoduletosubabgr : submodule >-> subabgr.

Definition submodule_to_issubsetwithsmul {R : ring} {M : module R} (A : submodule M) :
  issubsetwithsmul (module_mult M) A :=
  pr2 (pr2 A).

Local Open Scope module_scope.

Definition submodule_smul {R : ring} {M : module R} {A : submodule M} (r : R) (m : A) : A.
Proof.
  use tpair.
  - exact (r * pr1 m).
  - exact (submodule_to_issubsetwithsmul A r (pr1 m) (pr2 m)).
Defined.

Definition carrierofasubmodule {R : ring} {M : module R} (A : submodule M) : module R.
Proof.
  use mult_to_module.
  - exact (carrierofasubabgr A).
  - exact (submodule_smul).
  - intros r a b. apply (invmaponpathsincl _ (isinclpr1carrier A)). apply module_mult_is_ldistr.
  - intros r s a. apply (invmaponpathsincl _ (isinclpr1carrier A)). apply module_mult_is_rdistr.
  - intros r s a. apply (invmaponpathsincl _ (isinclpr1carrier A)). apply module_mult_assoc.
  - intros f. apply (invmaponpathsincl _ (isinclpr1carrier A)). apply module_mult_unel2.
Defined.

Coercion carrierofasubmodule : submodule >-> module.
Lemma intersection_submodule {R : ring} {M : module R} {I : UU} (S : I -> hsubtype M)
      (each_is_submodule : ∏ i : I, issubmodule (S i)) :
  issubmodule (subtype_intersection S).
Proof.
  intros.
  use make_issubmodule.
  - exact (intersection_subgr S (λ i, (pr1 (each_is_submodule i)))).
  - intros r m a i. exact (pr2 (each_is_submodule i) r m (a i)).
Qed.

Lemma ismodulefun_pr1 {R : ring} {M : module R} (A : submodule M) : @ismodulefun R A M pr1.
Proof.
  use make_ismodulefun.
  exact (pr1 (ismonoidfun_pr1 A)).
  intros r a. reflexivity.
Defined.

Definition submodule_incl {R : ring} {M : module R} (A : submodule M) : modulefun A M :=
  make_modulefun _ (ismodulefun_pr1 A).

(* Kernel and image *)
Lemma issubmodule_kernel {R : ring} {A B : module R} (f : modulefun A B) :
  issubmodule (abgr_kernel_hsubtype (modulefun_to_monoidfun f)).
Proof.
  split.
  - apply abgr_Kernel_subabgr_issubgr.
  - intros r x p.
    cbn.
    rewrite (modulefun_to_islinear f).
    rewrite <- (module_mult_1 r), <- p.
    reflexivity.
Defined.

Definition module_kernel {R : ring} {A B : module R} (f : modulefun A B) : submodule A :=
  make_submodule _ (issubmodule_kernel f).

Definition module_kernel_eq {R : ring} {A B : module R} (f : modulefun A B) x :
  f (submodule_incl (module_kernel f) x) = unel B := (pr2 x).

Lemma issubmodule_image {R : ring} {A B : module R} (f : modulefun A B) :
  issubmodule (abgr_image_hsubtype (modulefun_to_monoidfun f)).
Proof.
  split.
  - apply abgr_image_issubgr.
  - intros r x. apply hinhfun. cbn. intro ap. induction ap as [a p].
    split with (r * a). now rewrite (modulefun_to_islinear f), <- p.
Defined.

Definition module_image {R : ring} {A B : module R} (f : modulefun A B) : submodule B :=
  make_submodule _ (issubmodule_image f).

Section submodule_helpers.

  Context {R : ring}
          {M : module R}
          (A : submodule M).

  Local Notation "x + y" := (@op _ x y).
  Local Notation "x - y" := (@op _ x (grinv _ y)).

  Definition submoduleadd (x y : M) : A x -> A y -> A (x + y).
  Proof.
    intros ax ay.
    exact (pr1 (pr1 (pr1 (pr2 A))) (make_carrier A x ax) (make_carrier A y ay)).
  Defined.

  Definition submodule0 : A (unel M) := pr2 (pr1 (pr1 (pr2 A))).

  Definition submoduleinv (x : M) : A x -> A (grinv _ x) := λ ax, (pr2 (pr1 (pr2 A)) x ax).

  Local Open Scope module.

  Definition submodulemult (r : R) (m : M) : A m -> A (r * m) := (pr2 (pr2 A) r m).

End submodule_helpers.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Sterbenz conditions for exact subtraction *)

Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_generic_fmt.
Require Import Fcalc_ops.

Section Fprop_Sterbenz.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { monotone_exp : Monotone_exp fexp }.
Notation format := (generic_format beta fexp).

Theorem generic_format_plus :
  forall x y,
  format x -> format y ->
  (Rabs (x + y) < bpow (Zmin (ln_beta beta x) (ln_beta beta y)))%R ->
  format (x + y)%R.
Proof.
intros x y Fx Fy Hxy.
destruct (Req_dec (x + y) 0) as [Zxy|Zxy].
rewrite Zxy.
apply generic_format_0.
destruct (Req_dec x R0) as [Zx|Zx].
now rewrite Zx, Rplus_0_l.
destruct (Req_dec y R0) as [Zy|Zy].
now rewrite Zy, Rplus_0_r.
revert Hxy.
destruct (ln_beta beta x) as (ex, Ex). simpl.
specialize (Ex Zx).
destruct (ln_beta beta y) as (ey, Ey). simpl.
specialize (Ey Zy).
intros Hxy.
set (fx := Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp ex)).
assert (Hx: x = F2R fx).
rewrite Fx at 1.
unfold canonic_exp.
now rewrite ln_beta_unique with (1 := Ex).
set (fy := Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp ey)).
assert (Hy: y = F2R fy).
rewrite Fy at 1.
unfold canonic_exp.
now rewrite ln_beta_unique with (1 := Ey).
rewrite Hx, Hy.
rewrite <- F2R_plus.
apply generic_format_F2R.
intros _.
case_eq (Fplus beta fx fy).
intros mxy exy Pxy.
rewrite <- Pxy, F2R_plus, <- Hx, <- Hy.
unfold canonic_exp.
replace exy with (fexp (Zmin ex ey)).
apply monotone_exp.
now apply ln_beta_le_bpow.
replace exy with (Fexp (Fplus beta fx fy)) by exact (f_equal Fexp Pxy).
rewrite Fexp_Fplus.
simpl. clear -monotone_exp.
apply sym_eq.
destruct (Zmin_spec ex ey) as [(H1,H2)|(H1,H2)] ; rewrite H2.
apply Zmin_l.
now apply monotone_exp.
apply Zmin_r.
apply monotone_exp.
apply Zlt_le_weak.
now apply Zgt_lt.
Qed.

Theorem generic_format_plus_weak :
  forall x y,
  format x -> format y ->
  (Rabs (x + y) <= Rmin (Rabs x) (Rabs y))%R ->
  format (x + y)%R.
Proof.
intros x y Fx Fy Hxy.
destruct (Req_dec x R0) as [Zx|Zx].
now rewrite Zx, Rplus_0_l.
destruct (Req_dec y R0) as [Zy|Zy].
now rewrite Zy, Rplus_0_r.
apply generic_format_plus ; try assumption.
apply Rle_lt_trans with (1 := Hxy).
unfold Rmin.
destruct (Rle_dec (Rabs x) (Rabs y)) as [Hxy'|Hxy'].
rewrite Zmin_l.
destruct (ln_beta beta x) as (ex, Hx).
now apply Hx.
now apply ln_beta_le_abs.
rewrite Zmin_r.
destruct (ln_beta beta y) as (ex, Hy).
now apply Hy.
apply ln_beta_le_abs.
exact Zy.
apply Rlt_le.
now apply Rnot_le_lt.
Qed.

Lemma sterbenz_aux :
  forall x y, format x -> format y ->
  (y <= x <= 2 * y)%R ->
  format (x - y)%R.
Proof.
intros x y Hx Hy (Hxy1, Hxy2).
unfold Rminus.
apply generic_format_plus_weak.
exact Hx.
now apply generic_format_opp.
rewrite Rabs_pos_eq.
rewrite Rabs_Ropp.
rewrite Rmin_comm.
assert (Hy0: (0 <= y)%R).
apply Rplus_le_reg_r with y.
apply Rle_trans with x.
now rewrite Rplus_0_l.
now rewrite Rmult_plus_distr_r, Rmult_1_l in Hxy2.
rewrite Rabs_pos_eq with (1 := Hy0).
rewrite Rabs_pos_eq.
unfold Rmin.
destruct (Rle_dec y x) as [Hyx|Hyx].
apply Rplus_le_reg_r with y.
now ring_simplify.
now elim Hyx.
now apply Rle_trans with y.
now apply Rle_0_minus.
Qed.

Theorem sterbenz :
  forall x y, format x -> format y ->
  (y / 2 <= x <= 2 * y)%R ->
  format (x - y)%R.
Proof.
intros x y Hx Hy (Hxy1, Hxy2).
destruct (Rle_or_lt x y) as [Hxy|Hxy].
rewrite <- Ropp_minus_distr.
apply generic_format_opp.
apply sterbenz_aux ; try easy.
split.
exact Hxy.
apply Rcompare_not_Lt_inv.
rewrite <- Rcompare_half_r.
now apply Rcompare_not_Lt.
apply sterbenz_aux ; try easy.
split.
now apply Rlt_le.
exact Hxy2.
Qed.

End Fprop_Sterbenz.


Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import SystemF.
Require Import Coq.Program.Equality.
Require Export Subtyping.

Module MDisjointness
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module MSubtyping := MSubtyping(VarTyp)(set).
Export MSubtyping.

(* Disjointness: Implementation *)

Definition hd (p : PTyp) : nat :=
  match p with
  | PInt       => 0
  | Fun t1 t2  => 1
  | ForAll d t => 2
  | Rec l t    => 3
  | Top        => 4
  | PBVarT n   => 5
  | PFVarT v   => 6
  | And t1 t2  => 7
  end.

Definition OrthoAx (t1 t2 : PTyp) : Prop :=
  (hd t1 < 4 /\ hd t2 < 4 /\ not (hd t1 = hd t2)).

Inductive Ortho : context TyEnvSource -> PTyp -> PTyp -> Prop :=
  | OAnd1 : forall Gamma t1 t2 t3, Ortho Gamma t1 t3 -> Ortho Gamma t2 t3 -> Ortho Gamma (And t1 t2) t3
  | OAnd2 : forall Gamma t1 t2 t3, Ortho Gamma t1 t2 -> Ortho Gamma t1 t3 -> Ortho Gamma t1 (And t2 t3)
  | OFun  : forall Gamma t1 t2 t3 t4, Ortho Gamma t2 t4 -> Ortho Gamma (Fun t1 t2) (Fun t3 t4)
  | OForAll : forall L Gamma d1 d2 t1 t2,
                (forall x, not (In x L) -> Ortho (extend x (TyDis (And d1 d2)) Gamma)
                                           (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                PType (And d1 d2) ->
                Ortho Gamma (ForAll d1 t1) (ForAll d2 t2)
  | OVar : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                       usub A ty ->
                       PType ty ->
                       Ortho Gamma (PFVarT x) ty
  | OVarSym : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                          usub A ty ->
                          PType ty ->
                          Ortho Gamma ty (PFVarT x)
  | OTop1 : forall Gamma t, Ortho Gamma Top t
  | OTop2 : forall Gamma t, Ortho Gamma t Top
  | ORecNeq : forall Gamma l1 l2 t1 t2, l1 <> l2 -> Ortho Gamma (Rec l1 t1) (Rec l2 t2)
  | ORecEq : forall Gamma l t1 t2, Ortho Gamma t1 t2 -> Ortho Gamma (Rec l t1) (Rec l t2)
  | OAx : forall Gamma t1 t2, OrthoAx t1 t2 -> Ortho Gamma t1 t2.

Hint Constructors Ortho.

(* Disjointness: Specification *)

Definition OrthoS (A B : PTyp) := not (exists C, Sub A C /\ Sub B C).

Ltac orthoax_inv H :=
  let H' := fresh in
  let m := fresh in
  let H1 := fresh in
  let H2 := fresh in
  inversion H as [H' | m H1 H2 ]; orthoax_inv H1.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t1 is not part of OrthoAx *)
Ltac orthoax_inv_l :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [H1 _]; orthoax_inv H1
  end.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t2 is not part of OrthoAx *)
Ltac orthoax_inv_r :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [_ [H1 _]]; orthoax_inv H1
  end.

(** Ortho environment properties **)

Lemma ortho_weaken :
  forall G E F t1 t2, Ortho (E ++ G) t1 t2 ->
                 Ortho (E ++ F ++ G) t1 t2.
Proof.
  intros.
  remember (E ++ G) as H'.
  generalize dependent HeqH'.
  generalize dependent E.
  dependent induction H; intros; eauto; subst.
  - apply_fresh OForAll as x.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    rewrite <- app_comm_cons.
    unfold extend; simpl; reflexivity.
    auto.
  - apply OVar with (A := A); auto.
    apply in_app_or in H; inversion H; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    apply in_app_or in H; inversion H; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_strengthen : forall z U E F ty1 ty2,
  not (In z (union (fv_ptyp ty1) (fv_ptyp ty2))) ->
  Ortho (E ++ ((z,U) :: nil) ++ F) ty1 ty2 ->
  Ortho (E ++ F) ty1 ty2.
Proof.
  intros.
  remember (E ++ ((z,U) :: nil) ++ F).

  generalize dependent Heql.
  generalize dependent E.

  induction H0; intros; auto.
  - apply OAnd1; [ apply IHOrtho1 | apply IHOrtho2 ];
    simpl in H; not_in_L z; apply Heql.
  - apply OAnd2; [ apply IHOrtho1 | apply IHOrtho2 ];
    simpl in H; not_in_L z; apply Heql.
  - apply OFun;
    apply IHOrtho; simpl in H; not_in_L z; auto.
  - apply_fresh OForAll as x.
    subst; unfold extend; simpl.
    rewrite app_comm_cons.
    eapply H1.
    not_in_L x.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.union_1 in HH.
    destruct HH as [HH | HH]; apply fv_open_rec_typ_source in HH.
    apply MSetProperties.Dec.F.union_1 in HH; simpl in HH; simpl in H.
    destruct HH as [HH | HH].
    apply H.
    apply MSetProperties.Dec.F.union_2.
    apply MSetProperties.Dec.F.union_3.
    assumption.
    not_in_L x.
    apply H16.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in HH.
    now symmetry.
    apply MSetProperties.Dec.F.union_1 in HH; simpl in HH; simpl in H.
    destruct HH as [HH | HH].
    apply H.
    apply MSetProperties.Dec.F.union_3.
    apply MSetProperties.Dec.F.union_3.
    assumption.
    not_in_L x.
    apply H16.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in HH.
    now symmetry.
    unfold extend; now simpl.
    auto.
  - subst.
    apply OVar with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H0; destruct H0; auto.
    destruct H0; auto.
    inversion H0; subst; simpl in H.
    not_in_L x.
    exfalso; apply H3.
    now apply MSetProperties.Dec.F.singleton_2.
  - subst.
    apply OVarSym with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H0; destruct H0; auto.
    destruct H0; auto.
    inversion H0; subst; simpl in H.
    not_in_L x.
    exfalso; apply H4.
    now apply MSetProperties.Dec.F.singleton_2.
  - subst.
    apply ORecEq.
    apply IHOrtho.
    simpl in *; not_in_L z.
    auto.
Qed.

Hint Resolve ortho_weaken ortho_strengthen.

Lemma ortho_extend_comm :
  forall F E x v ty1 ty2,
    Ortho (F ++ E ++ (x, v) :: nil) ty1 ty2 ->
    Ortho (F ++ (x, v) :: nil ++ E) ty1 ty2.
Proof.
  intros F E x v ty1 ty2 HOrtho.
  remember (F ++ E ++ (x, v) :: nil).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    change ((y, TyDis (And d1 d2)) :: F ++ (x, v) :: E) with
           (((y, TyDis (And d1 d2)) :: F) ++ ((x, v) :: nil) ++ E).
    apply H0.
    not_in_L y.
    unfold extend; now simpl.
    auto.
  - apply OVar with (A := A); auto.
    apply in_or_app; rewrite app_comm_cons.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    apply in_or_app; rewrite app_comm_cons.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_extend_comm' :
  forall F E x v ty1 ty2,
    Ortho (F ++ (x, v) :: nil ++ E) ty1 ty2 ->
    Ortho (F ++ E ++ (x, v) :: nil) ty1 ty2.
Proof.
  intros F E x v ty1 ty2 HOrtho.
  remember (F ++ (x, v) :: nil ++ E).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    change ((y, TyDis (And d1 d2)) :: F ++ E ++ (x, v) :: nil) with
           (((y, TyDis (And d1 d2)) :: F) ++ E ++ (x, v) :: nil).
    apply H0.
    not_in_L y.
    unfold extend; now simpl.
    auto.
  - apply OVar with (A := A); auto.
    rewrite app_comm_cons in H.
    apply in_or_app.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    rewrite app_comm_cons in H.
    apply in_or_app.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_app_comm :
  forall E F ty1 ty2, Ortho (F ++ E) ty1 ty2 -> Ortho (E ++ F) ty1 ty2.
Proof.
  intros E F ty1 ty2 HOrtho.
  remember (F ++ E).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    assert (Ha : not (In x L)) by not_in_L x.
    apply H0 with (F0 := extend x (TyDis (And d1 d2)) F) (E0 := E) in Ha.
    apply ortho_extend_comm' in Ha.
    change ((x, TyDis (And d1 d2)) :: E ++ F) with (nil ++ (x, TyDis (And d1 d2)) :: E ++ F).
    apply ortho_extend_comm with (E := E ++ F).
    simpl in *.
    rewrite <- app_assoc.
    apply Ha.
    unfold extend; now simpl.
    auto.
  - apply OVar with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H; destruct H; auto.
  - apply OVarSym with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H; destruct H; auto.
Qed.

Lemma ortho_middle_comm : forall H E F G ty1 ty2,
              Ortho (E ++ F ++ G ++ H) ty1 ty2 ->
              Ortho (E ++ G ++ F ++ H) ty1 ty2.
Proof.
  induction H; intros.
  - rewrite app_nil_r in *.
    rewrite app_assoc.
    apply ortho_app_comm.
    generalize dependent E.
    generalize dependent F.
    induction G; intros.
    + intros; rewrite app_nil_r in *; now apply ortho_app_comm.
    + intros.
      change (F ++ E ++ a :: G) with (F ++ E ++ (a :: nil) ++ G).
      destruct a.
      assert ((F ++ E ++ ((v, t0) :: nil) ++ G) = (F ++ (E ++ ((v, t0) :: nil)) ++ G))
             by now rewrite <- app_assoc.
      rewrite H0; clear H0.
      apply IHG.
      rewrite <- app_assoc.
      apply ortho_extend_comm.
      change (E ++ F ++ (v, t0) :: G) with (E ++ F ++ ((v, t0) :: nil) ++ G) in H.
      rewrite app_assoc in H.
      apply ortho_extend_comm' in H.
      now rewrite <- app_assoc in *.
  - change (E ++ G ++ F ++ a :: H) with (E ++ G ++ F ++ (a :: nil) ++ H).
    destruct a.
    assert ((E ++ G ++ F ++ ((v, t0) :: nil) ++ H) =
            (E ++ G ++ (F ++ ((v, t0) :: nil)) ++ H)) by
    now rewrite <- app_assoc.
    rewrite H1; clear H1.
    apply IHlist.
    rewrite <- app_assoc.
    rewrite app_assoc.
    apply ortho_extend_comm.
    rewrite <- app_assoc.
    rewrite <- app_assoc.
    rewrite app_assoc in H0.
    rewrite app_assoc in H0.
    change (((E ++ F) ++ G) ++ (v, t0) :: H) with
           (((E ++ F) ++ G) ++ ((v, t0) :: nil) ++ H).
    apply ortho_extend_comm' in H0.
    repeat rewrite <- app_assoc in H0.
    apply H0.
Qed.

Hint Resolve in_or_app.
Hint Resolve in_app_or.

Lemma ortho_env_comm :
  forall E F G H ty1 ty2, Ortho (E ++ F ++ G ++ H) ty1 ty2 ->
                     Ortho (E ++ G ++ F ++ H) ty1 ty2.
Proof.
  intros.
  remember (E ++ F ++ G ++ H).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  generalize dependent G.
  dependent induction H0; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl; rewrite app_comm_cons; apply H1.
    not_in_L x.
    reflexivity.
    auto.
  - apply OVar with (A := A); auto.
    repeat (apply in_app_or in H0; destruct H0); auto 10.
  - apply OVarSym with (A := A); auto.
    repeat (apply in_app_or in H0; destruct H0); auto 10.
Qed.

Lemma ortho_weaken_sub :
  forall E G x t1 t2 d1 d2,
    ~ (In x (union (dom E) (dom G))) ->
    Ortho (E ++ extend x (TyDis d1) G) t1 t2 ->
    usub d2 d1  ->
    Ortho (E ++ extend x (TyDis d2) G) t1 t2.
Proof.
  intros E G x t1 t2 d1 d2 HNotIn HOrtho Husub.
  remember (E ++ extend x (TyDis d1) G) as Gamma.
  generalize dependent HeqGamma.
  generalize dependent E.
  induction HOrtho; intros; subst; eauto.
  - apply_fresh OForAll as x.
    assert (extend y (TyDis (And d0 d3)) (E ++ extend x (TyDis d2) G) =
            (extend y (TyDis (And d0 d3)) E) ++ extend x (TyDis d2) G) by
        (unfold extend; now simpl).
    rewrite H2.
    apply H0.
    not_in_L y.
    simpl.
    unfold not; intros; apply HNotIn.
    rewrite MSetProperties.union_add in H3.
    assert (Ha : x <> y).
    not_in_L y; unfold not; intros; subst; apply H16.
    now apply MSetProperties.Dec.F.singleton_iff.
    apply MSetProperties.Dec.F.add_iff in H3.
    destruct H3; auto.
    symmetry in H3; contradiction.
    now simpl.
    auto.
  - destruct (VarTyp.eq_dec x x0); subst.
    assert (Ha : A = d1).
    apply in_app_or in H.
    destruct H.
    not_in_L x0.
    exfalso; apply H2; now apply list_impl_m in H.
    not_in_L x0.
    apply in_app_or in H.
    destruct H.
    inversion H; now inversion H4.
    exfalso; apply H3; now apply list_impl_m in H.
    subst.
    apply OVar with (A := d2); auto.
    apply in_or_app.
    right.
    now left.
    apply usub_trans with (B := d1); auto.
    apply OVar with (A := A); auto.
    apply in_app_or in H.
    destruct H; auto.
    apply in_app_or in H.
    destruct H.
    simpl in H; destruct H.
    inversion H; subst; exfalso; now apply n.
    inversion H.
    apply in_or_app; right.
    apply in_or_app; auto.
  - destruct (VarTyp.eq_dec x x0); subst.
    assert (Ha : A = d1).
    apply in_app_or in H.
    destruct H.
    not_in_L x0.
    exfalso; apply H2; now apply list_impl_m in H.
    not_in_L x0.
    apply in_app_or in H.
    destruct H.
    inversion H; now inversion H4.
    exfalso; apply H3; now apply list_impl_m in H.
    subst.
    apply OVarSym with (A := d2); auto.
    apply in_or_app.
    right.
    now left.
    apply usub_trans with (B := d1); auto.
    apply OVarSym with (A := A); auto.
    apply in_app_or in H.
    destruct H; auto.
    apply in_app_or in H.
    destruct H.
    simpl in H; destruct H.
    inversion H; subst; exfalso; now apply n.
    inversion H.
    apply in_or_app; right.
    apply in_or_app; auto.
Qed.

Lemma ortho_weaken_sub_extend :
  forall Gamma x t1 t2 d1 d2, ~ In x (dom Gamma) ->
                     Ortho (extend x (TyDis d1) Gamma) t1 t2 ->
                     usub d2 d1 ->
                     Ortho (extend x (TyDis d2) Gamma) t1 t2.
Proof.
  intros Gamma x t1 t2 d1 d2 HNotIn HOrtho Husub.
  change (extend x (TyDis d2) Gamma) with (nil ++ extend x (TyDis d2) Gamma).
  apply ortho_weaken_sub with (d1 := d1); auto.
Qed.

Lemma Ortho_sym : forall Gamma t1 t2, Ortho Gamma t1 t2 -> Ortho Gamma t2 t1.
Proof.
  intros Gamma t1 t2 HOrtho.
  induction HOrtho; eauto.
  - inversion H1; subst.
    apply_fresh OForAll as x.
    apply ortho_weaken_sub_extend with (d1 := And d1 d2).
    not_in_L x.
    apply H0.
    not_in_L x.
    apply USAnd1.
    apply USAnd3; auto.
    apply usub_refl; auto.
    apply USAnd2.
    apply usub_refl; auto.
    auto.
    auto.
  - apply OAx; auto.
    destruct H as [H1 [H2 H3]].
    unfold OrthoAx; auto.
Qed.

Lemma Ortho_usub_trans :
  forall Gamma u ty d,
    PType ty ->
    Ortho Gamma u d ->
    usub d ty ->
    Ortho Gamma u ty.
Proof.
  intros Gamma u ty d HWFty HOrtho HSub.
  generalize dependent ty.
  induction HOrtho; intros; eauto;
  try now (dependent induction HSub; eauto; inversion HWFty; subst; auto).
  - dependent induction HSub; eauto.
    inversion HWFty; subst; auto.
    inversion HWFty; subst; auto.
    inversion H1; subst.
    apply_fresh OForAll as x.
    apply ortho_weaken_sub_extend with (d1 := And d1 d2).
    not_in_L x.
    apply H0.
    not_in_L x.
    apply H7.
    not_in_L x.
    apply H3.
    not_in_L x.
    apply USAnd1.
    apply USAnd2; auto.
    apply usub_refl; auto.
    apply USAnd3; auto.
    auto.
  - pose (usub_trans _ _ _ HWFty H0 HSub).
    apply OVar with (A := A) ; auto.
  - destruct t1; destruct t2;
    try (destruct H0 as [_ [_ H0]]; exfalso; now apply H0);
    try (now orthoax_inv_r H0); try (now orthoax_inv_l H0);
    try now (induction ty; inversion HSub; subst; inversion HWFty; auto).
Qed.

(* Properties concerning substitution and sub/ortho/wf *)

Lemma ortho_subst_not_in :
  forall Gamma z u t1 t2,
    not (In z (union (fv_ptyp t1) (fv_ptyp t2))) ->
    PType u ->
    Ortho Gamma t1 t2 ->
    Ortho (subst_env Gamma z u) t1 t2.
Proof.
  intros Gamma z u t1 t2 HNotIn HWFu HOrtho.
  generalize dependent z.
  induction HOrtho; intros z HNotIn; simpl in HNotIn; auto.
  - apply OAnd1; [ apply IHHOrtho1 | apply IHHOrtho2 ]; auto; not_in_L z;
    now inversion HWFt1.
  - apply OAnd2; [ apply IHHOrtho1 | apply IHHOrtho2 ]; auto; not_in_L z;
    now inversion HWFt2.
  - apply OFun; apply IHHOrtho; auto; not_in_L z.
  - assert (Ha : Ortho (subst_env Gamma z u) (ForAll (subst_typ_source z u d1) t1)
                       (ForAll (subst_typ_source z u d2) t2)).
    apply_fresh OForAll as x. apply H0. not_in_L x.
    unfold not; intros HH; rewrite union_spec in HH; destruct HH as [HH | HH];
    apply fv_open_rec_typ_source in HH; simpl in HH; rewrite union_spec in HH;
    destruct HH as [HH | HH]; try (now not_in_L z);
    not_in_L x; apply H11; apply MSetProperties.Dec.F.singleton_iff;
    apply MSetProperties.Dec.F.singleton_iff in HH; auto.
    apply PType_And.
    apply subst_source_lc; inversion H1; subst; auto.
    apply subst_source_lc; inversion H1; subst; auto.
    assert (Ha1 : d1 = subst_typ_source z u d1) by
        (rewrite subst_typ_source_fresh; auto; not_in_L z).
    assert (Ha2 : d2 = subst_typ_source z u d2) by
        (rewrite subst_typ_source_fresh; auto; not_in_L z).
    now rewrite Ha1, Ha2.
  - apply OVar with (A := subst_typ_source z u A); auto.
    apply in_persists_subst_env; auto.
    apply usub_subst_not_in; auto.
    not_in_L z.
  - apply OVarSym with (A := subst_typ_source z u A); auto.
    apply in_persists_subst_env; auto.
    apply usub_subst_not_in; auto.
    not_in_L z.
  - apply ORecEq.
    apply IHHOrtho.
    not_in_L z.
Qed.

Lemma ortho_subst :
  forall z u Gamma d t1 t2,
    not (In z (fv_ptyp u)) ->
    WFEnv (subst_env Gamma z u) ->
    WFEnv Gamma ->
    MapsTo Gamma z d ->
    Ortho Gamma u d ->
    Ortho Gamma t1 t2 ->
    PType u ->
    PType t1 ->
    PType t2 ->
    Ortho (subst_env Gamma z u) (subst_typ_source z u t1) (subst_typ_source z u t2).
Proof.
  intros z u Gamma d t1 t2 HNotIn HWFEnvS HWFEnv HMapsTo HOrthoud HOrthot1t2 HWFu HWFt1 HWFt2.
  induction HOrthot1t2.
  - simpl; inversion HWFt1; auto.
  - simpl; inversion HWFt2; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst.
    apply_fresh OForAll as x.
    repeat rewrite subst_typ_source_open_source_var.
    simpl in H0.
    apply H0.
    not_in_L x.
    apply WFPushV; auto.
    simpl.
    not_in_L x.
    apply fv_subst_source in H6; rewrite union_spec in H6; destruct H6; not_in_L x.
    apply fv_subst_source in H6; rewrite union_spec in H6; destruct H6; not_in_L x.
    rewrite dom_subst_id; not_in_L x.
    apply WFPushV; auto; not_in_L x.
    simpl in H6; rewrite union_spec in H6; destruct H6; not_in_L x.
    apply MapsTo_extend; auto.
    not_in_L x.
    rewrite <- app_nil_l with (l := (extend x (TyDis (And d1 d2)) Gamma)).
    apply ortho_weaken.
    now simpl.
    apply H5.
    not_in_L x.
    apply H9.
    not_in_L x.
    not_in_L x.
    assumption.
    not_in_L x.
    assumption.
    apply PType_And; apply subst_source_lc; auto.
  - assert (Ha : sumbool (x = z) (not (x = z))) by apply VarTyp.eq_dec.
    destruct Ha as [Ha | Ha].
    + assert (HWFEnv' : WFEnv Gamma) by assumption.
      assert (Ha1 : A = d) by (subst; eapply MapsTo_In_eq with (Gamma := Gamma); eauto).
      subst; simpl; rewrite EqFacts.eqb_refl.
      assert (Ha2 : not (In z (fv_ptyp d))) by
          (apply not_in_wfenv with (Gamma := Gamma); auto).
      apply Ortho_usub_trans with (d := subst_typ_source z u d).
      now apply subst_source_lc.
      rewrite subst_typ_source_fresh; auto.
      apply ortho_subst_not_in; auto.
      not_in_L z.
      apply usub_subst; auto.
    + simpl; apply EqFacts.eqb_neq in Ha; rewrite Ha.
      apply OVar with (A := subst_typ_source z u A); auto.
      apply in_persists_subst_env; auto.
      apply usub_subst; auto.
      now apply subst_source_lc.
  - assert (Ha : sumbool (x = z) (not (x = z))) by apply VarTyp.eq_dec.
    destruct Ha as [Ha | Ha].
    + assert (HWFEnv' : WFEnv Gamma) by assumption.
      assert (Ha1 : A = d) by (subst; eapply MapsTo_In_eq with (Gamma := Gamma); eauto).
      subst; simpl; rewrite EqFacts.eqb_refl.
      apply Ortho_sym.
      assert (Ha2 : not (In z (fv_ptyp d))) by
          (apply not_in_wfenv with (Gamma := Gamma); auto).
      apply Ortho_usub_trans with (d := subst_typ_source z u d).
      now apply subst_source_lc.
      rewrite subst_typ_source_fresh; auto.
      apply ortho_subst_not_in; auto.
      not_in_L z.
      apply usub_subst; auto.
    + simpl; apply EqFacts.eqb_neq in Ha; rewrite Ha.
      apply OVarSym with (A := subst_typ_source z u A); auto.
      apply in_persists_subst_env; auto.
      apply usub_subst; auto.
      now apply subst_source_lc.
  - simpl; apply OTop1.
  - simpl; apply OTop2.
  - simpl; inversion HWFt1; inversion HWFt2; subst; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst; auto.
  - apply OAx; auto.
    assert (Ha : OrthoAx t1 t2) by assumption.
    destruct t1; destruct t2; auto; simpl; try (now orthoax_inv_r H0);
    try now orthoax_inv_l H0.
Qed.

End MDisjointness.


Add LoadPath "../from_compcert".
Require Import Libs.
(*Require Import Floats.*)
Require Import AST.
Require Import Setoid.
Require Import ArithClasses.
Require Import Memory.
Require Import Instructions.
Require Import Bounds.

Parameter ocaml_string: Type.
Extract Constant ocaml_string =>
  "string".

Set Implicit Arguments.

Module BM := BMem(ZNum).

Module Instructions <:INSTRS(ZNum) with Definition Value := BM.Value.
  Module T := Tools(ZNum).
  Import T.

  (* The values of the language *)
  Definition Value := BM.Value.

  Inductive Binary_opp:=
  | BO_add
  | BO_mul
  | BO_sub
  | BO_div.

  Inductive Expression (n:nat) : Type :=
  | Exp_const: ZVector (S n) -> Expression n
  | Exp_loc: Array_Id * list (ZVector (S n)) -> Expression n
  | Exp_bin: Expression n -> Binary_opp -> Expression n -> Expression n
  | Exp_opp: Expression n -> Expression n.

  Record Instruction': Type :=
    { context_size: nat;
      write_loc: Array_Id * list (ZVector (S context_size));
      body: Expression context_size;
      (* what follows is here for pretty printing reasons *)
      instr_loop_vars : list ocaml_string;
      instr_body_string: ocaml_string
    }.

  Definition Instruction := Instruction'.

  Fixpoint exp_read_locs {n} (exp: Expression n) :=
    match exp with
      | Exp_const _ => []
      | Exp_loc loc => [loc]
      | Exp_bin l _ r => exp_read_locs l ++ exp_read_locs r
      | Exp_opp e => exp_read_locs e
    end.

  Definition read_locs instr:=
    exp_read_locs (body instr).

  Definition eval_bin_opp opp arg1 arg2 :=
    match opp with
    | BO_add => Some (arg1 + arg2)
    | BO_mul => Some (arg1 * arg2)
    | BO_sub => Some (arg1 - arg2)
    | BO_div => if arg2 == 0 then None else Some (arg1 / arg2)
  end.

  Fixpoint eval_exp {n}  ectxt (exp: Expression n) rvals :
    option (Value * list Value):=
    match exp with
    | Exp_const v => Some (〈v, ectxt〉, rvals)
    | Exp_loc _ =>
      match rvals with
      | [] => None
      | z :: rvals' =>
        Some (z, rvals')
      end
    | Exp_bin l opp r =>
      do{;
        (zl, rvals1) <- eval_exp ectxt l rvals;;
        (zr, rvals2) <- eval_exp ectxt r rvals1;;
        res <- eval_bin_opp opp zl zr;
        Some (res, rvals2)
      }
    | Exp_opp e =>
      do (res, rvals') <- eval_exp ectxt e rvals;
      Some (- res, rvals')
    end.

  Definition semantics (instr:Instruction) ctxt rvals res : Prop :=
    eval_exp (1:::ctxt) instr.(body) rvals = Some(res, []).

  Lemma semantics_deterministic:
    forall i v lv val1 val2,
      semantics i v lv val1 -> semantics i v lv val2 -> val1 = val2.
  Proof.
    unfold semantics; intros; congruence.
  Qed.
End Instructions.