(*This files are the defintions and lemmas about general SN model*)
Require Export basic ZF SN_CC_Real ZFuniv_real.
Module Lc := Lambda.

Reserved Notation "[ x , t ] \real A" (at level 60).

(***************************************************************************************)
(*This following lemmas should be put in ObjectSN, about properties of lift and subst*)
(***************************************************************************************)

Lemma lift_rec_acc : forall t m n p q,
  q <= p <= n + q  ->
  eq_term (lift_rec m p (lift_rec n q t)) (lift_rec (m+n) q t).
intros; apply eq_term_intro; intros; [| |destruct t; simpl; trivial].
 do 3 rewrite int_lift_rec_eq. unfold V.lams, V.shift. apply int_morph; [reflexivity|].
  do 2 red; intros. destruct (le_gt_dec q a) as [le|gt].
   replace (q+(n+(a-q))) with (n+a) by omega.
   destruct (le_gt_dec p (n+a)) as [le'|gt]; [|omega].
    replace (p+(m+(n+a-p))) with (m+n+a) by omega.
    replace (q+(m+n+(a-q))) with (m+n+a) by omega. reflexivity.

   destruct (le_gt_dec p a) as [le|gt']; [omega|reflexivity].

 do 3 rewrite tm_lift_rec_eq. unfold I.lams, I.shift. apply tm_morph; [reflexivity|].
  do 2 red; intros. destruct (le_gt_dec q a) as [le|gt].
   replace (q+(n+(a-q))) with (n+a) by omega.
   destruct (le_gt_dec p (n+a)) as [le'|gt]; [|omega].
    replace (p+(m+(n+a-p))) with (m+n+a) by omega.
    replace (q+(m+n+(a-q))) with (m+n+a) by omega. reflexivity.

   destruct (le_gt_dec p a) as [le|gt']; [omega|reflexivity].
Qed.

Lemma lift_rec_comm : forall t m n p q,
  p <= q ->
  eq_term (lift_rec m p (lift_rec n q t)) (lift_rec n (m+q) (lift_rec m p t)).
intros; apply eq_term_intro; intros; [| |destruct t; simpl; trivial].
 do 4 rewrite int_lift_rec_eq. unfold V.lams, V.shift. apply int_morph; [reflexivity|].
  do 2 red; intros. destruct (le_gt_dec q a) as [le|gt].
   replace (q+(n+(a-q))) with (n+a) by omega.
   destruct (le_gt_dec p (n+a)) as [le'|gt]; [|omega].
    destruct (le_gt_dec p a) as [le''|gt]; [|omega].
     replace (p+(m+(a-p))) with (m+a) by omega.
     destruct (le_gt_dec (m+q) (m+a)) as [le'''|gt]; [|omega].
      replace (p+(m+(n+a-p))) with (m+n+a) by omega.
      replace (m+q+(n+(m+a-(m+q)))) with (m+n+a); [reflexivity|omega].

   destruct (le_gt_dec p a) as [le|gt'].
    replace (p+(m+(a-p))) with (m+a) by omega.
    destruct (le_gt_dec (m+q) (m+a)) as [le'|gt']; [omega|reflexivity].

    destruct (le_gt_dec (m+q) a) as [le|gt'']; [omega|reflexivity].

 do 4 rewrite tm_lift_rec_eq. unfold I.lams, I.shift. apply tm_morph; [reflexivity|].
  do 2 red; intros. destruct (le_gt_dec q a) as [le|gt].
   replace (q+(n+(a-q))) with (n+a) by omega.
   destruct (le_gt_dec p (n+a)) as [le'|gt]; [|omega].
    destruct (le_gt_dec p a) as [le''|gt]; [|omega].
     replace (p+(m+(a-p))) with (m+a) by omega.
     destruct (le_gt_dec (m+q) (m+a)) as [le'''|gt]; [|omega].
      replace (p+(m+(n+a-p))) with (m+n+a) by omega.
      replace (m+q+(n+(m+a-(m+q)))) with (m+n+a); [reflexivity|omega].

   destruct (le_gt_dec p a) as [le|gt'].
    replace (p+(m+(a-p))) with (m+a) by omega.
    destruct (le_gt_dec (m+q) (m+a)) as [le'|gt']; [omega|reflexivity].

    destruct (le_gt_dec (m+q) a) as [le|gt'']; [omega|reflexivity].
Qed.

Lemma subst_lift_ge : forall m n t u k,
  m >= n + k ->
  eq_term (subst_rec t (S m) (lift_rec (S n) k u))
         (lift_rec 1 k (subst_rec t m (lift_rec n k u))).
intros; apply eq_term_intro; simpl; intros; [| |destruct u; simpl; trivial].
 rewrite int_lift_rec_eq.
 do 2 rewrite int_subst_rec_eq. do 2 rewrite int_lift_rec_eq.
 apply int_morph; [reflexivity | do 2 red; intros].
  unfold V.lams, V.shift.
  destruct (le_gt_dec k a).
   replace (k+(S n + (a-k))) with (S n + a) by omega.
   destruct (le_gt_dec (S m) (S n + a)) as [le|gt];
     replace (k+(n+(a-k))) with (n+a) by omega.
    destruct (le_gt_dec m (n+a)) as [le'|gt]; [|omega].
     apply V.cons_morph; [apply int_morph; [reflexivity|do 2 red; intros]|do 2 red; intros];
       (destruct (le_gt_dec k (m+a0)) as [le''|gt]; [|omega]);
       (replace (k+(1+(m+a0-k))) with (S m + a0); [reflexivity|omega]).

    destruct (le_gt_dec m (n+a)) as [le|gt']; [omega|].
     destruct (le_gt_dec k (n+a)) as [le|gt'']; [|omega].
      replace (k+(1+(n+a-k))) with (S n + a); [reflexivity|omega].

   destruct (le_gt_dec (S m) a) as [le|gt]; [omega|].
    destruct (le_gt_dec m a) as [le|gt']; [omega|reflexivity].

 rewrite tm_lift_rec_eq.
 do 2 rewrite tm_subst_rec_eq. do 2 rewrite tm_lift_rec_eq.
 apply tm_morph; [reflexivity|do 2 red; intros].
  unfold I.lams, I.shift.
  destruct (le_gt_dec k a).
   replace (k+(S n + (a-k))) with (S n + a) by omega.
   destruct (le_gt_dec (S m) (S n + a)) as [le|gt];
     replace (k+(n+(a-k))) with (n+a) by omega.
    destruct (le_gt_dec m (n+a)) as [le'|gt]; [|omega].
     apply I.cons_morph; [apply tm_morph; [reflexivity|do 2 red; intros]|do 2 red; intros];
       (destruct (le_gt_dec k (m+a0)) as [le''|gt]; [|omega]);
       (replace (k+(1+(m+a0-k))) with (S m + a0); [reflexivity|omega]).

    destruct (le_gt_dec m (n+a)) as [le|gt']; [omega|].
     destruct (le_gt_dec k (n+a)) as [le|gt'']; [|omega].
      replace (k+(1+(n+a-k))) with (S n + a); [reflexivity|omega].

   destruct (le_gt_dec (S m) a) as [le|gt]; [omega|].
    destruct (le_gt_dec m a) as [le|gt']; [omega|reflexivity].
Qed.

Lemma subst_lift_lt : forall m n t u,
  m <= n ->
  eq_term (subst_rec t m (lift (S n) u)) (lift n u).
intros; apply eq_term_intro; simpl; intros; [| |destruct u; simpl; trivial].
 unfold lift. rewrite int_subst_rec_eq. do 2 rewrite int_lift_rec_eq.
 do 2 rewrite V.lams0. unfold V.lams, V.shift; simpl.
 apply int_morph; [reflexivity|do 2 red; intros].
  destruct (le_gt_dec m (S (n + a))) as [le|gt]; [|omega].
  destruct m; simpl; [reflexivity|].
   case_eq (n + a - m); intros; simpl;
     [|replace (S (m + n0)) with (n + a); [reflexivity|]]; omega.

 unfold lift. rewrite tm_subst_rec_eq. do 2 rewrite tm_lift_rec_eq.
 do 2 rewrite I.lams0. unfold I.lams, I.shift; simpl.
 apply tm_morph; [reflexivity|do 2 red; intros].
  destruct (le_gt_dec m (S (n + a))) as [le|gt]; [|omega].
  destruct m; simpl; [reflexivity|].
   case_eq (n + a - m); intros; simpl;
     [|replace (S (m + n0)) with (n + a); [reflexivity|]]; omega.
Qed.

Lemma subst0_lift : forall A n,
  eq_term (subst (Ref 0) (lift_rec (S n) 1 A)) (lift_rec n 1 A).
 intros A n; apply eq_term_intro.
  red; intros i0. rewrite <- int_subst_eq. do 2 rewrite int_lift_rec_eq; simpl.
  assert (eq_val (V.cons (i0 0) (V.shift 1 i0)) i0).
   apply V.cons_ext; reflexivity. rewrite <- H at 3.
  rewrite <- V.cons_lams; [|do 2 red; intros; rewrite H0; reflexivity].
  rewrite <- V.cons_lams; [|do 2 red; intros; rewrite H0; reflexivity].
  do 2 rewrite V.lams0. rewrite V.shiftS_split; reflexivity.

  intros j0. rewrite tm_lift_rec_eq. rewrite tm_subst_eq; simpl.
  rewrite <-tm_subst_cons. rewrite tm_lift_rec_eq.
  assert (Lc.eq_intt (I.cons (j0 0) (I.shift 1 j0)) j0).
   apply I.cons_ext; reflexivity. rewrite <- H at 3.
  rewrite <- I.cons_lams; [|do 2 red; intros; rewrite H0; reflexivity].
  rewrite <- I.cons_lams; [|do 2 red; intros; rewrite H0; reflexivity].
  do 2 rewrite I.lams0. rewrite I.shiftS_split; trivial.

  destruct A; simpl; trivial.
Qed.

Lemma eq_term_lift_ref_bd : forall n i k,
  k > i ->
  eq_term (lift_rec n k (Ref i)) (Ref i).
intros; simpl; split; red; intros.
 unfold V.lams, V.shift. destruct (le_gt_dec k i); [omega|apply H0].

 unfold I.lams, I.shift. destruct (le_gt_dec k i); [omega|apply H0].
Qed.

Definition closed_term t := forall i1 i2, int i1 t == int i2 t.

(***************************************************************************************)
(*This following lemmas should be put in GenRealSN*)
(***************************************************************************************)

Lemma red_typ : forall e i j M T,
  val_ok e i j -> typ e M T -> T <> None ->
  M <> None /\ [int M i, tm M j] \real int T i.
intros e i j M T val_ok_e typ_M some_T.
red in typ_M; specialize typ_M with (1:=val_ok_e).
destruct typ_M as (some_M, hyp).
split; trivial.
 destruct T; trivial.
  elim some_T; trivial.
Qed.

Lemma real_morph : forall x y u v A B,
  x == y ->
  A == B ->
  u = v ->
  ([x, u] \real A <-> [y, v] \real B).
split; intros; destruct H2; unfold inX in H2.
 split; [unfold inX | rewrite <- H1]; rewrite <- H, <- H0; trivial.

 split; [unfold inX | rewrite H1]; rewrite H, H0; trivial.
Qed.

Lemma typ_subst : forall A B C D e,
  A <> kind ->
  C <> kind ->
  typ (A::e) B (lift 1 C) ->
  typ e D A ->
  typ e (subst D B) C.
red; intros A B C D e HA HC HB HD i j Hok.
apply red_typ with (1:=Hok) in HD; [destruct HD as (_, HD)|trivial].
assert (val_ok (A::e) (V.cons (int D i) i) (I.cons (tm D j) j)) by
  (apply vcons_add_var; trivial).
apply red_typ with (1:=H) in HB;
  [destruct HB as (HSB, HB)|destruct C; [discriminate|trivial]].
apply in_int_intro; [destruct B; [discriminate|]| |]; trivial.
revert HB; apply real_morph.
 rewrite int_subst_eq; reflexivity.

 rewrite int_cons_lift_eq; reflexivity.

 rewrite tm_subst_eq; rewrite tm_subst_cons; trivial.
Qed.

Lemma weakening_bind : forall A B e C D,
  typ (C :: e) A D ->
  typ ((lift 1 C) :: B :: e) (lift_rec 1 1 A) (lift_rec 1 1 D).
red; intros A B e C D HA i j Hok.
assert (val_ok (C :: e) (V.lams 1 (V.shift 1) i) (I.lams 1 (I.shift 1) j)).
 red in Hok |- *; intros. destruct n.
  simpl in H. injection H; clear H; intros H; subst T.
  assert (value (lift 1 C) = value (lift 1 C)) by trivial.
  specialize Hok with (n:=0) (T:=(lift 1 C)) (1:=H). clear H.
  destruct C; destruct Hok as (_, Hok).
   do 4 red in Hok. split; [discriminate|do 2 red].
   simpl int in Hok |- *. simpl tm in Hok |- *.
   do 2 rewrite V.lams0 in Hok. rewrite V.lams0. rewrite V.lams_shift. exact Hok.

   split; [discriminate|simpl tm; trivial].

  specialize Hok with (n:=(S (S n))) (T:=T) (1:=H); clear H.
  destruct Hok as (_, Hok). split; [discriminate|].
  destruct T; [do 2 red in Hok|-*|do 2 red in Hok |-*].
   simpl int in Hok |- *. simpl tm in Hok |- *.
   rewrite V.lams0 in Hok |- *. rewrite V.shiftS_split.
   rewrite V.lams_shift. do 2 rewrite <- V.shiftS_split.
   revert Hok; apply real_morph; [|reflexivity|].
    unfold V.lams, V.shift; simpl.
    replace (n-0) with n; [reflexivity|omega].

    unfold I.lams, I.shift; simpl.
    replace (n-0) with n; [reflexivity|omega].

   rewrite kind_ok_lift with (k:=0).
   rewrite eq_term_lift_ref_fv; [|omega].
   unfold I.lams, I.shift; simpl in Hok |- *.
   replace (n-0) with n; [trivial|omega].

red in HA. specialize HA with (1:=H). clear H.
destruct HA as (HSA, HA).
split; [case_eq A; intros; [discriminate|contradiction]|clear HSA].
destruct D; rewrite tm_lift_rec_eq;
  [red; do 2 rewrite int_lift_rec_eq|red; rewrite <- kind_ok_lift]; trivial.
Qed.

(***************************************************************************************)
(*This following definition should be in Lambda.v*)
(***************************************************************************************)
Definition closed_pure_term t := forall k, ~ Lc.occur k t.

(***************************************************************************************)
(*This following lemma should be in SATnat.v.*)
(*For any natural number, there exists a closed realizer*)
(***************************************************************************************)
Require Import SN_nat.

(*Require Import SATnat.*)

Import ZFnats Sat SAT_nat.

(*Import ZFind_nat.*)

Lemma inSAT_n : forall n, n ∈ N -> exists t, inSAT t (cNAT n) /\ closed_pure_term t.
intros. pattern n; apply N_ind; trivial; intros.
 destruct H2 as (t, (HinSAT, Hclsd)).
 exists t; split;[revert HinSAT; apply cNAT_morph; auto with *|trivial].

 exists ZE. split; [apply cNAT_ZE|unfold closed_pure_term].
  intros k HF. inversion_clear HF. inversion_clear H0. inversion_clear H1.

 destruct H1 as (t, (HinSAT, Hclsd)); exists (Lc.App SU t).
 split; [apply cNAT_SU; trivial|unfold closed_pure_term in Hclsd |- *].
  intros k HF. inversion_clear HF.
   inversion_clear H1. inversion_clear H2. inversion_clear H1. inversion_clear H2.
    inversion_clear H1; inversion_clear H2.

    inversion_clear H1; inversion_clear H2; inversion_clear H1.

   apply Hclsd in H1; trivial.
Qed.


Require Import Recdef.
Require Import NArith.
Require Import GeoCoq.Utils.sets.

Module SSWP := WPropertiesOn SetOfSetsOfPositiveOrderedType SS.

Module SSWEqP := WEqPropertiesOn SetOfSetsOfPositiveOrderedType SS.

Module SPWEqP := WEqPropertiesOn SetOfPairsOfPositiveOrderedType SP.

Definition pick_line (s : SS.elt) (sp : SP.t) :=
  SP.exists_ (fun p => (S.mem (fstpp p) s) && (S.mem (sndpp p) s)) sp.

Lemma proper_00 : forall s,
  Proper
  ((fun t1 t2 : SetOfPairsOfPositiveOrderedType.t =>
    Pos.eq (fstpp t1) (fstpp t2) /\ Pos.eq (sndpp t1) (sndpp t2)) ==> eq)
  (fun p : SP.elt =>
   S.mem (fstpp p) s && S.mem (sndpp p) s).
Proof.
intros s x y Hxy.
destruct Hxy as [Hxyfst Hxysnd].
rewrite Hxyfst.
rewrite Hxysnd.
reflexivity.
Qed.

Lemma proper_0 :
  Proper (S.Equal ==> eq ==> eq) pick_line.
Proof.
intros x1 y1 HXY1.
intros x2 y2 HXY2.
unfold pick_line; unfold SP.exists_; unfold SP.Raw.exists_.
rewrite HXY2.
induction (SP.this y2); try intuition.

  assert (HEqMem : forall e, S.mem e x1 = S.mem e y1)
    by (intro; apply SWP.Dec.F.mem_m; intuition).
  assert (HEqAI : (S.mem (fstpp a) x1 && S.mem (sndpp a) x1) =
                  (S.mem (fstpp a) y1 && S.mem (sndpp a) y1))
    by (rewrite HEqMem; rewrite HEqMem; intuition).
  rewrite HEqAI.
  induction (S.mem (fstpp a) y1 && S.mem (sndpp a) y1);
    intuition.
Qed.

Lemma proper_1 : forall s1 sp,
  Proper (S.Equal ==> eq)
  (fun s2 : SS.elt => pick_line (S.inter s1 s2) sp).
Proof.
intros s1 sp.
intros x y HXY.
assert (HEqI : S.Equal (S.inter s1 x) (S.inter s1 y))
  by (apply SWP.inter_equal_2; assumption).
apply proper_0; auto.
Qed.

Definition exists_witness (f : SS.elt -> bool) (s : SS.t) : option SS.elt :=
  SS.choose (SS.filter f s).

Lemma exists_witness_ok : forall e f s,
  Proper (S.Equal ==> eq) f ->
  exists_witness f s = Some e -> SS.In e s.
Proof.
intros e f s HP H.
unfold exists_witness in H.
apply SSWEqP.MP.Dec.F.mem_2.
apply SSWEqP.choose_mem_1 in H.
rewrite SSWEqP.filter_mem in H; try assumption.
apply andb_true_iff in H.
induction H.
assumption.
Qed.

Definition pick_lines_aux (s1 : SS.elt)
                          (ss : SS.t)
                          (sp : SP.t)
                          : (option (SS.elt * SS.elt)) :=
  match ((exists_witness (fun s2 => let i := S.inter s1 s2 in
                                    pick_line i sp)) ss) with
    | None => None
    | Some s2 => Some(s1,s2)
  end.

Definition pick_lines (ss : SS.t) (sp : SP.t)
                      : (option (SS.elt * SS.elt)) :=
  match (exists_witness (fun s =>
                           match (pick_lines_aux s (SS.remove s ss) sp) with
                             | None => false
                             | _ => true
                           end) ss) with
    | None => None
    | Some s1 => pick_lines_aux s1 (SS.remove s1 ss) sp
  end.

Definition eqop (p1 p2 : option SS.elt) :=
  match p1,p2 with
    | None, None => True
    | Some s1, Some s2 => True
    | _, _ => False
  end.

Lemma proper_2 : forall (f1 f2 : SS.elt -> bool) (s1 s2 : SS.t),
  Proper (S.Equal ==> eq) f1 ->
  Proper (S.Equal ==> eq) f2 ->
  (forall x, f1 x = f2 x) ->
  SS.Equal s1 s2 ->
  eqop (exists_witness f1 s1) (exists_witness f2 s2).
Proof.
intros f1 f2 s1 s2.
intros H1 H2 H3 H4.
unfold eqop.
unfold exists_witness in *.
assert (SS.Equal (SS.filter f1 s1) (SS.filter f2 s2)) by (apply SSWEqP.MP.Dec.F.filter_ext; assumption).
case_eq (SS.choose (SS.filter f1 s1)); case_eq (SS.choose (SS.filter f2 s2)).

  intuition.

  intros HCN e HCS.
  apply SS.choose_spec1 in HCS.
  apply SS.choose_spec2 in HCN.
  rewrite H in HCS.
  apply SSWEqP.MP.empty_is_empty_1 in HCN.
  rewrite HCN in HCS.
  rewrite <- SSWEqP.MP.Dec.F.empty_iff.
  eassumption.

  intros e HCS HCN.
  apply SS.choose_spec1 in HCS.
  apply SS.choose_spec2 in HCN.
  rewrite H in HCN.
  apply SSWEqP.MP.empty_is_empty_1 in HCN.
  rewrite HCN in HCS.
  rewrite <- SSWEqP.MP.Dec.F.empty_iff.
  eassumption.

  intuition.
Qed.

Definition eqopp (p1 p2 : option (SS.elt * SS.elt)) :=
  match p1,p2 with
    | None, None => True
    | Some s1, Some s2 => True
    | _, _ => False
  end.

Lemma proper_3 : Proper (S.Equal ==> SS.Equal ==> eq ==> eqopp) pick_lines_aux.
Proof.
intros x1 y1 HXY1.
intros x2 y2 HXY2.
intros x3 y3 HXY3.
unfold pick_lines_aux.
rewrite HXY3.
assert (eqop (exists_witness (fun s2 : SS.elt => pick_line (S.inter x1 s2) y3) x2)
             (exists_witness (fun s2 : SS.elt => pick_line (S.inter y1 s2) y3) y2)).

  apply proper_2.

    apply proper_1.

    apply proper_1.

    intro; apply proper_0; try reflexivity.

      apply SWP.inter_equal_1; assumption.

      assumption.

case_eq (exists_witness (fun s2 : SS.elt => pick_line (S.inter y1 s2) y3) y2);
case_eq (exists_witness (fun s2 : SS.elt => pick_line (S.inter x1 s2) y3) x2).

  simpl; intuition.

  intros HCN e HCS.
  simpl in *.
  rewrite HCS in H; rewrite HCN in H.
  simpl in *.
  intuition.

  intros e HCS HCN.
  simpl in *.
  rewrite HCS in H; rewrite HCN in H.
  simpl in *.
  intuition.

  intuition.
Qed.

Lemma pick_lines_ok_1 : forall s1 s2 ss sp,
  pick_lines ss sp = Some(s1,s2) ->
  SS.In s1 ss.
Proof.
intros s1 s2 ss sp H.
unfold pick_lines in H.
case_eq (exists_witness (fun s : SS.elt => match pick_lines_aux s
                          (SS.remove s ss) sp with | Some _ => true | None => false end) ss).

  intros e1 HEW1.
  rewrite HEW1 in H.
  unfold pick_lines_aux in H.
  case_eq (exists_witness (fun s2 : SS.elt => pick_line (S.inter e1 s2) sp) (SS.remove e1 ss)).

    intros e2 HEW2.
    rewrite HEW2 in H.
    assert (HEq1 : e1 = s1) by (injection H; intros; assumption).
    rewrite HEq1 in *.
    assert (HEq2 : e2 = s2) by (injection H; intros; assumption).
    rewrite HEq2 in *.
    apply exists_witness_ok with (fun s : SS.elt =>
      match pick_lines_aux s (SS.remove s ss) sp with | Some _ => true | None => false end).
    intros x y HXY.
    assert (SS.Equal (SS.remove x ss) (SS.remove y ss))
      by (apply SSWP.Dec.F.remove_m; try assumption; reflexivity).
    assert (eqopp (pick_lines_aux x (SS.remove x ss) sp) (pick_lines_aux y (SS.remove y ss) sp)).
    apply proper_3; auto.
    case_eq (pick_lines_aux x (SS.remove x ss) sp);
      intros;
      case_eq (pick_lines_aux y (SS.remove y ss) sp);
      intros.
      reflexivity.

      rewrite H2 in H1; rewrite H3 in H1.
      unfold eqop in H1; simpl in H1.
      intuition.
      rewrite H2 in H1; rewrite H3 in H1.
      unfold eqop in H1; simpl in H1.
      intuition.
      reflexivity.

    assumption.

    intro HEW2.
    rewrite HEW2 in H.
    discriminate.

  intro HEW.
  rewrite HEW in H.
  discriminate.
Qed.

Lemma pick_lines_ok_2 : forall s1 s2 ss sp,
  pick_lines ss sp = Some(s1,s2) ->
  SS.In s2 (SS.remove s1 ss).
Proof.
intros s1 s2 ss sp H.
unfold pick_lines in H.
case_eq (exists_witness (fun s : SS.elt => match pick_lines_aux s
                          (SS.remove s ss) sp with | Some _ => true | None => false end) ss).

  intros e1 HEW1.
  rewrite HEW1 in H.
  unfold pick_lines_aux in H.
  case_eq (exists_witness (fun s2 : SS.elt => pick_line (S.inter e1 s2) sp) (SS.remove e1 ss)).

    intros e2 HEW2.
    rewrite HEW2 in H.
    assert (HEq1 : e1 = s1) by (injection H; intros; assumption).
    rewrite HEq1 in *.
    assert (HEq2 : e2 = s2) by (injection H; intros; assumption).
    rewrite HEq2 in *.
    apply exists_witness_ok with (fun s2 : SS.elt => pick_line (S.inter s1 s2) sp).
    intros x y HXY.
    apply proper_1; assumption.
    assumption.

    intro HEW2.
    rewrite HEW2 in H.
    discriminate.

  intro HEW.
  rewrite HEW in H.
  discriminate.
Qed.

Function identify_lines (ss : SS.t) (sp : SP.t) {measure SS.cardinal ss}
                        : SS.t :=
  let lines := pick_lines ss sp in
    match lines with
      |None => ss
      |Some (s1,s2) => let auxsetofsets := SS.remove s2 (SS.remove s1 ss) in
                       let auxset := S.union s1 s2 in
                       let newss := SS.add auxset auxsetofsets in
                         identify_lines newss sp
    end.
Proof.
intros.
assert (S(SS.cardinal (SS.remove s1 ss)) = SS.cardinal ss).
apply SSWP.remove_cardinal_1.
apply pick_lines_ok_1 with s2 sp.
assumption.
assert (S(S(SS.cardinal (SS.remove s2 (SS.remove s1 ss)))) = S(SS.cardinal (SS.remove s1 ss))).
apply eq_S.
apply SSWP.remove_cardinal_1.
apply pick_lines_ok_2 with sp.
assumption.
assert (HR1 : S(S(SS.cardinal (SS.remove s2 (SS.remove s1 ss)))) = SS.cardinal ss).
transitivity (S(SS.cardinal (SS.remove s1 ss))); assumption.
elim (SSWP.In_dec (S.union s1 s2) (SS.remove s2 (SS.remove s1 ss))); intro HDec.

  assert (HR2 : SS.cardinal (SS.add (S.union s1 s2) (SS.remove s2 (SS.remove s1 ss))) = SS.cardinal (SS.remove s2 (SS.remove s1 ss))).
  apply SSWP.add_cardinal_1; assumption.
  rewrite HR2.
  rewrite <- HR1.
  apply le_S;apply le_n.

  assert (HR2 : SS.cardinal (SS.add (S.union s1 s2) (SS.remove s2 (SS.remove s1 ss))) = S( SS.cardinal (SS.remove s2 (SS.remove s1 ss)))).
  apply SSWP.add_cardinal_2; assumption.
  rewrite HR2.
  rewrite <- HR1.
  apply le_n.
Defined.

Definition test_col (ss : SS.t) (sp : SP.t) p1 p2 p3 : bool :=
  let newss := identify_lines ss sp  in
    SS.exists_ (fun s => S.mem p1 s && S.mem p2 s && S.mem p3 s) newss.

Section Col_refl.

Context `{CT:Col_theory}.

Lemma CTcol_permutation_5 : forall A B C : COLTpoint, CTCol A B C -> CTCol A C B.
Proof.
apply CTcol_permutation_2.
Qed.

Lemma CTcol_permutation_2 : forall A B C : COLTpoint, CTCol A B C -> CTCol C A B.
Proof.
intros.
apply CTcol_permutation_1.
apply CTcol_permutation_1.
assumption.
Qed.

Lemma CTcol_permutation_3 : forall A B C : COLTpoint, CTCol A B C -> CTCol C B A.
Proof.
intros.
apply CTcol_permutation_5.
apply CTcol_permutation_2.
assumption.
Qed.

Lemma CTcol_permutation_4 : forall A B C : COLTpoint, CTCol A B C -> CTCol B A C.
Proof.
intros.
apply CTcol_permutation_5.
apply CTcol_permutation_1.
assumption.
Qed.

Lemma CTcol_trivial_1 : forall A B : COLTpoint, CTCol A A B.
Proof.
apply CTcol_trivial.
Qed.

Lemma CTcol_trivial_2 : forall A B : COLTpoint, CTCol A B B.
Proof.
intros.
apply CTcol_permutation_2.
apply CTcol_trivial_1.
Qed.

Definition ss_ok (ss : SS.t) (interp: positive -> COLTpoint) :=
  forall s, SS.mem s ss = true ->
  forall p1 p2 p3, S.mem p1 s && S.mem p2 s && S.mem p3 s = true ->
    CTCol (interp p1) (interp p2) (interp p3).

Definition sp_ok (sp : SP.t) (interp: positive -> COLTpoint) :=
  forall p, SP.mem p sp = true -> interp (fstpp p) <> interp (sndpp p).

Lemma identify_lines_ok : forall ss sp interp,
  ss_ok ss interp -> sp_ok sp interp ->
  ss_ok (identify_lines ss sp) interp.
Proof.
intros ss sp interp HSS HSP.
apply (let P interp ss sp newss :=
       ss_ok ss interp -> sp_ok sp interp -> ss_ok newss interp in
         identify_lines_ind (P interp)); try assumption.

  intros.
  assumption.

  clear HSS; clear HSP; clear ss; clear sp.
  intros ss sp suitablepairofsets s1 s2 Hs1s2 auxsetofsets auxset newss H HSS HSP.
  assert (Hs1 := Hs1s2).
  assert (Hs2 := Hs1s2).
  apply pick_lines_ok_1 in Hs1.
  apply pick_lines_ok_2 in Hs2.
  apply SSWEqP.MP.Dec.F.remove_3 in Hs2.
  apply H; try assumption; clear H.
  intros s Hmem p1 p2 p3 Hmemp.
  do 2 (rewrite andb_true_iff in Hmemp).
  destruct Hmemp as [[Hmemp1 Hmemp2] Hmemp3].
  unfold newss in Hmem; clear newss.
  elim (SS.E.eq_dec auxset s); intro HEq.

    rewrite <- HEq in *; clear HEq; clear s.
    unfold suitablepairofsets in Hs1s2; clear suitablepairofsets.
    unfold pick_lines in Hs1s2.
    case_eq (exists_witness
            (fun s : SS.elt =>
             match pick_lines_aux s (SS.remove s ss) sp with
             | Some _ => true
             | None => false
             end) ss); try (intro HEW; rewrite HEW in *; discriminate).
    intros e1 HEW; rewrite HEW in *; clear HEW.
    unfold pick_lines_aux in *.
    case_eq (exists_witness
            (fun s2 : SS.elt => pick_line (S.inter e1 s2) sp)
            (SS.remove e1 ss)); try (intro HEW; rewrite HEW in *; discriminate).
    intros e2 HEW; rewrite HEW in *.
    injection Hs1s2; intros He2s2 He1s1.
    rewrite He2s2 in *; rewrite He1s1 in *; clear He2s2; clear He1s1; clear Hs1s2; clear e2; clear e1.
    case_eq (pick_line (S.inter s1 s2) sp).

      clear HEW; intro HEW.
      unfold pick_line in HEW.
      apply SPWEqP.exists_mem_4 in HEW; try (apply proper_00).
      destruct HEW as [x [HmemSP HmemS]].
      rewrite andb_true_iff in HmemS; destruct HmemS as [Hmemfsts Hmemsnds].
      apply HSP in HmemSP.
      apply SWP.Dec.F.mem_2 in Hmemfsts.
      apply S.inter_spec in Hmemfsts.
      destruct Hmemfsts as [Hfss1 Hfss2].
      apply SWP.Dec.F.mem_2 in Hmemsnds.
      apply S.inter_spec in Hmemsnds.
      destruct Hmemsnds as [Hsss1 Hsss2].
      unfold auxset in *.
      apply CTcol3 with (interp (fstpp(x))) (interp (sndpp(x))); try assumption.

        apply SWP.Dec.F.mem_2 in Hmemp1.
        apply SWP.Dec.F.union_1 in Hmemp1.
        elim (Hmemp1); intro HInp1.

          apply HSS with s1.
          apply SSWP.Dec.F.mem_1; assumption.
          do 2 (rewrite andb_true_iff).
          repeat split; apply SWP.Dec.F.mem_1; assumption.

          apply HSS with s2.
          apply SSWP.Dec.F.mem_1; assumption.
          do 2 (rewrite andb_true_iff).
          repeat split; apply SWP.Dec.F.mem_1; assumption.

        apply SWP.Dec.F.mem_2 in Hmemp2.
        apply SWP.Dec.F.union_1 in Hmemp2.
        elim (Hmemp2); intro HInp2.

          apply HSS with s1.
          apply SSWP.Dec.F.mem_1; assumption.
          do 2 (rewrite andb_true_iff).
          repeat split; apply SWP.Dec.F.mem_1; assumption.

          apply HSS with s2.
          apply SSWP.Dec.F.mem_1; assumption.
          do 2 (rewrite andb_true_iff).
          repeat split; apply SWP.Dec.F.mem_1; assumption.

        apply SWP.Dec.F.mem_2 in Hmemp3.
        apply SWP.Dec.F.union_1 in Hmemp3.
        elim (Hmemp3); intro HInp3.

          apply HSS with s1.
          apply SSWP.Dec.F.mem_1; assumption.
          do 2 (rewrite andb_true_iff).
          repeat split; apply SWP.Dec.F.mem_1; assumption.

          apply HSS with s2.
          apply SSWP.Dec.F.mem_1; assumption.
          do 2 (rewrite andb_true_iff).
          repeat split; apply SWP.Dec.F.mem_1; assumption.

      intro HEW2; unfold exists_witness in *; apply SS.choose_spec1 in HEW.
      apply SSWEqP.MP.Dec.F.filter_2 in HEW; try apply proper_1.
      rewrite HEW2 in *; discriminate.

    rewrite SSWP.Dec.F.add_neq_b in Hmem; try assumption.
    apply HSS with s.
    unfold auxsetofsets in *.
    apply SSWEqP.MP.Dec.F.mem_2 in Hmem.
    do 2 (apply SSWEqP.MP.Dec.F.remove_3 in Hmem).
    apply SSWEqP.MP.Dec.F.mem_1.
    assumption.
    do 2 (rewrite andb_true_iff).
    repeat split; assumption.
Qed.

Lemma test_col_ok : forall ss sp interp p1 p2 p3,
  ss_ok ss interp -> sp_ok sp interp ->
  test_col ss sp p1 p2 p3 = true ->
  CTCol (interp p1) (interp p2) (interp p3).
Proof.
intros ss sp interp p1 p2 p3 HSS HSP HTC.
unfold test_col in *.
assert (HSS2 : ss_ok (identify_lines ss sp) interp)
  by (apply identify_lines_ok; assumption).

unfold ss_ok in HSS2.
apply SSWEqP.MP.Dec.F.exists_2 in HTC.
unfold SS.Exists in HTC.
destruct HTC as [s [HIn Hmem]].
apply HSS2 with s.
apply SSWEqP.MP.Dec.F.mem_1.
assumption.
assumption.

intros x y Hxy.
assert (HmemEq : forall p, S.mem p x = S.mem p y)
  by (intro; apply SWP.Dec.F.mem_m; auto).
do 3 (rewrite HmemEq); reflexivity.
Qed.

Lemma ss_ok_empty : forall interp,
  ss_ok SS.empty interp.
Proof.
intros interp ss Hmem1 p1 p2 p3 Hmem2.
rewrite SSWEqP.MP.Dec.F.empty_b in Hmem1.
discriminate.
Qed.

Lemma sp_ok_empty : forall interp,
  sp_ok SP.empty interp.
Proof.
intros.
unfold sp_ok.
intros p Hp.
rewrite SPWEqP.MP.Dec.F.empty_b in Hp.
discriminate.
Qed.

Lemma collect_cols :
  forall (A B C : COLTpoint) (HCol : CTCol A B C) pa pb pc ss (interp :  positive -> COLTpoint),
  interp pa = A ->
  interp pb = B ->
  interp pc = C ->
  ss_ok ss interp -> ss_ok (SS.add (S.add pa (S.add pb (S.add pc S.empty))) ss) interp.
Proof.
intros A B C HCol pa pb pc ss interp HA HB HC HSS.
unfold ss_ok.
intros s Hs.
intros p1 p2 p3 Hmem.
apply SSWEqP.MP.Dec.F.mem_2 in Hs.
apply SSWEqP.MP.Dec.F.add_iff in Hs.
do 2 (rewrite andb_true_iff in Hmem).
destruct Hmem as [[Hmem1 Hmem2] Hmem3].
elim Hs; intro HsE.

  assert (HmemR : forall p, S.mem p (S.add pa (S.add pb (S.add pc S.empty))) = S.mem p s)
    by (intros; apply SWP.Dec.F.mem_m; auto).
  rewrite <- HmemR in Hmem1.
  rewrite <- HmemR in Hmem2.
  rewrite <- HmemR in Hmem3.
  clear HmemR.
  elim (Pos.eq_dec pa p1); intro Hpap1.

    rewrite Hpap1 in *; rewrite HA.
    elim (Pos.eq_dec p1 p2); intro Hp1p2.

      rewrite Hp1p2 in *; rewrite HA.
      apply CTcol_trivial_1.

      rewrite SWP.Dec.F.add_neq_b in Hmem2.
      elim (Pos.eq_dec pb p2); intro Hpbp2.

        rewrite Hpbp2 in *; rewrite HB.
        elim (Pos.eq_dec p3 p1); intro Hp3p1; elim (Pos.eq_dec p3 p2); intro Hp3p2.

          rewrite Hp3p2; rewrite HB; apply CTcol_trivial_2.

          rewrite Hp3p1; rewrite HA; apply CTcol_permutation_1; apply CTcol_trivial_1.

          rewrite Hp3p2; rewrite HB; apply CTcol_trivial_2.

          do 2 (rewrite SWP.Dec.F.add_neq_b in Hmem3).
          rewrite <- SWP.singleton_equal_add in Hmem3.
          apply SWP.Dec.F.mem_iff in Hmem3.
          apply SWP.Dec.F.singleton_1 in Hmem3.
          rewrite <- Hmem3; rewrite HC; assumption.
          intuition.
          intuition.
          intuition.

        rewrite SWP.Dec.F.add_neq_b in Hmem2.
        rewrite <- SWP.singleton_equal_add in Hmem2.
        apply SWP.Dec.F.mem_iff in Hmem2.
        apply SWP.Dec.F.singleton_1 in Hmem2.
        rewrite <- Hmem2 in *; rewrite HC.
        elim (Pos.eq_dec p3 p1); intro Hp3p1; elim (Pos.eq_dec p3 p2); intro Hp3p2.

          rewrite Hp3p2 in *; rewrite Hmem2 in *; rewrite HC; apply CTcol_trivial_2.

          rewrite Hp3p1 in *; rewrite HA; apply CTcol_permutation_1; apply CTcol_trivial_1.

          rewrite Hp3p2 in *; rewrite Hmem2 in *; rewrite HC; apply CTcol_trivial_2.

          rewrite SWP.Dec.F.add_neq_b in Hmem3.
          elim (Pos.eq_dec p3 pb); intro Hp3pb.

            rewrite Hp3pb in *; rewrite HB; apply CTcol_permutation_5; assumption.

            rewrite SWP.Dec.F.add_neq_b in Hmem3.
            rewrite <- SWP.singleton_equal_add in Hmem3.
            apply SWP.Dec.F.mem_iff in Hmem3.
            apply SWP.Dec.F.singleton_1 in Hmem3.
            rewrite Hmem3 in *; contradiction.
            intuition.

          intuition.

        intuition.

      intuition.

    rewrite SWP.Dec.F.add_neq_b in Hmem1.
    elim (Pos.eq_dec p1 pb); intro Hp1pb.

      rewrite Hp1pb in *; rewrite HB.
      elim (Pos.eq_dec pa p2); intro Hpap2.

        rewrite Hpap2 in *; rewrite HA.
        elim (Pos.eq_dec p3 p2); intro Hp3p2; elim (Pos.eq_dec p3 pb); intro Hp3pb.

          rewrite Hp3pb; rewrite HB; apply CTcol_permutation_1; apply CTcol_trivial_1.

          rewrite Hp3p2; rewrite HA; apply CTcol_trivial_2.

          rewrite Hp3pb; rewrite HB; apply CTcol_permutation_1; apply CTcol_trivial_1.

          do 2 (rewrite SWP.Dec.F.add_neq_b in Hmem3).
          rewrite <- SWP.singleton_equal_add in Hmem3.
          apply SWP.Dec.F.mem_iff in Hmem3.
          apply SWP.Dec.F.singleton_1 in Hmem3.
          rewrite <- Hmem3; rewrite HC; apply CTcol_permutation_4; assumption.
          intuition.
          intuition.
          intuition.

        rewrite SWP.Dec.F.add_neq_b in Hmem2.
        elim (Pos.eq_dec p2 pb); intro Hp2pb.

          rewrite Hp2pb; rewrite HB; apply CTcol_trivial_1.

          rewrite SWP.Dec.F.add_neq_b in Hmem2.
          rewrite <- SWP.singleton_equal_add in Hmem2.
          apply SWP.Dec.F.mem_iff in Hmem2.
          apply SWP.Dec.F.singleton_1 in Hmem2.
          rewrite <- Hmem2 in *; rewrite HC.
          elim (Pos.eq_dec p3 p1); intro Hp3p1; elim (Pos.eq_dec p3 p2); intro Hp3p2.

            rewrite Hp3p2 in *; rewrite Hmem2 in *; rewrite HC; apply CTcol_trivial_2.

            rewrite Hp3p1 in *; rewrite Hp1pb; rewrite HB; apply CTcol_permutation_1; apply CTcol_trivial_1.

            rewrite Hp3p2 in *; rewrite Hmem2 in *; rewrite HC; apply CTcol_trivial_2.

            elim (Pos.eq_dec p3 pa); intro Hp3pa.

              rewrite Hp3pa; rewrite HA; apply CTcol_permutation_1; assumption.

              rewrite SWP.Dec.F.add_neq_b in Hmem3.
              elim (Pos.eq_dec p3 pb); intro Hp3pb.

                rewrite Hp3pb in *; rewrite HB; apply CTcol_permutation_5; apply CTcol_trivial_1.

                rewrite SWP.Dec.F.add_neq_b in Hmem3.
                rewrite <- SWP.singleton_equal_add in Hmem3.
                apply SWP.Dec.F.mem_iff in Hmem3.
                apply SWP.Dec.F.singleton_1 in Hmem3.
                rewrite Hmem3 in *; contradiction.
                intuition.

              intuition.

          intuition.

        intuition.

      rewrite SWP.Dec.F.add_neq_b in Hmem1.
      rewrite <- SWP.singleton_equal_add in Hmem1.
      apply SWP.Dec.F.mem_iff in Hmem1.
      apply SWP.Dec.F.singleton_1 in Hmem1.
      rewrite <- Hmem1 in *; rewrite HC.
      elim (Pos.eq_dec pa p2); intro Hpap2.

        rewrite Hpap2 in *; rewrite HA.
        elim (Pos.eq_dec p3 p2); intro Hp3p2; elim (Pos.eq_dec p3 pb); intro Hp3pb.

          rewrite Hp3pb; rewrite HB; apply CTcol_permutation_2; assumption.

          rewrite Hp3p2; rewrite HA; apply CTcol_trivial_2.

          rewrite Hp3pb; rewrite HB; apply CTcol_permutation_2; assumption.

          do 2 (rewrite SWP.Dec.F.add_neq_b in Hmem3).
          rewrite <- SWP.singleton_equal_add in Hmem3.
          apply SWP.Dec.F.mem_iff in Hmem3.
          apply SWP.Dec.F.singleton_1 in Hmem3.
          rewrite <- Hmem3; rewrite HC; apply CTcol_permutation_1; apply CTcol_trivial_1.
          intuition.
          intuition.
          intuition.

        rewrite SWP.Dec.F.add_neq_b in Hmem2.
        elim (Pos.eq_dec p2 pb); intro Hp2pb.

          rewrite Hp2pb; rewrite HB.
          elim (Pos.eq_dec p3 pa); intro Hp3pa; elim (Pos.eq_dec p3 pb); intro Hp3pb.

            rewrite Hp3pa; rewrite HA; apply CTcol_permutation_3; assumption.

            rewrite Hp3pa; rewrite HA; apply CTcol_permutation_3; assumption.

            rewrite Hp3pb; rewrite HB; apply CTcol_trivial_2.

            do 2 (rewrite SWP.Dec.F.add_neq_b in Hmem3).
            rewrite <- SWP.singleton_equal_add in Hmem3.
            apply SWP.Dec.F.mem_iff in Hmem3.
            apply SWP.Dec.F.singleton_1 in Hmem3.
            rewrite <- Hmem3 in *; rewrite HC; apply CTcol_permutation_1; apply CTcol_trivial_1.
            intuition.

          intuition.

        intuition.

        rewrite SWP.Dec.F.add_neq_b in Hmem2.
        rewrite <- SWP.singleton_equal_add in Hmem2.
        apply SWP.Dec.F.mem_iff in Hmem2.
        apply SWP.Dec.F.singleton_1 in Hmem2.
        rewrite <- Hmem2 in *; rewrite HC; apply CTcol_trivial_1.
        intuition.

        intuition.

      intuition.

    intuition.

  unfold ss_ok in *.
  apply HSS with s.
  apply SSWEqP.MP.Dec.F.mem_1.
  assumption.
  rewrite Hmem1; rewrite Hmem2; rewrite Hmem3; reflexivity.
Qed.

Lemma collect_diffs :
  forall (A B : COLTpoint) (H : A <> B) pa pb sp (interp :  positive -> COLTpoint),
  interp pa = A ->
  interp pb = B ->
  sp_ok sp interp -> sp_ok (SP.add (pa, pb) sp) interp.
Proof.
intros A B HDiff pa pb sp interp HA HB HSP.
unfold sp_ok.
intros p Hp.
apply SPWEqP.MP.Dec.F.mem_2 in Hp.
apply SPWEqP.MP.Dec.F.add_iff in Hp.
elim Hp; intro HpE.

  destruct HpE as [HEq1 HEq2].
  destruct p as [fstp sndp].
  simpl in *.
  elim (Pos.min_spec pa pb); intro Hmin1; elim (Pos.min_spec fstp sndp); intro Hmin2;
  destruct Hmin1 as [Hpapb1 Hmin1]; destruct Hmin2 as [Hfpsp1 Hmin2];
  elim (Pos.max_spec pa pb); intro Hmax1; elim (Pos.max_spec fstp sndp); intro Hmax2;
  destruct Hmax1 as [Hpapb2 Hmax1]; destruct Hmax2 as [Hfpsp2 Hmax2].

    rewrite Hmin1 in *; rewrite Hmin2 in *; rewrite Hmax1 in *;rewrite Hmax2 in *.
    rewrite <- HEq1; rewrite <- HEq2; rewrite HA in *; rewrite HB in *; assumption.

    rewrite <- Pos.ltb_lt in Hfpsp1; rewrite Pos.ltb_antisym in Hfpsp1;
    rewrite negb_true_iff in Hfpsp1; rewrite Pos.leb_nle in Hfpsp1; contradiction.

    rewrite <- Pos.ltb_lt in Hpapb1; rewrite Pos.ltb_antisym in Hpapb1;
    rewrite negb_true_iff in Hpapb1; rewrite Pos.leb_nle in Hpapb1; contradiction.

    rewrite <- Pos.ltb_lt in Hfpsp1; rewrite Pos.ltb_antisym in Hfpsp1;
    rewrite negb_true_iff in Hfpsp1; rewrite Pos.leb_nle in Hfpsp1; contradiction.

    rewrite <- Pos.ltb_lt in Hfpsp2; rewrite Pos.ltb_antisym in Hfpsp2;
    rewrite negb_true_iff in Hfpsp2; rewrite Pos.leb_nle in Hfpsp2; contradiction.

    rewrite Hmin1 in *; rewrite Hmin2 in *; rewrite Hmax1 in *;rewrite Hmax2 in *.
    rewrite <- HEq1; rewrite <- HEq2; rewrite HA in *; rewrite HB in *; assumption.

    rewrite <- Pos.ltb_lt in Hfpsp2; rewrite Pos.ltb_antisym in Hfpsp2;
    rewrite negb_true_iff in Hfpsp2; rewrite Pos.leb_nle in Hfpsp2; contradiction.

    rewrite <- Pos.ltb_lt in Hpapb1; rewrite Pos.ltb_antisym in Hpapb1;
    rewrite negb_true_iff in Hpapb1; rewrite Pos.leb_nle in Hpapb1; contradiction.

    rewrite <- Pos.ltb_lt in Hpapb2; rewrite Pos.ltb_antisym in Hpapb2;
    rewrite negb_true_iff in Hpapb2; rewrite Pos.leb_nle in Hpapb2; contradiction.

    rewrite <- Pos.ltb_lt in Hpapb2; rewrite Pos.ltb_antisym in Hpapb2;
    rewrite negb_true_iff in Hpapb2; rewrite Pos.leb_nle in Hpapb2; contradiction.

    rewrite Hmin1 in *; rewrite Hmin2 in *; rewrite Hmax1 in *;rewrite Hmax2 in *.
    rewrite <- HEq1; rewrite <- HEq2; rewrite HA in *; rewrite HB in *; intuition.

    rewrite <- Pos.ltb_lt in Hfpsp1; rewrite Pos.ltb_antisym in Hfpsp1;
    rewrite negb_true_iff in Hfpsp1; rewrite Pos.leb_nle in Hfpsp1; contradiction.

    rewrite <- Pos.ltb_lt in Hpapb2; rewrite Pos.ltb_antisym in Hpapb2;
    rewrite negb_true_iff in Hpapb2; rewrite Pos.leb_nle in Hpapb2; contradiction.

    rewrite <- Pos.ltb_lt in Hpapb2; rewrite Pos.ltb_antisym in Hpapb2;
    rewrite negb_true_iff in Hpapb2; rewrite Pos.leb_nle in Hpapb2; contradiction.

    rewrite <- Pos.ltb_lt in Hfpsp2; rewrite Pos.ltb_antisym in Hfpsp2;
    rewrite negb_true_iff in Hfpsp2; rewrite Pos.leb_nle in Hfpsp2; contradiction.

    rewrite Hmin1 in *; rewrite Hmin2 in *; rewrite Hmax1 in *;rewrite Hmax2 in *.
    rewrite <- HEq1; rewrite <- HEq2; rewrite HA in *; rewrite HB in *; intuition.

  unfold sp_ok in *.
  apply HSP.
  apply SPWEqP.MP.Dec.F.mem_1.
  assumption.
Qed.

Definition list_assoc_inv :=
  (fix list_assoc_inv_rec (A:Type) (B:Set)
                          (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
                          (lst : list (prodT A B)) {struct lst} : B -> A -> A :=
  fun (key:B) (default:A) =>
    match lst with
      | nil => default
      | cons (pairT v e) l =>
        match eq_dec e key with
          | left _ => v
          | right _ => list_assoc_inv_rec A B eq_dec l key default
        end
    end).

Lemma positive_dec : forall (p1 p2:positive), {p1=p2}+{~p1=p2}.
Proof.
decide equality.
Defined.

Definition interp (lvar : list (COLTpoint * positive)) (Default : COLTpoint) : positive -> COLTpoint :=
  fun p => list_assoc_inv COLTpoint positive positive_dec lvar p Default.

Definition eq_tagged (lvar : list (COLTpoint * positive)) := lvar = lvar.

Lemma eq_eq_tagged : forall lvar, lvar = lvar -> eq_tagged lvar.
Proof.
trivial.
Qed.

Definition partition_ss e ss :=
  SS.partition (fun s => S.mem e s) ss.

Definition fst_ss (pair : SS.t * SS.t) :=
 match pair with
    |(a,b) => a
  end.

Definition snd_ss (pair : SS.t * SS.t) :=
 match pair with
    |(a,b) => b
  end.

Definition subst_in_set p1 p2 s := S.add p1 (S.remove p2 s).

Definition subst_in_ss_aux p1 p2 := (fun s ss => SS.add (subst_in_set p1 p2 s) ss).

Definition subst_in_ss p1 p2 ss :=
  let pair := partition_ss p2 ss in
  let fss := fst_ss(pair) in
  let sss := snd_ss(pair) in
  let newfss := SS.fold (subst_in_ss_aux p1 p2) fss SS.empty in
  SS.union newfss sss.

Lemma proper_4 : forall p, Proper (S.Equal ==> eq) (fun s : SS.elt => S.mem p s).
Proof.
intros p x y Hxy.
apply SWP.Dec.F.mem_m; intuition.
Qed.

Lemma proper_5 : forall p, Proper (S.Equal ==> eq) (fun s : SS.elt => negb (S.mem p s)).
Proof.
intros p x y Hxy.
f_equal.
apply SWP.Dec.F.mem_m; intuition.
Qed.

Lemma subst_ss_ok :
  forall (A B : COLTpoint) (H : A = B) pa pb ss (interp :  positive -> COLTpoint),
  interp pa = A ->
  interp pb = B ->
  ss_ok ss interp -> ss_ok (subst_in_ss pa pb ss) interp.
Proof.
intros A B H pa pb ss interp HA HB HSS.
unfold subst_in_ss.
unfold ss_ok.
intros s Hs.
intros p1 p2 p3 Hmem.
apply SSWEqP.MP.Dec.F.mem_2 in Hs.
rewrite SSWEqP.MP.Dec.F.union_iff in Hs.
elim Hs; intro HIn; clear Hs.

  assert (HSSF : ss_ok (fst_ss (partition_ss pb ss)) interp).

    clear Hmem; clear p1; clear p2; clear p3.
    intros s' Hs'.
    intros.
    apply SSWEqP.MP.Dec.F.mem_2 in Hs'.
    unfold partition in Hs'.
    apply SS.partition_spec1 in Hs'; try apply proper_4.
    apply SSWEqP.MP.Dec.F.filter_1 in Hs'; try apply proper_4.
    unfold ss_ok in HSS.
    apply HSS with s'; try assumption.
    apply SSWEqP.MP.Dec.F.mem_1; assumption.

  assert (HSSF' : ss_ok (SS.fold (subst_in_ss_aux pa pb) (fst_ss (partition_ss pb ss)) SS.empty) interp).

    apply SSWEqP.MP.fold_rec_nodep; try apply ss_ok_empty.
    intros x a HIn1 HSSa.
    clear Hmem; clear p1; clear p2; clear p3.
    intros s' Hs'.
    intros p1 p2 p3 Hmem.
    unfold subst_in_ss_aux in *.
    apply SSWEqP.MP.Dec.F.mem_2 in Hs'.
    rewrite SSWEqP.MP.Dec.F.add_iff in Hs'.
    elim Hs'; intro HIn2; clear Hs'.

      unfold subst_in_set in HIn2.
      clear HIn; clear s; assert (HEq := HIn2); clear HIn2; assert (HIn := HIn1); clear HIn1.
      elim (Pos.eq_dec pb p1); intro Hp1; elim (Pos.eq_dec pb p2); intro Hp2; elim (Pos.eq_dec pb p3); intro Hp3.

        subst.
        apply CTcol_trivial_1.

        subst.
        apply CTcol_trivial_1.

        subst.
        apply CTcol_permutation_4; apply CTcol_trivial_2.

        subst.
        do 2 (rewrite andb_true_iff in Hmem).
        destruct Hmem as [[Hmem1' Hmem2'] Hmem3'].
        assert (Hmem1 : S.mem p1 x = true).

          unfold partition in HIn.
          apply SS.partition_spec1 in HIn; try apply proper_4.
          apply SSWEqP.MP.Dec.F.filter_2 in HIn; try assumption; apply proper_4.

        elim (Pos.eq_dec pa p2); intro Hpap2.

          subst; rewrite HB; apply CTcol_trivial_1.

          assert (Hmem2 : S.mem p2 x = true).

            rewrite <- HEq in Hmem2'.
            rewrite SWP.Dec.F.add_neq_b in Hmem2'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem2'; assumption.

          elim (Pos.eq_dec pa p3); intro Hpap3.

            subst; rewrite HB; apply CTcol_permutation_4; apply CTcol_trivial_2.

            assert (Hmem3 : S.mem p3 x = true).

              rewrite <- HEq in Hmem3'.
              rewrite SWP.Dec.F.add_neq_b in Hmem3'; try assumption.
              rewrite SWP.Dec.F.remove_neq_b in Hmem3'; assumption.

            unfold ss_ok in HSSF.
            apply HSSF with x.

              apply SSWEqP.MP.Dec.F.mem_1; assumption.

              do 2 (rewrite andb_true_iff); repeat split; assumption.

        subst.
        apply CTcol_trivial_2.

        subst.
        do 2 (rewrite andb_true_iff in Hmem).
        destruct Hmem as [[Hmem1' Hmem2'] Hmem3'].
        assert (Hmem2 : S.mem p2 x = true).

          unfold partition in HIn.
          apply SS.partition_spec1 in HIn; try apply proper_4.
          apply SSWEqP.MP.Dec.F.filter_2 in HIn; try assumption; apply proper_4.

        elim (Pos.eq_dec pa p1); intro Hpap1.

          subst; rewrite HB; apply CTcol_trivial_1.

          assert (Hmem1 : S.mem p1 x = true).

            rewrite <- HEq in Hmem1'.
            rewrite SWP.Dec.F.add_neq_b in Hmem1'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem1'; assumption.

          elim (Pos.eq_dec pa p3); intro Hpap3.

            subst; rewrite HB; apply CTcol_trivial_2.

            assert (Hmem3 : S.mem p3 x = true).

              rewrite <- HEq in Hmem3'.
              rewrite SWP.Dec.F.add_neq_b in Hmem3'; try assumption.
              rewrite SWP.Dec.F.remove_neq_b in Hmem3'; assumption.

            unfold ss_ok in HSSF.
            apply HSSF with x.

              apply SSWEqP.MP.Dec.F.mem_1; assumption.

              do 2 (rewrite andb_true_iff); repeat split; assumption.

        subst.
        do 2 (rewrite andb_true_iff in Hmem).
        destruct Hmem as [[Hmem1' Hmem2'] Hmem3'].
        assert (Hmem3 : S.mem p3 x = true).

          unfold partition in HIn.
          apply SS.partition_spec1 in HIn; try apply proper_4.
          apply SSWEqP.MP.Dec.F.filter_2 in HIn; try assumption; apply proper_4.

        elim (Pos.eq_dec pa p1); intro Hpap1.

          subst; rewrite HB; apply CTcol_permutation_4; apply CTcol_trivial_2.

          assert (Hmem1 : S.mem p1 x = true).

            rewrite <- HEq in Hmem1'.
            rewrite SWP.Dec.F.add_neq_b in Hmem1'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem1'; assumption.

          elim (Pos.eq_dec pa p2); intro Hpap2.

            subst; rewrite HB; apply CTcol_trivial_2.

            assert (Hmem2 : S.mem p2 x = true).

              rewrite <- HEq in Hmem2'.
              rewrite SWP.Dec.F.add_neq_b in Hmem2'; try assumption.
              rewrite SWP.Dec.F.remove_neq_b in Hmem2'; assumption.

            unfold ss_ok in HSSF.
            apply HSSF with x.

              apply SSWEqP.MP.Dec.F.mem_1; assumption.

              do 2 (rewrite andb_true_iff); repeat split; assumption.

        do 2 (rewrite andb_true_iff in Hmem).
        destruct Hmem as [[Hmem1' Hmem2'] Hmem3'].

        elim (Pos.eq_dec pa p1); intro Hpap1;
        elim (Pos.eq_dec pa p2); intro Hpap2;
        elim (Pos.eq_dec pa p3); intro Hpap3.

          subst; apply CTcol_trivial_1.

          subst; apply CTcol_trivial_1.

          subst; apply CTcol_permutation_4; apply CTcol_trivial_2.

          subst.
          assert (Hmem1 : S.mem pb x = true).

            unfold partition in HIn.
            apply SS.partition_spec1 in HIn; try apply proper_4.
            apply SSWEqP.MP.Dec.F.filter_2 in HIn; try assumption; apply proper_4.

          assert (Hmem2 : S.mem p2 x = true).

            rewrite <- HEq in Hmem2'.
            rewrite SWP.Dec.F.add_neq_b in Hmem2'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem2'; assumption.

          assert (Hmem3 : S.mem p3 x = true).

            rewrite <- HEq in Hmem3'.
            rewrite SWP.Dec.F.add_neq_b in Hmem3'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem3'; assumption.

          rewrite <- HB.
          unfold ss_ok in HSSF.
          apply HSSF with x.

            apply SSWEqP.MP.Dec.F.mem_1; assumption.

            do 2 (rewrite andb_true_iff); repeat split; assumption.

          subst; apply CTcol_trivial_2.

          subst.
          assert (Hmem2 : S.mem pb x = true).

            unfold partition in HIn.
            apply SS.partition_spec1 in HIn; try apply proper_4.
            apply SSWEqP.MP.Dec.F.filter_2 in HIn; try assumption; apply proper_4.

          assert (Hmem1 : S.mem p1 x = true).

            rewrite <- HEq in Hmem1'.
            rewrite SWP.Dec.F.add_neq_b in Hmem1'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem1'; assumption.

          assert (Hmem3 : S.mem p3 x = true).

            rewrite <- HEq in Hmem3'.
            rewrite SWP.Dec.F.add_neq_b in Hmem3'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem3'; assumption.

          rewrite <- HB.
          unfold ss_ok in HSSF.
          apply HSSF with x.

            apply SSWEqP.MP.Dec.F.mem_1; assumption.

            do 2 (rewrite andb_true_iff); repeat split; assumption.

          subst.
          assert (Hmem3 : S.mem pb x = true).

            unfold partition in HIn.
            apply SS.partition_spec1 in HIn; try apply proper_4.
            apply SSWEqP.MP.Dec.F.filter_2 in HIn; try assumption; apply proper_4.

          assert (Hmem1 : S.mem p1 x = true).

            rewrite <- HEq in Hmem1'.
            rewrite SWP.Dec.F.add_neq_b in Hmem1'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem1'; assumption.

          assert (Hmem2 : S.mem p2 x = true).

            rewrite <- HEq in Hmem2'.
            rewrite SWP.Dec.F.add_neq_b in Hmem2'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem2'; assumption.

          rewrite <- HB.
          unfold ss_ok in HSSF.
          apply HSSF with x.

            apply SSWEqP.MP.Dec.F.mem_1; assumption.

            do 2 (rewrite andb_true_iff); repeat split; assumption.

         assert (Hmem1 : S.mem p1 x = true).

            rewrite <- HEq in Hmem1'.
            rewrite SWP.Dec.F.add_neq_b in Hmem1'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem1'; assumption.

          assert (Hmem2 : S.mem p2 x = true).

            rewrite <- HEq in Hmem2'.
            rewrite SWP.Dec.F.add_neq_b in Hmem2'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem2'; assumption.

          assert (Hmem3 : S.mem p3 x = true).

            rewrite <- HEq in Hmem3'.
            rewrite SWP.Dec.F.add_neq_b in Hmem3'; try assumption.
            rewrite SWP.Dec.F.remove_neq_b in Hmem3'; assumption.

          unfold ss_ok in HSSF.
          apply HSSF with x.

            apply SSWEqP.MP.Dec.F.mem_1; assumption.

            do 2 (rewrite andb_true_iff); repeat split; assumption.

      unfold ss_ok in HSSa.
      apply HSSa with s'; try assumption.
      apply SSWEqP.MP.Dec.F.mem_1; assumption.

  clear HSSF; assert (HSSF := HSSF'); clear HSSF'.

  unfold ss_ok in HSSF.
  apply HSSF with s; try assumption.
  apply SSWEqP.MP.Dec.F.mem_1; assumption.

  assert (HSSS : ss_ok (snd_ss (partition_ss pb ss)) interp).

    clear Hmem; clear p1; clear p2; clear p3.
    intros s' Hs'.
    intros.
    apply SSWEqP.MP.Dec.F.mem_2 in Hs'.
    unfold partition in Hs'.
    apply SS.partition_spec2 in Hs'; try apply proper_4.
    apply SSWEqP.MP.Dec.F.filter_1 in Hs'; try apply proper_5.
    unfold ss_ok in HSS.
    apply HSS with s'; try assumption.
    apply SSWEqP.MP.Dec.F.mem_1; assumption.

  unfold ss_ok in HSSS.
  apply HSSS with s; try assumption.
  apply SSWEqP.MP.Dec.F.mem_1; assumption.
Qed.

Definition partition_sp_1 p sp :=
  SP.partition (fun e => Pos.eqb (fstpp e) p || Pos.eqb (sndpp e) p) sp.

Definition partition_sp_2 p sp :=
  SP.partition (fun e => Pos.eqb (fstpp e) p) sp.

Definition fst_sp (pair : SP.t * SP.t) :=
 match pair with
    |(a,b) => a
  end.

Definition snd_sp (pair : SP.t * SP.t) :=
 match pair with
    |(a,b) => b
  end.

Definition new_pair_1 pair (pos : positive) := (pos, sndpp(pair)).

Definition new_pair_2 pair (pos : positive) := (fstpp(pair), pos).

Definition subst_in_sp_aux_1 := (fun pos pair sp => SP.add (new_pair_1 pair pos) sp).

Definition subst_in_sp_aux_2 := (fun pos pair sp => SP.add (new_pair_2 pair pos) sp).

Definition subst_in_sp p1 p2 sp :=
  let pair_1 := partition_sp_1 p2 sp in
  let sp_to_modify := fst_sp(pair_1) in
  let sp_to_keep := snd_sp(pair_1) in
  let pair_2 := partition_sp_2 p2 sp_to_modify in
  let sp_to_modify_f := fst_sp(pair_2) in
  let sp_to_modify_s := snd_sp(pair_2) in
  let newsp_to_modify_f := SP.fold (subst_in_sp_aux_1 p1) sp_to_modify_f SP.empty in
  let newsp_to_modify_s := SP.fold (subst_in_sp_aux_2 p1) sp_to_modify_s SP.empty in
  SP.union (SP.union newsp_to_modify_f newsp_to_modify_s) sp_to_keep.

Lemma proper_6 : forall p, Proper ((fun t1 t2 : SetOfPairsOfPositiveOrderedType.t =>
                                  Pos.eq (fstpp t1) (fstpp t2) /\ Pos.eq (sndpp t1) (sndpp t2)) ==> eq)
                                  (fun e : SP.elt => (fstpp e =? p)%positive || (sndpp e =? p)%positive).
Proof.
intros p x y Hxy.
destruct Hxy as [Hxyf Hxys].
rewrite Hxyf; rewrite Hxys.
reflexivity.
Qed.

Lemma proper_7 : forall p, Proper ((fun t1 t2 : SetOfPairsOfPositiveOrderedType.t =>
                                  Pos.eq (fstpp t1) (fstpp t2) /\ Pos.eq (sndpp t1) (sndpp t2)) ==> eq)
                                  (fun x : SP.elt => negb ((fstpp x =? p)%positive || (sndpp x =? p)%positive)).
Proof.
intros p x y Hxy.
destruct Hxy as [Hxyf Hxys].
rewrite Hxyf; rewrite Hxys.
reflexivity.
Qed.

Lemma proper_8 : forall p, Proper ((fun t1 t2 : SetOfPairsOfPositiveOrderedType.t =>
                                  Pos.eq (fstpp t1) (fstpp t2) /\ Pos.eq (sndpp t1) (sndpp t2)) ==> eq)
                                  (fun e : SP.elt => (fstpp e =? p)%positive).
Proof.
intros p x y Hxy.
destruct Hxy as [Hxyf Hxys].
rewrite Hxyf.
reflexivity.
Qed.

Lemma proper_9 : forall p, Proper ((fun t1 t2 : SetOfPairsOfPositiveOrderedType.t =>
                                  Pos.eq (fstpp t1) (fstpp t2) /\ Pos.eq (sndpp t1) (sndpp t2)) ==> eq)
                                  (fun x : SP.elt => negb (fstpp x =? p)%positive).
Proof.
intros p x y Hxy.
destruct Hxy as [Hxyf Hxys].
rewrite Hxyf.
reflexivity.
Qed.

Lemma subst_sp_ok :
  forall (A B : COLTpoint) (H : A = B) pa pb sp (interp :  positive -> COLTpoint),
  interp pa = A ->
  interp pb = B ->
  sp_ok sp interp -> sp_ok (subst_in_sp pa pb sp) interp.
Proof.
intros A B H pa pb sp interp HA HB HSP.
unfold subst_in_sp.
unfold sp_ok.
intros p Hp.
apply SPWEqP.MP.Dec.F.mem_2 in Hp.
do 2 rewrite SPWEqP.MP.Dec.F.union_iff in Hp.
elim Hp; intro HInAux; clear Hp.

  assert (HSPM : sp_ok (fst_sp (partition_sp_1 pb sp)) interp).

    intros p' Hp'.
    apply SPWEqP.MP.Dec.F.mem_2 in Hp'.
    unfold partition_sp_1 in Hp'.
    apply SP.partition_spec1 in Hp'; try apply proper_6.
    apply SPWEqP.MP.Dec.F.filter_1 in Hp'; try apply proper_6.
    unfold sp_ok in HSP.
    apply HSP; try assumption.
    apply SPWEqP.MP.Dec.F.mem_1; assumption.

  clear HSP.
  elim HInAux; intro HIn; clear HInAux.

    assert (HSPF : sp_ok (fst_sp (partition_sp_2 pb (fst_sp (partition_sp_1 pb sp)))) interp).

      intros p' Hp'.
      apply SPWEqP.MP.Dec.F.mem_2 in Hp'.
      unfold partition_sp_1 in Hp'.
      apply SP.partition_spec1 in Hp'; try apply proper_8.
      apply SPWEqP.MP.Dec.F.filter_1 in Hp'; try apply proper_8.
      unfold sp_ok in HSPM.
      apply HSPM; try assumption.
      apply SPWEqP.MP.Dec.F.mem_1; assumption.

    clear HSPM.

    assert (HSPF' : sp_ok (SP.fold (subst_in_sp_aux_1 pa)
                         (fst_sp (partition_sp_2 pb (fst_sp (partition_sp_1 pb sp))))
                         SP.empty) interp).
    apply SPWEqP.MP.fold_rec_nodep; try apply sp_ok_empty.
    clear HIn.
    intros x a HInRec HSPRec.
    intros p' Hp'.
    unfold subst_in_sp_aux_1 in *.
    apply SPWEqP.MP.Dec.F.mem_2 in Hp'.
    rewrite SPWEqP.MP.Dec.F.add_iff in Hp'.
    elim Hp'; intro HIn; clear Hp'.

      destruct HIn as [HEq1 HEq2].
      rewrite <- HEq1; rewrite <- HEq2.
      unfold new_pair_1.
      clear HSPRec; clear a.
      elim (Pos.min_spec pa (sndpp(x))); intro Hmin.

        destruct Hmin as [HLt Hmin].
        assert (Hmax : Pos.max pa (sndpp(x)) = (sndpp(x))) by (apply Pos.max_r; apply Pos.lt_le_incl; assumption).
        assert (HF : fstpp(pa, sndpp(x)) = pa) by (unfold fstpp; assumption).
        assert (HS : sndpp(pa, sndpp(x)) = sndpp(x)) by (unfold sndpp; assumption).
        rewrite HF; rewrite HS.

        assert (Hpb : fstpp(x) = pb).

          unfold partition_sp_2 in HInRec.
          apply SP.partition_spec1 in HInRec; try apply proper_8.
          apply SPWEqP.MP.Dec.F.filter_2 in HInRec; try apply proper_8.
          apply Ndec.Peqb_complete.
          assumption.

        intro HEq4.
        unfold sp_ok in HSPF.
        apply SPWEqP.MP.Dec.F.mem_1 in HInRec.
        apply (HSPF x) in HInRec.
        apply HInRec.
        rewrite Hpb; rewrite <- HEq4; rewrite HA; rewrite HB; rewrite H; reflexivity.

        destruct Hmin as [HLe Hmin].
        assert (Hmax : Pos.max pa (sndpp(x)) = pa) by (apply Pos.max_l; assumption).
        assert (HF : fstpp(pa, sndpp(x)) = sndpp(x)) by (unfold fstpp; assumption).
        assert (HS : sndpp(pa, sndpp(x)) = pa) by (unfold sndpp; assumption).
        rewrite HF; rewrite HS.

        assert (Hpb : fstpp(x) = pb).

          unfold partition_sp_2 in HInRec.
          apply SP.partition_spec1 in HInRec; try apply proper_8.
          apply SPWEqP.MP.Dec.F.filter_2 in HInRec; try apply proper_8.
          apply Ndec.Peqb_complete.
          assumption.

        intro HEq4.
        unfold sp_ok in HSPF.
        apply SPWEqP.MP.Dec.F.mem_1 in HInRec.
        apply (HSPF x) in HInRec.
        apply HInRec.
        rewrite Hpb; rewrite HEq4; rewrite HA; rewrite HB; rewrite H; reflexivity.

      unfold sp_ok in HSPRec.
      apply HSPRec.
      apply SPWEqP.MP.Dec.F.mem_1; assumption.

    clear HSPF; assert (HSPF := HSPF'); clear HSPF'.
    unfold sp_ok in HSPF.
    apply HSPF.
    apply SPWEqP.MP.Dec.F.mem_1; assumption.

    assert (HSPS : sp_ok (snd_sp (partition_sp_2 pb (fst_sp (partition_sp_1 pb sp)))) interp).

      intros p' Hp'.
      apply SPWEqP.MP.Dec.F.mem_2 in Hp'.
      unfold partition_sp_1 in Hp'.
      apply SP.partition_spec2 in Hp'; try apply proper_8.
      apply SPWEqP.MP.Dec.F.filter_1 in Hp'; try apply proper_9.
      unfold sp_ok in HSPM.
      apply HSPM; try assumption.
      apply SPWEqP.MP.Dec.F.mem_1; assumption.

    clear HSPM.

    assert (HSPS' : sp_ok (SP.fold (subst_in_sp_aux_2 pa)
                         (snd_sp (partition_sp_2 pb (fst_sp (partition_sp_1 pb sp))))
                         SP.empty) interp).
    apply SPWEqP.MP.fold_rec_nodep; try apply sp_ok_empty.
    clear HIn.
    intros x a HInRec HSPRec.
    intros p' Hp'.
    unfold subst_in_sp_aux_2 in *.
    apply SPWEqP.MP.Dec.F.mem_2 in Hp'.
    rewrite SPWEqP.MP.Dec.F.add_iff in Hp'.
    elim Hp'; intro HIn; clear Hp'.

      destruct HIn as [HEq1 HEq2].
      rewrite <- HEq1; rewrite <- HEq2.
      unfold new_pair_2.
      clear HSPRec; clear a.
      elim (Pos.min_spec (fstpp(x)) pa); intro Hmin.

        destruct Hmin as [HLt Hmin].
        assert (Hmax : Pos.max (fstpp(x)) pa = pa) by (apply Pos.max_r; apply Pos.lt_le_incl; assumption).
        assert (HF : fstpp(fstpp(x), pa) = fstpp(x)) by (unfold fstpp; assumption).
        assert (HS : sndpp(fstpp(x), pa) = pa) by (unfold sndpp; assumption).
        rewrite HF; rewrite HS.

        assert (Hpb : sndpp(x) = pb).

          assert (HIn : SP.In x (fst_sp (partition_sp_1 pb sp))).

            unfold partition_sp_2 in HInRec.
            apply SP.partition_spec2 in HInRec; try apply proper_8.
            apply SPWEqP.MP.Dec.F.filter_1 in HInRec; try apply proper_9.
            assumption.

          unfold partition_sp_2 in HInRec.
          apply SP.partition_spec2 in HInRec; try apply proper_8.
          apply SPWEqP.MP.Dec.F.filter_2 in HInRec; try apply proper_9.
          unfold partition_sp_1 in HIn.
          apply SP.partition_spec1 in HIn; try apply proper_6.
          apply SPWEqP.MP.Dec.F.filter_2 in HIn; try apply proper_6.
          apply orb_true_iff in HIn.
          elim HIn; intro HEqb; clear HIn.

            apply Peqb_true_eq in HEqb.
            apply negb_true_iff in HInRec.
            apply Pos.eqb_neq in HInRec.
            rewrite HEqb in HInRec.
            intuition.

            apply Peqb_true_eq in HEqb.
            assumption.

        intro HEq4.
        unfold sp_ok in HSPS.
        apply SPWEqP.MP.Dec.F.mem_1 in HInRec.
        apply (HSPS x) in HInRec.
        apply HInRec.
        rewrite Hpb; rewrite HEq4; rewrite HA; rewrite HB; rewrite H; reflexivity.

        destruct Hmin as [HLe Hmin].
        assert (Hmax : Pos.max (fstpp(x)) pa = fstpp(x)) by (apply Pos.max_l; assumption).
        assert (HF : fstpp(fstpp(x), pa) = pa) by (unfold fstpp; assumption).
        assert (HS : sndpp(fstpp(x), pa) = fstpp(x)) by (unfold sndpp; assumption).
        rewrite HF; rewrite HS.

        assert (Hpb : sndpp(x) = pb).

          assert (HIn : SP.In x (fst_sp (partition_sp_1 pb sp))).

            unfold partition_sp_2 in HInRec.
            apply SP.partition_spec2 in HInRec; try apply proper_8.
            apply SPWEqP.MP.Dec.F.filter_1 in HInRec; try apply proper_9.
            assumption.

          unfold partition_sp_2 in HInRec.
          apply SP.partition_spec2 in HInRec; try apply proper_8.
          apply SPWEqP.MP.Dec.F.filter_2 in HInRec; try apply proper_9.
          unfold partition_sp_1 in HIn.
          apply SP.partition_spec1 in HIn; try apply proper_6.
          apply SPWEqP.MP.Dec.F.filter_2 in HIn; try apply proper_6.
          apply orb_true_iff in HIn.
          elim HIn; intro HEqb; clear HIn.

            apply Peqb_true_eq in HEqb.
            apply negb_true_iff in HInRec.
            apply Pos.eqb_neq in HInRec.
            rewrite HEqb in HInRec.
            intuition.

            apply Peqb_true_eq in HEqb.
            assumption.

        intro HEq4.
        unfold sp_ok in HSPS.
        apply SPWEqP.MP.Dec.F.mem_1 in HInRec.
        apply (HSPS x) in HInRec.
        apply HInRec.
        rewrite Hpb; rewrite <- HEq4; rewrite HA; rewrite HB; rewrite H; reflexivity.

      unfold sp_ok in HSPRec.
      apply HSPRec.
      apply SPWEqP.MP.Dec.F.mem_1; assumption.

    clear HSPS; assert (HSPS := HSPS'); clear HSPS'.
    unfold sp_ok in HSPS.
    apply HSPS.
    apply SPWEqP.MP.Dec.F.mem_1; assumption.

  assert (HIn := HInAux); clear HInAux.
  assert (HSPK : sp_ok (snd_sp (partition_sp_1 pb sp)) interp).

    intros p' Hp'.
    apply SPWEqP.MP.Dec.F.mem_2 in Hp'.
    unfold partition_sp_1 in Hp'.
    apply SP.partition_spec2 in Hp'; try apply proper_6.
    apply SPWEqP.MP.Dec.F.filter_1 in Hp'; try apply proper_7.
    unfold sp_ok in HSP.
    apply HSP; try assumption.
    apply SPWEqP.MP.Dec.F.mem_1; assumption.

  unfold sp_ok in HSPK.
  apply HSPK; try assumption.
  apply SPWEqP.MP.Dec.F.mem_1; assumption.
Qed.

End Col_refl.


Require Import String.

(*
data PTyp a = Var a | Forall (a -> PSigma a) | Fun (PSigma a) (PSigma a) | PInt

data PSigma a = And (PSigma a) (PSigma a) | Typ (PTyp a)
*)

Inductive PTyp : Type :=
  | PInt : PTyp
  | Fun : PTyp -> PTyp -> PTyp
  | And : PTyp -> PTyp -> PTyp.

(* Atomic types *)

(*
Inductive Atomic : PTyp -> Prop :=
  | AInt : Atomic PInt
  | AFun : forall t1 t2, Atomic (Fun t1 t2).
*)

Require Import Arith.
Require Import Setoid.

(* Subtyping relation *)

Inductive sub : PTyp -> PTyp -> Prop :=
  | SInt : sub PInt PInt
  | SFun : forall o1 o2 o3 o4, sub o3 o1 -> sub o2 o4 -> sub (Fun o1 o2) (Fun  o3 o4)
  | SAnd1 : forall t t1 t2, sub t t1 -> sub t t2 -> sub t (And  t1 t2)
  | SAnd2 : forall t t1 t2, sub t1 t -> sub (And  t1 t2) t
  | SAnd3 : forall t t1 t2, sub t2 t -> sub (And  t1 t2) t.

(* Orthogonality: Implementation *)

Inductive Ortho : PTyp -> PTyp -> Prop :=
  | OAnd1 : forall t1 t2 t3, Ortho t1 t3 -> Ortho t2 t3 -> Ortho (And t1 t2) t3
  | OAnd2 : forall t1 t2 t3, Ortho t1 t2 -> Ortho t1 t3 -> Ortho t1 (And t2 t3)
  | OFun  : forall t1 t2 t3 t4, Ortho t2 t4 -> Ortho (Fun t1 t2) (Fun t3 t4)
  | OIntFun : forall t1 t2, Ortho PInt (Fun t1 t2)
  | OFunInt : forall t1 t2, Ortho (Fun t1 t2) PInt.

(*  | OLift : forall t1 t2, not (sub t1 t2) -> not (sub t2 t1) -> Atomic t1 -> Atomic t2 -> Ortho t1 t2. *)

(* Orthogonality: Specification *)

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

(* Well-formed types *)

Inductive WFTyp : PTyp -> Prop :=
  | WFInt : WFTyp PInt
  | WFFun : forall t1 t2, WFTyp t1 -> WFTyp t2 -> WFTyp (Fun t1 t2)
  | WFAnd : forall t1 t2, WFTyp t1 -> WFTyp t2 -> Ortho t1 t2 -> WFTyp (And t1 t2).

(* Reflexivity *)

Hint Resolve SInt SFun SAnd1 SAnd2 SAnd3.

Lemma reflex : forall (t1 : PTyp), sub t1 t1.
Proof.
induction t1; intros; auto.
Defined.

Lemma invWFSInt : forall t2, WFTyp t2 -> sub PInt t2 -> t2 = PInt.
Proof.
intro. intro. intro.
induction H; intros. reflexivity.
inversion H0.
inversion H0.
assert (t1 = PInt). apply  IHWFTyp1. auto. rewrite H8 in H2.
assert (t2 = PInt). apply  IHWFTyp2. auto. rewrite H9 in H2.
inversion H2.
Defined.

(*
Lemma invWFSFun : forall t1 t2 t3, WFTyp t3 -> sub (Fun t1 t2) t3 -> exists t4 t5, sub t4 t1 /\ sub t2 t5 /\ t3 = Fun t4 t5.
Proof.
intros.
induction H.
inversion H0.
exists t0. exists t3. split. inversion H0. auto.
split. inversion H0. auto. reflexivity.
inversion H0.
assert (exists t4 t5 : PTyp, sub t4 t1 /\ sub t2 t5 /\ t0 = Fun t4 t5). apply IHWFTyp1. auto.
destruct H8. destruct H8. destruct H8. destruct H9. rewrite H10 in H2.
assert (exists t4 t5 : PTyp, sub t4 t1 /\ sub t2 t5 /\ t3 = Fun t4 t5). apply IHWFTyp2. auto.
destruct H11. destruct H11. destruct H11. destruct H12. rewrite H13 in H2.
exists x. exists x0. split. exact H8. split. exact H9.
inversion H2.
admit.*)

(* Orthogonality algorithm is complete *)

Lemma ortho_completness : forall (t1 t2 : PTyp), OrthoS t1 t2 -> Ortho t1 t2.
Proof.
induction t1; intros; unfold OrthoS in H.
(* Case PInt *)
induction t2.
destruct H. exists PInt. split; apply reflex.
apply OIntFun.
apply OAnd2.
apply IHt2_1. unfold not. unfold not in H. intros; apply H.
destruct H0. destruct H0.
exists x. split. exact H0. apply SAnd2. exact H1.
apply IHt2_2. unfold not. unfold not in H. intros. apply H.
destruct H0. destruct H0. exists x.
split. auto. apply SAnd3.
auto.
(* Case Fun t1 t2 *)
induction t2.
apply OFunInt.
apply OFun.
apply IHt1_2. unfold OrthoS. unfold not. intros.
unfold not in H. apply H.
destruct H0. destruct H0.
exists (Fun (And t1_1 t2_1) x).
split.
apply SFun.
apply SAnd2.
apply reflex.
auto.
apply SFun.
apply SAnd3. apply reflex.
auto.
(* Case t11 -> t12 _|_ t21 & t22 *)
apply OAnd2.
apply IHt2_1.
unfold not. unfold not in H. intros. apply H.
destruct H0. destruct H0.
exists x. split. auto. apply SAnd2. exact H1.
apply IHt2_2.
unfold not. unfold not in H. intros. apply H.
destruct H0. destruct H0.
exists x. split. auto. apply SAnd3. exact H1.
(* Case (t11 & t12) _|_ t2 *)
apply OAnd1.
apply IHt1_1.
unfold OrthoS.
unfold not. unfold not in H.
intro.
apply H.
clear H. destruct H0. destruct H.
exists x.
split.
apply SAnd2. exact H.
exact H0.
apply IHt1_2.
unfold OrthoS; unfold not; intro. unfold not in H.
apply H. clear H.
destruct H0.
destruct H.
exists x.
split.
apply SAnd3.
exact H.
exact H0.
Defined.

Lemma nosub : forall t1 t2, OrthoS t1 t2 -> not (sub t1 t2) /\ not (sub t2 t1).
Proof.
intros; split; unfold not.
unfold OrthoS in H. unfold not in H. intros.
apply H.
exists t2.
split. auto. apply reflex.
unfold OrthoS in H. unfold not in H. intros.
apply H.
exists t1. split. apply reflex. auto.
Defined.

Lemma invAndS1 : forall t t1 t2, sub t (And t1 t2) -> sub t t1 /\ sub t t2.
Proof.
induction t; intros.
(* Case Int *)
inversion H.
split; auto.
(* Case Fun *)
inversion H.
split; auto.
(* Case And *)
inversion H.
split; auto.
assert (sub t1 t0 /\ sub t1 t3).
apply IHt1.
auto.
destruct H4.
split.
apply SAnd2.
auto.
apply SAnd2.
auto.
assert (sub t2 t0 /\ sub t2 t3).
apply IHt2.
auto.
destruct H4.
split.
apply SAnd3.
auto.
apply SAnd3.
auto.
Defined.

Lemma uniquesub : forall A B C,
  OrthoS A B -> sub (And A B) C -> not (sub A C /\ sub B C).
Proof.
intros. unfold OrthoS in H. unfold not. intros. apply H. exists C. auto.
Defined.

(* Lemmas needed to prove soundness of the orthogonality algorithm *)

Lemma ortho_sym : forall A B, OrthoS A B -> OrthoS B A.
Proof.
unfold OrthoS. unfold not.
intros. apply H.
destruct H0. destruct H0.
exists x.
split; auto.
Defined.

Lemma ortho_and : forall A B C, OrthoS A C -> OrthoS B C -> OrthoS (And A B) C.
Proof.
intros. unfold OrthoS.
unfold not. intros.
destruct H1. destruct H1.
induction x.
inversion H1. unfold OrthoS in H. apply H. exists (PInt). split; auto.
unfold OrthoS in H0. apply H0. exists (PInt). split; auto.
inversion H1. unfold OrthoS in H. apply H. exists (Fun x1 x2). split; auto.
unfold OrthoS in H0. apply H0. exists (Fun x1 x2). split; auto.
assert (sub C x1 /\ sub C x2). apply invAndS1. auto. destruct H3.
inversion H1. apply IHx1; auto.
unfold OrthoS in H. apply H. exists (And x1 x2). split; auto.
unfold OrthoS in H0. apply H0. exists (And x1 x2). split; auto.
Defined.

Lemma common_supertype : forall x a b c d , sub (Fun a b) x -> sub (Fun c d) x -> exists c, sub d c /\ sub b c.
induction x; intros.
inversion H.
exists x2.
split.
inversion H0.
exact H6.
inversion H.
exact H6.
inversion H.
inversion H0.
apply (IHx2 a _ c).
apply H5.
apply H10.
Defined.

Lemma ortho_soundness : forall (t1 t2 : PTyp), Ortho t1 t2 -> OrthoS t1 t2.
intros.
induction H.
(* Hard case *)
assert (OrthoS t1 t3). apply IHOrtho1; auto.
assert (OrthoS t2 t3). apply IHOrtho2; auto.
apply ortho_and; auto.
assert (OrthoS t2 t1). apply ortho_sym. apply IHOrtho1; auto.
assert (OrthoS t3 t1). apply ortho_sym. apply IHOrtho2; auto.
apply ortho_sym.
apply ortho_and; auto.
(* Case FunFun *)
unfold OrthoS. unfold not. intros.
unfold OrthoS in IHOrtho. unfold not in IHOrtho. apply IHOrtho.
destruct H0. destruct H0. apply (common_supertype x t3 _ t1); auto.
(* Case IntFun *)
unfold OrthoS. unfold not. intros.
destruct H. destruct H. induction x. inversion H0. inversion H.
apply IHx1.
inversion H. auto.
inversion H0. auto.
(* Case FunInt *)
unfold OrthoS. unfold not. intros.
destruct H. destruct H. induction x. inversion H. inversion H0.
apply IHx1. inversion H. auto.
inversion H0. auto.
Defined.

(* Old theorems *)

Lemma invAndS1 : forall t t1 t2 i, sub i t (And nat t1 t2) -> sub i t t1 /\ sub i t t2.
Proof.
(*
induction t; intros; split; try (inversion H); auto.
*)
induction t; intros.
(* Case Var *)
inversion H.
split.
exact H4.
exact H5.
(* Case Int *)
inversion H.
split.
exact H4.
exact H5.
(* Case Forall *)
inversion H0.
split.
exact H5.
exact H6.
(* Case Fun *)
inversion H.
split.
exact H4.
exact H5.
(* Case And *)
inversion H.
split.
exact H4.
exact H5.
assert (sub i t1 t0 /\ sub i t1 t3).
apply IHt1.
exact H4.
destruct H5.
split.
apply SAnd2.
exact H5.
apply SAnd2.
exact H6.
assert (sub i t2 t0 /\ sub i t2 t3).
apply IHt2.
exact H4.
destruct H5.
split.
apply SAnd3.
exact H5.
apply SAnd3.
exact H6.
Defined.

Definition transitivity_sub S Q T := forall i, sub i S Q -> sub i Q T -> sub i S T.

Lemma trans : forall Q T S, transitivity_sub S Q T.
induction Q.
unfold transitivity_sub; intros.
induction T; try (inversion H0); auto.
rewrite H4 in H. auto.
unfold transitivity_sub; intros.
induction T; try (inversion H0); auto.
(* Case Forall *)
unfold transitivity_sub. intros.
generalize H1 H0. clear H0. clear H1.
generalize S. clear S.
induction T; intro; intro; try (inversion H1); auto.
induction S; intro; try (inversion H6); intros; auto.
apply SForall.
inversion H7.
apply (H i); auto.
(* Case Fun *)
unfold transitivity_sub; intros.
generalize H0 H. clear H0. clear H.
generalize S. clear S.
induction T; intro; intro; try (inversion H0); auto.
induction S; intro; try (inversion H7); auto.
inversion H8.
apply SFun.
apply IHQ1; auto.
apply IHQ2; auto.
(* Case And *)
unfold transitivity_sub; intros.
assert (sub i S Q1 /\ sub i S Q2).
apply invAndS1; auto.
destruct H1.
generalize H1 H2.
induction T; intros.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply IHQ1; auto.
apply IHQ2; auto.
inversion H0.
apply SAnd1.
apply IHT1; auto.
apply IHT2; auto.
apply IHQ1; auto.
apply IHQ2; auto.
Defined.

Definition Ortho A B := forall n, not (exists C, sub n A C /\ sub n B C).

Lemma p1 : forall (A B C : Prop), (A \/ B -> C) -> ((A -> C) /\ (B -> C)).
Proof.
intros.
split; intros.
apply H.
left.
exact H0.
apply H.
right.
exact H0.
Defined.

Definition equiv i t1 t2 := sub i t1 t2 /\ sub i t2 t1.

Definition contextEq i t1 t2 := (forall t, sub i t1 t -> sub i t2 t) /\ (forall t, sub i t t1 -> sub i t t2).

Definition narrowing_sub P Q X S T := forall i, sub i P Q -> (sub i X Q -> sub i S T) -> sub i X P -> sub i S T.

Lemma narrowing : forall X P Q S T, transitivity_sub X P Q -> narrowing_sub P Q X S T.
unfold narrowing_sub; intros.
apply H1.
apply H.
exact H2.
exact H0.
Defined.

Definition substitutability :
  forall t1 t2 i, equiv i t2 t1 -> contextEq i t2 t1 /\ contextEq i t1 t2.
intro. intro. intro. intro.
destruct H.
induction H; split; try split; intros.
(* Case Int *)
exact H.
exact H.
exact H.
exact H.
(* Case Var *)
exact H.
exact H.
exact H.
exact H.
(* Case Forall *)
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd1.
apply IHt1.
apply H6.
apply IHt2.
apply H7.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd2.
apply IHt1.
apply H6.
apply SAnd3.
apply IHt2.
apply H6.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd1.
apply IHt1.
apply H6.
apply IHt2.
apply H7.
induction t; try (inversion H1).
apply SForall.
apply IHsub.
inversion H0.
exact H10.
exact H6.
apply SAnd2.
apply IHt1.
apply H6.
apply SAnd3.
apply IHt2.
apply H6.
(* Case Fun *)
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd1.
apply IHt1.
exact H7.
apply IHt2.
exact H8.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd2.
apply IHt1.
exact H7.
apply SAnd3.
apply IHt2.
exact H7.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd1.
apply IHt1.
exact H7.
apply IHt2.
exact H8.
induction t; try (inversion H2).
inversion H0.
inversion H2.
apply SFun.
apply IHsub1.
apply H14.
apply H7.
apply IHsub2.
exact H16.
exact H23.
apply SAnd2.
apply IHt1.
exact H7.
apply SAnd3.
apply IHt2.
exact H7.
(* Case And1 *)
(*
generalize i, t1, t2, H, H1, H0, IHsub1, IHsub2, t0, H2.
clear H2. clear t0. clear IHsub2. clear IHsub1. clear H0. clear H1. clear H. clear t2. clear t1. clear i. *)
induction t; intros.
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
inversion H0. (*H2*)
apply SAnd2.
apply IHsub1.
exact H8.
exact H2. (*H3*)
apply SAnd3.
apply IHsub2.
exact H8.
exact H2. (*H3*)
inversion H0.
apply SAnd2.
apply IHsub1.
exact H7.
exact H2.
apply SAnd3.
apply IHsub2.
exact H7.
exact H2.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
Defined.

Lemma ForallInv : forall t p g i, (forall t : PTyp nat, sub i (Forall nat p) t -> sub i (Forall nat g) t) ->
                  sub (i + 1) (p i) t -> sub (i + 1) (g i) t.
intros.
assert (sub i (Forall nat g) (Forall nat (fun i => t))).
apply H.
apply SForall.
exact H0.
inversion H1.
exact H5.
Defined.

Lemma FunInv1 : forall o t t1 t2 t3 t4 i, (forall t : PTyp nat, sub i (Fun nat t1 t2) t -> sub i (Fun nat t3 t4) t) ->
               sub i t1 t -> sub i o t.
intros.
(* assert (sub i (Fun nat t3 t4) (Fun )). *)
admit.
Defined.

Lemma FunInv2 : forall t t1 t2 t3 t4 i, (forall t : PTyp nat, sub i (Fun nat t1 t2) t -> sub i (Fun nat t3 t4) t) ->
               sub i t2 t -> sub i t4 t.
intros.
assert (exists t10, sub i (Fun nat t3 t4) (Fun nat t10 t)).
exists t1.
apply H.
apply SFun.
apply reflex.
exact H0.
destruct H1.
inversion H1.
exact H8.
Defined.

Lemma funnyLemma : forall t1 t3 i (s : sub i t1 t3) t2, (forall t, sub i t2 t -> sub i t3 t) -> sub i t1 t2.
intro. intro. intro. intro.
induction s; intros.
(* Case PInt *)
apply H.
apply reflex.
(* Case Var *)
apply H.
apply reflex.
(* Case Forall *)
assert (sub i (Forall nat g) t2).
apply H.
apply reflex.
induction t2; try (inversion H0).
assert (sub (i+1) (f i) (p i)).
apply IHs. intro.
apply (ForallInv _ _ _ _ H).
apply SForall.
exact H6.
apply SAnd1.
apply IHt2_1.
intros.
apply H.
apply SAnd2.
exact H7.
exact H5.
apply IHt2_2.
intros.
apply H.
apply SAnd3.
exact H7.
exact H6.
(* Case Fun *)
(*
generalize i, o1, o2, o3, o4 , s1, s2, IHs1, IHs2, H.
clear H. clear IHs2. clear IHs1. clear s2. clear s1. clear o4. clear o3. clear o2. clear o1. clear i.
induction t2; intros.
assert (sub i (Fun nat o3 o4) (Var nat a)).
apply H. apply reflex.
inversion H0.
admit.
admit.
apply SFun.
*)

assert (sub i (Fun nat o3 o4) t2).
apply H.
apply reflex.
induction t2; try (inversion H0).
apply SFun.
assert (sub i o3 t2_1).
apply IHs1.
intros.
assert (sub i (Fun nat o3 o4) (Fun nat (Fun nat o1 o2) t2_1)).
apply H.
apply SFun.
apply IHt2_1.
intros.
apply H.

(* Using H! *)
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
admit.
Defined.

(* A functional definition : algorithm *)

Fixpoint size (t : PTyp nat) (i : nat) : nat :=
  match t with
      | PInt => 1
      | Var x => 1
      | Forall f => 1 + size (f i) (i+1)
      | And o1 o2 => 1 + max (size o1 i) (size o2 i)
      | Fun o1 o2 => 1 + max (size o1 i) (size o2 i)
  end.

Fixpoint subTyp (n : nat) (t1 : PTyp nat) (t2 : PTyp nat) (i : nat) : Prop  :=
  match n with
      | 0 => False
      | S m =>
          match (t1,t2) with
            | (PInt,PInt) => True
            | (Var x, Var y) => if (eq_nat_dec x y) then True else False
            | (Forall f, Forall g) => subTyp m (f i) (g i) (i+1)
            | (And o1 o2, And o3 o4) => and (subTyp m o1 o3 i) (subTyp m o2 o4 i)
            | (Fun o1 o2, Fun o3 o4) => and (subTyp m o3 o1 i) (subTyp m o2 o4 i)
            | (_,_) => False
          end
  end.

Lemma implements : forall t1 t2 n i, subTyp (size t1 n) t1 t2 i -> sub i t1 t2.
Proof.
induction t1; intros.
simpl in H.
destruct t2; try destruct H.
destruct (eq_nat_dec a n0).
rewrite e.
apply SVar. reflexivity.
destruct H.
destruct t2; try destruct H.


(** * Utils/InvMisc.v
-----------------

Provides a collection of miscellaneous facts and properties about
 standard data types that we could not find in ssreflect.*)

From mathcomp.ssreflect
     Require Import ssreflect ssrbool ssrnat eqtype fintype finset choice ssrfun bigop seq path finfun tuple.

Lemma ltn_Snn a b : a.+1 < b.+1 -> a < b.
Proof.
    by rewrite -{1}(addn1 a) -{1}(addn1 b) ltn_add2r.
Qed.

Lemma rem_in_neq (A: eqType) (q p: A) (inds: seq A) (Hneq:   q != p):
  (q \in rem p inds) = (q \in inds).
Proof.
  elim: inds => //= ind inds IHind.
  move: Hneq.
  case Heqind: (ind == p).
  - by move/eqP: Heqind ->;   rewrite in_cons eq_sym =>/Bool.negb_true_iff -> //=.
  - by rewrite !in_cons IHind.
Qed.

Lemma all_in_negP (A: eqType) (I J : seq A) :
  all (fun j => j \notin I) J = all (fun i => i \notin J) I.
Proof.
  apply/allP.
  case Hall: all.
  - by move/allP: Hall => Hnin; move=> j Hj; apply/memPn => i Hi; move: (Hnin i Hi) =>/memPn/(_ j Hj); rewrite eq_sym.
  - by move/Bool.negb_true_iff: Hall => /allPn [i Hi];
                                          rewrite Bool.negb_involutive => Hiinj;
                                                                            apply/allP;apply/allPn; exists i => //=; rewrite Bool.negb_involutive.
Qed.

Lemma minn_mult m l: (minn m (l * m + m) = m). Proof. by rewrite minnE //= addnC subnDA subnn subn0. Qed.

Lemma mult_subn m l: ((m * l) + l - l) = (m * l). Proof. by rewrite -addnBA //= subnn addn0. Qed.

(** utility function for ranges of values form (inclusive) a to b (exclusive) *)
Definition itoj (m n : nat) : seq.seq nat :=
  iota m (n - m).

(** Couldn't find a remove_nth function in stdlib or ssreflect*)
Fixpoint rem_nth {A:Type} (n : nat) (ls : list A) : list A :=
  match n with
  | 0 => if ls is h::t then t else nil
  | S n' => if ls is h :: t
            then h :: (rem_nth n' t)
            else ls
  end.
(*
Example rem_nth_test_1 : rem_nth 0 [:: 1; 2; 3] = [:: 2; 3].
Proof. by []. Qed.
Example rem_nth_test_2 : rem_nth 1 [:: 1; 2; 3] = [:: 1; 3].
Proof. by []. Qed.
Example rem_nth_test_3 : rem_nth 2 [:: 1; 2; 3] = [:: 1; 2].
Proof. by []. Qed.
 *)

Definition option_cons
           {A : Type}
           (self : option A)
           (list : seq.seq A) : seq.seq A := match self with
                                             | Some value => value :: list
                                             | None => list
                                             end.
(*Example option_cons_test_1 : option_cons (Some 1) [:: 2; 3] = [:: 1; 2; 3].
Proof. by []. Qed.
Example option_cons_test_2 : option_cons None [:: 2; 3] = [:: 2; 3].
Proof. by []. Qed.*)

Lemma options_cons_some_eq_cons : forall (A : Type) (x : A) (xs : seq.seq A), option_cons (Some x) xs = cons x xs.
Proof.
    by [].
Qed.

Lemma options_cons_none_ident : forall (A : Type) (xs : seq.seq A), option_cons None xs = xs.
Proof.
    by [].
Qed.
Fixpoint prefix {A : eqType} (xs : list A) (ys : list A) :=
  if length xs > length ys
  then false
  else
    match ys with
    | [::] => xs == [::]
    | y' :: ys' => if length ys == length xs
                   then xs == ys
                   else prefix  xs ys'
    end.

Example prefix_example_1 : prefix  [:: 1; 2; 3] [:: 4; 5; 1; 2; 3].
Proof. by []. Qed.
Example prefix_example_2 : @prefix _ [:: 1; 2; 3] [:: 1; 2; 3].
Proof. by []. Qed.

Fixpoint all_consecutive_sequences {A} (xs : list A) (l : nat) (p : list A -> bool) :=
  if (length xs) < l
  then true
  else
    match xs with
    | [::] => true
    | x' :: xs' => p (take l xs) && all_consecutive_sequences xs' l p
    end.

Definition mod_incr (n : nat) (pf: n > 0) (m : 'I_n) : 'I_n.
  case_eq (m < n)=> H.
  exact (Ordinal H).
  exact (Ordinal pf).
Qed.

Lemma negb_eqn b: b != true -> eq_op b false.
Proof.
    by case b.
Qed.

Lemma length_sizeP (T : Type) (ls : seq.seq T) : size ls = length ls.
Proof.
    by elim ls.
Qed.

Lemma has_countPn (T : Type) (a : pred T) (s : seq T) : ~~ has a s -> count a s = 0.
Proof.
  rewrite has_count.
    by rewrite -eqn0Ngt => /eqP .
Qed.

Lemma ltn_transPn n r : n < r -> r < n.+1 -> False.
Proof.
  elim: n => //= .
    by elim r => //=.
    move=> n IHn.
    move=> Hltn Hltr.
    apply IHn.
    rewrite leq_eqVlt in Hltn.
    move/orP: Hltn => [/eqP <- //=|].
    move/ltn_trans: Hltr => H /H.
      by rewrite ltnn.
      rewrite leq_eqVlt in Hltr.
      move/orP: Hltr => [/eqP [] Hwr|].
      move: Hltn.
      rewrite Hwr.
        by rewrite ltnn.
        rewrite -{1}(addn1 r).
        rewrite -{1}(addn1 n.+1).
          by rewrite ltn_add2r.
Qed.

Lemma subn_eqP n m : n <= m -> n - m = 0.
Proof.
    by rewrite -subn_eq0 => /eqP ->.
Qed.

Lemma ltn1 n : (n < 1)%nat = (n == 0%nat)%bool.
Proof.
    by elim n.
Qed.

Lemma ltnSn_eq a b : (a < b.+1)%nat -> (b < a.+1)%nat -> (a == b)%bool.
Proof.
  move: a.
  induction b => //= a.
  rewrite ltn1.
    by move=>  /eqP -> .
    have H (x y : nat) : (x > 0)%nat -> (x.-1 == y)%bool = (x == y.+1)%bool. by elim x  =>//=.
    case (0 < a)%nat eqn: Hva.
    rewrite -H //=.
    move=> Haltb Hblta.
    apply IHb.
    rewrite -ltnS.
      by rewrite prednK.
        by rewrite prednK.
        move/negP/negP: Hva.
        rewrite -leqNgt.
        rewrite leq_eqVlt.
        rewrite (ltnS b.+1).
        move=>/orP[/eqP ->|].
          by rewrite ltn0.
            by rewrite ltn0.
Qed.

Lemma addr_ltn a b c:
  (a + b < c)%nat -> (a < c)%nat.
Proof.
    by move=>/(ltn_addr b); rewrite ltn_add2r.
Qed.

Lemma ltn_leq_split a b c : (a + b - 1 < c.+1)%nat -> ~~ (b <= c)%nat -> ((b == c.+1)%bool  && (a == 0%nat)%bool).
Proof.
  rewrite -ltnNge.
  case (b) => [|b'].
    by rewrite ltn0.
    rewrite subn1 addnS.
    move=> Hab. move: (Hab).
    have Hltnadn x : (x > 0)%nat -> x.+1.-1 = x.-1.+1. by elim x => //=.
    move=> Habltn; move: Hab; rewrite prednK //=.
    move=> Hab; move: (Hab); rewrite addnC.
    move=> /addr_ltn Hbltc Hcltb.
    move: (ltnSn_eq _ _ Hbltc Hcltb) => /eqP Hbeq; move: Hab.
    rewrite Hbeq -(addn1 c) addnC ltn_add2l ltn1.
    move=>/eqP ->; apply/andP.
      by [].
Qed.

Lemma ltn_SnnP a b : (a.+1 < b.+1)%nat <-> (a < b)%nat.
Proof.
  split.
    by elim: a => //=.
      by elim: a => //=.
Qed.

Lemma subn_ltn_pr a b c : (a < c)%nat -> (a - b < c)%nat.
Proof.
  move: a b.
  elim: c => //= c .
  move=> IHn a b.
  case H: (a < c)%nat.
  move=> _.
  rewrite -(addn1 c).
  apply ltn_addr.
    by apply IHn.
    move/negP/negP: H .
    rewrite -leqNgt .
    rewrite -ltnS.
    move=> /ltnSn_eq H /(H) /eqP Heqa.
    induction a => //=.
    induction b => //=.
      by rewrite -Heqa subn0.
      rewrite subSS.
      rewrite -(addn1 c).
      apply ltn_addr.
      apply IHn.
        by rewrite Heqa.
Qed.

Lemma ltn_subn_pr a b c : (a < b - c) -> (a < b).
Proof.
  move: a b.
  elim: c=>//= [ a b | c  IHc a b].
    by rewrite subn0.
    rewrite subnS -subn1 subnAC =>/IHc.
    rewrite ltn_subRL addnC addn1.
    case: b => //= b /ltn_SnnP /(ltn_addr 1).
      by rewrite addn1.
Qed.

Lemma leq_subn_pr a b c : (a <= b - c) -> (a <= b).
Proof.
  rewrite {1}leq_eqVlt => /orP [/eqP -> | ].
    by apply leq_subr.
    move=>/ltn_subn_pr Hlt.
      by apply/ltnW.
Qed.

Lemma ltnn_subS n : (n > 0) -> n.-1 < n.
Proof.
    by case n .
Qed.

Lemma ltn_weaken a b c : a + b < c -> a < c.
Proof.
  elim: c => //= c IHc.
  rewrite leq_eqVlt => /orP [/eqP [] <- |].
  rewrite -addnS.
    by elim a => //=.
    rewrite -(addn1 (a + b)).
    rewrite -(addn1 c).
    rewrite ltn_add2r.
    move=>/IHc Hlt.
      by apply ltn_addr.
Qed.

Lemma ltn_subl1 a b : a < b -> a.-1 < b.
Proof.
  move: b.
  elim:a => //= a IHa b.
    by rewrite -{1}(addn1 a) => /ltn_weaken.
Qed.

Lemma ltn_subl a b c : a < b -> a - c < b.
Proof.
  move: a b.
  elim: c => //= [a b | c IHc a b].
    by rewrite subn0.
    move=> /IHc Hlt.
    rewrite subnS.
      by apply ltn_subl1.
Qed.

Lemma ltn_subLR  m n p : ( p > 0) -> (n  < p + m) -> (n - m < p).
Proof.
  move: n p.
  elim: m => [//=|m IHn].
  move=>  n p.
    by rewrite addn0 subn0.
    move=> n p p_vld H.
    rewrite subnS.
    rewrite -subn1.
    rewrite subnAC.
    apply IHn =>//=.
    rewrite addnS  ltnS in H.
    rewrite leq_eqVlt in H.
    move/orP: H => [/eqP ->|].
      by rewrite addnC -addnBA; [rewrite ltn_add2l subn1; apply ltnn_subS|].
      move=> H.
      rewrite subn1.
        by apply ltn_subl1.
Qed.

Lemma leq_addr_weaken x y z : (x + y <= z)%nat -> (x <= z)%nat.
Proof.
  move: x y.
  elim: z => [ | z IHz x y] //=.
    by move=> [|] //=.
    rewrite {1}leq_eqVlt => /orP [ /eqP <- | ].
      by apply (leq_addr ).
      move=> /IHz Hltxz.
      rewrite -(addn1 z) -(addn0 x).
        by apply leq_add.
Qed.

Lemma subn_eqQ a b : a - b = a -> a = 0 \/ b = 0.
Proof.
  case: a => //= [ | a]. by move=> _; left.
  case Hltn: (b <= a).
  rewrite subSn //= => [] [].
  move=>/(f_equal (fun x => x + b)).
  rewrite addnC.
  rewrite subnKC //=.
  move=>/(f_equal (fun x => x - a)).
  rewrite subnn.
  rewrite addnC.
    by rewrite -addnBA //= subnn addn0 => Hbeqn0; right.
    move/negP/negP: Hltn.
      by rewrite -ltnNge -subn_eq0 => /eqP ->.
Qed.

Lemma addr2n r : (r - 2 < r)%nat \/ (r == (r - 2%nat)%nat)%bool /\ (r == 0%nat)%bool.
Proof.
  elim r=> //.
    by right; rewrite sub0n.
    move=> n [IHn|IHn].
    case (n > 1)%nat eqn: H.
      by left; rewrite subSn; [rewrite -(addn1 (n - 2%nat)) -(addn1 n) ltn_add2r| ].
      move/negP/negP: H.
      rewrite -leqNgt leq_eqVlt.
        by move=>/orP[/eqP -> | ]; [left; rewrite subnn | rewrite ltn1; move=>/eqP ->; left].
          by destruct IHn as [_ Heq0]; move/eqP:Heq0 -> ; left.
Qed.

Lemma add_lt0 x y: (0 < x + y)%nat = ((0 <x)%nat && (0 <= y)%nat) || ((0 <=x)%nat && (0 < y)%nat).
Proof.
    by induction x => //=.
Qed.

Lemma addn_lt1 x y :  ((x + y)%nat <= 1)%nat -> (((x == 0)) || ((y == 0)))%nat.
Proof.
    by case: x => //= x; case: x => //=; case: y => //=.
Qed.

Lemma iota_predn r s : iota r s.+1 = iota r s ++ [:: r + s].
Proof.
  move: r.
  elim: s => [//=| s IHs   ] r.
    by rewrite addn0.
    rewrite -{1}(addn1 ).
    rewrite iota_add .
    have: (iota (r + s.+1) 1 = [:: r + s.+1]). by [].
      by move=> ->.
Qed.

Lemma size_iota_rcons (P : nat -> bool) r s : ~~ P (r + s.-1) -> size (filter P (iota r s)) = size (filter P (iota r s.-1)).
Proof.
  elim: s => [//=|] s' IHs Hs'.
  rewrite iota_predn.
  rewrite -pred_Sn.
  rewrite -pred_Sn in Hs'.
  rewrite filter_cat.
  have: ([seq x <- [:: r + s'] | P x] = [::]).
  move=> //=.
    by apply ifN.
    move=> ->.
      by rewrite cats0.
Qed.

Lemma subn_eq0_eq a b : (a - b == 0) -> (b - a == 0) -> a == b.
Proof.
  move: a; elim: b => //= [a| b IHn a].
    by rewrite subn0 sub0n => /eqP ->.
    rewrite !subn_eq0.
    rewrite leq_eqVlt => /orP [/eqP -> //=| ].
    elim: a => //= a Heqn.
    rewrite -{1}(addn1 a).
    move=> /ltn_weaken.
      by move=>/ltnSn_eq H /H /eqP ->.
Qed.

Lemma leq_exists  a b : a <= b -> exists c, a + c = b.
Proof.
  rewrite leq_eqVlt => /orP [/eqP -> | ]; first by exists 0; rewrite addn0.
                                                          move: a.
                                                          elim: b => //= b IHb a.
                                                          rewrite ltnS leq_eqVlt => /orP [/eqP -> | ]. by exists 1; rewrite addn1.
                                                                                by move=> /IHb [c' Heqn]; exists (c'.+1); rewrite addnS Heqn.
Qed.

Lemma addn_ltn_eqn' a b c : a > 0 -> a + c = b -> c < b.
Proof.
  move=> Hgt0a Heqn.
  rewrite -subn_eq0.
  rewrite -Heqn.
  rewrite subnDA.
  rewrite subnAC.
  rewrite subSn //= subnn.
  move: Hgt0a.
    by case a .
Qed.

Lemma ltn_exists a b : a > 0  -> a < b -> exists c, c < b /\ a + c = b.
Proof.
  move: a; elim: b => //= b IHb a Hltn0.
  rewrite leq_eqVlt => /orP [ /eqP [] Heq0 | ].
    by move: Hltn0; rewrite Heq0 => Hlnt0; exists 1; split => //=; rewrite addn1.
    rewrite -{1}(addn1 a) -{1}(addn1 b). rewrite ltn_add2r.
    move=> /IHb Hltn.
    move: (Hltn Hltn0) => [b' [Hb'ltb Hb'eqb]].
    exists (b'.+1); split.
      by rewrite -{1}(addn1 b) -{1}(addn1 b'); rewrite ltn_add2r.
        by rewrite addnS Hb'eqb.
Qed.

Lemma ltn_exists_multi a b : a > 0 -> a < b -> exists c d, c + d = b /\ c < a.
Proof.
  move: a; elim: b => //= b IHb'' a Ha0vld.
  move: (Ha0vld) => /IHb'' IHb' . clear IHb''.
  rewrite leq_eqVlt => /orP [ /eqP [] Haeqb | ].
  rewrite Haeqb.
  rewrite Haeqb in Ha0vld.
  exists b.-1.
  exists 2.
  split; last first.
    by apply ltnn_subS; move: Ha0vld.
      by rewrite addn2 -addn1 prednK //= addn1.
      rewrite -{1}(addn1 a).
      rewrite -{1}(addn1 b).
      rewrite ltn_add2r => /IHb' [c' [d' [Heqn Hlt]]].
      exists c'.
      exists d'.+1.
        by split; [rewrite addnS Heqn | ].
Qed.

Lemma leqn_eq0 a b : a > 0 -> (a <= a - b) -> b == 0 .
Proof.
  move: b.
  case: a => //= a b.
  case: b => //= b _ .
  rewrite subSS.
  move=> /ltn_subn_pr.
    by rewrite ltnn.
Qed.

Lemma nth_set_nth_ident
      (A : Type) (P : pred A) (ls : seq A) (a a' : A) (n : nat) :
  ~~ P a -> ~~ P (nth a ls n) -> ~~ P a' -> length (filter P (set_nth a ls n a'))
                                            = length (filter P ls).
Proof.
  elim: ls n => [n H0 H1 H2| a'' ls n n'] //=.
  rewrite /filter.
  case n => [//=|n0//=]; rewrite ifN.
    by [].
      by [].
        by induction n0 => //=; rewrite ifN.
          by [].
          induction n' => //= H0 H1 H2.
            by rewrite ifN; [rewrite ifN| by []] .
            case_eq (P a'') => H //=.
              by rewrite n.
                by rewrite n.
Qed.

Lemma nth_set_nth_ident_general (A : Type) (P : pred A) (ls : seq A) (a a' : A) (n : nat) :
  n < length ls ->
  P (nth a ls n) == P a' ->
  length (filter P (set_nth a ls n a')) = length (filter P ls).
Proof.

  elim: ls n => [n H0 | a'' ls n n'] //=.
  move=> H0 /eqP H.
  case_eq (P a'') =>  //=.
  move: H H0.
  case_eq n' => //=.
  move=> n0 H H1 H2.
  rewrite ifT.
    by [].
      by rewrite -H H2.
      move=> n0 n0eq H H1 H2.
      rewrite ifT.
      rewrite -(n n0) => //=.
        by rewrite H.
          by [].
          move=> H1.
          move: H.
          case_eq n' => //=.
          move=> H2 H.
          rewrite ifF.
            by [].
              by rewrite -H.
              move=> n0 H2 H.
              rewrite ifN.
              rewrite n => //=.
                by rewrite H2 in H0.
                  by rewrite H.
                    by rewrite H1.
Qed.

Lemma nth_set_nth_incr (A : Type) (P : pred A) (ls : seq A) (a a' : A) (n : nat):
  n < length ls ->
  P a' ->
  ~~ P (nth a ls n)  ->
  length (filter P (set_nth a ls n a')) = (length (filter P ls)).+1.
Proof.
  elim: ls n => [n H0 | a'' ls H n' ltnN Pa nPcons] //=.
  move: nPcons.
  case_eq n' => //= n0.
  move=> H1.
  rewrite ifT .
    by rewrite ifN.
      by [].
      move=> n_eq.
      move=> H1.
      case_eq (P a'') => //= Pa''.
      rewrite H.
        by [].
        rewrite n_eq in ltnN.
        move: ltnN => //=.
          by [].
            by [].
            rewrite H.
              by [].
              rewrite n_eq in ltnN.
              move: ltnN => //=.
                by [].
                  by [].
Qed.

Lemma itoj_eq_0 s r : (s < r)%nat -> itoj r s = [::].
Proof.
  rewrite /itoj; move=> Hsltr.
  have H: ((s - r)%nat = 0%nat). by apply /eqP; rewrite subn_eq0 leq_eqVlt; apply /orP; right.
  rewrite H => //=.
Qed.

Lemma addn_eq0 a b : (eq_op (a + b)%nat a) -> (eq_op b 0%nat).
Proof.
  move: b.
    by elim: a => //=.
Qed.

(* Miscellaneous Real Lemmas
 *)
Require Import Reals Fourier FunctionalExtensionality.
From infotheo
     Require Import fdist  proba ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop .

Local Open Scope real_scope.
Local Open Scope R_scope.
Local Open Scope reals_ext_scope.

Lemma Rleq_eqVlt : forall m n : R, (m <= n)%R <-> (m = n) \/ (m < n)%R.
Proof.
  split.
  move=>/Rle_lt_or_eq_dec.
    by case=> H; [right|left].
      by case=> [/Req_le | /Rlt_le].
Qed.
(* Probably not the best way to do this *)

Lemma R_w_distr (A : finType) (f g : A -> R) :
  (forall w : A, (f w * g w) = 0) -> (forall w : A, (f w) = 0) \/ (exists w : A, (g w) = 0).
  move=> H.
  case ([forall w, f w == 0]) eqn: Hall0.
    by move/eqfunP: Hall0 => Hall; left.
    right.
    apply/exists_eqP.
    move/negP/negP: Hall0.
    rewrite negb_forall=>/existsP [w /eqP Hw].
      by move: (H w) => /Rmult_integral [Hf0 | Hg0]; [move: (Hw Hf0) => [] | apply /exists_eqP; exists w].
Qed.
(** Subtracts a value from an ordinal value returning another value in the ordinal range *)
Definition ordinal_sub {max : nat} (value : 'I_max) (suband : nat) : 'I_max :=
  ssr_have (value - suband < max)%nat
           match value as o return (o - suband < max)%nat with
           | @Ordinal _ m i =>
             (fun Hpft =>
                (fun Hpf : (Ordinal (n:=max) (m:=m) i < max)%nat =>
                   eq_ind_r [eta is_true] Hpft (subn_ltn_pr (Ordinal (n:=max) (m:=m) i) suband max Hpf)))
               is_true_true i
           end [eta Ordinal (n:=max) (m:=value - suband)] .

Lemma Rle_big_eqP (A : finType) (f g : A -> R) (P : pred A) :
  (forall i : A, P i -> f i <= g i) ->
  \sum_(i | P i) g i = \sum_(i | P i) f i <->
  (forall i : A, P i -> g i = f i).
Proof.
  move=> hf; split => [/Rle_big_eq H//=|].
    by  exact (H hf).
    move=> H.
      by  exact (@eq_bigr _ _ _ A _ P  g f H).
Qed.

Lemma addRA_rsum  (A : finType) f g :
  \sum_(i in A) (f i + g i)%R = (\sum_(i in A) f i + \sum_(i in A) g i)%R .
Proof.
  rewrite unlock.
  elim index_enum => //=.
  have H : R0 = 0. (* there's some issues with the types 0 doesn't want to auto-coerce  to R0 *)
    by [].
    move: (addR0   ).
    rewrite /right_id => H'.
    move: (H' R0).
      by rewrite H.
      move=> x xs IHn.
        by rewrite IHn addRA (addRC (f x) (g x)) -(addRA (g x)) (addRC (g x)) -(addRA (f x + _)).
Qed.

Lemma gtRP (a b : R) : reflect (a > b) (a >b b).
Proof.
    by rewrite /gtRb /ltRb; apply: (iffP idP); [case Hrlta: (Rlt_dec b a) | case (Rlt_dec b a) ].
Qed.

Lemma foldl_rcons (T R : Type) (f : R -> T -> R) (b : R) (x : T) (xs : seq.seq T) : foldl f b (rcons xs x ) = f (foldl f b xs ) x.
Proof.
    by rewrite -cats1 foldl_cat => //=.
Qed.

Lemma  Rmult_integralP   r1 r2 :  (r1 * r2)%R <> 0%R -> r1 <> 0%R /\ r2 <> 0%R .
Proof.
  case Hr1eq0: (eq_op r1 0).
    by move/eqP: Hr1eq0 => ->; rewrite (Rmult_0_l r2) .
    case Hr2eq0: (eq_op r2 0).
      by move/eqP: Hr2eq0 => ->; rewrite (Rmult_0_r r1) .
        by move/eqP: Hr1eq0 => Hr1neq; move/eqP: Hr2eq0 => Hr2neq.
Qed.

Lemma index_enum_simpl y: ((index_enum y)) = (index_enum [finType of y]).
Proof.
    by rewrite /index_enum //= /[finType of _] //=; case: y => //=.
Qed.

Lemma ordinal_simplP (m p: nat) (i : [finType of m.-tuple 'I_p.+1]) val:
  size [seq tnth i x | x in [set ind | tnth i ind != val]] = #|[set ind0 | tnth i ind0 != val]|.
  by rewrite size_image.
Qed.

Lemma index_enum_ordP (T:finType) (m:nat)
      (t: T) (S: {set T}) (Hs: #| S | == m):
  t \in S -> (index t (enum S) < m )%nat.
Proof.
  move/eqP:Hs <- => Ht.
  apply seq_index_enum_card => //=.
  apply enum_uniq.
Qed.

Lemma index_enum_ordPn (T:finType) (m q:nat)
      (t: T) (S: {set T}) (Ht: #| T | = m) (Hs: #| S | == q):
  t \in S = false -> (index t (enum (~: S)) < m - q)%nat.
Proof.
  move=>/Bool.negb_true_iff Ht'; move: Ht <-; move/eqP:Hs <-.
  rewrite cardsCs subKn //=.
  apply seq_index_enum_card => //=.
    by apply enum_uniq.
      by rewrite in_setC.
        by rewrite -(cardsC S); apply leq_addl.
Qed.


(* DEC 2.0 language specification.
   Paolo Torrini,
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.

Require Export AuxLibI1.

Import ListNotations.

Open Scope type_scope.

(** Types *)

(** - The type of C value types *)

Inductive signedness : Type :=
  | Signed: signedness
  | Unsigned: signedness.

Inductive intsize : Type :=
  | I8: intsize
  | I16: intsize
  | I32: intsize
  | IBool: intsize.

Inductive CTyp (t: Type) : Type :=
                     | CVoid
                     | CBool : (t = bool) -> intsize -> signedness -> CTyp t
                     | CInt : (t = nat) -> intsize -> signedness -> CTyp t
                     | CPtr : (t = nat) -> CTyp t -> CTyp t.

(** - The type of value types *)

Inductive VTyp : Type := VT (st: Type) (ct: CTyp st).

(** - Extractors *)

Definition sVTyp (t: VTyp) : Type := match t with
                                     | VT st _ => st
                                     end.

(** DEC state class *)

Class PState (W: Type) : Type := {

   b_init : W ;
}.

(***********************************************************************)

(** - Value type abbreviations *)

Definition Unit : VTyp := VT (unit:Type) (CVoid unit).

Definition Nat : VTyp := VT (nat:Type) (CInt nat eq_refl I32 Unsigned).

Definition Bool : VTyp := VT (bool:Type) (CBool bool eq_refl IBool Unsigned).

(*************************************************************************)

(** - Parameter types *)

Inductive PTyp : Type := PT (ts: list VTyp).

(** - Function types *)

Inductive FTyp : Type := FT (prs_type: PTyp) (ret_type: VTyp).

(** - Extractors for function and parameter types *)

Definition ftypPT (ft: FTyp) : PTyp :=
  match ft with FT ps _ => ps end.

Definition ftypVT (ft: FTyp) : VTyp :=
  match ft with FT _ t => t end.

Definition ptypLS (ps: PTyp) : list VTyp :=
  match ps with PT ts => ts end.

Definition sPTyp (pt: PTyp) : Type :=
  tlist2type (map sVTyp (ptypLS pt)).

Definition VTypLs2Type (ts: list VTyp) : Type :=
  tlist2type (map sVTyp ts).