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

(****************************************************************************)
(*                                                                          *)
(*  Proof of the three gap theorem.                                         *)
(*                                                                          *)
(*  Micaela Mayero (INRIA-Rocquencourt)                                     *)
(*  September 1998                                                          *)
(*                                                                          *)
(****************************************************************************)
(****************************************************************************)
(*                               prop_fl.v                                  *)
(****************************************************************************)

(*********************************************************)
(*              Properties first last after              *)
(*                                                       *)
(*********************************************************)

Require Export prop_elem.
Require Export Classical_Prop.

Unset Standard Proposition Elimination Names.

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

Section theoreme.
Hypothesis alpha_irr : forall n p : Z, (alpha * IZR p)%R <> IZR n.
Hypothesis prop_alpha : (0 < alpha)%R /\ (alpha < 1)%R.
Hypothesis prop_N : forall N : nat, N >= 2.

(**********)
Lemma tech_fp_alp_irr :
 forall n m : nat, frac_part_n_alpha n = frac_part_n_alpha m -> n = m.
intros;
 generalize (Rminus_diag_eq (frac_part_n_alpha n) (frac_part_n_alpha m) H);
 unfold frac_part_n_alpha in |- *;
 elim (Rminus_fp1 (INR n * alpha) (INR m * alpha)).
unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
 rewrite (Rmult_comm (INR n) alpha); rewrite (Rmult_comm (- INR m) alpha);
 rewrite <- Rmult_plus_distr_l; intro;
 elim (fp_nat (alpha * (INR n + - INR m)) H0); intros;
 fold (INR n - INR m)%R in H1; rewrite (INR_IZR_INZ n) in H1;
 rewrite (INR_IZR_INZ m) in H1;
 rewrite (Z_R_minus (Z_of_nat n) (Z_of_nat m)) in H1;
 generalize (alpha_irr x (Z_of_nat n - Z_of_nat m));
 intro; elimtype False; auto.
unfold Rge in |- *; auto.
Qed.

(**********)
Lemma fp_first_R0 : forall N : nat, (frac_part_n_alpha (first N) > 0)%R.
intro; generalize (P1 (first N)); intro; unfold Rle in H; unfold Rgt in |- *;
 elim H; intro; auto; clear H; rewrite <- fp_R0 in H0;
 rewrite <- (Rmult_0_l alpha) in H0; cut (INR 0 = 0%R).
intro; rewrite <- H in H0;
 cut (frac_part (INR 0 * alpha) = frac_part_n_alpha 0).
intro; rewrite H1 in H0; generalize (tech_fp_alp_irr 0 (first N) H0); intro;
 generalize (first_0 N (prop_N N)); intro;
 generalize (lt_not_eq 0 (first N) H3); intro; elimtype False;
 auto.
unfold frac_part_n_alpha in |- *; auto.
auto.
Qed.

(**********)
Lemma contra_tech_fp_alp_irr :
 forall n m : nat, n <> m -> frac_part_n_alpha n <> frac_part_n_alpha m.
intros; generalize (tech_fp_alp_irr n m); tauto.
Qed.

(**********)
Lemma contradiction1 :
 forall N k : nat,
 N <= k ->
 k < first N + last N ->
 (frac_part_n_alpha k < frac_part_n_alpha (first N))%R \/
 (frac_part_n_alpha k > frac_part_n_alpha (last N))%R -> False.
intros; elim H1; intro; clear H1.
cut
 ((frac_part_n_alpha (last N) -
   (frac_part_n_alpha k - frac_part_n_alpha (first N) + 1))%R = 0%R).
unfold frac_part_n_alpha in |- *;
 rewrite <- (Rminus_fp2 (INR k * alpha) (INR (first N) * alpha) H2);
 generalize
  (Rminus_fp1 (INR (last N) * alpha) (INR k * alpha - INR (first N) * alpha));
 intros;
 cut
  (frac_part (INR (last N) * alpha) >=
   frac_part (INR k * alpha - INR (first N) * alpha))%R.
intro; rewrite <- (H1 H4) in H3; clear H1 H4;
 elim
  (fp_nat (INR (last N) * alpha - (INR k * alpha - INR (first N) * alpha)) H3).
unfold Rminus in |- *;
 rewrite <- (Ropp_mult_distr_l_reverse (INR (first N)) alpha);
 rewrite (Ropp_plus_distr (INR k * alpha) (- INR (first N) * alpha));
 rewrite <- (Ropp_mult_distr_l_reverse (INR k) alpha);
 rewrite <- (Ropp_mult_distr_l_reverse (- INR (first N)) alpha);
 rewrite (Ropp_involutive (INR (first N)));
 rewrite (Rmult_comm (- INR k) alpha);
 rewrite (Rmult_comm (INR (first N)) alpha);
 rewrite (Rmult_comm (INR (last N)) alpha);
 rewrite <- (Rmult_plus_distr_l alpha (- INR k) (INR (first N)));
 rewrite <-
  (Rmult_plus_distr_l alpha (INR (last N)) (- INR k + INR (first N)))
  ; rewrite (Rplus_comm (- INR k) (INR (first N)));
 rewrite <- (Rplus_assoc (INR (last N)) (INR (first N)) (- INR k));
 fold (INR (last N) + INR (first N) - INR k)%R in |- *;
 rewrite <- (plus_INR (last N) (first N));
 rewrite (INR_IZR_INZ (last N + first N)).
rewrite (INR_IZR_INZ k).
rewrite (Z_R_minus (Z_of_nat (last N + first N)) (Z_of_nat k)).
intros.
generalize (alpha_irr x (Z_of_nat (last N + first N) - Z_of_nat k)).
intro.
auto.
unfold Rge in |- *; right; apply Rminus_diag_uniq; auto.
cut
 ((frac_part_n_alpha k - frac_part_n_alpha (first N) + 1 <=
   frac_part_n_alpha (last N))%R /\
  (frac_part_n_alpha k - frac_part_n_alpha (last N) + 1 >=
   frac_part_n_alpha (first N))%R).
intro; elim H1; intros; clear H1.
generalize
 (Rle_minus (frac_part_n_alpha k - frac_part_n_alpha (first N) + 1)
    (frac_part_n_alpha (last N)) H3);
 generalize
  (Rge_minus (frac_part_n_alpha k - frac_part_n_alpha (last N) + 1)
     (frac_part_n_alpha (first N)) H4); intros; clear H3 H4;
 generalize
  (Rge_le
     (frac_part_n_alpha k - frac_part_n_alpha (last N) + 1 -
      frac_part_n_alpha (first N)) 0 H1); intro; clear H1;
 rewrite <- Ropp_minus_distr; rewrite <- Ropp_0; apply Ropp_eq_compat.
unfold Rminus in H3;
 rewrite (Rplus_comm (frac_part_n_alpha k) (- frac_part_n_alpha (last N)))
   in H3;
 rewrite (Rplus_assoc (- frac_part_n_alpha (last N)) (frac_part_n_alpha k) 1)
   in H3.
rewrite
 (Rplus_assoc (- frac_part_n_alpha (last N)) (frac_part_n_alpha k + 1)
    (- frac_part_n_alpha (first N))) in H3;
 rewrite
  (Rplus_comm (- frac_part_n_alpha (last N))
     (frac_part_n_alpha k + 1 + - frac_part_n_alpha (first N)))
   in H3;
 rewrite
  (Rplus_assoc (frac_part_n_alpha k) 1 (- frac_part_n_alpha (first N)))
   in H3; rewrite (Rplus_comm 1 (- frac_part_n_alpha (first N))) in H3;
 rewrite <-
  (Rplus_assoc (frac_part_n_alpha k) (- frac_part_n_alpha (first N)) 1)
   in H3; fold (frac_part_n_alpha k - frac_part_n_alpha (first N))%R in H3;
 fold
  (frac_part_n_alpha k - frac_part_n_alpha (first N) + 1 -
   frac_part_n_alpha (last N))%R in H3;
 elim
  (Rle_le_eq
     (frac_part_n_alpha k - frac_part_n_alpha (first N) + 1 -
      frac_part_n_alpha (last N)) 0); auto.
split; unfold frac_part_n_alpha in |- *.
unfold frac_part_n_alpha in H2;
 rewrite <- (Rminus_fp2 (INR k * alpha) (INR (first N) * alpha) H2);
 elim (tech_first_last N (k - first N) (prop_N N)).
intros; unfold ordre_total in H3; unfold frac_part_n_alpha in H3;
 cut (first N <= k).
intro; rewrite (minus_INR k (first N) H4) in H3; unfold Rminus in H3;
 rewrite (Rmult_comm (INR k + - INR (first N)) alpha) in H3;
 rewrite (Rmult_plus_distr_l alpha (INR k) (- INR (first N))) in H3;
 rewrite (Rmult_comm alpha (- INR (first N))) in H3;
 rewrite (Ropp_mult_distr_l_reverse (INR (first N)) alpha) in H3;
 fold (alpha * INR k - INR (first N) * alpha)%R in H3;
 rewrite (Rmult_comm alpha (INR k)) in H3; auto.
generalize (first_N01 N); intro; apply (le_trans (first N) N k H4 H).
elim (lt_minus2 (first N) k); auto.
generalize (first_N N (prop_N N)); intro.
apply (lt_le_trans (first N) N k H1 H).
cut (k - first N < last N).
generalize (last_N01 N); intros;
 apply (lt_le_trans (k - first N) (last N) N H3 H1).
apply (lt_plus_minus k (first N) (last N)).
generalize (first_N N (prop_N N)); intro;
 apply (lt_le_trans (first N) N k H1 H).
assumption.
cut (frac_part_n_alpha k < frac_part_n_alpha (last N))%R.
intro; unfold frac_part_n_alpha in H1;
 rewrite <- (Rminus_fp2 (INR k * alpha) (INR (last N) * alpha) H1);
 elim (tech_first_last N (k - last N) (prop_N N)).
intros; unfold ordre_total in H3; unfold frac_part_n_alpha in H3;
 cut (last N <= k).
intro; rewrite (minus_INR k (last N) H5) in H3; unfold Rminus in H3;
 rewrite (Rmult_comm (INR k + - INR (last N)) alpha) in H3;
 rewrite (Rmult_plus_distr_l alpha (INR k) (- INR (last N))) in H3;
 rewrite (Rmult_comm alpha (- INR (last N))) in H3;
 rewrite (Ropp_mult_distr_l_reverse (INR (last N)) alpha) in H3;
 fold (alpha * INR k - INR (last N) * alpha)%R in H3;
 rewrite (Rmult_comm alpha (INR k)) in H3;
 apply
  (Rle_ge (frac_part (INR (first N) * alpha))
     (frac_part (INR k * alpha - INR (last N) * alpha))
     (H3 prop_alpha)).
generalize (last_N01 N); intro; apply (le_trans (last N) N k H5 H).
elim (lt_minus2 (last N) k); auto.
generalize (last_N N (prop_N N)); intro.
apply (lt_le_trans (last N) N k H3 H).
cut (k - last N < first N).
generalize (first_N01 N); intros;
 apply (lt_le_trans (k - last N) (first N) N H4 H3).
apply (lt_plus_minus k (last N) (first N)).
generalize (last_N N (prop_N N)); intro;
 apply (lt_le_trans (last N) N k H3 H).
rewrite plus_comm; assumption.
generalize (le_first_last N (prop_N N)); unfold ordre_total in |- *; intros;
 apply
  (Rlt_le_trans (frac_part_n_alpha k) (frac_part_n_alpha (first N))
     (frac_part_n_alpha (last N)) H2 (H1 prop_alpha)).
(***)
cut
 ((frac_part_n_alpha (last N) -
   (frac_part_n_alpha k - frac_part_n_alpha (first N)))%R = 0%R).
cut (frac_part_n_alpha k >= frac_part_n_alpha (first N))%R.
unfold frac_part_n_alpha in |- *; intro;
 rewrite <- (Rminus_fp1 (INR k * alpha) (INR (first N) * alpha) H1);
 generalize
  (Rminus_fp1 (INR (last N) * alpha) (INR k * alpha - INR (first N) * alpha));
 intros;
 cut
  (frac_part (INR (last N) * alpha) >=
   frac_part (INR k * alpha - INR (first N) * alpha))%R.
intro; rewrite <- (H3 H5) in H4; clear H3 H5;
 elim
  (fp_nat (INR (last N) * alpha - (INR k * alpha - INR (first N) * alpha)) H4).
unfold Rminus in |- *;
 rewrite <- (Ropp_mult_distr_l_reverse (INR (first N)) alpha);
 rewrite (Ropp_plus_distr (INR k * alpha) (- INR (first N) * alpha));
 rewrite <- (Ropp_mult_distr_l_reverse (INR k) alpha);
 rewrite <- (Ropp_mult_distr_l_reverse (- INR (first N)) alpha);
 rewrite (Ropp_involutive (INR (first N)));
 rewrite (Rmult_comm (- INR k) alpha);
 rewrite (Rmult_comm (INR (first N)) alpha);
 rewrite (Rmult_comm (INR (last N)) alpha);
 rewrite <- (Rmult_plus_distr_l alpha (- INR k) (INR (first N)));
 rewrite <-
  (Rmult_plus_distr_l alpha (INR (last N)) (- INR k + INR (first N)))
  ; rewrite (Rplus_comm (- INR k) (INR (first N)));
 rewrite <- (Rplus_assoc (INR (last N)) (INR (first N)) (- INR k));
 fold (INR (last N) + INR (first N) - INR k)%R in |- *;
 rewrite <- (plus_INR (last N) (first N)).
rewrite (INR_IZR_INZ (last N + first N)).
rewrite (INR_IZR_INZ k).
rewrite (Z_R_minus (Z_of_nat (last N + first N)) (Z_of_nat k)).
intros.
generalize (alpha_irr x (Z_of_nat (last N + first N) - Z_of_nat k)).
intro.
auto.
unfold Rge in |- *; right; apply Rminus_diag_uniq; auto.
generalize (le_first_last N (prop_N N)); unfold ordre_total in |- *; intros;
 unfold Rgt in H2; cut (frac_part_n_alpha (first N) <= frac_part_n_alpha k)%R.
intro; apply (Rle_ge (frac_part_n_alpha (first N)) (frac_part_n_alpha k) H3).
cut (frac_part_n_alpha (first N) < frac_part_n_alpha k)%R.
intro; apply (Rlt_le (frac_part_n_alpha (first N)) (frac_part_n_alpha k) H3).
apply
 (Rle_lt_trans (frac_part_n_alpha (first N)) (frac_part_n_alpha (last N))
    (frac_part_n_alpha k) (H1 prop_alpha) H2).
cut
 ((frac_part_n_alpha k - frac_part_n_alpha (first N) <=
   frac_part_n_alpha (last N))%R /\
  (frac_part_n_alpha k - frac_part_n_alpha (last N) >=
   frac_part_n_alpha (first N))%R).
intro; elim H1; intros; clear H1.
generalize
 (Rle_minus (frac_part_n_alpha k - frac_part_n_alpha (first N))
    (frac_part_n_alpha (last N)) H3);
 generalize
  (Rge_minus (frac_part_n_alpha k - frac_part_n_alpha (last N))
     (frac_part_n_alpha (first N)) H4); intros; clear H3 H4;
 generalize
  (Rge_le
     (frac_part_n_alpha k - frac_part_n_alpha (last N) -
      frac_part_n_alpha (first N)) 0 H1); intro; clear H1;
 rewrite <- Ropp_minus_distr; rewrite <- Ropp_0; apply Ropp_eq_compat.
unfold Rminus in H3;
 rewrite
  (Rplus_assoc (frac_part_n_alpha k) (- frac_part_n_alpha (last N))
     (- frac_part_n_alpha (first N))) in H3;
 rewrite
  (Rplus_comm (- frac_part_n_alpha (last N)) (- frac_part_n_alpha (first N)))
   in H3;
 rewrite <-
  (Rplus_assoc (frac_part_n_alpha k) (- frac_part_n_alpha (first N))
     (- frac_part_n_alpha (last N))) in H3;
 fold (frac_part_n_alpha k - frac_part_n_alpha (first N))%R in H3;
 fold
  (frac_part_n_alpha k - frac_part_n_alpha (first N) -
   frac_part_n_alpha (last N))%R in H3;
 elim
  (Rle_le_eq
     (frac_part_n_alpha k - frac_part_n_alpha (first N) -
      frac_part_n_alpha (last N)) 0); auto.
split.
cut (frac_part_n_alpha k >= frac_part_n_alpha (first N))%R.
unfold frac_part_n_alpha in |- *; intro;
 rewrite <- (Rminus_fp1 (INR k * alpha) (INR (first N) * alpha) H1);
 elim (tech_first_last N (k - first N) (prop_N N)).
intros; unfold ordre_total in H4; unfold frac_part_n_alpha in H4;
 cut (first N <= k).
intro; rewrite (minus_INR k (first N) H5) in H4; unfold Rminus in H4;
 rewrite (Rmult_comm (INR k + - INR (first N)) alpha) in H4;
 rewrite (Rmult_plus_distr_l alpha (INR k) (- INR (first N))) in H4;
 rewrite (Rmult_comm alpha (- INR (first N))) in H4;
 rewrite (Ropp_mult_distr_l_reverse (INR (first N)) alpha) in H4;
 fold (alpha * INR k - INR (first N) * alpha)%R in H4;
 rewrite (Rmult_comm alpha (INR k)) in H4; auto.
generalize (first_N01 N); intro; apply (le_trans (first N) N k H5 H).
elim (lt_minus2 (first N) k); auto.
generalize (first_N N (prop_N N)); intro.
apply (lt_le_trans (first N) N k H3 H).
cut (k - first N < last N).
generalize (last_N01 N); intros;
 apply (lt_le_trans (k - first N) (last N) N H4 H3).
apply (lt_plus_minus k (first N) (last N)).
generalize (first_N N (prop_N N)); intro;
 apply (lt_le_trans (first N) N k H3 H).
assumption.
unfold frac_part_n_alpha in |- *; generalize (le_first_last N (prop_N N));
 unfold ordre_total in |- *; intros; unfold Rgt in H2;
 cut (frac_part_n_alpha (first N) <= frac_part_n_alpha k)%R.
intro; apply (Rle_ge (frac_part_n_alpha (first N)) (frac_part_n_alpha k) H3).
cut (frac_part_n_alpha (first N) < frac_part_n_alpha k)%R.
intro; apply (Rlt_le (frac_part_n_alpha (first N)) (frac_part_n_alpha k) H3).
apply
 (Rle_lt_trans (frac_part_n_alpha (first N)) (frac_part_n_alpha (last N))
    (frac_part_n_alpha k) (H1 prop_alpha) H2).
cut (frac_part_n_alpha k >= frac_part_n_alpha (last N))%R.
unfold frac_part_n_alpha in |- *; intro;
 rewrite <- (Rminus_fp1 (INR k * alpha) (INR (last N) * alpha) H1);
 elim (tech_first_last N (k - last N) (prop_N N)).
intros; unfold ordre_total in H3; unfold frac_part_n_alpha in H3;
 cut (last N <= k).
intro; rewrite (minus_INR k (last N) H5) in H3; unfold Rminus in H3;
 rewrite (Rmult_comm (INR k + - INR (last N)) alpha) in H3;
 rewrite (Rmult_plus_distr_l alpha (INR k) (- INR (last N))) in H3;
 rewrite (Rmult_comm alpha (- INR (last N))) in H3;
 rewrite (Ropp_mult_distr_l_reverse (INR (last N)) alpha) in H3;
 fold (alpha * INR k - INR (last N) * alpha)%R in H3;
 rewrite (Rmult_comm alpha (INR k)) in H3;
 apply
  (Rle_ge (frac_part (INR (first N) * alpha))
     (frac_part (INR k * alpha - INR (last N) * alpha))
     (H3 prop_alpha)).
generalize (last_N01 N); intro; apply (le_trans (last N) N k H5 H).
elim (lt_minus2 (last N) k); auto.
generalize (last_N N (prop_N N)); intro.
apply (lt_le_trans (last N) N k H3 H).
cut (k - last N < first N).
generalize (first_N01 N); intros;
 apply (lt_le_trans (k - last N) (first N) N H4 H3).
apply (lt_plus_minus k (last N) (first N)).
generalize (last_N N (prop_N N)); intro;
 apply (lt_le_trans (last N) N k H3 H).
rewrite plus_comm; assumption.
apply Rgt_ge; auto.
Qed.

(**********)
Lemma absurd1 :
 forall N k : nat,
 N <= k ->
 k < first N + last N ->
 (frac_part_n_alpha k >= frac_part_n_alpha (first N))%R /\
 (frac_part_n_alpha k <= frac_part_n_alpha (last N))%R.
intros; generalize (contradiction1 N k H H0); intro;
 cut
  (~ (frac_part_n_alpha k < frac_part_n_alpha (first N))%R /\
   ~ (frac_part_n_alpha k > frac_part_n_alpha (last N))%R).
intro; elim H2; intros; split.
apply (Rnot_lt_ge (frac_part_n_alpha k) (frac_part_n_alpha (first N)) H3).
apply (Rnot_gt_le (frac_part_n_alpha k) (frac_part_n_alpha (last N)) H4).
apply
 (not_or_and (frac_part_n_alpha k < frac_part_n_alpha (first N))%R
    (frac_part_n_alpha k > frac_part_n_alpha (last N))%R H1).
Qed.

(**********)
Lemma absurd_first :
 forall N k : nat,
 0 < k ->
 k < first N + last N ->
 (frac_part_n_alpha (first N) <= frac_part_n_alpha k)%R.
intros; elim inser_trans_lt with 0 k (first N + last N) N.
intro y; elim y; intros; apply (first_n N k (prop_N N) H1 H2 prop_alpha).
intro y; elim y; intros.
elim (absurd1 N k H1 H2); intros.
unfold Rge in H3; unfold Rle in |- *; unfold Rgt in H3; elim H3; intro.
left; assumption.
right; auto.
auto.
Qed.

(**********)
Lemma absurd_last :
 forall N k : nat,
 0 < k ->
 k < first N + last N ->
 (frac_part_n_alpha k <= frac_part_n_alpha (last N))%R.
intros; elim inser_trans_lt with 0 k (first N + last N) N.
intro y; elim y; intros; apply (last_n N k (prop_N N) H1 H2 prop_alpha).
intro y; elim y; intros.
elim (absurd1 N k H1 H2); intros; auto.
auto.
Qed.

(**********)
Lemma tech_first_aux :
 forall N a : nat,
 0 < a ->
 a < N ->
 ((forall b : nat,
   0 < b -> b < N -> (frac_part_n_alpha a <= frac_part_n_alpha b)%R) <->
  a = first N).
intros; split; intro.
cut (frac_part_n_alpha a = frac_part_n_alpha (first N)).
intro; apply (tech_fp_alp_irr a (first N) H2).
elim (Rle_le_eq (frac_part_n_alpha a) (frac_part_n_alpha (first N))); intros;
 clear H3;
 generalize (H1 (first N) (first_0 N (prop_N N)) (first_N N (prop_N N)));
 generalize (first_n N a (prop_N N) H H0 prop_alpha);
 intros; apply H2.
split; auto.
intros; rewrite H1; apply (first_n N b (prop_N N) H2 H3 prop_alpha).
Qed.

(**********)
Lemma eq_first_M_N :
 forall N M : nat,
 M = first N + last N ->
 ((forall b : nat,
   0 < b -> b < M -> (frac_part_n_alpha (first N) <= frac_part_n_alpha b)%R) <->
  first N = first M).
intros; split; intro.
elim (tech_first_aux M (first N) (first_0 N (prop_N N))).
intros; clear H2; auto.
rewrite H; apply (lt_plus (first N) (last N) (last_0 N (prop_N N))).
elim
 (tech_first_aux M (first M) (first_0 M (prop_N M)) (first_N M (prop_N M))).
intros; clear H1; rewrite H0; auto.
Qed.

(**********)
Lemma first_eq_M_N :
 forall N M : nat, M = first N + last N -> first N = first M.
intros; elim (eq_first_M_N N M H); intros; clear H1; apply H0.
intros; rewrite H in H2; apply (absurd_first N b H1 H2).
Qed.

(**********)
Lemma tech_last_aux :
 forall N a : nat,
 0 < a ->
 a < N ->
 ((forall b : nat,
   0 < b -> b < N -> (frac_part_n_alpha b <= frac_part_n_alpha a)%R) <->
  a = last N).
intros; split; intro.
cut (frac_part_n_alpha a = frac_part_n_alpha (last N)).
intro; apply (tech_fp_alp_irr a (last N) H2).
elim (Rle_le_eq (frac_part_n_alpha a) (frac_part_n_alpha (last N))); intros;
 clear H3;
 generalize (H1 (last N) (last_0 N (prop_N N)) (last_N N (prop_N N)));
 generalize (last_n N a (prop_N N) H H0 prop_alpha);
 intros; apply H2.
split; auto.
intros; rewrite H1; apply (last_n N b (prop_N N) H2 H3 prop_alpha).
Qed.

(**********)
Lemma eq_last_M_N :
 forall N M : nat,
 M = first N + last N ->
 ((forall b : nat,
   0 < b -> b < M -> (frac_part_n_alpha b <= frac_part_n_alpha (last N))%R) <->
  last N = last M).
intros; split; intro.
elim (tech_last_aux M (last N) (last_0 N (prop_N N))).
intros; clear H2; auto.
rewrite H; rewrite plus_comm;
 apply (lt_plus (last N) (first N) (first_0 N (prop_N N))).
elim (tech_last_aux M (last M) (last_0 M (prop_N M)) (last_N M (prop_N M))).
intros; clear H1; rewrite H0; auto.
Qed.

(**********)
Lemma last_eq_M_N : forall N M : nat, M = first N + last N -> last N = last M.
intros; elim (eq_last_M_N N M H); intros; clear H1; apply H0.
intros; rewrite H in H2; apply (absurd_last N b H1 H2).
Qed.

(**********)
Lemma tech_after :
 forall N n m : nat,
 0 < n ->
 n < N ->
 0 <= m ->
 m < N ->
 (frac_part_n_alpha n < frac_part_n_alpha m)%R ->
 ((exists k : nat,
     0 < k /\
     k < N /\
     (frac_part_n_alpha n < frac_part_n_alpha k)%R /\
     (frac_part_n_alpha k < frac_part_n_alpha m)%R) -> False) ->
 m = after N n.
intros; unfold after in |- *.
case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N); intro.
elim s; intros x y.
elim y; intros.
clear s y.
elim H6; intros; clear H6.
elim H8; intros; clear H8.
generalize
 (tech_not_exist_pt (fun k : nat => 0 < k) (fun k : nat => k < N)
    (fun k : nat => (frac_part_n_alpha n < frac_part_n_alpha k)%R)
    (fun k : nat => (frac_part_n_alpha k < frac_part_n_alpha m)%R) H4);
 clear H4; intro.
elim (H4 x H5 H7); intro.
absurd (frac_part_n_alpha n < frac_part_n_alpha x)%R; auto.
unfold Rgt in H9; generalize (H9 m H1 H2 H3); intro;
 generalize (Rnot_lt_ge (frac_part_n_alpha x) (frac_part_n_alpha m) H8);
 intro;
 generalize (Rge_antisym (frac_part_n_alpha m) (frac_part_n_alpha x) H10 H11);
 intro; apply (tech_fp_alp_irr m x H12).
elim (a m H1 H2); intros; unfold Rle in H6; elim H6; intro.
generalize (Rlt_asym (frac_part_n_alpha m) (frac_part_n_alpha n) H7); intro;
 elimtype False; auto.
cut
 ((frac_part_n_alpha n < frac_part_n_alpha m)%R \/
  (frac_part_n_alpha n > frac_part_n_alpha m)%R).
intro;
 generalize
  (Rlt_dichotomy_converse (frac_part_n_alpha n) (frac_part_n_alpha m) H8);
 intro; elimtype False; auto.
left; auto.
Qed.

(**********)
Lemma prop_after :
 forall N n m : nat,
 after N n = m ->
 (exists k : nat,
    0 < k /\
    k < N /\
    (frac_part_n_alpha n < frac_part_n_alpha k)%R /\
    (frac_part_n_alpha k < frac_part_n_alpha m)%R) -> False.
intros; elim H0; intros; elim H1; intros; elim H3; intros; elim H5; intro;
 clear H0 H1 H3 H5; rewrite <- H; unfold after in |- *;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N);
 intro.
elim s; intros x0 y H0; elim y; intros; elim H3; intros; elim H7; intros;
 clear s y H3 H7; fold (frac_part_n_alpha x > frac_part_n_alpha n)%R in H6;
 generalize (H9 x (lt_le_weak 0 x H2) H4 H6); intro;
 generalize (Rgt_not_le (frac_part_n_alpha x0) (frac_part_n_alpha x) H0);
 intro; cut (frac_part_n_alpha x0 <= frac_part_n_alpha x)%R.
intro; auto.
unfold Rge in H3; unfold Rle in |- *; elim H3; auto.
unfold frac_part_n_alpha in |- *; simpl in |- *; rewrite (Rmult_0_l alpha);
 rewrite fp_R0; elim (base_fp (INR x * alpha)); intros;
 generalize (Rgt_not_le 0 (frac_part (INR x * alpha)) H3);
 intro; cut (0 <= frac_part (INR x * alpha))%R.
intro; auto.
unfold Rge in H0; unfold Rle in |- *; elim H0; auto.
Qed.

(**********)
Lemma tech_after_lt :
 forall N n m : nat,
 0 < n ->
 n < N ->
 m <> 0 -> after N n = m -> (frac_part_n_alpha n < frac_part_n_alpha m)%R.
intros; rewrite <- H2; unfold after in |- *;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N);
 intros.
elim s; intros x y.
elim y; intros; clear y.
elim H4; intros; clear H4.
elim H6; intros; clear H6; auto.
cut (after N n = 0).
intro; rewrite H2 in H3; elimtype False; auto.
unfold after in |- *;
 case (exist_after_M (frac_part_n_alpha n) (P1 n) (P2 n) N);
 intros; auto.
elim s; intros x y.
elim y; intros; clear y.
elim H4; intros; clear H4.
elim H6; intros; clear H6; clear s.
generalize (lt_le_weak 0 x H3); intro.
elim (a x H6 H5); intros.
unfold Rle in H9; elim H9; intro; clear H9.
generalize (Rlt_asym (frac_part_n_alpha n) (frac_part_n_alpha x) H4); intro;
 elimtype False; auto.
generalize (sym_eq H10); intro; clear H10.
cut
 ((frac_part_n_alpha n < frac_part_n_alpha x)%R \/
  (frac_part_n_alpha n > frac_part_n_alpha x)%R); auto.
intro;
 generalize
  (Rlt_dichotomy_converse (frac_part_n_alpha n) (frac_part_n_alpha x) H10);
 intro; elimtype False; auto.
Qed.

(**********)
Lemma after_last : forall N : nat, after N (last N) = 0.
unfold after in |- *; intro;
 case
  (exist_after_M (frac_part_n_alpha (last N)) (P1 (last N)) (P2 (last N)) N);
 auto.
intro; elim s; intros x y; elim y; intros; elim H0; intros; elim H2; intros;
 clear s y H0 H2 H4; generalize (last_n N x (prop_N N) H H1 prop_alpha);
 intro;
 generalize
  (Rgt_not_le (frac_part_n_alpha x) (frac_part_n_alpha (last N)) H3);
 intro; elimtype False; auto.
Qed.

(**********)
Lemma prop_M :
 forall N M : nat,
 M = first N + last N ->
 (frac_part_n_alpha M < frac_part_n_alpha (first N))%R \/
 (frac_part_n_alpha M > frac_part_n_alpha (last N))%R.
intros; rewrite H;
 cut
  ((frac_part_n_alpha (first N) + frac_part_n_alpha (last N) < 1)%R \/
   (frac_part_n_alpha (first N) + frac_part_n_alpha (last N) >= 1)%R).
intros; elim H0; intro; clear H0.
right; unfold frac_part_n_alpha in H1; unfold frac_part_n_alpha in |- *;
 rewrite (plus_INR (first N) (last N));
 rewrite (Rmult_comm (INR (first N) + INR (last N)) alpha);
 rewrite (Rmult_plus_distr_l alpha (INR (first N)) (INR (last N)));
 rewrite (Rmult_comm (INR (first N)) alpha) in H1;
 rewrite (Rmult_comm (INR (last N)) alpha) in H1;
 rewrite (Rmult_comm (INR (last N)) alpha);
 rewrite (plus_frac_part2 (alpha * INR (first N)) (alpha * INR (last N)) H1);
 elim (Rplus_ne (alpha * INR (last N))); intros; clear H0;
 pattern (alpha * INR (last N))%R at 2 in |- *; rewrite <- H2;
 rewrite
  (Rplus_comm (frac_part (alpha * INR (first N)))
     (frac_part (alpha * INR (last N))));
 rewrite (Rplus_comm 0 (alpha * INR (last N)));
 cut (frac_part (alpha * INR (last N)) + frac_part 0 < 1)%R.
intro; rewrite (plus_frac_part2 (alpha * INR (last N)) 0 H0); rewrite fp_R0;
 apply
  (Rplus_gt_compat_l (frac_part (alpha * INR (last N)))
     (frac_part (alpha * INR (first N))) 0); generalize (fp_first_R0 N);
 unfold frac_part_n_alpha in |- *; rewrite (Rmult_comm alpha (INR (first N)));
 auto.
rewrite fp_R0; elim (Rplus_ne (frac_part (alpha * INR (last N)))); intros;
 clear H3; rewrite H0; rewrite (Rmult_comm alpha (INR (last N)));
 cut (frac_part (INR (last N) * alpha) = frac_part_n_alpha (last N)).
intro; rewrite H3; apply (P2 (last N)).
unfold frac_part_n_alpha in |- *; auto.
(**)
left; unfold frac_part_n_alpha in H1; unfold frac_part_n_alpha in |- *;
 unfold frac_part_n_alpha in |- *; rewrite (plus_INR (first N) (last N));
 rewrite (Rmult_comm (INR (first N) + INR (last N)) alpha);
 rewrite (Rmult_plus_distr_l alpha (INR (first N)) (INR (last N)));
 rewrite (Rmult_comm (INR (first N)) alpha) in H1;
 rewrite (Rmult_comm (INR (last N)) alpha) in H1;
 rewrite (Rmult_comm (INR (first N)) alpha);
 rewrite (plus_frac_part1 (alpha * INR (first N)) (alpha * INR (last N)) H1);
 unfold Rminus in |- *; rewrite Rplus_assoc;
 elim (Rplus_ne (alpha * INR (first N))); intros; clear H2;
 pattern (alpha * INR (first N))%R at 2 in |- *; rewrite <- H0;
 cut (frac_part (alpha * INR (first N)) + frac_part 0 < 1)%R.
intro; rewrite (plus_frac_part2 (alpha * INR (first N)) 0 H2); rewrite fp_R0;
 apply
  (Rplus_lt_compat_l (frac_part (alpha * INR (first N)))
     (frac_part (alpha * INR (last N)) + -1) 0);
 cut
  ((frac_part (alpha * INR (last N)) + -1)%R =
   (frac_part (alpha * INR (last N)) - 1)%R).
intro; rewrite H3; clear H3;
 apply (Rlt_minus (frac_part (alpha * INR (last N))) 1).
rewrite (Rmult_comm alpha (INR (last N)));
 cut (frac_part (INR (last N) * alpha) = frac_part_n_alpha (last N)).
intro; rewrite H3; apply (P2 (last N)).
unfold frac_part_n_alpha in |- *; auto.
unfold Rminus in |- *; auto.
rewrite fp_R0; elim (Rplus_ne (frac_part (alpha * INR (first N)))); intros;
 clear H3; rewrite H2; rewrite (Rmult_comm alpha (INR (first N)));
 cut (frac_part (INR (first N) * alpha) = frac_part_n_alpha (first N)).
intro; rewrite H3; apply (P2 (first N)).
unfold frac_part_n_alpha in |- *; auto.
(**)
unfold Rge in |- *;
 generalize
  (Rtotal_order (frac_part_n_alpha (first N) + frac_part_n_alpha (last N)) 1);
 intro; elim H0; intro.
left; auto.
right; elim H1; auto.
Qed.

(**********)
Lemma le_N_M : forall N M : nat, M = first N + last N -> N <= M.
intros; generalize (prop_M N M H); intro; cut (~ N > M).
intro; apply not_gt_le; auto.
unfold gt in |- *; red in |- *; intro; cut (0 < M).
intro; elim H0; intro; clear H0.
generalize (first_n N M (prop_N N) H2 H1 prop_alpha); intro.
generalize
 (Rgt_not_le (frac_part_n_alpha (first N)) (frac_part_n_alpha M) H3);
 intro; clear H3; auto.
generalize (last_n N M (prop_N N) H2 H1 prop_alpha); intro.
unfold Rgt in H3;
 generalize
  (Rgt_not_le (frac_part_n_alpha M) (frac_part_n_alpha (last N)) H3);
 intro; clear H3; auto.
rewrite H; generalize (first_0 N (prop_N N)); intro;
 apply (lt_O_plus (first N) (last N) H2).
Qed.

End theoreme.


(* Distributed under the terms of the MIT license. *)
Set Warnings "-notation-overridden".

From MetaCoq.Utils Require Import utils.
From MetaCoq.Template Require Import All.
Unset Universe Checking.
From MetaCoq.Translations Require Import translation_utils times_bool_fun MiniHoTT.
Import MCMonadNotation.

Unset MetaCoq Strict Unquote Universe Mode.

MetaCoq Run (TC <- ImplementExisting emptyTC "paths" ;;
                     TC <- ImplementExisting TC "idpath" ;;
                     TC <- ImplementExisting TC "paths_ind" ;;
                     TC <- ImplementExisting TC "transport" ;;
                     TC <- ImplementExisting TC "sigT" ;;
                     TC <- ImplementExisting TC "projT1" ;;
                     TC <- ImplementExisting TC "projT2" ;;
                     TC <- ImplementExisting TC "existT" ;;
                     tmDefinition "eqTC" TC).
Next Obligation.
  tIntro A. tIntro x. tIntro y. exact (x = y).
Defined.
Next Obligation.
  tIntro A. tIntro x. exact 1.
Defined.
Next Obligation.
  tIntro A. tIntro a. tIntro P. tIntro t. tIntro y. tIntro p.
  exact (paths_ind a (fun y p => π1 (π1 P y) p) t y p).
Defined.
Next Obligation.
  tIntro A. tIntro P. tIntro x. tIntro y. tIntro p. tIntro t.
  exact (transport (π1 P) p t).
Defined.
Next Obligation.
  tIntro A. tIntro B. exact (sigT (π1 B)).
Defined.
Next Obligation.
  tIntro A. tIntro B. tIntro u. exact u.1.
Defined.
Next Obligation.
  tIntro A. tIntro B. tIntro u. exact u.2.
Defined.
Next Obligation.
  tIntro A. tIntro B. tIntro x. tIntro y. exact (x; y).
Defined.

Definition isequiv {A B} (f : A -> B) :=
  exists (g : B -> A) (H1 : forall x, paths (g (f x)) x), (forall y, paths (f (g y)) y).

Definition idequiv A : @isequiv A A (fun x => x).
  unshelve econstructor. exact (fun y => y).
  split; intro; exact 1.
Defined.

Definition equiv A B := exists f, @isequiv A B f.

Definition coe {A B} (p : A = B) : A -> B
  := transport idmap p.

Definition transport_pV {A : Type} (P : A -> Type) {x y : A} (p : x = y)
  : forall z : P y, p # p^ # z = z
  := paths_ind x (fun y p => forall z : P y, p # p^ # z = z) (fun z => 1) y p.

Definition transport_Vp {A : Type} (P : A -> Type) {x y : A} (p : x = y)
  : forall z : P x, p^ # p # z = z
  := paths_ind x (fun y p => forall z : P x, p^ # p # z = z) (fun z => 1) y p.

Definition id2equiv A B (p : A = B) : equiv A B.
  repeat unshelve econstructor.
  exact (transport idmap p).
  exact (transport idmap p^).
  all: unfold coe; intro.
  (* refine (paths_ind A (fun y p => forall z : A, p^ # p # z = z) (fun z => 1) B p _). *)
  (* refine (paths_ind A (fun y p => forall z : y, p # p^ # z = z) (fun z => 1) B p _). *)
  exact (transport_Vp idmap _ _).
  exact (transport_pV idmap _ _).
Defined.

Definition UA := forall A B, isequiv (id2equiv A B).

MetaCoq Run (TC <- Translate eqTC "isequiv" ;;
                     TC <- Translate TC "equiv" ;;
                     TC <- ImplementExisting TC "eq" ;;
                     TC <- Translate TC "inverse" ;;
                     tmDefinition "eqTC2" TC).
Next Obligation.
  tIntro A. tIntro x. tIntro y. exact (@eq A x y).
Defined.

Definition contr A := exists x : A, forall y, x = y.
Definition weakFunext
  := forall (A : Type) (P : A -> Type), (forall x, contr (P x)) -> contr (forall x, P x).

MetaCoq Run (TC <- Translate eqTC2 "contr" ;;
                     TC <- Translate TC "weakFunext" ;;
                     tmDefinition "eqTC3" TC).

Goal weakFunextᵗ -> False.
  intro H. tSpecialize H unit. tSpecialize H (pair (fun _ => unit) true).
  simple refine (let H' := π1 H _ in _).
  - tIntro x. lazy. exists tt. tIntro y; now destruct y.
  - lazy in H'. destruct H' as [H1 H2]; clear H.
    tSpecialize H2 (pair (π1 H1) (negb (π2 H1))).
    apply (f_equal π2) in H2. lazy in H2.
    set (π2 H1) in H2. change (b = negb b) in H2.
    destruct b; inversion H2.
Defined.

Definition retract A B := exists (f : A -> B) (g : B -> A), g o f == idmap.

Definition contr_retract {A B} (R : retract A B) (C : contr B) : contr A.
  destruct R as [f [g e]].
  exists (g C.1). intro y.
  refine (ap g _ @ e y).
  exact (C.2 (f y)).
Defined.

Definition postcompose_equiv
  := forall A B (e : equiv A B) A', isequiv (fun (g : A' -> A) => e.1 o g).

Definition UA_postcomposeequiv : UA -> postcompose_equiv.
  (* uses eta *)
Admitted.

Definition α {A} (P : A -> Type) := fun (g : A -> sigT P) => pr1 o g.

Definition contr_isequivα := forall A P, (forall x, contr (P x)) -> isequiv (@α A P).

Definition postcomposeequiv_αequiv
  : postcompose_equiv -> contr_isequivα.
  (* no eta ? *)
  intros H A P C.
  refine (H (sigT P) A (_; _) _).
  unshelve econstructor.
  exact (fun x => (x; (C x).1)).
  lazy. econstructor.
  intros [x y]. refine (path_sigma' P 1 _). exact ((C x).2 y).
  intro; exact 1.
Defined.

Definition fib {A B} (f : A -> B) y := exists x, f x = y.

Definition equiv_contrfib {A B} (f : A -> B) (Hf : isequiv f) y : contr (fib f y).
Admitted.

Definition contr_retractα
  := forall A P, (forall x, contr (P x)) -> retract (forall x : A, P x) (fib (α P) idmap).

Definition contr_retract_α : contr_retractα.
  intros A P H.
  simple refine (_; (_; _)).
  - intro f. exists (fun x => (x; f x)). exact 1.
  - intros [g p] x. refine (_ # (g x).2).
    exact (ap10 p x).
  - intro f; lazy. exact 1. (* uses eta! *)
Defined.

(* MetaCoq Run (TC <- TranslateRec eqTC3 contr_retractα ;; *)
(*                      TC <- ImplementExisting TC "contr_retract_α" ;; *)
(*                      tmDefinition "eqTC4" TC). *)
(* Next Obligation. *)
(*   tIntro A. tIntro P. tIntro H. *)
(*   simple refine (_; (_; _)). *)
(*   - tIntro f. exists (pair (fun x => (x; π1 f x)) (π2 f)). exact 1. *)
(*   - tIntro gp. refine (pair (fun x => _) (π2 gp.1)). *)
(*     refine (_ # ((π1 gp.1) x).2). all: lazy. *)
(*     exact (ap10 (ap π1 gp.2) x). *)
(*   - tIntro f; lazy. exact 1. *)
(* Defined. *)

Definition UA_postcomposeequiv' : UA -> postcompose_equiv.
  intros ua A B e X. repeat unshelve econstructor.
  - intros f x. exact (e.2.1 (f x)).
  - intro f.

  (* uses eta *)
Admitted.

Definition αequiv_weakfunext : contr_isequivα -> weakFunext.
  intros Hα A P H.
  refine (contr_retract _ _).
  2: exact (equiv_contrfib _ (Hα A P H) idmap).
  exact (contr_retract_α A P H).
Defined.


Require Import Coqlib.
Require Import List. Import ListNotations.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import sha.ByteBitRelations. (* TODO this is only here because of bitsToBytes *)

Module Type ABSTRACT_ENTROPY.

Parameter stream: Type.

Inductive error_code: Type :=
| catastrophic_error
| generic_error
.

Inductive result X: Type: Type :=
| success: X -> stream -> @result X
| error : error_code -> stream -> @result X
.

Arguments success {X} _ _.
Arguments error {X} _ _.

Parameter get_bytes: nat -> stream -> result (list Z).
Parameter get_bits: nat -> stream -> result (list bool).

End ABSTRACT_ENTROPY.

Module OPTIONAL_ENTROPY <: ABSTRACT_ENTROPY.

Definition stream: Type := nat -> option bool.

Inductive error_code: Type :=
| catastrophic_error
| generic_error
.

Inductive result X: Type: Type :=
| success: X -> stream -> @result X
| error : error_code -> stream -> @result X
.

Arguments success {X} _ _.
Arguments error {X} _ _.

Fixpoint get_bits (k: nat) (s: stream): result (list bool) :=
  match k with
    | O => success [] s
    | S k' => match get_bits k' s with
                | error e s' => error  e s'
                | success b s' =>
                  match s' O with
                    | None => error catastrophic_error (fun i => match nat_compare i k' with
                                                                   | Lt => s i
                                                                   | Eq | Gt => s (1 + i)%nat
                                                                 end
                                                       )
                    | Some e => success (b ++ [e]) (fun i => s (k + i)%nat)
                  end
              end
  end.

Example get_bits_test1:
  forall bits s output s',
    bits = [Some false; Some true; Some false; Some false] ->
    s = (fun i => nth i bits None) ->
    success output s' = get_bits (length bits) s ->
    s' = (fun i => s (length bits + i)%nat) /\ output = [false; true; false; false].
Proof.
  intros.
  subst.
  inv H1.
  split.
  extensionality i. destruct i; reflexivity.
  reflexivity.
Qed.

Example get_bits_test2:
  forall bits s output s' s'',
    bits = [Some false; None; Some true; Some false; Some false] ->
    s = (fun i => nth i bits None) ->
    error catastrophic_error s' = get_bits 4%nat s ->
    success output s'' = get_bits 4%nat s' ->
    s'' = (fun i => s (length bits + i)%nat) /\ output = [false; true; false; false].
Proof.
  intros.
  subst.
  inv H1.
  inv H2.
  split.
  extensionality i. reflexivity.
  reflexivity.
Qed.

Example get_bits_test3:
  forall bits s output s' s'',
    bits = [None; Some false; Some true; Some false; Some false] ->
    s = (fun i => nth i bits None) ->
    error catastrophic_error s' = get_bits 4%nat s ->
    success output s'' = get_bits 4%nat s' ->
    s'' = (fun i => s (length bits + i)%nat) /\ output = [false; true; false; false].
Proof.
  intros.
  subst.
  inv H1.
  inv H2.
  split.
  extensionality i. reflexivity.
  reflexivity.
Qed.

Example get_bits_test4:
  forall bits s output s' s'',
    bits = [Some false; Some true; Some false; None; Some false] ->
    s = (fun i => nth i bits None) ->
    error catastrophic_error s' = get_bits 4%nat s ->
    success output s'' = get_bits 4%nat s' ->
    s'' = (fun i => s (length bits + i)%nat) /\ output = [false; true; false; false].
Proof.
  intros.
  subst.
  inv H1.
  inv H2.
  split.
  extensionality i. reflexivity.
  reflexivity.
Qed.
(*
Fixpoint get_bits_concrete (k: nat) (s: stream) (max: nat): @result (list bool) :=
  match k with
    | O => success [] s
    | S k' =>
      match s (max - k)%nat with
        | None => error catastrophic_error (fun i => s (1 + i)%nat)
        | Some bit =>
          match get_bits_concrete k' s max with
            | error e s' => error e (fun i => match nat_compare i (max - k)%nat with
                                                  | Gt => s' i
                                                  | Eq | Lt => s i
                                     end)
            | success b s' => success (bit::b) (fun i => s (k + i)%nat)
          end
      end
  end
.
Lemma get_bits_concrete_correct:
  forall k s, get_bits k s = get_bits_concrete k s k.
Proof.
  intros k.
  induction k as [|k']; [reflexivity|].
  intros s.
  simpl.
  rewrite IHk'. clear IHk'.
  replace (k' - k')%nat with O by omega.
  remember (s O) as sO.
  destruct sO.
  {
    (* s 0 <> None *)
    (*
    remember (get_bits_concrete k' s k') as result.
    destruct result as [string s' | e s'].
    {
      remember (get_bits_concrete k' s (S k')) as result2.
      destruct result2 as [string2 s'2 | e2 s'2].
      {
        (* case where both result return success *)
        generalize dependent s.
        induction k' as [|k'']; intros.
        simpl in *. inv Heqresult. inv Heqresult2. rewrite <- HeqsO. auto.
        simpl in *. replace (k'' - k'')%nat with O in * by omega. rewrite <- HeqsO in *.
        rewrite IHk''.
      }
      unfold get_bits_concrete.
    }
*)
    induction k' as [|k''].
    {
      simpl. rewrite <- HeqsO.
      reflexivity.
    }
    simpl.
    replace (k'' - k'')%nat with O by omega.
    rewrite <- HeqsO in *.
    replace (match k'' with
             | 0%nat => S k''
             | S l => (k'' - l)%nat
             end) with 1%nat by (destruct k''; omega).

  }
  {
    destruct k' as [|k''].
    {
      simpl. rewrite <- HeqsO.
      replace (fun i : nat =>
      match nat_compare i 0 with
      | Eq => s (S i)
      | Lt => s i
      | Gt => s (S i)
      end) with (fun i => s (S i)); [reflexivity|].
      extensionality i.
      destruct i as [|i']; reflexivity.
    }
    simpl.
    replace (k'' - k'')%nat with O by omega; rewrite <- HeqsO.
    reflexivity.
  }
  simpl.
  *)

Definition get_bytes (k: nat) (s: stream): result (list Z) :=
  match get_bits (8 * k)%nat s with
    | success bits s' => success (bitsToBytes bits) s'
    | error e s' => error e s'
  end
.

End OPTIONAL_ENTROPY.

Module ENTROPY := OPTIONAL_ENTROPY.

Definition get_entropy (security_strength min_length max_length: Z) (prediction_resistance: bool) s :=
           ENTROPY.get_bytes (Z.to_nat min_length) s.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

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

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

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

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

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

*)

Require Export sterm.
Require Export sequents_tacs.
Require Export per_props_tequality.
Require Export per_props_disect.
Require Export per_props_union.
Require Export subst_tacs.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export sequents2.
Require Export rules_useful.
Require Export subst_tacs_aeq.
Require Export cequiv_tacs.
Require Export variables.
Require Export per_props_subtype_rel.

Lemma equality_subtype_rel_refl {o} :
  forall lib (A: @CTerm o),
    type lib A
    -> equality lib mkc_axiom mkc_axiom (mkc_subtype_rel A A).
Proof.
  intros.
  rw @equality_in_subtype_rel.
  split. spcast. eauto 2 with slow. split. spcast. eauto 2 with slow.
  split; auto. split; auto. unfold subtype_rel. auto.
Qed.
Hint Resolve equality_subtype_rel_refl : slow.

Lemma subtype_rel_refl {o} :
  forall lib (A : @CTerm o),
    subtype_rel lib A A.
Proof.
  introv h; tcsp.
Qed.
Hint Resolve subtype_rel_refl : slow.

Lemma equality_in_mkc_istype {o} :
  forall lib a b (A: @CTerm o),
    equality lib a b (mkc_istype A)
    <=> type lib A # ccomputes_to_valc lib a mkc_axiom # ccomputes_to_valc lib b mkc_axiom.
Proof.
  intros.
  rw @equality_in_subtype_rel.
  split; intro h; repnd; dands; spcast; eauto 3 with slow.
Qed.

Lemma equality_axiom_in_mkc_istype {o} :
  forall lib (A: @CTerm o),
    equality lib mkc_axiom mkc_axiom (mkc_istype A)
    <=> type lib A.
Proof.
  introv; rw @equality_in_mkc_istype; split; intro h; repnd; dands; spcast; eauto 3 with slow.
Qed.

Lemma implies_equality_in_mkc_istype {o} :
  forall lib (A: @CTerm o),
    type lib A
    -> equality lib mkc_axiom mkc_axiom (mkc_istype A).
Proof.
  introv h.
  apply equality_in_mkc_istype; dands; spcast; eauto 3 with slow.
Qed.
Hint Resolve implies_equality_in_mkc_istype : slow.

Lemma tequality_subtype_rel_refl {o} :
  forall lib (A B: @CTerm o),
    tequality lib A B
    -> tequality lib (mkc_subtype_rel A A) (mkc_subtype_rel B B) .
Proof.
  intros.
  rw @mkc_subtype_rel_eq. rw @mkc_subtype_rel_eq. apply tequality_mkc_member_if_cequivc.
  split.
  { apply tequality_fun. split; auto. }
  { eauto 2 with slow. }
Qed.
Hint Resolve tequality_subtype_rel_refl : slow.

Lemma tequality_mkc_subtype_rel {o} :
  forall lib (A B C D: @CTerm o),
    tequality lib (mkc_subtype_rel A B) (mkc_subtype_rel C D)
    <=> (tequality lib A C # (inhabited_type lib A -> tequality lib B D)).
Proof.
  introv; repeat rewrite mkc_subtype_rel_eq; split; intro h.
  { apply tequality_mkc_member in h; repnd.
    apply tequality_mkc_fun in h0; repnd; tcsp. }
  { repnd.
    apply tequality_mkc_member_if_cequivc.
    rw @tequality_mkc_fun; dands; tcsp.
  }
Qed.

Lemma tequality_mkc_istype {o} :
  forall lib (A B : @CTerm o),
    tequality lib (mkc_istype A) (mkc_istype B) <=> tequality lib A B.
Proof.
  introv.
  unfold mkc_istype.
  rw @tequality_mkc_subtype_rel; split; intro h; repnd; tcsp.
Qed.

Lemma tequality_implies_type_left {o} :
  forall lib (a b : @CTerm o),
    tequality lib a b -> type lib a.
Proof.
  introv teq; eauto 3 with slow.
  apply tequality_refl in teq; auto.
Qed.
Hint Resolve tequality_implies_type_left : slow.

Lemma tequality_implies_type_right {o} :
  forall lib (a b : @CTerm o),
    tequality lib a b -> type lib b.
Proof.
  introv teq; eauto 3 with slow.
  apply tequality_sym in teq; apply tequality_refl in teq; auto.
Qed.
Hint Resolve tequality_implies_type_right : slow.

Lemma teq_and_eq_istype {o} :
  forall lib
         (T1 T2 : @CTerm o),
    tequality lib T1 T2
    -> tequality lib (mkc_istype T1) (mkc_istype T2)
       # equality lib mkc_axiom mkc_axiom (mkc_istype T1).
Proof.
  introv teq.
  rw @tequality_mkc_istype; dands; eauto 3 with slow.
Qed.

Lemma cover_vars_family {o} :
  forall  (x y : NVar) (B : NTerm) (s : CSub) (a : CTerm),
    cover_vars_upto B (csub_filter s [x]) [x]
    -> cover_vars (subst B x (@mk_var  o y)) (snoc s (y, a)).
Proof.
  introv cov.
  unfold cover_vars_upto in cov.
  unfold cover_vars.
  unfold over_vars; simpl in *.
  rw @dom_csub_csub_filter in cov.
  rw @dom_csub_snoc. simpl.
  allrw subvars_eq.
  introv i; allrw in_snoc.
  apply eqset_free_vars_disjoint in i; simpl in *.
  allrw in_app_iff; allrw in_remove_nvars; allrw in_single_iff.
  boolvar; repndors; repnd; tcsp;
    unfold sub_free_vars in *; simpl in *; repndors; subst; tcsp;
      apply cov in i0; simpl in *; allrw in_remove_nvars; allrw in_single_iff;
        repndors; repnd; subst; tcsp.
Qed.

(* This rule says that in order to prove that T is a type
   it is enough to prove that it is inhabited.

    H |-  istype(T)
        By inhabitedType t
    H |-  t in T
*)

Definition rule_inhabited_type {o}
           (H : barehypotheses)
           (T t: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_istype T)))
    [ mk_baresequent H (mk_conclax (mk_member t T))
    ]
    [].

Lemma tequality_preserves_member {p} :
  forall lib (a b t: @CTerm p),
    tequality lib a b
    ->  member lib t a
    ->  member lib t b.
Proof.
  introv teq inh.
  allunfold @tequality; exrepnd.
  allunfold @member.
  allunfold @equality; exrepnd.
  generalize (nuprl_uniquely_valued lib a eq eq0); intro i; repeat (dest_imp i hyp).
  apply nuprl_refl with (t2 := b); sp.
  exists eq; sp.
  apply nuprl_refl with (t2 := a); sp.
  apply nuprl_sym; sp.
  rw i; sp.
Qed.

Lemma rule_inhabited_type_true {o} :
  forall lib (H : barehypotheses)
         (T t: @NTerm o),
    rule_true lib (rule_inhabited_type H T t).
Proof.
  unfold rule_inhabited_type, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom o (nh_vars_hyps H)).

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hyp; clear hyp1.
  exrepnd.
  lsubst_tac.
  apply teq_and_eq_istype.
  allrw @tequality_mkc_member; tcsp.
Qed.

Lemma mk_istype_true2_implies {o} :
   forall lib (H : barehypotheses)
          (A : @NTerm o),
     (sequent_true2 lib (mk_baresequent H (mk_conclax (mk_istype A)))) ->
     (forall (s1 s2 : CSub)
             (w : wf_term A)
             (c1 : cover_vars A s1)
             (c2 : cover_vars A s2),
       hyps_functionality lib s1 H ->
       similarity lib s1 s2 H ->
       (type lib (lsubstc A w s1 c1)
        # (tequality lib (lsubstc A w s1 c1) (lsubstc A w s2 c2)))).
Proof.
    unfold mk_istype.
    intros. destruct X as [ ws1 hyp1 ].
    vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2) as hyp; clear hyp1.
    repeat (autodimp hyp hh).
    exrepnd.
    lsubst_tac.
    apply equality_in_subtype_rel in hyp1; repnd.
    split. auto.
    generalize_lsubstc_terms T1.
    generalize_lsubstc_terms T2.
    clear - hyp0.
    rw @mkc_subtype_rel_eq in hyp0.
    rw @mkc_subtype_rel_eq in hyp0.
    rw @tequality_mkc_member in hyp0.
    exrepnd.
    rw @tequality_mkc_fun in hyp1.
    exrepnd.
    auto.
Qed.

Lemma implies_cover_vars_var_snoc {o} :
  forall v (s : @CSub o) t,
    cover_vars (mk_var v) (snoc s (v, t)).
Proof.
  introv; apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; tcsp.
Qed.
Hint Resolve implies_cover_vars_var_snoc : slow.

(* We can prove that a:A -> B, a:A x B, {a:A | B}, and isect(a:A,B) are types when
    A is a type and  a:A |-  B is a type  *)

(*  Here is the rule for the function type:

    H |-  istype(x:A->B)
        By functionType y
    H |-  istype(A)
    H, y:A |- istype(B[x/y])
*)

Definition rule_function_type {o}
           (H : barehypotheses)
           x y
           (A B: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_istype (mk_function A x B))))
    [ mk_baresequent H (mk_conclax (mk_istype A)),
      mk_baresequent (snoc H (mk_hyp y A)) (mk_conclax (mk_istype (subst B x (mk_var y))))
    ]
    [ sarg_var y ].

Lemma rule_function_type_true3 {o} :
   forall lib (H : barehypotheses) x y
           (A B: @NTerm o),
   rule_true3 lib (rule_function_type H x y A B).
Proof.
  unfold rule_function_type, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.

(* We will use the first Hyp to get that A is a type, i.e. functional *)
  pose proof (@mk_istype_true2_implies o lib H A Hyp) as Atype.
(* We will use the second Hyp0 to get that B is a type family *)
  pose proof (@mk_istype_true2_implies o lib (snoc H (mk_hyp y A)) (subst B x (mk_var y)) Hyp0) as Btype.
  destruct Hyp as [ ws1 hyp1].
  destruct Hyp0 as [ ws2 hyp2].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_conclax (mk_istype (mk_function A x B))))) as wfc.
  {
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; eauto 2 with slow.
  }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.
  clear hyp1 hyp2.

  (* We prove some simple facts on our sequents *)
  assert ((y <> x -> !LIn y (free_vars B))
          # !LIn y (free_vars A)
          # !LIn y (vars_hyps H)) as vhyps.

  { dwfseq.
    sp;
      try (complete (generalize (wfc0 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc1 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc2 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp)).
  }

  destruct vhyps as [ nyB vhyps ].
  destruct vhyps as [ nyA vhyps ].
  (* done with proving these simple facts *)
  vr_seq_true.
  lsubst_tac.
  apply teq_and_eq_istype.
  apply tequality_function.

  pose proof (Atype s1 s2 w0 c0 c4) as q.
  repeat (autodimp q hyp); repnd; dands; auto;[].
  introv eqa.
  repeat substc_lsubstc_vars3.

  assert (wf_term (subst B x (mk_var y))) as wfs by eauto 3 with slow.
  assert (cover_vars (subst B x (mk_var y)) (snoc s1 (y,a))) as cov1.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_function in c1; tcsp. }
  assert (cover_vars (subst B x (mk_var y)) (snoc s2 (y,a'))) as cov2.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_function in c3; tcsp. }
  pose proof (Btype (snoc s1 (y,a)) (snoc s2 (y,a')) wfs cov1 cov2) as z.

  assert (cover_vars (mk_var y) (snoc s1 (y, a))) as covy1 by eauto 3 with slow.
  assert (cover_vars (mk_var y) (snoc s2 (y, a'))) as covy2 by eauto 3 with slow.

  repeat (autodimp z hyp); repnd; auto.

  { apply hyps_functionality_snoc2; simpl; auto;[].
    introv equa sim'.
    pose proof (Atype s1 s' w0 c0 c') as xx.
    repeat (autodimp xx hyp); repnd; dands; auto;[].
    proof_irr; auto. }

  { sim_snoc; dands; auto. }

  repeat (lsubstc_subst_aeq2;[]).
  repeat (substc_lsubstc_vars3;[]).
  progress lsubst_tac.
  repeat lsubstc_snoc2.
  GC; proof_irr; auto.
Qed.

(*  Next is the rule for the product type:

    H |-  istype(x:A x B)
        By productType y
    H |-  istype(A)
    H, y:A |- istype(B[x/y])
*)

Definition rule_product_type {o}
           (H : barehypotheses)
           x y
           (A B: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_istype (mk_product A x B))))
    [ mk_baresequent H (mk_conclax (mk_istype A)),
      mk_baresequent (snoc H (mk_hyp y A)) (mk_conclax (mk_istype (subst B x (mk_var y))))
    ]
    [ sarg_var y ].

Lemma rule_product_type_true3 {o} :
   forall lib (H : barehypotheses) x y
           (A B: @NTerm o),
   rule_true3 lib (rule_product_type H x y A B).
Proof.
  unfold rule_product_type, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.

(* We will use the first Hyp to get that A is a type, i.e. functional *)
  pose proof (@mk_istype_true2_implies o lib H A Hyp) as Atype.
(* We will use the second Hyp0 to get that B is a type family *)
  pose proof (@mk_istype_true2_implies o lib (snoc H (mk_hyp y A)) (subst B x (mk_var y)) Hyp0) as Btype.
  destruct Hyp as [ ws1 hyp1].
  destruct Hyp0 as [ ws2 hyp2].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_conclax (mk_istype (mk_function A x B))))) as wfc.
  {
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; eauto 2 with slow.
  }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.
  clear hyp1 hyp2.

  (* We prove some simple facts on our sequents *)
  assert ((y <> x -> !LIn y (free_vars B))
          # !LIn y (free_vars A)
          # !LIn y (vars_hyps H)) as vhyps.

  { dwfseq.
    sp;
      try (complete (generalize (wfc0 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc1 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc2 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp)).
  }

  destruct vhyps as [ nyB vhyps ].
  destruct vhyps as [ nyA vhyps ].
  (* done with proving these simple facts *)
  vr_seq_true.
  lsubst_tac.
  apply teq_and_eq_istype.
  apply tequality_product.

  pose proof (Atype s1 s2 w0 c2 c4) as q.
  repeat (autodimp q hyp); repnd; dands; auto;[].
  introv eqa.
  repeat substc_lsubstc_vars3.

  assert (wf_term (subst B x (mk_var y))) as wfs by eauto 3 with slow.
  assert (cover_vars (subst B x (mk_var y)) (snoc s1 (y,a))) as cov1.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_function in c1; tcsp. }
  assert (cover_vars (subst B x (mk_var y)) (snoc s2 (y,a'))) as cov2.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_product in c0; tcsp.
 }
  pose proof (Btype (snoc s1 (y,a)) (snoc s2 (y,a')) wfs cov1 cov2) as z.

  assert (cover_vars (mk_var y) (snoc s1 (y, a))) as covy1 by eauto 3 with slow.
  assert (cover_vars (mk_var y) (snoc s2 (y, a'))) as covy2 by eauto 3 with slow.

  repeat (autodimp z hyp); repnd; auto.

  { apply hyps_functionality_snoc2; simpl; auto;[].
    introv equa sim'.
    pose proof (Atype s1 s' w0 c2 c') as xx.
    repeat (autodimp xx hyp); repnd; dands; auto;[].
    proof_irr; auto. }

  { sim_snoc; dands; auto. }

  repeat (lsubstc_subst_aeq2;[]).
  repeat (substc_lsubstc_vars3;[]).
  progress lsubst_tac.
  repeat lsubstc_snoc2.
  GC; proof_irr; auto.
Qed.

(*  Next is the rule for the intersection type:

    H |-  istype(isect(x:A, B)
        By isectType y
    H |-  istype(A)
    H, y:A |- istype(B[x/y])
*)

Definition rule_isect_type {o}
           (H : barehypotheses)
           x y
           (A B: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_istype (mk_isect A x B))))
    [ mk_baresequent H (mk_conclax (mk_istype A)),
      mk_baresequent (snoc H (mk_hyp y A)) (mk_conclax (mk_istype (subst B x (mk_var y))))
    ]
    [ sarg_var y ].

Lemma rule_isect_type_true3 {o} :
   forall lib (H : barehypotheses) x y
           (A B: @NTerm o),
   rule_true3 lib (rule_isect_type H x y A B).
Proof.
  unfold rule_isect_type, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.

(* We will use the first Hyp to get that A is a type, i.e. functional *)
  pose proof (@mk_istype_true2_implies o lib H A Hyp) as Atype.
(* We will use the second Hyp0 to get that B is a type family *)
  pose proof (@mk_istype_true2_implies o lib (snoc H (mk_hyp y A)) (subst B x (mk_var y)) Hyp0) as Btype.
  destruct Hyp as [ ws1 hyp1].
  destruct Hyp0 as [ ws2 hyp2].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_conclax (mk_istype (mk_function A x B))))) as wfc.
  {
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; eauto 2 with slow.
  }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.
  clear hyp1 hyp2.

  (* We prove some simple facts on our sequents *)
  assert ((y <> x -> !LIn y (free_vars B))
          # !LIn y (free_vars A)
          # !LIn y (vars_hyps H)) as vhyps.

  { dwfseq.
    sp;
      try (complete (generalize (wfc0 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc1 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc2 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp)).
  }

  destruct vhyps as [ nyB vhyps ].
  destruct vhyps as [ nyA vhyps ].
  (* done with proving these simple facts *)
  vr_seq_true.
  lsubst_tac.
  apply teq_and_eq_istype.
  apply tequality_isect.

  pose proof (Atype s1 s2 w0 c0 c4) as q.
  repeat (autodimp q hyp); repnd; dands; auto;[].
  introv eqa.
  repeat substc_lsubstc_vars3.

  assert (wf_term (subst B x (mk_var y))) as wfs by eauto 3 with slow.
  assert (cover_vars (subst B x (mk_var y)) (snoc s1 (y,a))) as cov1.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_function in c1; tcsp. }
  assert (cover_vars (subst B x (mk_var y)) (snoc s2 (y,a'))) as cov2.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_isect in c3; tcsp.
 }
  pose proof (Btype (snoc s1 (y,a)) (snoc s2 (y,a')) wfs cov1 cov2) as z.

  assert (cover_vars (mk_var y) (snoc s1 (y, a))) as covy1 by eauto 3 with slow.
  assert (cover_vars (mk_var y) (snoc s2 (y, a'))) as covy2 by eauto 3 with slow.

  repeat (autodimp z hyp); repnd; auto.

  { apply hyps_functionality_snoc2; simpl; auto;[].
    introv equa sim'.
    pose proof (Atype s1 s' w0 c7 c') as xx.
    repeat (autodimp xx hyp); repnd; dands; auto;[].
    proof_irr; auto. }

  { sim_snoc; dands; auto. }

  repeat (lsubstc_subst_aeq2;[]).
  repeat (substc_lsubstc_vars3;[]).
  progress lsubst_tac.
  repeat lsubstc_snoc2.
  GC; proof_irr; auto.
Qed.

(*  Next is the rule for the set type:

    H |-  istype({x:A | B})
        By setType y
    H |-  istype(A)
    H, y:A |- istype(B[x/y])
*)

Definition rule_set_type {o}
           (H : barehypotheses)
           x y
           (A B: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_istype (mk_set A x B))))
    [ mk_baresequent H (mk_conclax (mk_istype A)),
      mk_baresequent (snoc H (mk_hyp y A)) (mk_conclax (mk_istype (subst B x (mk_var y))))
    ]
    [ sarg_var y ].

Lemma rule_set_type_true3 {o} :
   forall lib (H : barehypotheses) x y
           (A B: @NTerm o),
   rule_true3 lib (rule_set_type H x y A B).
Proof.
  unfold rule_set_type, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.

(* We will use the first Hyp to get that A is a type, i.e. functional *)
  pose proof (@mk_istype_true2_implies o lib H A Hyp) as Atype.
(* We will use the second Hyp0 to get that B is a type family *)
  pose proof (@mk_istype_true2_implies o lib (snoc H (mk_hyp y A)) (subst B x (mk_var y)) Hyp0) as Btype.
  destruct Hyp as [ ws1 hyp1].
  destruct Hyp0 as [ ws2 hyp2].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_conclax (mk_istype (mk_function A x B))))) as wfc.
  {
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; eauto 2 with slow.
  }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.
  clear hyp1 hyp2.

  (* We prove some simple facts on our sequents *)
  assert ((y <> x -> !LIn y (free_vars B))
          # !LIn y (free_vars A)
          # !LIn y (vars_hyps H)) as vhyps.

  { dwfseq.
    sp;
      try (complete (generalize (wfc0 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc1 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc2 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp)).
  }

  destruct vhyps as [ nyB vhyps ].
  destruct vhyps as [ nyA vhyps ].
  (* done with proving these simple facts *)
  vr_seq_true.
  lsubst_tac.
  apply teq_and_eq_istype.
  apply tequality_set.

  pose proof (Atype s1 s2 w0 c0 c4) as q.
  repeat (autodimp q hyp); repnd; dands; auto;[].
  introv eqa.
  repeat substc_lsubstc_vars3.

  assert (wf_term (subst B x (mk_var y))) as wfs by eauto 3 with slow.
  assert (cover_vars (subst B x (mk_var y)) (snoc s1 (y,a))) as cov1.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_function in c1; tcsp. }
  assert (cover_vars (subst B x (mk_var y)) (snoc s2 (y,a'))) as cov2.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_isect in c3; tcsp.
 }
  pose proof (Btype (snoc s1 (y,a)) (snoc s2 (y,a')) wfs cov1 cov2) as z.

  assert (cover_vars (mk_var y) (snoc s1 (y, a))) as covy1 by eauto 3 with slow.
  assert (cover_vars (mk_var y) (snoc s2 (y, a'))) as covy2 by eauto 3 with slow.

  repeat (autodimp z hyp); repnd; auto.

  { apply hyps_functionality_snoc2; simpl; auto;[].
    introv equa sim'.
    pose proof (Atype s1 s' w0 c7 c') as xx.
    repeat (autodimp xx hyp); repnd; dands; auto;[].
    proof_irr; auto. }

  { sim_snoc; dands; auto. }

  repeat (lsubstc_subst_aeq2;[]).
  repeat (substc_lsubstc_vars3;[]).
  progress lsubst_tac.
  repeat lsubstc_snoc2.
  GC; proof_irr; auto.
Qed.

(*  Next is the rule for the dependent intersection type:

    H |-  istype(x:A isect B)
        By depIsectType y
    H |-  istype(A)
    H, y:A |- istype(B[x/y])
*)

Definition rule_dep_isect_type {o}
           (H : barehypotheses)
           x y
           (A B: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_istype (mk_disect A x B))))
    [ mk_baresequent H (mk_conclax (mk_istype A)),
      mk_baresequent (snoc H (mk_hyp y A)) (mk_conclax (mk_istype (subst B x (mk_var y))))
    ]
    [ sarg_var y ].

Lemma rule_dep_isect_type_true3 {o} :
   forall lib (H : barehypotheses) x y
           (A B: @NTerm o),
   rule_true3 lib (rule_dep_isect_type H x y A B).
Proof.
  unfold rule_dep_isect_type, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.

(* We will use the first Hyp to get that A is a type, i.e. functional *)
  pose proof (@mk_istype_true2_implies o lib H A Hyp) as Atype.
(* We will use the second Hyp0 to get that B is a type family *)
  pose proof (@mk_istype_true2_implies o lib (snoc H (mk_hyp y A)) (subst B x (mk_var y)) Hyp0) as Btype.
  destruct Hyp as [ ws1 hyp1].
  destruct Hyp0 as [ ws2 hyp2].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_conclax (mk_istype (mk_function A x B))))) as wfc.
  {
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; eauto 2 with slow.
  }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.
  clear hyp1 hyp2.

  (* We prove some simple facts on our sequents *)
  assert ((y <> x -> !LIn y (free_vars B))
          # !LIn y (free_vars A)
          # !LIn y (vars_hyps H)) as vhyps.

  { dwfseq.
    sp;
      try (complete (generalize (wfc0 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc1 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (wfc2 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp)).
  }

  destruct vhyps as [ nyB vhyps ].
  destruct vhyps as [ nyA vhyps ].
  (* done with proving these simple facts *)
  vr_seq_true.
  lsubst_tac.
  apply teq_and_eq_istype.
  apply tequality_disect.

  pose proof (Atype s1 s2 w0 c0 c4) as q.
  repeat (autodimp q hyp); repnd; dands; auto;[].
  introv eqa.
  repeat substc_lsubstc_vars3.

  assert (wf_term (subst B x (mk_var y))) as wfs by eauto 3 with slow.
  assert (cover_vars (subst B x (mk_var y)) (snoc s1 (y,a))) as cov1.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_function in c1; tcsp. }
  assert (cover_vars (subst B x (mk_var y)) (snoc s2 (y,a'))) as cov2.
  { eauto 3 with slow.
    apply cover_vars_family.
    apply cover_vars_isect in c3; tcsp.
 }
  pose proof (Btype (snoc s1 (y,a)) (snoc s2 (y,a')) wfs cov1 cov2) as z.

  assert (cover_vars (mk_var y) (snoc s1 (y, a))) as covy1 by eauto 3 with slow.
  assert (cover_vars (mk_var y) (snoc s2 (y, a'))) as covy2 by eauto 3 with slow.

  repeat (autodimp z hyp); repnd; auto.

  { apply hyps_functionality_snoc2; simpl; auto;[].
    introv equa sim'.
    pose proof (Atype s1 s' w0 c7 c') as xx.
    repeat (autodimp xx hyp); repnd; dands; auto;[].
    proof_irr; auto. }

  { sim_snoc; dands; auto. }

  repeat (lsubstc_subst_aeq2;[]).
  repeat (substc_lsubstc_vars3;[]).
  progress lsubst_tac.
  repeat lsubstc_snoc2.
  GC; proof_irr; auto.
Qed.

(*  Next is the rule for the disjoint union type:

    H |-  istype(A + B)
        By unionType
    H |- istype(A)
    H |- istype(B)
*)

Definition rule_union_type {o}
           (H : barehypotheses)
           (A B: @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_istype (mk_union A B))))
    [ mk_baresequent H (mk_conclax (mk_istype A)),
      mk_baresequent H (mk_conclax (mk_istype B))]
    [ ].

Lemma rule_union_type_true3 {o} :
   forall lib (H : barehypotheses)
           (A B: @NTerm o),
   rule_true3 lib (rule_union_type H A B).
Proof.
  unfold rule_union_type, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.

(* We will use the first Hyp to get that A is a type, i.e. functional *)
  pose proof (@mk_istype_true2_implies o lib H A Hyp) as Atype.
(* We will use the second Hyp to get that B is a type, i.e. functional *)
  pose proof (@mk_istype_true2_implies o lib H B Hyp0) as Btype.
  destruct Hyp as [ ws1 hyp1].
  destruct Hyp0 as [ ws2 hyp2].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_conclax (mk_istype (mk_union A B))))) as wfc.
  {
    unfold wf_csequent, wf_sequent, wf_concl; simpl.
    dands; eauto 2 with slow.
  }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.
  clear hyp1 hyp2.

  vr_seq_true.
  lsubst_tac.
  apply teq_and_eq_istype.
  rw @tequality_mkc_union.

  pose proof (Atype s1 s2 w0 c2 c4) as q.
  repeat (autodimp q hyp); repnd; dands; auto;[].
  pose proof (Btype s1 s2 w2 c3 c5) as r.
  repeat (autodimp r hyp). repnd. auto.
Qed.


(**
Rainbow, a termination proof certification tool

See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2013-08-31

* Translate CPF type into CoLoR type.

*)

Set Implicit Arguments.

Require Import ATrs BinNat cpf cpf_ind Coccinelle2 rpo_extension2
  cpf_util List rpo2 LogicUtil.

Section precedence.

  Variable arity : symbol -> nat.
  Notation Sig := (Sig arity).

  Section status_type.

    Variable f : symbol.

    Fixpoint color_status_type
      (l : list(symbol * cpf.arity * nonNegativeInteger * t2))
      : status_type :=
      match l with
        | (g, _, _, t) :: l' =>
          match @eq_symb_dec Sig g f with
            | left _ => match t with
                          | T2_lex => Lex
                          | T2_mul => Mul
                        end
            | right _ => color_status_type l'
          end
        | nil => Lex (* if it is nil return Lex *)
      end.

  End status_type.

  (* Define a section for prec_nat return nat from list of
     statusPrecedence. *)

  Section prec_nat.

    Variable f: symbol.

    Fixpoint color_prec_nat
      (l : list (symbol * cpf.arity * nonNegativeInteger * t2))
      : nat :=
      match l with
        | (g, _, n, _) :: l' =>
          match @eq_symb_dec Sig g f with
            | left _ => let n := nat_of_N n in n
            | right _ => color_prec_nat l'
          end
        | nil => 0 (* when it is nil return 0 *)
      end.

  End prec_nat.

  (* Define a function for [status: Sig -> status_type];
     [prec_nat : Sig -> nat] *)

  (* FIXME: it is like the function [trsInt] in poly.v *)

  Section S.

    Variable l : list (symbol * cpf.arity * nonNegativeInteger * t2).

    Definition status (f: symbol) : status_type := color_status_type f l.

    Definition prec_nat (f: symbol) : nat := color_prec_nat f l.

    (* Proof the lemma [prec_eq_status] by assume the boolean function  *)

    (* Proof a correctness of [prec_eq] *)

    Lemma prec_eq_ok : forall f g,
      prec_eq_bool' Sig prec_nat f g = true <-> prec_eq' Sig prec_nat f g.

    Proof.
      intros f g. gen (prec_eq_bool_ok' Sig prec_nat f g).
      intuition. rewrite H0 in H. hyp.
      case_eq (prec_eq_bool' Sig prec_nat f g); intros; try refl.
      rewrite H1 in H. absurd (prec_eq' Sig prec_nat f g); hyp.
    Qed.

    (* Define a boolean function for status symbol. *)

    Definition bprec_eq_status_symb f g : bool :=
      implb (prec_eq_bool' Sig prec_nat f g)
      (beq_status (status f) (status g)).

    (* Correctness proof of boolean function for status symbol. *)

    Lemma bprec_eq_status_symb_ok : forall f g,
      bprec_eq_status_symb f g = true <->
      (prec_eq' Sig prec_nat f g -> status f = status g).

    Proof.
      intros f g. unfold bprec_eq_status_symb, implb.
      case_eq (prec_eq_bool' Sig prec_nat f g); intros.
      rewrite prec_eq_ok in H. rewrite beq_status_ok.
      intuition.
      intuition. rewrite <- prec_eq_ok in H1. rewrite H in H1.
      discr.
    Qed.

    (* FIXME: assume a condition of bprec_eq_status_symb is true,
       this assume is a condition will be formalize in the pathOrder
       function. *)

    Definition list_sig : list symbol := split_list l.

    (* FIXME *)

    (*
       Variable T : forallb
       (fun x => bprec_eq_status Sig status prec_nat list_sig) list_sig= true.*)

    (*Variable H: forallb (fun f =>
       forallb (fun g => bprec_eq_status_symb f g) list_sig) list_sig = true.*)

    (*Variable H : forall f g, bprec_eq_status_symb f g = true.*)

    Lemma prec_eq_status : forall f g, prec_eq' Sig prec_nat f g ->
      status f = status g.

    Proof.
      intros f g. erewrite bprec_eq_status_ok.
    (* TODO *)
    Admitted.

    (* Define the record type PRECEDENCE *)

    (* Assume variable b of type nat. *)

    Variable bb : nat.

    Definition P : PRECEDENCE Sig :=
      Coccinelle2.mkPrecedence Sig status prec_nat bb prec_eq_status.

    (* Define a function [empty_rpo_infos] to be used in function
       [rpo_eval]. *)

    Definition empty_rpo_infos :=
      empty_rpo_infos Sig status prec_nat prec_eq_status bb.

    (* Define a function [rpo_eval] to be used in the function
       [pathOrdering] *)

    Definition rpo_eval :=
      @rpo_eval Sig status prec_nat prec_eq_status empty_rpo_infos bb.

  End S.

End precedence.


Require Export Iron.Language.SystemF2Effect.Type.
Require Export Iron.Language.SystemF2Effect.Value.Exp.
Require Export Iron.Language.SystemF2Effect.Value.Relation.Wf.
Require Export Iron.Language.SystemF2Effect.Value.Operator.LiftX.
Require Export Iron.Language.SystemF2Effect.Store.Prop.

(********************************************************************)
(* Store Environment holds the types of locations. *)
Definition stenv := list ty.

(* Types of primops.
   We keep this separate from the main typing judgement to make it easy
   to add new primops. *)
Fixpoint typeOfOp1 (op : op1) : ty
 := match op with
    | OSucc    => TFun TNat TNat  (TBot KEffect)
    | OIsZero  => TFun TNat TBool (TBot KEffect)
    end.

(* Types of Value expressions *)
Inductive
  TypeV : kienv -> tyenv -> stenv -> stprops
        -> val  -> ty
        -> Prop :=

  (* Variables.
     We get the type of a variable from the type environment. *)
  | TvVar
    :  forall ke te se sp i t
    ,  get i te = Some t
    -> KindT  ke sp t KData
    -> TypeV  ke te se sp (VVar i) t

  (* Store locations.
     We get the type of a location from the store typing.
     The type of a location must be a Reference because we need somewhere
     to attach the region variable. Our primitive types don't have region
     annotations themselves. *)
  | TvLoc
    :  forall ke te se sp l r t
    ,  get l se = Some (TRef r t)
    -> KindT  ke sp       (TRef r t) KData
    -> TypeV  ke te se sp (VLoc l)   (TRef r t)

  (* Value abstraction.
     The body is checked in an environment extended with the type of
     of the formal parameter. *)
  | TvLam
    :  forall ke te se sp t1 t2 x2 e2
    ,  KindT  ke sp t1 KData
    -> TypeX  ke (te :> t1) se sp x2 t2 e2
    -> TypeV  ke te         se sp (VLam t1 x2) (TFun t1 e2 t2)

  (* Type abstraction.
     The body is checked in an environemnt extended with the kind of
     the formal parameter. As the parameter kind is pushed onto the base
     of the kind environment we need to lift any references to kinds
     higher in the stack across the new one. The body expression must
     be pure because we don't have anywhere to store the effect of the
     body in the type of the overall abstraction. This is different for
     value abstractions, where the function constructor has an effect
     annotation. *)
  | TvLAM
    :  forall ke te se sp k1 t2 x2
    ,  TypeX (ke :> k1) (liftTE 0 te) (liftTE 0 se) sp x2 t2 (TBot KEffect)
    -> TypeV ke          te            se   sp (VLAM k1 x2) (TForall k1 t2)

  (* Primitive constants.
     We get the types of these from the 'typeOfConst' function so we can
     add new sorts of constants without changing the proof. *)
  | TvConst
    :  forall ke te se sp c t
    ,  t = typeOfConst c
    -> TypeV  ke te se sp (VConst c) t

  with TypeX :  kienv -> tyenv -> stenv -> stprops
             -> exp   -> ty -> ty
             -> Prop :=

  (* Embed values in the expression language.
     All values are pure because they can't be stepped further, which
     in turn means they can't perform any more effectful actions. *)
  | TxVal
    :  forall ke te se sp v1 t1
    ,  TypeV  ke te se sp v1 t1
    -> TypeX  ke te se sp (XVal v1) t1 (TBot KEffect)

  (* Let-bindings. *)
  | TxLet
    :  forall ke te se sp t1 x1 t2 x2 e1 e2
    ,  KindT  ke sp t1 KData
    -> TypeX  ke te         se sp x1 t1 e1
    -> TypeX  ke (te :> t1) se sp x2 t2 e2
    -> TypeX  ke te         se sp (XLet t1 x1 x2) t2 (TSum e1 e2)

  (* Value application. *)
  | TxApp
    :  forall ke te se sp t11 t12 v1 v2 e1
    ,  TypeV  ke te se sp v1 (TFun t11 e1 t12)
    -> TypeV  ke te se sp v2 t11
    -> TypeX  ke te se sp (XApp v1 v2) t12 e1

  (* Type application. *)
  | TvAPP
    :  forall ke te se sp v1 k11 t12 t2
    ,  TypeV  ke te se sp v1 (TForall k11 t12)
    -> KindT  ke sp t2 k11
    -> TypeX  ke te se sp (XAPP v1 t2) (substTT 0 t2 t12) (TBot KEffect)

  (* Store Operators ******************)
  (* Create a private region. *)
  | TxPrivate
    :  forall ke te se sp x t tL e eL
    ,  lowerTT 0 t                = Some tL
    -> lowerTT 0 (maskOnVarT 0 e) = Some eL
    -> TypeX (ke :> KRegion) (liftTE 0 te) (liftTE 0 se) sp x            t  e
    -> TypeX ke              te            se            sp (XPrivate x) tL eL

  (* Extend an existing region. *)
  | TxExtend
    :  forall ke te se sp r1 x2 t e eL
    ,  lowerTT 0 (maskOnVarT 0 e) = Some eL
    -> KindT ke sp r1 KRegion
    -> TypeX (ke :> KRegion) (liftTE 0 te) (liftTE 0 se) sp x2 t e
    -> TypeX ke te se  sp (XExtend r1 x2) (substTT 0 r1 t) (TSum eL (TAlloc r1))

  (* Allocate a new heap binding. *)
  | TxOpAlloc
    :  forall ke te se sp r1 v2 t2
    ,  KindT  ke sp r1 KRegion
    -> TypeV  ke te se sp v2 t2
    -> TypeX  ke te se sp (XAlloc r1 v2) (TRef r1 t2) (TAlloc r1)

  (* Read a value from a heap binding. *)
  | TxOpRead
    :  forall ke te se sp v1 r1 t2
    ,  KindT  ke sp r1 KRegion
    -> TypeV  ke te se sp v1 (TRef r1 t2)
    -> TypeX  ke te se sp (XRead r1 v1)     t2    (TRead r1)

  (* Write a value to a heap binding. *)
  | TxOpWrite
    :  forall ke te se sp v1 v2 r1 t2
    ,  KindT  ke sp r1 KRegion
    -> TypeV  ke te se sp v1 (TRef r1 t2)
    -> TypeV  ke te se sp v2 t2
    -> TypeX  ke te se sp (XWrite r1 v1 v2) TUnit (TWrite r1)

  (* Primtive Operators ***************)
  | TxOpPrim
    :  forall ke te se sp op v1 t11 t12 e
    ,  typeOfOp1 op = TFun t11 t12 e
    -> TypeV  ke te se sp v1 t11
    -> TypeX  ke te se sp (XOp1 op v1) t12 e.

Hint Constructors TypeV.
Hint Constructors TypeX.

(********************************************************************)
(* Invert all hypothesis that are compound typing statements. *)
Ltac inverts_type :=
 repeat
  (match goal with
   | [ H: TypeV _ _ _ _ (VVar   _)     _    |- _ ] => inverts H
   | [ H: TypeV _ _ _ _ (VLoc   _)     _    |- _ ] => inverts H
   | [ H: TypeV _ _ _ _ (VLam   _ _)   _    |- _ ] => inverts H
   | [ H: TypeV _ _ _ _ (VLAM   _ _)   _    |- _ ] => inverts H
   | [ H: TypeV _ _ _ _ (VConst _)     _    |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XVal   _)     _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XLet   _ _ _) _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XApp   _ _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XAPP   _ _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XPrivate _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XExtend  _ _) _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XAlloc _ _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XRead  _ _)   _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XWrite _ _ _) _ _  |- _ ] => inverts H
   | [ H: TypeX _ _ _ _ (XOp1   _ _)   _ _  |- _ ] => inverts H
   end).