(*
   Copyright (C) 2001, 2009 Luc Rutten

   This file 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 2, or (at your option) any later version.

   This file 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 this file; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place - Suite 330,
   Boston, MA 02111-1307, USA.
*)

(*
   Fast reduction of nonnegative integers
   by moduli M such that 1 <= M <= 2 ^ (w - 1)
   where w denotes a processor's word size.
*)
(* Faster than the version proposed in multired2.v on some processors. *)

(* Coq 8.2 *)

Require Import ZArith.

Require Import preparation.
Require Import unsigned.

Require Import modred.

Open Scope Z_scope.

(* <KEEP TOGETHER - loop_invariant *)
Definition P (M p : Z) (d r : Z_ (2 ^ w)) (h : Z) (l : Z_ (2 ^ w)) :=
  (_Z d = (h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p mod M \/
   _Z d = (h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p mod M + M \/
   _Z d = ((h mod M + M) * 2 ^ w + l) / 2 ^ p * 2 ^ p mod M \/
   _Z d = ((h mod M + M) * 2 ^ w + l) / 2 ^ p * 2 ^ p mod M + M
  ) /\
   _Z r = (d + l mod 2 ^ p) mod 2 ^ w.
(* KEEP TOGETHER> *)

Section parm_sec.

Variable M_in_Z_ : Z_ (2 ^ w).

Variable ptM'cM'' : Z_ w * Z_ w * Z_ (2 ^ w) * Z_ (2 ^ w) * Z_ (2 ^ w).
Variable d_Sir_Si : Z_ (2 ^ w) * Z_ (2 ^ w).
Variable l_in_Z_ : Z_ (2 ^ w).
Variable x_i_in_Z_ : Z_ (2 ^ w).
Variable h : Z.

Let p_in_Z_w := fst (fst (fst (fst ptM'cM''))).
Let t_in_Z_w := snd (fst (fst (fst ptM'cM''))).
Let M'_in_Z_ := snd (fst (fst ptM'cM'')).
Let c_in_Z_ := snd (fst ptM'cM'').
Let M''_in_Z_ := snd ptM'cM''.

Let M := _Z M_in_Z_.
Let p := _Z p_in_Z_w.
Let t := _Z t_in_Z_w.
Let c := _Z c_in_Z_.
Let M'' := _Z M''_in_Z_.
Let M' := _Z M'_in_Z_.
Let l := _Z l_in_Z_.
Let x_i := _Z x_i_in_Z_.

Definition d_Si := fst d_Sir_Si.
Definition r_Si := snd d_Sir_Si.

Hypothesis d_Si_eq_r_Si_eq : P M p d_Si r_Si h l_in_Z_.

Hypothesis le_1_M : 1 <= M.
Hypothesis le_M_max : M <= 2 ^ (w - 1).
Hypothesis p_M : p = Zlog_sup M.
Hypothesis t_M : t = w - p \/ M = 1.
Hypothesis c_M : c = 2 ^ p.
Hypothesis M''_M : M'' = (2 ^ t * M) mod 2 ^ w.
Hypothesis M'_M : M' = 2 ^ (p + w) / M mod 2 ^ w.

Lemma le_0_p : 0 <= p.

  unfold p. apply le_0__Z. Qed.

Lemma le02w : 0 <= 2 ^ w.

  apply Zlt_le_weak. exact lt02w. Qed.

Local Hint Resolve le_0_w lt02w le02w : a.

Local Hint Resolve le_0_p : a.

Lemma le_M_2pp : M <= 2 ^ p.

  clear x_i_in_Z_ x_i.
  rewrite p_M. generalize le_1_M. case M. intro. absurd (2 <= 0); omega. intros q H.
  elim (Zlog_sup_correct2 (Zpos q)). omega. omega. intros q H. absurd (2 <= Zneg q). apply Zlt_not_le.
  unfold Zlt. trivial. assumption. Qed.

Lemma le_1_p : 1 <= p \/ M = 1.

  clear x_i_in_Z_ x_i.
  rewrite p_M. elim (Zle_lt_or_eq 1 M). intro H. left. apply Zle_trans with (Zlog_sup 2). simpl. omega.
  apply Zlog_sup_seq. omega. intro H. right. symmetry. trivial. assumption. Qed.

Lemma lt_0_p : 0 < p \/ M = 1.

  clear x_i_in_Z_ x_i.
  elim le_1_p; intro H; omega. Qed.

Lemma le_0_pm1 : 0 <= p - 1 \/ M = 1.

  clear x_i_in_Z_ x_i.
  elim lt_0_p; intro H; omega. Qed.

Local Hint Resolve le_M_2pp le_1_p lt_0_p le_0_pm1 : a.

Lemma lt_2pm1_M : 2 ^ (p - 1) < M \/ M = 1.

  clear x_i_in_Z_ x_i.
  elim (Zle_lt_or_eq 1 M). intro H. rewrite p_M. generalize le_1_M. case M. intro. absurd (2 <= 0); omega.
  intros q H0. elim (Zlog_sup_correct2 (Zpos q)). omega. omega. intros q H0. absurd (1 <= Zneg q).
  apply Zlt_not_le. unfold Zlt. trivial. assumption. omega. assumption. Qed.

Local Hint Resolve lt_2pm1_M : a.

Lemma div_M_1 : 2 ^ p / M = 1.

  clear x_i_in_Z_ x_i.
  elim (Zle_lt_or_eq 1 M). intro H. replace (2 ^ p) with (1 * M + (2 ^ p - M)). apply Zdiv_mult_plus. omega.
  cut (M <= 2 ^ p). omega. auto with a. cut (2 ^ p < M + M). omega.
  apply Zlt_le_trans with (2 ^ (p - 1) + 1 + (2 ^ (p - 1) + 1)).
  replace (2 ^ (p - 1) + 1 + (2 ^ (p - 1) + 1)) with (2 ^ (p - 1) + 2 ^ (p - 1) + 2). rewrite Z_pow_plus.
  replace (p - 1 + 1) with p. omega. ring. elim le_0_pm1. omega. intro H0. absurd (1 < M). omega.
  assumption. ring. cut (2 ^ (p - 1) < M). omega. elim lt_2pm1_M. omega. intro H0. absurd (1 < M). omega.
  assumption. ring. intro H0. rewrite p_M. rewrite <- H0. trivial. assumption. Qed.

Lemma large_M'_eq : 2 ^ w + (2 ^ (p + w) / M) mod 2 ^ w = 2 ^ (p + w) / M.

  transitivity (2 ^ (p + w) / M / 2 ^ w * 2 ^ w + (2 ^ (p + w) / M) mod 2 ^ w).
  apply f_equal2 with (f := Zplus). replace (2 ^ (p + w) / M / 2 ^ w) with 1. ring.
  rewrite Zdivdivdiv. rewrite Zmult_comm. rewrite <- Zdivdivdiv. rewrite Zpower_exp; auto with a.
  rewrite Z_div_mult. symmetry. exact div_M_1. apply Zlt_gt. auto with a. apply Zle_ge. auto with a.
  apply Zle_ge. auto with a. auto with a. omega. omega. auto with a. trivial. apply Zdivmod_split.
  auto with a. Qed.

(* <KEEP TOGETHER - multired_equations *)
Let r'_i := ltw d_Si M_in_Z_ r_Si (minusw r_Si M_in_Z_).

Let s_i := ursh x_i_in_Z_ p_in_Z_w.

Let s'_i := multp2 s_i p_in_Z_w.

Let s''_i := ltw r'_i c_in_Z_ s_i (minusw s_i M''_in_Z_).

Let h_i := multp2 r'_i t_in_Z_w.

Let h'_i := plusw h_i s''_i.

Let q_i := uhwm h'_i M'_in_Z_.

Let q'_i := plusw q_i h'_i.

Let y_i := multw q'_i M_in_Z_.

Definition d_i := minusw s'_i y_i.

Definition r_i := minusw x_i_in_Z_ y_i.
(* KEEP TOGETHER> *)

Let d0 := d_Si. (* notation *)
Let r0 := r_Si. (* notation *)

(* <KEEP TOGETHER - multired_final *)
Let r'0 := ltw d0 M_in_Z_ r0 (minusw r0 M_in_Z_). (* notation *)

Let r''0 := ltw r'0 c_in_Z_ r'0 (minusw r'0 M_in_Z_). (* only needed after the loop *)

Definition r'''0 := ltw r''0 M_in_Z_ r''0 (minusw r''0 M_in_Z_). (* only needed after the loop *)
(* KEEP TOGETHER> *)

Let h_i' := multp2 r''0 t_in_Z_w.

Let h'_i' := plusw h_i' s_i.

Definition g' := r'''0. (* only needed after the loop *)

Let x := h * 2 ^ w + l.

Let x' := r''0 * 2 ^ w + x_i.

Lemma x_i_eq : x_i = x' mod 2 ^ w.

  unfold x'. rewrite Zmod_km_plus. symmetry. unfold x_i. apply modred. apply le_0__Z. apply lt_z__Z. exact lt02w. Qed.

Lemma lt_0_2ppw : 0 < 2 ^ (p + w).

  apply lt_0_Zpow. fold (0 + 0). apply Zplus_le_compat; auto with a. Qed.

Lemma lt_0_2pp : 0 < 2 ^ p.

  apply lt_0_Zpow. auto with a. Qed.

Local Hint Resolve lt_0_2pp : a.

Lemma le_0_wm1 : 0 <= w - 1.

  clear. cut (0 < w). omega. exact lt_0_w. Qed.

Local Hint Resolve le_0_wm1 lt_0_w : a.

Lemma lt_p_w : p < w.

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  rewrite p_M. apply Zle_lt_trans with (w - 1). rewrite <- Zlog_sup_pow. apply Zlog_sup_seq.
  assumption. auto with a. omega. Qed.

Lemma le_p_w : p <= w.

  apply Zlt_le_weak. exact lt_p_w. Qed.

Lemma le_0_wmp : 0 <= w - p.

  cut (p <= w). omega. exact le_p_w. Qed.

Local Hint Resolve lt_p_w le_p_w le_0_wmp : a.

Lemma lt_M_2pw : M < 2 ^ w.

  unfold M. apply lt_z__Z. Qed.

Lemma le_M_2pw : M <= 2 ^ w.

  apply Zlt_le_weak. exact lt_M_2pw. Qed.

Hint Resolve lt_M_2pw le_M_2pw : a.

Lemma d_Si_eq :
  _Z d_Si = (h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p mod M \/
  _Z d_Si = (h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p mod M + M \/
  _Z d_Si = ((h mod M + M) * 2 ^ w + l) / 2 ^ p * 2 ^ p mod M \/
  _Z d_Si = ((h mod M + M) * 2 ^ w + l) / 2 ^ p * 2 ^ p mod M + M.

  unfold P in d_Si_eq_r_Si_eq. tauto. Qed.

Lemma r_Si_eq_lit :
   _Z r_Si = (d_Si + l mod 2 ^ p) mod 2 ^ w.

  unfold P in d_Si_eq_r_Si_eq. tauto. Qed.

Lemma r_Si_eq_a :
  _Z r_Si = ( d_Si + (h mod M * 2 ^ w + l) mod 2 ^ p) mod 2 ^ w.

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i' x'.
  replace (h mod M * 2 ^ w) with (0 + h mod M * 2 ^ (w - p + p)). rewrite Zpower_exp. rewrite Zmult_assoc.
  rewrite Zmod_plus_distr_l with (m := 2 ^ p). rewrite Z_mod_plus. rewrite modred with (x := 0).
  replace (0 + l) with l. exact r_Si_eq_lit. ring. omega. apply lt_0_Zpow. auto with a.
  apply Zlt_gt. apply Zlt_le_trans with M. omega. auto with a. apply lt_0_Zpow. auto with a. cut (p < w). omega. auto with a.
  apply Zle_ge. auto with a. replace (w - p + p) with w. ring. ring. Qed.

Lemma r_Si_eq_b :
  _Z r_Si = ( d_Si + ((h mod M + M) * 2 ^ w + l) mod 2 ^ p) mod 2 ^ w.

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  replace ((h mod M + M) * 2 ^ w) with (0 + (h mod M + M) * 2 ^ (w - p + p)). rewrite Zpower_exp. rewrite Zmult_assoc.
  rewrite Zmod_plus_distr_l with (m := 2 ^ p). rewrite Z_mod_plus. rewrite modred with (x := 0).
  replace (0 + l) with l. exact r_Si_eq_lit. ring. omega. apply lt_0_Zpow. auto with a.
  apply Zlt_gt. apply Zlt_le_trans with M. omega. auto with a. apply lt_0_Zpow. auto with a. cut (p < w). omega. auto with a.
  apply Zle_ge. auto with a. replace (w - p + p) with w. ring. ring. Qed.

Lemma p2wp : 2 ^ w = 2 ^ (w - p) * 2 ^ p.

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  rewrite <- Zpower_exp. replace (w - p + p) with w. trivial. ring. cut (p < w). omega. auto with a. apply Zle_ge. auto with a.
  Qed.

Lemma mod2p : forall a b c', (a * 2 ^ w + b) mod 2 ^ p = (c' * 2 ^ w + b) mod 2 ^ p.

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  intros a b c'. replace w with (w - p + p). rewrite Zpower_exp. do 2 rewrite Zmult_assoc. do 2 rewrite Zplus_comm with (m := b).
  rewrite Z_mod_plus. rewrite Z_mod_plus. trivial. apply Zlt_gt. apply lt_0_Zpow. auto with a. apply Zlt_gt. apply lt_0_Zpow.
  auto with a. cut (p < w). omega. auto with a. apply Zle_ge. auto with a. ring. Qed.

(* <KE EP TOGETHER - r'_i_eq *)
Lemma r'_i_eq : _Z r'_i = (h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p mod M + (h mod M * 2 ^ w + l) mod 2 ^ p.
(* KE EP TOGETHER> *)

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  unfold r'_i. elim d_Si_eq; intro H. rewrite ltw_true. rewrite r_Si_eq_a. rewrite H. apply modred. apply Zplus_le_0_compat.
  apply Zmod_le_0_z. omega. apply Zmod_le_0_z. apply lt_0_Zpow. auto with a. apply Zlt_le_trans with (M + 2 ^ p).
  apply Zplus_lt_le_compat. apply Zmod_lt_z_m. omega. apply Zlt_le_weak. apply Zmod_lt_z_m. apply lt_0_Zpow. auto with a.
  rewrite Zpow_2_w_is_2Zpow_2_wm1. apply Zplus_le_compat. assumption. apply Zle_pow_le. auto with a. cut (p < w). omega.
  auto with a. rewrite H. fold M. apply Zmod_lt_z_m. omega. elim H; intro H0. rewrite ltw_false. simpl. rewrite r_Si_eq_a. fold M.
  rewrite H0. rewrite <- Zmod_minus_distr_l.
  replace (((h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p) mod M + M + (h mod M * 2 ^ w + l) mod 2 ^ p - M)
     with (((h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p) mod M + (h mod M * 2 ^ w + l) mod 2 ^ p).
  apply modred. apply Zplus_le_0_compat. apply Zmod_le_0_z. omega. apply Zmod_le_0_z. apply lt_0_Zpow. auto with a.
  apply Zlt_le_trans with (M + 2 ^ p). apply Zplus_lt_le_compat. apply Zmod_lt_z_m. omega. apply Zlt_le_weak. apply Zmod_lt_z_m.
  apply lt_0_Zpow. auto with a. rewrite Zpow_2_w_is_2Zpow_2_wm1. apply Zplus_le_compat. assumption. apply Zle_pow_le. auto with a.
  cut (p < w). omega. auto with a. ring. exact lt02w. rewrite H0. fold M.
  cut (0 <= ((h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p) mod M). omega. apply Zmod_le_0_z. omega. elim H0; intro H1.
  rewrite ltw_true. rewrite r_Si_eq_b. rewrite H1. rewrite p2wp. rewrite Zmult_assoc. rewrite mod_over_div.
  rewrite Zmod_mult_distr_l with (a := h mod M + M). replace (h mod M + M) with (h mod M + 1 * M). rewrite Z_mod_plus.
  rewrite <- Zmod_mult_distr_l. rewrite <- mod_over_div. rewrite <- Zmult_assoc. rewrite <- Zmult_assoc. rewrite <- Zpower_exp.
  replace (w - p + p) with w. rewrite mod2p with (c' := h mod M). apply modred. apply Zplus_le_0_compat.
  apply Zmod_le_0_z. omega. apply Zmod_le_0_z. apply lt_0_Zpow. auto with a. apply Zlt_le_trans with (M + 2 ^ p).
  apply Zplus_lt_le_compat. apply Zmod_lt_z_m. omega. apply Zlt_le_weak. apply Zmod_lt_z_m. apply lt_0_Zpow. auto with a.
  rewrite Zpow_2_w_is_2Zpow_2_wm1. apply Zplus_le_compat. assumption. apply Zle_pow_le. auto with a. cut (p < w). omega.
  auto with a. ring. cut (p < w). omega. auto with a. apply Zle_ge. auto with a. apply lt_0_Zpow. auto with a. omega. omega.
  omega. ring. omega. apply lt_0_Zpow. auto with a. omega. rewrite H1. fold M. apply Zmod_lt_z_m. omega.
  rewrite ltw_false. simpl. rewrite r_Si_eq_b. rewrite H1.
  (* rewrite p2wp. *) (* does not work: Cannot solve a second-order unification problem *)
  (* replace ((h mod M + M) * 2 ^ w) with ((h mod M + M) * (2 ^ (w - p) * 2 ^ p)). *) (* again, does not work *)
  transitivity ((((((h mod M + M) * (2 ^ (w - p) * 2 ^ p) + l) / 2 ^ p * 2 ^ p) mod M + M +
    ((h mod M + M) * (2 ^ (w - p) * 2 ^ p) + l) mod 2 ^ p) mod
      (2 ^ (w - p) * 2 ^ p) - M) mod (2 ^ (w - p) * 2 ^ p)). (* workaround *)
  rewrite <- p2wp. trivial. (* this works *)
  rewrite Zmult_assoc. rewrite mod_over_div.
  rewrite Zmod_mult_distr_l with (a := h mod M + M). replace (h mod M + M) with (h mod M + 1 * M). rewrite Z_mod_plus.
  rewrite <- Zmod_mult_distr_l. rewrite <- mod_over_div. rewrite <- Zmult_assoc. rewrite <- Zmult_assoc. rewrite <- Zpower_exp.
  replace (w - p + p) with w. rewrite mod2p with (c' := h mod M). rewrite <- Zmod_minus_distr_l. fold M.
  replace (((h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p) mod M + M + (h mod M * 2 ^ w + l) mod 2 ^ p - M)
     with (((h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p) mod M + (h mod M * 2 ^ w + l) mod 2 ^ p). apply modred.
  apply Zplus_le_0_compat. apply Zmod_le_0_z. omega. apply Zmod_le_0_z. apply lt_0_Zpow. auto with a.
  apply Zlt_le_trans with (M + 2 ^ p). apply Zplus_lt_le_compat. apply Zmod_lt_z_m. omega. apply Zlt_le_weak. apply Zmod_lt_z_m.
  apply lt_0_Zpow. auto with a. rewrite Zpow_2_w_is_2Zpow_2_wm1. apply Zplus_le_compat. assumption. apply Zle_pow_le. auto with a.
  cut (p < w). omega. auto with a. ring. auto with a. ring. cut (p < w). omega. auto with a. apply Zle_ge. auto with a.
  apply lt_0_Zpow. auto with a. omega. omega. omega. ring. omega. apply lt_0_Zpow. auto with a. omega. rewrite H1. fold M.
  cut (0 <= (((h mod M + M) * 2 ^ w + l) / 2 ^ p * 2 ^ p) mod M). omega. apply Zmod_le_0_z. omega. Qed.

Let x'' := h mod M * 2 ^ w + l.

Lemma sum_r'_i : forall a b : Z, (a mod M + b mod M) / M = 0 \/ (a mod M + b mod M) / M = 1.

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  intros a b. cut (0 <= (a mod M + b mod M) / M). cut ((a mod M + b mod M) / M <= 1). omega.
  apply Zle_trans with ((M - 1 + M) / M). apply Zdiv_le. omega. apply Zplus_le_compat. cut (a mod M < M). omega.
  apply Zmod_lt_z_m. omega. cut (b mod M < M). omega. apply Zmod_lt_z_m. omega. replace (M - 1 + M) with (2 * M - 1).
  rewrite Zdiv_mult_minus. omega. omega. omega. omega. ring. apply Zle_0_div. fold (0 + 0). apply Zplus_le_compat.
  apply Zmod_le_0_z. omega. apply Zmod_le_0_z. omega. omega. Qed.

Lemma div_r'_i : forall a : Z, a mod 2 ^ p / M = 0 \/ a mod 2 ^ p / M = 1.

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  intro a. cut (0 <= a mod 2 ^ p / M). cut (a mod 2 ^ p / M <= 1). omega. apply Zle_trans with (2 ^ p / M). apply Zdiv_le. omega.
  cut (a mod 2 ^ p < 2 ^ p). omega. apply Zmod_lt_z_m. apply lt_0_Zpow. auto with a. rewrite div_M_1. omega. apply Zle_0_div.
  apply Zmod_le_0_z. apply lt_0_Zpow. auto with a. omega. Qed.

Lemma r'_i_eq'_i : _Z r'_i = x mod M \/ _Z r'_i = x mod M + M \/ _Z r'_i = x mod M + M + M.

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  rewrite r'_i_eq. fold x''. rewrite Z_div_mod_eq with (a := x'' mod 2 ^ p) (b := M).
  rewrite Zplus_comm with (m := (x'' mod 2 ^ p) mod M). rewrite Zplus_assoc.
  rewrite Z_div_mod_eq with (a := (x'' / 2 ^ p * 2 ^ p) mod M + (x'' mod 2 ^ p) mod M) (b := M). rewrite <- Zmod_plus_distr_l.
  rewrite Zplus_comm with (n := x'' / 2 ^ p * 2 ^ p). rewrite <- Zmod_plus_distr_l. rewrite Zplus_comm with (n := x'' mod 2 ^ p).
  rewrite Zmult_comm with (m := 2 ^ p). rewrite <- Z_div_mod_eq. replace (x'' mod M) with (x mod M).
  elim (sum_r'_i (2 ^ p * (x'' / 2 ^ p)) (x'' mod 2 ^ p)); intro H; elim (div_r'_i x''); intro H0; rewrite H; rewrite H0. left. ring.
  right. left. ring. right. left. ring. right. right. ring. unfold x''. rewrite Zmod_plus_distr_l. rewrite <- Zmod_mult_distr_l.
  rewrite <- Zmod_plus_distr_l. trivial. omega. omega. omega. apply Zlt_gt. apply lt_0_Zpow. auto with a. omega. omega. omega.
  omega. Qed.

(* <KE EP TOGETHER - s_i_eq *)
Lemma s_i_eq : _Z s_i = x' mod 2 ^ w / 2 ^ p.
(* KE EP TOGETHER> *)

  simpl. fold l. fold p. fold x_i. rewrite x_i_eq. trivial. Qed.

(* <KE EP TOGETHER - s'_i_eq *)
Lemma s'_i_eq : _Z s'_i = x' mod 2 ^ w - x' mod 2 ^ p.
(* KE EP TOGETHER> *)

  unfold s'_i. rewrite Z_from_multp2. fold p. rewrite s_i_eq. rewrite Zmult_comm. rewrite modred.
  replace (x' mod 2 ^ p) with (x' mod 2 ^ w mod 2 ^ p). apply Zdiv_a_b_b_Zmod. auto with a.
  replace (2 ^ w) with (2 ^ (w - p) * 2 ^ p). apply Zmod_prod_Zmod. apply lt_0_Zpow. auto with a.
  auto with a. rewrite <- Zpower_exp. apply f_equal2 with (f := Zpower). trivial. ring. apply Zle_ge.
  auto with a. apply Zle_ge. auto with a. fold (0 * 0). apply Zmult_le_compat. apply Zle_0_div.
  apply Zmod_le_0_z. auto with a. auto with a. apply Zlt_le_weak. auto with a. omega. omega.
  apply Zle_lt_trans with (x' mod 2 ^ w). rewrite Zmult_comm. apply Z_mult_div_ge. apply Zlt_gt.
  auto with a. apply Zmod_lt_z_m. auto with a. Qed.

Lemma le_0_x' : 0 <= x'.

  unfold x'. fold (0 + 0). apply Zplus_le_compat; auto with a. apply Zmult_le_0_compat. apply le_0__Z.
  auto with a. unfold x_i. apply le_0__Z. Qed.

Local Hint Resolve le_0_x' : a.

Lemma r''0_small : r''0 < 2 ^ p.

  unfold r''0.
  unfold r'0. unfold d0. unfold r0. fold r'_i. (* too long *)
  elim (Zle_or_lt c r'_i); intro H. rewrite ltw_false. rewrite Z_from_minusw. fold M. rewrite modred. rewrite r'_i_eq.
  cut (((h mod M * 2 ^ w + l) / 2 ^ p * 2 ^ p) mod M < M). cut ((h mod M * 2 ^ w + l) mod 2 ^ p < 2 ^ p). omega.
  apply Zmod_lt_z_m. apply lt_0_Zpow. auto with a. apply Zmod_lt_z_m. omega. cut (M <= r'_i). omega.
  apply Zle_trans with c. rewrite c_M. exact le_M_2pp. assumption. cut (0 <= M). cut (r'_i < 2 ^ w). omega. apply lt_z__Z.
  omega. assumption. rewrite ltw_true. rewrite <- c_M. assumption. assumption. Qed.

(* <KE EP TOGETHER - r''0_eq *)
Lemma r''0_eq : _Z r''0 = x mod M \/ _Z r''0 = x mod M + M.
(* KE EP TOGETHER> *)

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  unfold r''0.
  unfold r'0. unfold d0. unfold r0. fold r'_i. (* too long *) elim (Zle_or_lt c r'_i); intro H. rewrite ltw_false. simpl. fold M.
  rewrite modred. elim r'_i_eq'_i; intro H0. absurd (c <= r'_i). apply Zlt_not_le. rewrite H0. apply Zlt_le_trans with M.
  apply Zmod_lt_z_m. omega. rewrite c_M. exact le_M_2pp. assumption. elim H0; intro H1. left. omega. right. omega.
  cut (M <= 2 ^ p). omega. exact le_M_2pp. cut (r'_i < 2 ^ w). cut (0 < M). omega. omega. apply lt_z__Z. assumption.
  rewrite ltw_true. elim r'_i_eq'_i. intro H0. tauto. intro H0. elim H0; intro H1. tauto. absurd (r'_i < c). apply Zle_not_lt.
  rewrite H1. apply Zle_trans with (M + M). rewrite c_M. elim (Zle_lt_or_eq 1 M). intro H2. elim lt_2pm1_M; intro H3.
  replace p with (p - 1 + 1). rewrite Zpower_exp. simpl. unfold Zpower_pos. simpl. omega. cut (1 <= p). omega.
  replace 1 with (Zlog_sup 2). rewrite p_M. apply Zlog_sup_seq. omega. trivial. omega. ring. rewrite p_M. rewrite H3. omega.
  intro H2. rewrite p_M. rewrite <- H2. simpl. omega. omega. cut (0 <= x mod M). omega. apply Zmod_le_0_z. omega. assumption.
  assumption. Qed.

(* <KE EP TOGETHER - r'''0_eq *)
Lemma r'''0_eq : _Z r'''0 = x mod M.
(* KE EP TOGETHER> *)

  clear x_i_in_Z_ x_i s_i s'_i s''_i h'_i q_i q'_i y_i h'_i h'_i' x'.
  unfold r'''0. elim r''0_eq; intro H. rewrite ltw_true. trivial. rewrite H. apply Zmod_lt_z_m. fold M. omega. rewrite ltw_false.
  simpl. rewrite H. fold M. replace (x mod M + M - M) with (x mod M). apply modred.
  apply Zmod_le_0_z. omega. apply Zlt_trans with M. apply Zmod_lt_z_m. omega. unfold M. apply lt_z__Z. ring. rewrite H. fold M.
  cut (0 <= x mod M). omega. apply Zmod_le_0_z. omega. Qed.

Lemma lt_x'_x'max : x' < 2 ^ (p + w).

  unfold x'. apply Zle_lt_trans with ((2 ^ p - 1) * 2 ^ w + (2 ^ w - 1)). apply Zplus_le_compat.
  apply Zmult_le_compat. auto with a. auto with a. cut (r''0 < 2 ^ p). omega. apply r''0_small. omega. auto with a.
  apply le_0__Z. auto with a. cut (x_i < 2 ^ w). omega. unfold x_i. apply lt_z__Z. rewrite Zmult_minus_distr_r.
  rewrite <- Zpower_exp. omega. auto with a. apply Zle_ge. auto with a. apply Zle_ge. auto with a. Qed.

Lemma le_x'_x'max : x' <= 2 ^ (p + w) - 1.

  cut (x' < 2 ^ (p + w)). omega. exact lt_x'_x'max. Qed.

Local Hint Resolve lt_x'_x'max le_x'_x'max : a.

Lemma Meq_ir''0 : M = 1 -> _Z r''0 = 0.

  intro H. cut (r''0 < 2 ^ p). rewrite p_M. rewrite H. simpl. cut (0 <= r''0). omega. apply le_0__Z. exact r''0_small. Qed.

(* <KE EP TOGETHER - h_i'_eq *)
Lemma h_i'_eq : _Z h_i' = x' / 2 ^ w * 2 ^ (w - p).
(* KE EP TOGETHER> *)

  unfold x'. rewrite Zdiv_times_plus. rewrite Zdiv_small_0. simpl. fold t. replace (r''0 + 0) with (_Z r''0). elim t_M; intro H.
  rewrite H. rewrite Zmult_comm. apply modred. fold (0 * 0). apply Zmult_le_compat. apply le_0__Z. apply Zlt_le_weak.
  apply lt_0_Zpow. auto with a. omega.
  omega. apply Zlt_le_trans with (2 ^ p * 2 ^ (w - p)). apply Zmult_lt_compat_r. auto with a.
  apply lt_0_Zpow. auto with a. apply r''0_small. rewrite <- Zpower_exp. replace (p + (w - p)) with w. omega.
  ring. apply Zle_ge. auto with a. apply Zle_ge. auto with a. rewrite Meq_ir''0. rewrite Zmult_comm. simpl. apply modred. omega.
  auto with a. assumption. ring. unfold x_i. apply le_0__Z. unfold x_i. apply lt_z__Z. auto with a. Qed.

(* <KE EP TOGETHER - h'_i'_eq *)
Lemma h'_i'_eq : _Z h'_i' = x' / 2 ^ p.
(* KE EP TOGETHER> *)

  unfold h'_i'. rewrite Z_from_plusw. rewrite h_i'_eq. simpl. fold x_i p. rewrite x_i_eq. rewrite <- Zdiv_times_plus.
  rewrite <- Zmult_assoc. rewrite <- Zpower_exp. replace (w - p + p) with w. rewrite Zdivmod_split.
  apply modred. apply Zle_0_div. auto with a. auto with a. apply Zlt_le_trans with (2 ^ (p + w) / 2 ^ p).
  apply Zle_lt_trans with ((2 ^ (p + w) - 1) / 2 ^ p). apply Zdiv_le. auto with a. cut (x' < 2 ^ (p + w)).
  omega. auto with a. rewrite Zpower_exp. rewrite Zmult_comm. rewrite Zdiv_mult_minus. rewrite Z_div_mult.
  omega. apply Zlt_gt. auto with a. auto with a. omega. cut (0 < 2 ^ p). omega. auto with a. apply Zle_ge.
  auto with a. apply Zle_ge. auto with a. rewrite Zpower_exp. rewrite Zmult_comm. rewrite Z_div_mult.
  omega. apply Zlt_gt. auto with a. apply Zle_ge. auto with a. apply Zle_ge. auto with a. auto with a.
  ring. apply Zle_ge. auto with a. apply Zle_ge. auto with a. auto with a. Qed.

Lemma h'_i'h'_i_eq : _Z h'_i' = _Z h'_i.

  unfold h'_i'. unfold h'_i. simpl. unfold r''0.
  unfold r'0. unfold d0. unfold r0. fold r'_i. (* too long *)
  unfold s''_i. fold t. fold p. elim (Zle_or_lt c r'_i); intro H. rewrite ltw_false. rewrite ltw_false. simpl. fold M''.
  rewrite M''_M. fold M. fold x_i. rewrite Zmult_comm. rewrite <- Zmod_mult_distr_l. rewrite <- Zmod_plus_distr_l.
  rewrite <- Zmod_minus_distr_r. rewrite <- Zmod_plus_distr_l. rewrite Zplus_comm with (n := 2 ^ t * r'_i).
  rewrite <- Zmod_plus_distr_l. fold p. apply f_equal2 with (f := Zmod). ring. trivial. exact lt02w. exact lt02w. exact lt02w.
  exact lt02w. exact lt02w. assumption. assumption. rewrite ltw_true. rewrite ltw_true. trivial. assumption. assumption. Qed.

(* <KE EP TOGETHER - q_i_eq *)
Lemma q_i_eq :
  _Z q_i = x' / 2 ^ p * (2 ^ (p + w) / M mod 2 ^ w) / 2 ^ w.
(* KE EP TOGETHER> *)

  unfold q_i. rewrite uhwm_eq. rewrite <- h'_i'h'_i_eq. rewrite h'_i'_eq. fold M'. rewrite M'_M. trivial. Qed.

Lemma q'_i_eq_pre :
  _Z q'_i = (x' / 2 ^ p * (2 ^ (p + w) / M) / 2 ^ w) mod 2 ^ w.

  unfold q'_i. rewrite Z_from_plusw. rewrite q_i_eq. rewrite <- h'_i'h'_i_eq. rewrite h'_i'_eq. rewrite Zplus_comm.
  rewrite <- Zdiv_times_plus. rewrite <- Zmult_plus_distr_r. rewrite large_M'_eq. trivial. auto with a. Qed.

Lemma mod_ab_mod : forall z a b m : Z, 0 < m ->
  z = a \/ z = b -> z mod m = a mod m \/ z mod m = b mod m.

  intros z a b m H H0. elim H0; intro H1; rewrite H1; tauto. Qed.

(* <KE EP TOGETHER - q'_i_eq *)
Lemma q'_i_eq :
  _Z q'_i = (x' / 2 ^ p * 2 ^ p / M) mod 2 ^ w \/
  _Z q'_i = (x' / 2 ^ p * 2 ^ p / M - 1) mod 2 ^ w.
(* KE EP TOGETHER> *)

  rewrite q'_i_eq_pre. apply mod_ab_mod. auto with a.
  cut (x' / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w = x' / 2 ^ p * 2 ^ p / M - 1 \/
       x' / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w = x' / 2 ^ p * 2 ^ p / M).
  rewrite Zpower_exp. tauto. apply Zle_ge. auto with a. apply Zle_ge. auto with a.
  cut (x' / 2 ^ p * 2 ^ p / M - 1 <= x' / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w).
  cut (x' / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w <= x' / 2 ^ p * 2 ^ p / M). intros H H0.
  elim (Zle_lt_or_eq (x' / 2 ^ p * (2 ^ p * 2 ^ w / M) / 2 ^ w) (x' / 2 ^ p * 2 ^ p / M)). intro H1. left.
  omega. intro H1. right. omega. assumption. apply approx_0_one. omega. auto with a. auto with a.
  auto with a. apply approx_m1_one. auto with a. auto with a. omega. auto with a.
  cut (x' < 2 ^ p * 2 ^ w). cut (0 < 2 ^ p). omega. auto with a. rewrite <- Zpower_exp. auto with a.
  apply Zle_ge. auto with a. apply Zle_ge. auto with a. Qed.

(* <KE EP TOGETHER - y_i_eq *)
Lemma y_i_eq :
  _Z y_i = x' / 2 ^ p * 2 ^ p / M * M mod 2 ^ w \/
  _Z y_i = (x' / 2 ^ p * 2 ^ p / M * M - M) mod 2 ^ w.
(* KE EP TOGETHER> *)

  unfold y_i. rewrite Z_from_multw. fold M. elim q'_i_eq; intro H; rewrite H. left.
  rewrite <- Zmod_mult_distr_l. trivial. auto with a. right. rewrite <- Zmod_mult_distr_l.
  apply f_equal2 with (f := Zmod). ring. trivial. auto with a. Qed.

(* <KE EP TOGETHER - d_i_eq *)
Lemma d_i_eq :
  _Z d_i = x' / 2 ^ p * 2 ^ p mod M \/
  _Z d_i = x' / 2 ^ p * 2 ^ p mod M + M.
(* KE EP TOGETHER> *)

  unfold d_i. rewrite Z_from_minusw. rewrite s'_i_eq. rewrite Zmod_minus_distr_l.
  rewrite <- Zmod_minus_distr_l with (b := x' mod 2 ^ p). rewrite <- Zmod_minus_distr_l.
  rewrite <- Zdiv_a_b_b_Zmod. elim y_i_eq; intro H. left. rewrite H. rewrite <- Zmod_minus_distr_r.
  rewrite Zminus_Zdiv_Zmult. apply modred. apply Zmod_le_0_z. omega. apply Zlt_le_trans with M.
  apply Zmod_lt_z_m. omega. auto with a. omega. auto with a. right. rewrite H.
  rewrite <- Zmod_minus_distr_r.
  replace (x' / 2 ^ p * 2 ^ p - (x' / 2 ^ p * 2 ^ p / M * M - M))
     with (x' / 2 ^ p * 2 ^ p - x' / 2 ^ p * 2 ^ p / M * M + M). rewrite Zminus_Zdiv_Zmult. apply modred.
  fold (0 + 0). apply Zplus_le_compat. apply Zmod_le_0_z. omega. omega. apply Zlt_le_trans with (M + M).
  apply Zplus_lt_le_compat. apply Zmod_lt_z_m. omega. omega. rewrite Zpow_2_w_is_2Zpow_2_wm1. omega. omega.
  ring. auto with a. auto with a. auto with a. auto with a. auto with a. Qed.

(* <KE EP TOGETHER - r_i_eq *)
Lemma r_i_eq : _Z r_i = (_Z d_i + x' mod 2 ^ p) mod 2 ^ w.
(* KE EP TOGETHER> *)

  unfold r_i. unfold d_i. rewrite Z_from_minusw. rewrite Z_from_minusw. fold l. rewrite s'_i_eq.
  rewrite Zmod_minus_distr_l with (a := x' mod 2 ^ w - x' mod 2 ^ p).
  rewrite <- Zmod_minus_distr_l with (a := x'). rewrite <- Zmod_minus_distr_l. rewrite <- Zmod_plus_distr_l. fold x_i.
  replace (x' - x' mod 2 ^ p - _Z y_i + x' mod 2 ^ p) with (x' - _Z y_i). rewrite x_i_eq.
  rewrite <- Zmod_minus_distr_l. trivial. auto with a. ring. auto with a. auto with a. auto with a.
  auto with a. Qed.

Definition d_ir_i := (d_i, r_i).

Lemma d_i_r_i_eq : P M p d_i r_i x x_i_in_Z_.

  unfold P. split. elim d_i_eq; unfold x'. elim r''0_eq; intro H; rewrite H. tauto. tauto. elim r''0_eq; intro H; rewrite H. tauto.
  tauto. fold x_i. replace (x_i mod 2 ^ p) with (x' mod 2 ^ p). exact r_i_eq. unfold x'. rewrite mod2p with (c' := 0).
  apply f_equal2 with (f := Zmod). ring. trivial. Qed.

End parm_sec.

Section repeat.

Variable M_in_Z_ : Z_ (2 ^ w).

Variable ptM'cM'' : Z_ w * Z_ w * Z_ (2 ^ w) * Z_ (2 ^ w) * Z_ (2 ^ w).
Variable x : Z. (* multi-word *)

Let p_in_Z_w := fst (fst (fst (fst ptM'cM''))).
Let t_in_Z_w := snd (fst (fst (fst ptM'cM''))).
Let M'_in_Z_ := snd (fst (fst ptM'cM'')).
Let c_in_Z_ := snd (fst ptM'cM'').
Let M''_in_Z_ := snd ptM'cM''.

Let M := _Z M_in_Z_.
Let p := _Z p_in_Z_w.
Let t := _Z t_in_Z_w.
Let c := _Z c_in_Z_.
Let M'' := _Z M''_in_Z_.
Let M' := _Z M'_in_Z_.

Hypothesis le_1_M : 1 <= M.
Hypothesis le_M_max : M <= 2 ^ (w - 1).
Hypothesis p_M : p = Zlog_sup M.
Hypothesis t_M : t = w - p \/ M = 1.
Hypothesis c_M : c = 2 ^ p.
Hypothesis M''_M : M'' = (2 ^ t * M) mod 2 ^ w.
Hypothesis M'_M : M' = 2 ^ (p + w) / M mod 2 ^ w.

Definition x_ (i : nat) := exist (in_Z_ (2 ^ w)) (x / 2 ^ (Z_of_nat i * w) mod 2 ^ w) (mod_in_Z__ (x / 2 ^ (Z_of_nat i * w))).

Definition f' (d_Sir_Si : Z_ (2 ^ w) * Z_ (2 ^ w)) (xi : Z_ (2 ^ w)) :=
  (d_i M_in_Z_ ptM'cM'' d_Sir_Si xi, r_i M_in_Z_ ptM'cM'' d_Sir_Si xi).

Fixpoint foldlz (f : Z_ (2 ^ w) * Z_ (2 ^ w) -> Z_ (2 ^ w) -> Z_ (2 ^ w) * Z_ (2 ^ w)) (d_Sir_Si : Z_ (2 ^ w) * Z_ (2 ^ w)) (a:nat) {struct a} :
 Z_ (2 ^ w) * Z_ (2 ^ w) :=
  match a with
  | O   => d_Sir_Si
  | S i => foldlz f (f d_Sir_Si (x_ i)) i
  end.

Lemma P'f' : forall (d r : Z_ (2 ^ w)) (h : Z) (l x_i : Z_ (2 ^ w)),
  P M p d r h l -> P M p (fst (f' (d, r) x_i)) (snd (f' (d, r) x_i)) (h * 2 ^ w + l) x_i.

  intros d r  h l x_i H. unfold f'. unfold M. unfold p. unfold p_in_Z_w. simpl. apply d_i_r_i_eq; fold p_in_Z_w; fold M; fold p.
  assumption. omega. assumption. assumption. assumption. assumption. assumption. assumption. Qed.

Lemma P'f'x : forall (d r : Z_ (2 ^ w)) (n : nat),
  P M p d r (x / 2 ^ ((Z_of_nat n + 2) * w)) (x_ (S n)) ->
  P M p (fst (f' (d, r) (x_ n))) (snd (f' (d, r) (x_ n))) (x / 2 ^ ((Z_of_nat n + 1) * w)) (x_ n).

  intros d r n H.
  rewrite Z_div_mod_eq with (a := x / 2 ^ ((Z_of_nat n + 1) * w)) (b := 2 ^ w). rewrite Zdivdivdiv. rewrite <- Zpower_exp.
  replace ((Z_of_nat n + 1) * w + w) with ((Z_of_nat n + 2) * w). replace (Z_of_nat n + 1) with (Z_of_nat (S n)).
  replace ((x / 2 ^ (Z_of_nat (S n) * w)) mod 2 ^ w) with (_Z (x_ (S n))). rewrite Zmult_comm.
  apply P'f'. trivial. trivial. trivial.
  trivial. rewrite inj_S. ring. ring. apply Zle_ge. apply Zmult_le_0_compat. omega. exact le_0_w.
  apply Zle_ge. exact le_0_w. apply lt_0_Zpow. apply Zmult_le_0_compat. omega. exact le_0_w. exact lt02w. apply Zlt_gt.
  exact lt02w. Qed.

Lemma P'foldlz : forall (n : nat) (d r : Z_ (2 ^ w)),
  P M p d r (x / 2 ^ ((Z_of_nat n + 2) * w)) (x_ (S n)) ->
  P M p (fst (foldlz f' (d, r) (S n))) (snd (foldlz f' (d, r) (S n))) (x / 2 ^ w) (x_ O).

  induction n. intros d r. intro H.
  replace (foldlz f' (d, r) 1) with (f' (d, r) (x_ 0)).
  (* replace w with ((Z_of_nat 0 + 1) * w). *) (* does not work *)
  cut (P M p (fst (f' (d, r) (x_ 0))) (snd (f' (d, r) (x_ 0))) (x / 2 ^ ((Z_of_nat 0 + 1) * w)) (x_ 0)). (* workaroud *)
  replace ((Z_of_nat 0 + 1) * w) with w. (* works *) trivial. ring. apply P'f'x. assumption. trivial. intros d r. intro H.
  replace (foldlz f' (d, r) (S (S n))) with (foldlz f' (f' (d, r) (x_ (S n))) (S n)).
  replace (f' (d, r) (x_ (S n))) with (d_i M_in_Z_ ptM'cM'' (d, r) (x_ (S n)), r_i M_in_Z_ ptM'cM'' (d, r) (x_ (S n))). apply IHn.
  replace (Z_of_nat n + 2) with (Z_of_nat (S n) + 1).
  replace (d_i M_in_Z_ ptM'cM'' (d, r) (x_ (S n))) with (fst (f' (d, r) (x_ (S n)))).
  replace (r_i M_in_Z_ ptM'cM'' (d, r) (x_ (S n))) with (snd (f' (d, r) (x_ (S n)))).
  apply P'f'x. assumption. trivial. trivial. rewrite inj_S. unfold Zsucc. ring. trivial. trivial. Qed.

Lemma P_S : forall (n : nat),
  0 <= x -> x < 2 ^ (Z_of_nat (S n) * w) ->
  P M p (fst (foldlz f' (zero_in_Z_, zero_in_Z_) (S n)))
        (snd (foldlz f' (zero_in_Z_, zero_in_Z_) (S n))) (x / 2 ^ w) (x_ 0).

  intros n H H0. apply P'foldlz. rewrite Zdiv_small_0. simpl. unfold P. split. left.
  replace (_Z (x_ (S n))) with 0. replace (0 mod M) with 0. replace (0 * 2 ^ w + 0) with 0. rewrite Zdiv_small_0.
  replace (0 * 2 ^ p) with 0. rewrite modred. trivial. omega. omega. ring. omega. apply lt_0_Zpow. unfold p. unfold p_in_Z_w.
  apply le_0_p. trivial. symmetry. apply modred. omega. omega. transitivity (x / 2 ^ (Z_of_nat (S n) * w) mod 2 ^ w).
  rewrite Zdiv_small_0. symmetry. apply modred. omega. exact lt02w. assumption. assumption. trivial.
  replace (_Z (x_ (S n))) with 0. replace (0 mod 2 ^ p) with 0. simpl. symmetry. apply modred. omega. exact lt02w. symmetry.
  apply modred. omega. apply lt_0_Zpow. unfold p. unfold p_in_Z_w. apply le_0_p.
  transitivity (x / 2 ^ (Z_of_nat (S n) * w) mod 2 ^ w). rewrite Zdiv_small_0. symmetry. apply modred. omega. exact lt02w.
  assumption. assumption. trivial. assumption. apply Zlt_trans with (2 ^ (Z_of_nat (S n) * w)). assumption. apply Zlt_pow_lt.
  apply Zmult_le_0_compat. omega. exact le_0_w. apply Zmult_gt_0_lt_compat_r. apply Zlt_gt. exact lt_0_w. rewrite inj_S. omega.
  Qed.

Lemma P_O :
  0 <= x -> x < 2 ^ (Z_of_nat O * w) ->
  P M p (fst (foldlz f' (zero_in_Z_, zero_in_Z_) O))
        (snd (foldlz f' (zero_in_Z_, zero_in_Z_) O)) (x / 2 ^ w) (x_ 0).

  intros H H0. replace (Z_of_nat 0 * w) with 0 in H0. simpl in H0. cut (x = 0). intro H1. rewrite H1.
  rewrite Zdiv_small_0. unfold P. split. left. simpl. rewrite H1. rewrite Zdiv_small_0. replace (0 * 2 ^ p) with 0. symmetry.
  apply modred. omega. omega. ring. rewrite Zdiv_small_0. replace (0 mod 2 ^ w) with 0. omega. symmetry. apply modred. omega.
  exact lt02w. omega. omega. rewrite Zdiv_small_0. rewrite modred. apply lt_0_Zpow. unfold p. unfold p_in_Z_w. apply le_0_p.
  omega. exact lt02w. omega. omega. simpl. rewrite H1. rewrite Zdiv_small_0. rewrite modred. rewrite modred. symmetry.
  apply modred. omega. exact lt02w. rewrite modred. omega. omega. exact lt02w. rewrite modred. apply lt_0_Zpow. unfold p.
  unfold p_in_Z_w. apply le_0_p. omega. exact lt02w. rewrite modred. rewrite modred. omega. omega.
  exact lt02w. rewrite modred. omega. omega. exact lt02w. rewrite modred. apply lt_0_Zpow. unfold p. unfold p_in_Z_w.
  apply le_0_p. omega. exact lt02w. rewrite modred. rewrite modred. exact lt02w. omega. exact lt02w. rewrite modred.
  omega. omega. exact lt02w. rewrite modred. apply lt_0_Zpow. unfold p. unfold p_in_Z_w. apply le_0_p. omega. exact lt02w.
  omega. omega. omega. exact lt02w. omega. ring. Qed.

Lemma P_all : forall (n : nat),
  0 <= x -> x < 2 ^ (Z_of_nat n * w) ->
  P M p (fst (foldlz f' (zero_in_Z_, zero_in_Z_) n))
        (snd (foldlz f' (zero_in_Z_, zero_in_Z_) n)) (x / 2 ^ w) (x_ 0).

  intro n. case n. intros. apply P_O; assumption. intro n0. intros. apply P_S with (n := n0); assumption. Qed.

Lemma Q_lem : forall (n : nat),
  0 <= x -> x < 2 ^ (Z_of_nat n * w) ->
  _Z (r'''0 M_in_Z_ ptM'cM'' (foldlz f' (zero_in_Z_, zero_in_Z_) n)) = x mod M.

  intros n H H0.
  cut (P M p (fst (foldlz f' (zero_in_Z_, zero_in_Z_) n)) (snd (foldlz f' (zero_in_Z_, zero_in_Z_) n)) (x / 2 ^ w) (x_ 0)).
  intro H1. rewrite r'''0_eq with (d_Sir_Si := foldlz f' (zero_in_Z_, zero_in_Z_) n) (l_in_Z_ := x_ 0) (h := x / 2 ^ w). simpl.
  replace (x / 1) with ((x * 1 + 0) / 1).
  rewrite Zdiv_mult_plus. rewrite Zmult_comm. rewrite <- Z_div_mod_eq. trivial. apply Zlt_gt. exact lt02w. omega. omega. omega.
  apply f_equal2 with (f := Zdiv); ring. trivial. fold M. omega. trivial. trivial. assumption. assumption.
  apply P_all; assumption. Qed.

End repeat.

Lemma cex : forall M : Mset, in_Z_ (2 ^ w) (2 ^ Zlog_sup M).

  intro M. unfold in_Z_. split. cut (0 < 2 ^ Zlog_sup M). omega. apply lt_0_Zpow. apply Zle_trans with (Zlog_sup 1).
  simpl. omega. apply Zlog_sup_seq. apply Mset_l. apply Zlt_pow_lt. apply Zlog_sup_correct1. case M. unfold in_Mset. simpl.
  intros. omega. apply Zle_lt_trans with (Zlog_sup (2 ^ (w - 1))). apply Zlog_sup_seq. case M. unfold in_Mset. simpl. intros.
  omega. rewrite Zlog_sup_pow. omega. cut (0 < w). omega. exact lt_0_w. Qed.

Lemma M''ex : forall M : Mset, in_Z_ (2 ^ w) (2 ^ (w - Zlog_sup M - 1 / M) * M mod 2 ^ w).

  intro M. apply xlex. Qed.

Lemma M'mod : forall M : Mset,
   2 ^ (Zlog_sup M + w) / M - 2 ^ w =
  (2 ^ (Zlog_sup M + w) / M) mod 2 ^ w.

  intro M. rewrite <- Zmod_minus_m. symmetry. apply modred; elim (M'ex M); tauto. exact lt02w. Qed.

(* <KEEP TOGETHER - d_n_r_n_def *)
Definition d_n := zero_in_Z_.

Definition r_n := zero_in_Z_.
(* KEEP TOGETHER> *)

Definition MultiRed (M_in_Z_ : Z_ (2 ^ w)) (ptM'cM'' : Z_ w * Z_ w * Z_ (2 ^ w) * Z_ (2 ^ w) * Z_ (2 ^ w))
                    (n : nat) (x : Z_ (2 ^ (Z_of_nat n * w))) :=
  g' M_in_Z_ ptM'cM'' (foldlz x (f' M_in_Z_ ptM'cM'') (d_n, r_n) n).

(* <KEEP TOGETHER - C'def *)
Definition C' (M : Mset) :=
      ( C M,
        exist (in_Z_ (2 ^ w)) (2 ^ Zlog_sup M)                             (cex M),
        exist (in_Z_ (2 ^ w)) (2 ^ (w - Zlog_sup M - 1 / M) * M mod 2 ^ w) (M''ex M)).
(* KEEP TOGETHER> *)

(* <KEEP TOGETHER - multired_equality *)
Theorem MultiRed_eq : forall (M : Mset) (n : nat) (x : Z_ (2 ^ (Z_of_nat n * w))),
  _Z (MultiRed M (C' M) n x) = x mod M.
(* KEEP TOGETHER> *)

  intros M n x. unfold MultiRed. unfold d_n. unfold r_n. unfold g'. apply Q_lem; unfold C'; simpl.
  apply Mset_l. apply Mset_r. trivial. elim (Zle_lt_or_eq 1 M). intro H. left.
  rewrite Zdiv_small_0. ring. omega. assumption. intro H. rewrite H. tauto. apply Mset_l. trivial. trivial.
  apply M'mod; assumption. apply le_0__Z. apply lt_z__Z. Qed.

Close Scope Z_scope.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_21.

Coq < Goal forall r d f g s:Prop, (((~r \/ d) -> ~(f /\ g)) /\ ((f /\ r) -> s) /\ (f /\ ~s)) -> ~(s \/ g).
1 subgoal

  ============================
   forall r d f g s : Prop,
   (~ r \/ d -> ~ (f /\ g)) /\ (f /\ r -> s) /\ f /\ ~ s -> ~ (s \/ g)

Unnamed_thm < intros.
1 subgoal

  r : Prop
  d : Prop
  f : Prop
  g : Prop
  s : Prop
  H : (~ r \/ d -> ~ (f /\ g)) /\ (f /\ r -> s) /\ f /\ ~ s
  ============================
   ~ (s \/ g)

Unnamed_thm < elim H.
1 subgoal

  r : Prop
  d : Prop
  f : Prop
  g : Prop
  s : Prop
  H : (~ r \/ d -> ~ (f /\ g)) /\ (f /\ r -> s) /\ f /\ ~ s
  ============================
   (~ r \/ d -> ~ (f /\ g)) -> (f /\ r -> s) /\ f /\ ~ s -> ~ (s \/ g)

Unnamed_thm < intro.
1 subgoal

  r : Prop
  d : Prop
  f : Prop
  g : Prop
  s : Prop
  H : (~ r \/ d -> ~ (f /\ g)) /\ (f /\ r -> s) /\ f /\ ~ s
  H0 : ~ r \/ d -> ~ (f /\ g)
  ============================
   (f /\ r -> s) /\ f /\ ~ s -> ~ (s \/ g)

Unnamed_thm < intro.
1 subgoal

  r : Prop
  d : Prop
  f : Prop
  g : Prop
  s : Prop
  H : (~ r \/ d -> ~ (f /\ g)) /\ (f /\ r -> s) /\ f /\ ~ s
  H0 : ~ r \/ d -> ~ (f /\ g)
  H1 : (f /\ r -> s) /\ f /\ ~ s
  ============================
   ~ (s \/ g)

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <
*)

Require Import Classical.
Section Exercise_21.
Goal forall r d f g s:Prop, (((~r \/ d) -> ~(f /\ g)) /\ ((f /\ r) -> s) /\ (f /\ ~s)) -> ~(s \/ g).
intros.
elim H.
intro.
intro.
 firstorder .
 Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype finset rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint order finmap.

Module Monad.

(* Here we generalize monads not to be Type -> Type but rather dom -> Type, where dom is an arbitrary kind. This enables T to be from choiceType to Type, etc. clof then is the projection from dom back down to Type (ie, Choice.sort)

  Additionally we generalize the monad laws to be over an arbitrary relation mrel. in many cases this will be equal to (fun A => @eq (T A)) but could also be =1, in the case of state monad (not extensional)
*)

  Record axiom (dom : Type) (clof : dom -> Type) (T : dom -> Type) (mrel : forall A, T A -> T A -> Prop) (mret : forall A, clof A -> T A) (bind : forall A B, T A -> (clof A -> T B) -> T B) :=
    {
      _ : forall A B (x : clof A) (f : clof A -> T B) , mrel _ (bind _ _ (mret _ x) f) (f x);
      _ : forall A (m : T A), mrel _ (bind _ _ m (mret A)) m;
      _ : forall A B C (m : T A) (f : clof A -> T B) (g : clof B -> T C),
          mrel _ (bind _ _ (bind _ _ m f) g) (bind _ _ m (fun x => bind _ _ (f x) g));
      }.

Record mixin_of (dom : Type) (clof : dom -> Type) (T : dom -> Type) (mrel : forall A, T A -> T A -> Prop) : Type := Mixin { mret : forall A, clof A -> T A; bind : forall A B, T A -> (clof A -> T B) -> T B; _ : axiom dom clof T mrel mret bind }.
    Notation class_of := mixin_of (only parsing).

  Section ClassDef.

    Structure type := Pack {dom; clof; sort; mrel; _ : class_of dom clof sort mrel; _ : dom -> Type}.
    Local Coercion sort : type >-> Funclass.

Variables (dom0 : Type) (T : dom0 -> Type) (clof0 : dom0 -> Type) (mrel0 : forall A, T A -> T A -> Prop) (cT : type).
Definition class : mixin_of _ (clof cT) (sort cT) (mrel cT).
destruct cT; rewrite //=.
Defined.

Print Equality.pack.

Definition pack mrel (m : mixin_of dom0 clof0 T mrel) : type.
econstructor.
apply m.
apply T.
Defined.

Definition clone c of phant_id class c := @Pack dom0 clof0 T mrel0 c T.

End ClassDef.

Module Exports.
Coercion sort : type >-> Funclass.
Notation monadType := type.
Notation MonadMixin := Mixin.
Notation MonadType d c T r m := (@pack d c T r m).

Check clone.
Notation "[ 'monadType' 'of' T 'for' cT ]" := (@clone _ T _ _ cT _ idfun)
  (at level 0, format "[ 'monadType' 'of' T 'for' cT ]") : form_scope.
Notation "[ 'monadType' 'of' T ]" := (@clone _ T _ _ _ _ id)
  (at level 0, format "[ 'monadType' 'of' T ]") : form_scope.

End Exports.
End Monad.

Export Monad.Exports.
Definition mbind T := Monad.bind _ _ _ _ (Monad.class T).
Definition mret T := Monad.mret _ _ _ _ (Monad.class T).
Definition mrel T A x y := Monad.mrel T A x y.

Notation "'ret' x" := (mret _ _ x) (at level 70).
Notation "x <- c ; d" := (mbind _ _ _ c (fun x => d)) (right associativity, at level 80, d at next level).
Notation "c1 ~~ c2"  := (mrel _ _ c1 c2) (at level 70).

Section MonadDefs.
  Variable (m : monadType).
  Lemma bind_ret A (c : m A) : (x <- c; ret x) ~~ c.
    rewrite /mbind //=.
  destruct m.
  destruct m0.
  destruct a.
  simpl in *.
  apply m1.
  Qed.

  Lemma ret_bind (A : Monad.dom m)  B (a : Monad.clof m A) (c : Monad.clof m A -> m B) : (x <- (ret a); c x) ~~ c a.
  rewrite /mbind /mret //=.
  destruct m.
  destruct m0.
  destruct a0; simpl.
  apply m0.
  Qed.

  Lemma bindA A B C (a : m A) (c : Monad.clof m A -> m B) (d : Monad.clof m B -> m C) :
    (x <- (y <- a; c y); d x) ~~ (x <- a; (y <- c x; d y)).
  rewrite /mbind /mret //=.
  destruct m.
  destruct m0.
  destruct a0; simpl.
  apply m2.
  Qed.
End MonadDefs.

(* option *)

Lemma option_monad : Monad.axiom Type id option (fun A => @eq (option A)) (fun A (x : A) => Some x) (fun A B (x : option A) (y : A -> option B) => obind y x).
  constructor.
  rewrite //=.
  move => A; case; rewrite //=.
  move => A B C ma f g.
  case ma; rewrite //=.
Qed.

Canonical optionMonadMixin := Eval hnf in MonadMixin _ _ _ _ _ _ option_monad.
Canonical optionMonadType := Eval hnf in MonadType _ _ _ _ optionMonadMixin.

(* seq *)

Lemma seq_monad : Monad.axiom Type id seq (fun A => @eq (seq A)) (fun A (x : A) => [:: x]) (fun A B (x : seq A) (f : A -> seq B) => flatten (map f x)).
  constructor.
  rewrite //= => A B x f; rewrite cats0 //=.
  move => A m; rewrite //= flatten_seq1 //=.
  move => A B C m f g.
  induction m; rewrite //=.
  rewrite map_cat flatten_cat IHm //=.
Qed.

Canonical seqMonadMixin := Eval hnf in MonadMixin _ _ _ _ _ _ seq_monad.
Canonical seqMonadType := Eval hnf in MonadType _ _ _ _ seqMonadMixin.

(* state *)

Definition State (S : Type) (A : Type) := S -> A * S.

Lemma state_monadax (S : Type) : Monad.axiom Type id (State S) (fun A f1 f2 => f1 =1 f2)
                                             (fun A (x : A) => fun s => (x, s))
                                             (fun A B (x : State S A) (f : A -> State S B) s =>
                                                let p := x s in
                                                f (p.1) (p.2)).
  constructor; rewrite //=.
  move => A m x.
  destruct (m x); rewrite //=.
Qed.

Definition get {S} : State S S := fun (s : S) => (s, s).
Definition put {S} (s : S) : State S unit := fun (_ : S) => (tt, s).

Canonical stateMonadMixin S := Eval hnf in MonadMixin _ _ _ _ _ _ (state_monadax S).
Canonical stateMonadType S := Eval hnf in MonadType _ _ _ _ (stateMonadMixin S).

Check (fun (c : State _ _) => (x <- c; put x)).

(* finset *)

Lemma finset_monadax : Monad.axiom finType Finite.sort (fun A => {set A}) (fun A => @eq {set A})
                                   (fun (A : finType) (x : A) => set1 x)
                                   (fun A B (x : {set A}) (f : A -> {set B}) =>
                                     \bigcup_(a in x) (f a)).
  constructor; rewrite //=.
  move => A B x f; rewrite big_set1 //=.
  move => A m; apply/setP => x; apply Bool.eq_iff_eq_true; split.
  move/bigcupP; elim => x0 Hx0; rewrite in_set; move/eqP => ->; done.
  move => H; apply/bigcupP; eexists.
  apply H.
  rewrite in_set //=.
  move=>A B C m f g.

  apply/setP => x; apply Bool.eq_iff_eq_true; split.
  move/bigcupP; elim => b /bigcupP => [[i Hi] Hb] Hc.
  apply/bigcupP; eexists.
  apply Hi.
  apply/bigcupP; eexists.
  apply Hb.
  done.

  move/bigcupP; elim => a Ha /bigcupP => [[i Hi] Hb]; apply/bigcupP; eexists.
  apply/bigcupP; eexists.
  apply Ha.
  apply Hi.
  done.
Qed.

Canonical setMonadMixin := Eval hnf in MonadMixin _ _ _ _ _ _ (finset_monadax).
Canonical setMonadType := Eval hnf in MonadType _ _ _ _ (setMonadMixin).

(* fset *)

Lemma fset_monadax : Monad.axiom choiceType Choice.sort (fun A => {fset A}) (fun A => @eq {fset A})
                                   (fun (A : choiceType) (x : A) => fset1 x)
                                   (fun A B (x : {fset A}) (f : A -> {fset B}) =>
                                     \bigcup_(a <- x) (f a))%fset.
  constructor; rewrite //=.
  move => A B x f; rewrite big_seq_fset1 //=.
  move => A m; apply/fsetP => x; apply Bool.eq_iff_eq_true; split.
  move/bigfcupP; elim => x0 Hx0; rewrite in_fset //= in_cons //= in_nil orbF; move/eqP => ->; elim (andP Hx0); done.
  move => H; apply/bigfcupP; eexists.
  apply/andP; split; [apply H | done].
  rewrite in_fset in_cons eq_refl //=.

  move=>A B C m f g.
  apply/fsetP => x; apply Bool.eq_iff_eq_true; split.
  move/bigfcupP; elim => b /andP ; elim => /bigfcupP; elim => a /andP [Ha _] Hb _ Hg.
  apply/bigfcupP; eexists.
  apply/andP; split; [apply Ha | done].
  apply/bigfcupP; eexists.
  apply/andP; split; [apply Hb | done].
  done.

  move/bigfcupP; elim => a /andP [Ha _] /bigfcupP => [[i /andP [Hi _]] Hg].
  apply/bigfcupP; eexists.
  apply/andP; split; [apply/bigfcupP; eexists| done].
  apply/andP; split; [apply Ha | done].
  apply Hi.
  done.
Qed.

Canonical fsetMonadMixin := Eval hnf in MonadMixin _ _ _ _ _ _ (fset_monadax).
Canonical fsetMonadType := Eval hnf in MonadType _ _ _ _ (fsetMonadMixin).


(*

  Copyright 2014 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

*)

Require Export sequents_tacs.
Require Export per_props2.
Require Export subst_tacs.
Require Export per_props_equality.
Require Export sequents_equality.

(* begin hide *)

(* end hide *)

(**

  The following rule is used to prove that [mkc_tequality] terms are
  types (equal types).
<<
   H |- (mkc_tequality T1 T2) = (mkc_tequality U1 U2) in Type(i)

     By tequalityEquality ()

     H |- T1 = U1 in Type(i)
     H |- T2 = U2 in Type(i)
     H |- T1 = T2 in Type(i)
>>
 *)

Definition rule_tequality_equality {o}
           (T1 T2 U1 U2 : @NTerm o)
           (i : nat)
           (H : barehypotheses) :=
  mk_rule
    (mk_bseq
       H
       (mk_conclax (mk_equality
                      (mk_tequality T1 T2)
                      (mk_tequality U1 U2)
                      (mk_uni i))))
    [ mk_bseq H (mk_conclax (mk_equality T1 U1 (mk_uni i))),
      mk_bseq H (mk_conclax (mk_equality T2 U2 (mk_uni i))),
      mk_bseq H (mk_conclax (mk_equality T1 T2 (mk_uni i)))
    ]
    [ ].

Lemma rule_tequality_equality_true {o} :
  forall lib (T1 T2 U1 U2 : NTerm),
  forall i : nat,
  forall H : @barehypotheses o,
    rule_true lib (rule_tequality_equality
                 T1 T2 U1 U2
                 i
                 H).
Proof.
  unfold rule_tequality_equality, 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; rename Hyp1 into hyp2; rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.

  allrw @member_eq.
  allrw <- @member_equality_iff.

  generalize (teq_and_eq_if_equality lib
                (mk_uni i) (mk_tequality T1 T2) (mk_tequality U1 U2) s1 s2 H
                (wf_mk_uni i) w1 w2 c1 c0 c2 c3 cT cT0 eqh sim);
    intro k.
  lsubst_tac.
  apply k; clear k.

  apply tequality_mkc_uni.

  clear dependent s1.
  clear dependent s2.

  introv hf sim.

  vr_seq_true in hyp1.
  vr_seq_true in hyp2.
  vr_seq_true in hyp3.

  generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.
  generalize (hyp3 s1 s2 hf sim); clear hyp3; intro hyp3; exrepnd.
  lsubst_tac.
  proof_irr; GC.

  allrw @member_eq.
  allrw <- @member_equality_iff.
  apply mkc_tequality_equality_in_uni.
  dands; auto.

  apply equality_commutes4 in hyp0; auto.
  apply equality_commutes4 in hyp4; auto.
Qed.

(* begin hide *)

(* end hide *)

(**

This rule says that in an equality, a type can be replaced by an equal
types (this rule could be generalized):

<<
   H |- a = b in T

     By tequalitySubstEqual ()

     H |- (T = U)
     H |- a = b in U
>>

 *)

Definition rule_tequality_subst_equal {o}
           (a b T U : @NTerm o)
           (H : barehypotheses) :=
  mk_rule
    (mk_bseq H  (mk_conclax (mk_equality a b T)))
    [ mk_bseq H (mk_conclax (mk_tequality T U)),
      mk_bseq H (mk_conclax (mk_equality a b U))
    ]
    [ ].

Lemma rule_tequality_subst_equal_true {o} :
  forall lib (a b T U : NTerm),
  forall H : @barehypotheses o,
    rule_true lib (rule_tequality_subst_equal
                 a b T U
                 H).
Proof.
  unfold rule_tequality_subst_equal, 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; rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  exists ce0.

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.

  allrw @member_eq.
  allrw <- @member_equality_iff.

  generalize (teq_and_eq_if_equality
                lib T a b s1 s2 H
                wT w1 w2 c1 c0 c2 c3 cT cT0 eqh sim);
    intro k.
  lsubst_tac.
  apply k; clear k.

  - vr_seq_true in hyp1.
    generalize (hyp1 s1 s2 eqh sim); clear hyp1; intro hyp1; exrepnd.
    lsubst_tac.
    clear hyp1.
    rw @tequality_mkc_tequality in hyp0; repnd; auto.

  - clear dependent s1.
    clear dependent s2.

    introv hf sim.

    vr_seq_true in hyp1.
    vr_seq_true in hyp2.

    generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.
    generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.

    clear hyp1.
    lsubst_tac.
    allrw @member_eq.
    allrw <- @member_equality_iff.
    rw @tequality_mkc_tequality in hyp0; repnd.

    apply equality_commutes4 in hyp3; auto.
    apply tequality_preserving_equality with (A := lsubstc U wT0 s1 cT); auto.
    apply tequality_sym; auto.
Qed.

(* begin hide *)

(* end hide *)

(**

The following rule says that tequality types do not have any
computational content:

<<
   H |- a = b in (T = U)

     By tequalityMember ()

     H |- (T = U)
>>

 *)

Definition rule_tequality_member {o}
           (a b T U : @NTerm o)
           (H : barehypotheses) :=
  mk_rule
    (mk_bseq H  (mk_conclax (mk_equality a b (mk_tequality T U))))
    [ mk_bseq H (mk_conclax (mk_tequality T U))
    ]
    [ ].

Lemma rule_tequality_member_true {o} :
  forall lib (a b T U : NTerm),
  forall H : @barehypotheses o,
    rule_true lib (rule_tequality_member
                 a b T U
                 H).
Proof.
  unfold rule_tequality_member, 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 ce.

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.

  allrw @member_eq.
  allrw <- @member_equality_iff.

  generalize (teq_and_eq_if_equality
                lib (mk_tequality T U) a b s1 s2 H
                wfct0 w1 w2 c1 c0 c2 c3 cT cT0 eqh sim);
    intro k.
  lsubst_tac.
  apply k; clear k.

  - vr_seq_true in hyp1.
    generalize (hyp1 s1 s2 eqh sim); clear hyp1; intro hyp1; exrepnd.
    lsubst_tac.
    clear hyp1; auto.

  - clear dependent s1.
    clear dependent s2.

    introv hf sim.

    vr_seq_true in hyp1.
    generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.

    clear hyp1.
    lsubst_tac.
    rw @tequality_mkc_tequality in hyp0; repnd.
    apply equality_in_mkc_tequality; auto.
Qed.

(* begin hide *)

(* end hide *)

(**

The following rule says that tequality types are well-formed only when
they're true:

<<
   H |- (T = U)

     By tequalityWf ()

     H |- (T = U) is a type
>>

 *)

Definition rule_tequality_type {o}
           (T U : @NTerm o)
           (H : barehypotheses) :=
  mk_rule
    (mk_bseq H (mk_conclax (mk_tequality T U)))
    [ mk_bseq H (mk_concl_t (mk_tequality T U))
    ]
    [ ].

Lemma rule_tequality_type_true {o} :
  forall lib (T U : NTerm),
  forall H : @barehypotheses o,
    rule_true lib (rule_tequality_type
                 T U
                 H).
Proof.
  unfold rule_tequality_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)); GC.

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  vr_seq_true.
  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2 eqh sim); clear hyp1; intro hyp1; exrepnd.
  lsubst_tac.
  clear hyp1.
  allrw @tequality_mkc_tequality; repnd.
  dands; auto.
  apply equality_in_mkc_tequality; auto.
Qed.

(* begin hide *)

(* end hide *)

(**

The following rule says that tequality types are symmetric:

<<
   H |- (T = U)

     By tequalitySym ()

     H |- (U = T)
>>

 *)

Definition rule_tequality_sym {o}
           (T U : @NTerm o)
           (H : barehypotheses) :=
  mk_rule
    (mk_bseq H (mk_conclax (mk_tequality T U)))
    [ mk_bseq H (mk_conclax (mk_tequality U T))
    ]
    [ ].

Lemma rule_tequality_sym_true {o} :
  forall lib (T U : NTerm),
  forall H : @barehypotheses o,
    rule_true lib (rule_tequality_sym
                 T U
                 H).
Proof.
  unfold rule_tequality_sym, 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)); GC.

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  vr_seq_true.
  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2 eqh sim); clear hyp1; intro hyp1; exrepnd.
  lsubst_tac.
  clear hyp1.
  allrw @tequality_mkc_tequality; repnd.
  dands; auto.
  apply tequality_sym; auto.
  apply equality_in_mkc_tequality; auto.
  apply tequality_sym; auto.
Qed.

(* begin hide *)

Lemma tequality_member_uni {o} :
  forall lib A B i,
    @tequality o lib A B
    -> member lib A (mkc_uni i)
    -> member lib B (mkc_uni i)
    -> equality lib A B (mkc_uni i).
Proof.
  introv teq mem1 mem2.
  unfold member, equality in mem1; exrepnd.
  unfold member, equality in mem2; exrepnd.
  unfold tequality in teq; exrepnd.

Abort.

(**

The following rule allows one to weaken [mk_tequality] types to
[mk_equality] types in some universe.

<<
   H |- (T = U) in Type(i)

     By tequalityWeak ()

     H |- T in Type(i)
     H |- U in Type(i)
     H |- (T = U)
>>

 *)

Definition rule_tequality_weak {o}
           (T U : @NTerm o)
           (i : nat)
           (H : barehypotheses) :=
  mk_rule
    (mk_bseq H (mk_conclax (mk_equality T U (mk_uni i))))
    [ mk_bseq H (mk_conclax (mk_member T (mk_uni i))),
      mk_bseq H (mk_conclax (mk_member U (mk_uni i))),
      mk_bseq H (mk_conclax (mk_tequality T U))
    ]
    [ ].

Lemma rule_tequality_weak_true {o} :
  forall lib (T U : NTerm),
  forall i : nat,
  forall H : @barehypotheses o,
    rule_true lib (rule_tequality_weak
                 T U
                 i
                 H).
Proof.
  unfold rule_tequality_weak, 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; rename Hyp1 into hyp2; rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)); GC.

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.
  rw @member_eq.
  allrw <- @member_equality_iff.

  generalize (teq_and_eq_if_equality
                lib (mk_uni i) T U s1 s2 H
                (wf_mk_uni i) w1 w2 c1 c0 c2 c3 cT cT0 eqh sim);
    intro k.
  lsubst_tac.
  apply k; clear k.

  apply tequality_mkc_uni.

  clear dependent s1.
  clear dependent s2.

  introv hf sim.

  vr_seq_true in hyp1.
  vr_seq_true in hyp2.
  vr_seq_true in hyp3.
  generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.
  generalize (hyp3 s1 s2 hf sim); clear hyp3; intro hyp3; exrepnd.

  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_member_iff.
  apply equality_in_mkc_tequality in hyp3.
  rw @tequality_mkc_tequality in hyp5; repnd.

Abort.


Require Export D.

(** **** Exercise: 1 star (override_shadow')  *)
Theorem override_shadow' : forall (X:Type) x1 x2 k1 k2 (f : nat->X),
  (override' (override' f k1 x2) k1 x1) k2 = (override' f k1 x1) k2.
Proof.
 intros. unfold override'. destruct (eq_nat_dec k1 k2) eqn:Heq.
  Case "left". reflexivity.
  Case "right". reflexivity.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU Lesser 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                                                     *)

(** * Equality of sum leaves

- Key definitions: [same_sum_leaves]
- Initial author: Laurent.Thery@inria.fr (2003)

*)

From Coq Require Import Sorting.Permutation.
From Huffman Require Export Cover WeightTree.

Set Default Proof Using "Type".

Section SameSumLeaves.
Variable A : Type.
Variable f : A -> nat.

(** the sum leaves are the same upto permutation *)
Definition same_sum_leaves (l1 l2 : list (btree A)) : Prop :=
  exists l3 : list (btree A),
    (exists l4 : list (btree A),
       Permutation l1 l3 /\
       Permutation l2 l4 /\
       map (sum_leaves f) l3 = map (sum_leaves f) l4).

(** if the sum leaves are the same, the list are of same length *)
Theorem same_sum_leaves_length :
 forall l1 l2 : list (btree A),
 same_sum_leaves l1 l2 -> length l1 = length l2.
Proof.
intros l1 l2 (l3, (l4, (H0, (H1, H2)))).
rewrite (Permutation_length H0).
rewrite (Permutation_length H1).
repeat rewrite <- (map_length (sum_leaves f)); auto.
apply f_equal with (f := length (A:=nat)); auto.
Qed.

End SameSumLeaves.

Arguments same_sum_leaves [A].


(** Formal power series *)
(******************************************************************************)
(*       Copyright (C) 2019 Florent Hivert <florent.hivert@lri.fr>            *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice.
From mathcomp Require Import fintype div tuple finfun bigop finset fingroup.
From mathcomp Require Import perm ssralg poly polydiv mxpoly binomial bigop.
From mathcomp Require Import finalg zmodp matrix mxalgebra polyXY ring_quotient.
From mathcomp Require Import generic_quotient.
From mathcomp Require Import order.

Require Import natbar invlim.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.Def.
Import Order.Syntax.
Import Order.Theory.

Require Import auxresults tfps invlim.

Reserved Notation "{ 'series' R }"
         (at level 0, R at level 2, format "{ 'series'  R }").
Reserved Notation "c %:S" (at level 2, format "c %:S").
Reserved Notation "\series E .X^ i"
  (at level 36, E at level 36, i at level 50, format "\series  E  .X^ i").
Reserved Notation "''X" (at level 0).
Reserved Notation "'''X^' n" (at level 3, n at level 2, format "'''X^' n").
Reserved Notation "a ^`` ()" (at level 8, format "a ^`` ()").
Reserved Notation "s ``_ i" (at level 3, i at level 2, left associativity,
                            format "s ``_ i").

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory.
Local Open Scope ring_scope.

Section Defs.

Variable R : ringType.

Definition fps_bond := fun (i j : nat) of (i <= j)%O => @trXnt R j i.

Section Canonical.

Variables (i j : nat) (H : (i <= j)%O).
Lemma bond_is_rmorphism : rmorphism (fps_bond H).
Proof. by split; [exact: trXnt_is_linear | exact: trXnt_is_multiplicative]. Qed.
Canonical bond_additive := Additive bond_is_rmorphism.
Canonical bond_rmorphism := RMorphism bond_is_rmorphism.

Lemma bond_is_linear : linear (fps_bond H).
Proof. exact: trXnt_is_linear. Qed.
Canonical bond_linear := AddLinear bond_is_linear.
Canonical bond_lrmorphism := [lrmorphism of (fps_bond H)].

End Canonical.

Program Definition fps_invsys :=
  InvSys (bonding := fun i j (H : (i <= j)%O) => [lrmorphism of fps_bond H])
         0%N _ _.
Next Obligation. exact: trXnt_id. Qed.
Next Obligation. by move=> f; apply: trXnt_trXnt. Qed.

Definition fpseries_of of phant R := {invlim fps_invsys}.
Identity Coercion type_fpseries_of : fpseries_of >-> invlim_of.
Canonical fpseries_invLimType := [invLimType of fpseries_of (Phant R)].

Definition coef_series_def (s : fpseries_of (Phant R)) i := (s i)`_i.
Fact coef_series_key : unit. Proof. by []. Qed.
Definition coef_series := locked_with coef_series_key coef_series_def.
Canonical coef_series_unlockable := [unlockable fun coef_series].
Definition coefps_head h i (s : fpseries_of (Phant R)) :=
  let: tt := h in coef_series s i.

End Defs.

(* We need to break off the section here to let the argument scope *)
(* directives take effect.                                         *)
Bind Scope ring_scope with fpseries_of.

Arguments coefps_head {R} h i%N s%R.
Arguments coef_series {R} s%R i%N.

Notation "{ 'series' T }" := (fpseries_of (Phant T)).
Notation coefs := (coefps_head tt).
Notation "s ``_ i" := (coef_series s i).

Section CoeffSeries.

Variable R : ringType.

Implicit Types (a b c: R) (s t u : {series R}) (p q : {poly R}) (i j : nat).

Lemma coefs_piE i s : s``_i = ('pi_i s)`_i.
Proof. by rewrite unlock. Qed.

Lemma coefs_pi_leqE i j : (i <= j)%N -> forall s, s``_i = ('pi_j s)`_i.
Proof.
rewrite -leEnat => H s.
by rewrite coefs_piE -(ilprojE s H) /fps_bond coef_trXn leqnn.
Qed.

Lemma coefsE i s : coefs i s = s``_i.
Proof. by []. Qed.

Lemma coefs0 i : (0 : {series R })``_i = 0.
Proof. by rewrite coefs_piE raddf0 coef0. Qed.

Lemma coefs1 i : (1 : {series R })``_i = (i == 0%N)%:R.
Proof. by rewrite coefs_piE rmorph1 coef1. Qed.

Lemma seriesP s t : (forall n, s``_n = t``_n) <-> (s = t).
Proof.
split => [Hco|-> //]; apply/invlimP => /= i.
apply/tfpsP => j le_ji.
by rewrite -!(coefs_pi_leqE le_ji) Hco.
Qed.

Lemma coefs_is_additive i : additive (@coefps_head R tt i).
Proof. by move=> s t; rewrite !coefsE !coefs_piE !raddfB coefB. Qed.
Canonical coefs_additive i : {additive {series R} -> R} :=
  Additive (coefs_is_additive i).

Lemma coefsD s t i : (s + t)``_i = s``_i + t``_i.
Proof. exact: (raddfD (coefs_additive i)). Qed.
Lemma coefsN s i : (- s)``_i = - (s``_i).
Proof. exact: (raddfN (coefs_additive i)). Qed.
Lemma coefsB s t i : (s - t)``_i = s``_i - t``_i.
Proof. exact: (raddfB (coefs_additive i)). Qed.
Lemma coefsMn s n i : (s *+ n)``_i = (s``_i) *+ n.
Proof. exact: (raddfMn (coefs_additive i)). Qed.
Lemma coefsMNn s n i : (s *- n)``_i = (s``_i) *- n.
Proof. by rewrite coefsN coefsMn. Qed.
Lemma coefs_sum I (r : seq I) (s : pred I) (F : I -> {series R}) k :
  (\sum_(i <- r | s i) F i)``_k = \sum_(i <- r | s i) (F i)``_k.
Proof. exact: (raddf_sum (coefs_additive k)). Qed.

Lemma isthreadC c : isthread (fps_invsys R) (fun i => c%:S%tfps).
Proof. by move=> i j Hij; rewrite /fps_bond /= trXntC. Qed.
(* Definition seriesC c : {series R} := InvLim (isthreadC c). *)
Definition seriesC c : {series R} := ilthr (isthreadC c).
Local Notation "c %:S" := (seriesC c).

Lemma coefsC c i : c%:S``_i = (if i == 0%N then c else 0).
Proof. by rewrite coefs_piE invLimP coef_tfpsC. Qed.

Lemma series0E : 0%:S = 0.
Proof. by apply/seriesP => i; rewrite coefs0 coefsC; case eqP. Qed.
Lemma series1E : 1%:S = 1.
Proof. by apply/seriesP => i; rewrite coefs1 coefsC; case eqP. Qed.

Lemma seriesC_eq0 (c : R) : (c%:S == 0) = (c == 0).
Proof.
apply/eqP/eqP => [/(congr1 (coefs 0%N))|->]; last exact: series0E.
by rewrite /= coefs0 coefsC.
Qed.

Lemma seriesCB : {morph seriesC : a b / a + b}.
Proof.
by move=> a b; apply/seriesP=>[[|i]]; rewrite coefsD !coefsC ?addr0. Qed.
Lemma seriesCN : {morph seriesC : c / - c}.
Proof. by move=> c; apply/seriesP=> [[|i]]; rewrite coefsN !coefsC ?oppr0. Qed.
Lemma seriesCD : {morph seriesC : a b / a - b}.
Proof. by move=> a b; rewrite seriesCB seriesCN. Qed.

Canonical seriesC_additive := Additive seriesCD.

Lemma seriesCMn n : {morph seriesC : c / c *+ n}.
Proof. exact: raddfMn. Qed.
Lemma seriesCMNn n : {morph seriesC : c / c *- n}.
Proof. exact: raddfMNn. Qed.
Lemma seriesC_sum I (r : seq I) (s : pred I) (F : I -> R) :
  (\sum_(i <- r | s i) F i)%:S = \sum_(i <- r | s i) (F i)%:S.
Proof. exact: raddf_sum. Qed.

Lemma isthread_poly (p : {poly R}) :
  isthread (fps_invsys R) (fun n => trXn n p).
Proof. by move=> i j Hij; rewrite /fps_bond /trXnt /= trXn_trXn. Qed.
Definition series_poly (p : {poly R}) : {series R} := ilthr (isthread_poly p).

Lemma coefs_series_poly p i : (series_poly p)``_i = p`_i.
Proof. by rewrite coefs_piE invLimP coef_trXn leqnn. Qed.

Lemma series_polyK n p :
  (n >= size p)%N -> tfps ('pi_n (series_poly p)) = p.
Proof.
move=> Hn; apply/polyP => i; case: (leqP i n) => [le_in|lt_ni].
- by rewrite -[LHS](coefs_pi_leqE le_in) coefs_series_poly.
- by rewrite coef_tfps leqNgt lt_ni [RHS]nth_default ?(leq_trans Hn (ltnW _)).
Qed.

Lemma series_poly_inj : injective series_poly.
Proof.
move=> p q /(congr1 ('pi_(maxn (size p) (size q))))/(congr1 tfps).
by rewrite !series_polyK ?leq_maxr ?leq_maxl.
Qed.

Fact series_poly_is_additive : additive series_poly.
Proof.
move=> p q; apply/seriesP => n.
by rewrite coefsB !coefs_piE !invLimP raddfB /= coeftB /=.
Qed.
Canonical series_poly_additive := Additive series_poly_is_additive.

Lemma series_polyD p q : series_poly (p + q) = series_poly p + series_poly q.
Proof. exact: raddfD. Qed.
Lemma series_polyN p : series_poly (- p) = - series_poly p.
Proof. exact: raddfN. Qed.
Lemma series_polyB p q : series_poly (p - q) = series_poly p - series_poly q.
Proof. exact: raddfB. Qed.
Lemma series_polyMn p n : series_poly (p *+ n) = (series_poly p) *+ n.
Proof. exact: raddfMn. Qed.
Lemma series_polyMNn p n : series_poly (p *- n) = (series_poly p) *- n.
Proof. exact: raddfMNn. Qed.
Lemma series_poly_sum I (r : seq I) (s : pred I) (F : I -> {poly R}) :
  series_poly (\sum_(i <- r | s i) F i) = \sum_(i <- r | s i) series_poly (F i).
Proof. exact: raddf_sum. Qed.

Lemma poly_series_eqP s t :
  (forall n, 'pi_n s = 'pi_n t) <-> (s = t).
Proof. by split => [|-> //]; apply: invlimP. Qed.

Lemma poly_seriesC n c : tfps ('pi_n c%:S) = c%:P :> {poly R}.
Proof. by apply/polyP => i; rewrite invLimP coef_tfpsC coefC. Qed.

Lemma series_polyC c : series_poly c%:P = c%:S.
Proof. by apply/seriesP => n; rewrite coefs_series_poly coefC coefsC. Qed.

Lemma isthread_from_fun (f : nat -> R) :
  isthread (fps_invsys R) (fun n => [tfps i <= n => f i ]%tfps).
Proof.
Proof.
move=> i j le_ij; rewrite /fps_bond /trXnt.
apply/tfpsP => k le_ki.
by rewrite coef_trXn !coef_tfps_of_fun le_ki (leq_trans le_ki le_ij).
Qed.
Definition series_from_fun f : {series R} := MkInvLim (isthread_from_fun f).

Local Notation "\series E .X^ i" := (series_from_fun (fun i : nat => E)).

Lemma coefs_series E j : (\series E i .X^i)``_j = E j.
Proof. by rewrite /series_from_fun unlock /= coef_poly ltnSn. Qed.

Fact coefsM s t i : (s * t)``_i = \sum_(j < i.+1) s``_j * t``_(i - j).
Proof.
rewrite coefs_piE invLimP /= coefM_tfps leqnn.
apply eq_bigr => [[j]] /=; rewrite ltnS => le_ji _.
by rewrite -!coefs_pi_leqE ?leq_subr.
Qed.
Lemma coefsMr s t n : (s * t)``_n = \sum_(j < n.+1) s``_(n - j) * t``_j.
Proof.
rewrite coefs_piE invLimP /= coefMr_tfps leqnn.
apply eq_bigr => [[j]] /=; rewrite ltnS => le_ji _.
by rewrite -?coefs_pi_leqE ?leq_subr.
Qed.

Fact coefs0_multiplicative : multiplicative (coefs 0 : {series R} -> R).
Proof.
split=> [s t|] /=; last by rewrite coefs1.
by rewrite coefsM big_ord_recl big_ord0 addr0 /= subnn.
Qed.
Canonical coefs0_rmorphism := AddRMorphism coefs0_multiplicative.

Fact series_poly_is_rmorphism : rmorphism series_poly.
Proof.
split; first exact: series_poly_is_additive.
split=> [p q|]; apply/seriesP=> i; first last.
  by rewrite !coefs_piE !invLimP /= trXn1.
rewrite coefs_series_poly coefM coefsM; apply: eq_bigr => j _.
by rewrite !coefs_series_poly.
Qed.
Canonical series_poly_rmorphism := RMorphism series_poly_is_rmorphism.

Lemma series_polyX n : {morph series_poly : p / p ^+ n}.
Proof. exact: rmorphX. Qed.
Lemma series_poly1 : series_poly 1 = 1.
Proof. exact: rmorph1. Qed.
Lemma series_polyM : {morph series_poly : x y  / x * y}.
Proof. exact: rmorphM. Qed.

Lemma mul_seriesC a s : a%:S * s = a *: s.
Proof.
apply/poly_series_eqP => i.
by rewrite linearZ /= !invLimP -alg_tfpsC mulr_algl.
Qed.

Lemma coefsZ a s i : (a *: s)``_i = a * s``_i.
Proof. by rewrite !coefs_piE linearZ coefZ. Qed.

Lemma alg_seriesC a : a%:A = a%:S :> {series R}.
Proof. by rewrite -mul_seriesC mulr1. Qed.

Canonical coefps_linear i : {scalar {series R}} :=
  AddLinear ((fun a => (coefsZ a) ^~ i) : scalable_for *%R (coefs i)).
Canonical coefp0_lrmorphism := [lrmorphism of coefs 0].

Fact series_poly_is_scalable : scalable series_poly.
Proof.
move=> c p; apply/seriesP => n.
by rewrite coefsZ !coefs_series_poly coefZ.
Qed.
Canonical series_poly_linear := AddLinear series_poly_is_scalable.
Canonical series_poly_lrmorphism := [lrmorphism of series_poly].

Local Notation "''X" := (locked (@series_poly 'X)).
Local Notation "'''X^' n" := (''X ^+ n).

Lemma seriesXE n : 'pi_n ''X = (\X)%tfps.
Proof. by rewrite -lock invLimP. Qed.
Lemma seriesXnE n i : 'pi_n ''X^i = (\X)%tfps^+i.
Proof. by rewrite !rmorphX /= seriesXE. Qed.
Lemma coefsX i : (''X ``_i) = (i == 1%N)%:R :> R.
Proof. by rewrite -lock coefs_series_poly coefX. Qed.
Lemma coefsXn n i : (''X^n ``_i) = (i == n)%:R :> R.
Proof. by rewrite -lock -rmorphX /= coefs_series_poly coefXn. Qed.

Lemma seriesX_eq0 : (''X == 0 :> {series R}) = false.
Proof.
apply/negP => /eqP/seriesP/(_ 1%N)/eqP.
by rewrite coefsX coefs0 /= oner_eq0.
Qed.

Lemma commr_seriesX s : GRing.comm s ''X.
Proof.
apply/seriesP=> i; rewrite coefsMr coefsM.
by apply: eq_bigr => j _; rewrite coefsX commr_nat.
Qed.

Lemma commr_seriesXn n s : GRing.comm s ''X^n.
Proof. exact/commrX/commr_seriesX. Qed.

End CoeffSeries.

Coercion series_poly : poly_of >-> fpseries_of.

Arguments seriesC {R}.
Arguments series_poly {R}.
Notation "c %:S" := (seriesC c).
Notation "\series E .X^ i" := (series_from_fun _ (fun i : nat => E)).


Set Universe Polymorphism.
Set Printing Universes.
Unset Universe Minimization ToSet.

Definition foo : Type := nat.
About foo.
(* foo@{Top.1} : Type@{Top.1}*)
(* Top.1 |=  *)

Definition bar : foo -> nat.
Admitted.
About bar.
(* bar@{Top.2} : foo@{Top.2} -> nat *)
(* Top.2 |=  *)

Lemma baz@{i} : foo@{i} -> nat.
Proof.
  exact bar.
Defined.

Definition bar'@{i} : foo@{i} -> nat.
  intros f. exact 0.
Admitted.
About bar'.
(* bar'@{i} : foo@{i} -> nat *)
(* i |=  *)

Axiom f@{i} : Type@{i}.
(*
*** [ f@{i} : Type@{i} ]
(* i |=  *)
*)


Require Import List paco2.
Require Import Util IL.
Require Export SmallStepRelations StateType Sim.
Require Import Terminating.
Require Import NonParametricBiSim.

Set Implicit Arguments.
Unset Printing Records.

CoInductive indexBisim X R `{Terminating X R}
            {S} `{StateType S} {S'} `{StateType S'}  : X -> S -> S' -> Prop :=
  | IndexBisimSilent x (σ1 σ1':S) (σ2 σ2':S') :
      plus2 step σ1 nil σ1'
      -> plus2 step σ2 nil σ2'
      -> indexBisim x σ1' σ2'
      -> indexBisim x σ1 σ2
  | IndexBisimExtern x (pσ1 σ1:S) (pσ2 σ2:S') :
      star2 step pσ1 nil σ1
      -> star2 step pσ2 nil σ2
      -> activated σ1
      -> activated σ2
      -> (forall evt σ1', step σ1 evt σ1' -> exists σ2', step σ2 evt σ2' /\ indexBisim x σ1' σ2')
      -> (forall evt σ2', step σ2 evt σ2' -> exists σ1', step σ1 evt σ1' /\ indexBisim x σ1' σ2')
      -> indexBisim x pσ1 pσ2
  | IndexBisimTerm x (σ1 σ1':S) (σ2 σ2':S')
    : result σ1' = result σ2'
      -> star2 step σ1 nil σ1'
      -> star2 step σ2 nil σ2'
      -> normal2 step σ1'
      -> normal2 step σ2'
      -> indexBisim x σ1 σ2
  | IndexBisimStutter x y (σ1 σ1':S) (σ2 σ2':S')
    : R x y
      -> star2 step σ1 nil σ1'
      -> star2 step σ2 nil σ2'
      -> indexBisim y σ1' σ2'
      -> indexBisim x σ1 σ2.

Arguments indexBisim [X] [R] {H} [S] {H0} [S'] {H1} _ _ _.

(** *** Bisimulation is an reflexive and symmetric *)
Lemma bisim_refl {S} `{StateType S} (σ:S) X R `{Terminating X R} (x:X)
      : indexBisim x σ σ.
Proof.
  revert σ. cofix.
  intros. destruct (step_dec σ) as [[[] []]|].
  - eapply IndexBisimExtern; intros; eauto using star2_refl; eexists; eauto.
  - eapply IndexBisimSilent; eauto using plus2O.
  - eapply IndexBisimTerm; eauto using star2_refl.
Qed.

Lemma bisim_sym {S} `{StateType S} {S'} `{StateType S'} (σ:S) (σ':S')
      : bisim σ σ' -> bisim σ' σ.
Proof.
  revert σ σ'. cofix; intros.
  inv H1.
  - eapply BisimSilent; eauto.
  - eapply BisimExtern; eauto; intros.
    edestruct H7; eauto; dcr. eexists; eauto.
    edestruct H6; eauto; dcr. eexists; eauto.
  - eapply BisimTerm; eauto using star2_refl.
Qed.

(** ** Relationship of bisimulation to the parametric definition *)

Lemma bisim_indexBisim {S} `{StateType S} {S'} `{StateType S'} X R `{Terminating X R} x
  : forall (σ:S) (σ':S'), bisim σ σ' -> indexBisim x σ σ'.
Proof.
  cofix CIH; intros. invt bisim.
  - econstructor 1; eauto.
  - econstructor 2; eauto.
    + intros. edestruct H7; eauto; dcr; eauto.
    + intros. edestruct H8; eauto; dcr; eauto.
  - econstructor 3; eauto.
Qed.

Lemma indexBisim_inv {S} `{StateType S} {S'} `{StateType S'} X R `{Terminating X R}
      x (σ1:S) (σ2:S')
  : indexBisim x σ1 σ2
    -> (exists x σ1' σ2',
          plus2 step σ1 nil σ1' /\
          plus2 step σ2 nil σ2' /\
          indexBisim x σ1' σ2')
      \/ (exists x σ1' σ2',
            star2 step σ1 nil σ1' /\
            star2 step σ2 nil σ2' /\
            activated σ1' /\
            activated σ2' /\
            (forall evt σ1'', step σ1' evt σ1'' ->
                         exists σ2'', step σ2' evt σ2'' /\ indexBisim x σ1'' σ2'') /\
            (forall evt σ2'', step σ2' evt σ2'' ->
                         exists σ1'', step σ1' evt σ1'' /\ indexBisim x σ1'' σ2''))
      \/ (exists σ1' σ2',
            star2 step σ1 nil σ1' /\
            star2 step σ2 nil σ2' /\
            result σ1' = result σ2' /\
            normal2 step σ1' /\
            normal2 step σ2').
Proof.
  intros.
  pose proof (H1 x). general induction H3.
  inv H4; eauto 20.
  edestruct H0 as [? | [? | ?]]; eauto; dcr.
  - left. eexists x0, x1, x2.
    eauto using star2_plus2_plus2_silent.
  - right; left.
    eexists x0, x1, x2;
      repeat split; eauto using star2_trans_silent.
  - right; right.
    eexists x0, x1;
      repeat split; eauto using star2_trans_silent.
Qed.

Lemma indexBisim_bisim {S} `{StateType S} {S'} `{StateType S'} X R `{Terminating X R} x
  : forall (σ:S) (σ':S'), indexBisim x σ σ' -> bisim σ σ'.
Proof.
  revert x. cofix CIH; intros.
  eapply indexBisim_inv in H2.
  destruct H2 as [|[|]]; dcr.
  - econstructor 1; eauto.
  - econstructor 2; eauto.
    + intros. edestruct H7; eauto; dcr; eauto.
    + intros. edestruct H9; eauto; dcr; eauto.
  - econstructor 3; eauto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D M : Universe, ((wd_ B D /\ (wd_ A C /\ (wd_ M C /\ (wd_ M B /\ (wd_ M D /\ (wd_ A M /\ (col_ A B C /\ (col_ A M C /\ col_ B M D)))))))) -> col_ C D A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e383m421_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


(*

  Copyright 2014 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

*)

Require Export per_props.
Require Export subst_per.
Require Export sequents_tacs.
Require Import cequiv_tacs.
Require Import subst_tacs.

(*
Lemma tequality_mkc_erase :
  forall a b,
    tequality (mkc_erase a) (mkc_erase b)
    <=> tequality a b.
Proof.
  introv.
  repeat (rw mkc_erase_eq).
  rw tequality_mkc_ufun; split; sp.
  apply type_mkc_unit.
Qed.
*)

Lemma apply2_erasec_rel {o} :
  forall lib (A x y : @CTerm o),
    cequivc lib (mkc_apply2 (erasec_rel A) x y) A.
Proof.
  introv.
  destruct_cterms.
  unfold cequivc; simpl.
  unfold erase_rel.
  remember (newvars2 [x1]); sp.
  betared.
  apply newvars2_prop2 in Heqp; repnd.
  rw @subst_mk_lam; auto.
  repeat (rw subst_trivial; eauto with isprog).
  betared.
  repeat (rw @subst_trivial; eauto with isprog).
  apply cequiv_refl.
  apply isprog_implies; auto.
Qed.

Lemma forall_apply_erase_rel {o} :
  forall lib (A : @CTerm o),
    (forall x y : CTerm, type lib (mkc_apply2 (erasec_rel A) x y))
    <=> type lib A.
Proof.
  introv; split; intro k; introv.

  generalize (k mkc_axiom mkc_axiom); clear k; intro k.
  generalize (apply2_erasec_rel lib A mkc_axiom mkc_axiom); intro j.
  apply type_respects_cequivc_left in j; auto.
  apply tequality_refl in j; rw @fold_type in j; auto.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply cequivc_sym in j.
  apply type_respects_cequivc_left in j; auto.
  apply tequality_refl in j; auto.
Qed.

Lemma is_per_type_erasec_rel {o} :
  forall lib (A : @CTerm o), is_per_type lib (erasec_rel A).
Proof.
  introv.
  unfold is_per_type; dands.

  unfold sym_type; introv inh.
  generalize (apply2_erasec_rel lib A x y); intro j1.
  generalize (apply2_erasec_rel lib A y x); intro j2.
  apply inhabited_type_cequivc in j1; auto.
  apply inhabited_type_cequivc with (a := A);
    auto; try (apply cequivc_sym; auto).

  unfold trans_type.
  introv inh1 inh2.
  generalize (apply2_erasec_rel lib A x y); intro j1.
  generalize (apply2_erasec_rel lib A y z); intro j2.
  generalize (apply2_erasec_rel lib A x z); intro j3.
  apply inhabited_type_cequivc in j1; auto.
  apply inhabited_type_cequivc in j2; auto.
  apply inhabited_type_cequivc with (a := A);
    auto; try (apply cequivc_sym; auto).
Qed.
Hint Immediate is_per_type_erasec_rel.

Lemma is_per_type_erasec_rel_iff {o} :
  forall lib (A : @CTerm o), is_per_type lib (erasec_rel A) <=> True.
Proof.
  introv; split; sp.
Qed.

Lemma inhabited_type_apply2_erasec_rel {o} :
  forall lib (A x y : @CTerm o),
    inhabited_type lib (mkc_apply2 (erasec_rel A) x y)
    <=> inhabited_type lib A.
Proof.
  introv; split; intro k.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply inhabited_type_cequivc in j; auto.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply inhabited_type_cequivc with (a := A);
    auto; try (apply cequivc_sym; auto).
Qed.

Lemma inhabited_type_apply2_erasec_rel_iff {o} :
  forall lib (A B : @CTerm o),
    (forall x y : CTerm,
       inhabited_type lib (mkc_apply2 (erasec_rel A) x y)
       <=>
       inhabited_type lib (mkc_apply2 (erasec_rel B) x y))
    <=>
    (inhabited_type lib A <=> inhabited_type lib B).
Proof.
  introv.
  split; intro k.

  generalize (k mkc_axiom mkc_axiom).
  repeat (rw @inhabited_type_apply2_erasec_rel); auto.

  introv.
  repeat (rw @inhabited_type_apply2_erasec_rel); auto.
Qed.

Lemma tequality_erase {o} :
  forall lib (A B : @CTerm o),
    tequality lib (erasec A) (erasec B)
    <=> ((inhabited_type lib A <=> inhabited_type lib B)
         # type lib A
         # type lib B).
Proof.
  introv.
  allrw @erasec_eq.
  rw @tequality_mkc_pertype.
  repeat (rw @forall_apply_erase_rel).
  rw @is_per_type_erasec_rel_iff.
  rw @inhabited_type_apply2_erasec_rel_iff.
  split; sp.
Qed.

Lemma type_erase {o} :
  forall lib (A : @CTerm o), type lib (erasec A) <=> type lib A.
Proof.
  introv.
  rw @tequality_erase; split; sp.
Qed.

Lemma inhabited_type_respects_alphaeqc {o} :
  forall lib, respects1 alphaeqc (@inhabited_type o lib).
Proof.
  introv aeq inh.
  apply (alphaeqc_implies_cequivc lib) in aeq.
  apply @inhabited_type_cequivc with (a := a); auto.
Qed.
Hint Resolve inhabited_type_respects_alphaeqc : respects.

Lemma type_respects_cequivc {o} :
  forall lib, respects1 (cequivc lib) (@type o lib).
Proof.
  introv ceq typ.
  apply type_respects_cequivc_left in ceq; auto.
  apply tequality_refl in ceq; auto.
Qed.
Hint Resolve type_respects_cequivc : respects.

Lemma type_respects_alphaeqc {o} :
  forall lib, respects1 alphaeqc (@type o lib).
Proof.
  introv aeq inh.
  apply (alphaeqc_implies_cequivc lib) in aeq.
  apply type_respects_cequivc_left in aeq; auto.
  apply tequality_refl in aeq; auto.
Qed.
Hint Resolve type_respects_alphaeqc : respects.

Lemma type_apply2_erasec_rel {o} :
  forall lib (A x y : @CTerm o),
    type lib (mkc_apply2 (erasec_rel A) x y)
    <=> type lib A.
Proof.
  introv; split; intro k.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply type_respects_cequivc_left in j; auto.
  apply tequality_refl in j; auto.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply cequivc_sym in j.
  apply type_respects_cequivc_left in j; auto.
  apply tequality_refl in j; auto.
Qed.

Lemma equality_in_erasec {o} :
  forall lib (t1 t2 t : @CTerm o),
    equality lib t1 t2 (erasec t) <=> inhabited_type lib t.
Proof.
  introv; split; intro k; allunfold @inhabited_type; exrepnd;
  allrw @erasec_eq; allrw @equality_in_mkc_pertype; repnd;
  allrw @inhabited_type_apply2_erasec_rel; auto.

  dands; auto.
  exists t0; auto.
  introv.
  apply type_apply2_erasec_rel.
  apply inhabited_implies_tequality in k0; auto.
Qed.

Lemma inhabited_type_erasec {o} :
  forall lib (t : @CTerm o), inhabited_type lib (erasec t) <=> inhabited_type lib t.
Proof.
  introv; split; intro k; allunfold @inhabited_type; exrepnd.

  rw @equality_in_erasec in k0; allunfold @inhabited_type; exrepnd.
  exists t1; auto.

  exists (@mkc_axiom o).
  rw @equality_in_erasec.
  exists t0; auto.
Qed.

Lemma member_in_base_iff {o} :
  forall lib (t : @CTerm o), member lib t mkc_base <=> True.
Proof.
  intros; split; intro; auto; apply member_base.
Qed.

Lemma equality_in_isect2 {o} :
  forall lib (t u : @CTerm o) A v B,
    equality lib t u (mkc_isect A v B)
    <=>
    (type lib A
     # forall a a',
         equality lib a a' A
         -> (equality lib t u (substc a v B) # tequality lib (substc a v B) (substc a' v B))).
Proof.
  sp; rw @equality_in_isect; split; sp; discover; sp.
Qed.

Lemma member_in_isect {o} :
  forall lib (t : @CTerm o) A v B,
    member lib t (mkc_isect A v B)
    <=>
    (type lib A
     # forall a a',
         equality lib a a' A
         -> (member lib t (substc a v B) # tequality lib (substc a v B) (substc a' v B))).
Proof.
  sp; rw @equality_in_isect; split; sp; discover; sp.
Qed.

Lemma is_per_type_sqper_rel_change_subst {o} :
  forall lib v1 v2 R s1 s2 w c1 c2,
    (forall x y : @CTerm o,
       inhabited_type lib (mkc_apply2 (lsubstc (sqper_rel v1 v2 R) w s1 c1) x y)
       <=>
       inhabited_type lib (mkc_apply2 (lsubstc (sqper_rel v1 v2 R) w s2 c2) x y))
    -> is_per_type lib (lsubstc (sqper_rel v1 v2 R) w s1 c1)
    -> is_per_type lib (lsubstc (sqper_rel v1 v2 R) w s2 c2).
Proof.
  introv iff isper.
  allunfold @is_per_type.
  destruct isper as [sym trans].
  allunfold @sqper_rel; lsubst_tac.
  dands.

  - clear trans.
    allunfold @sym_type; introv inh.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec.
    generalize (sym x y); clear sym; intro sym.
    autodimp sym hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec.
    generalize (iff x y); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i1.
    autodimp i2 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (iff y x); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i2.
    autodimp i1 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.

  - clear sym.
    allunfold @trans_type; introv inh1 inh2.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (trans x y z); clear trans; intro trans.

    autodimp trans hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (iff x y); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i1.
    autodimp i2 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.

    autodimp trans hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (iff y z); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i1.
    autodimp i2 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.

    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (iff x z); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i2.
    autodimp i1 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
Qed.

Lemma tequality_iff_mkc_tequality {o} :
  forall lib (A B : @CTerm o),
    type lib (mkc_tequality A B) <=> tequality lib A B.
Proof.
  introv.
  split; intro k.

  - unfold type, tequality in k; exrepnd.
    inversion k0; subst; try not_univ.
    allunfold_per; computes_to_value_isvalue; allfold (@nuprl o).
    exists eqa; auto.

  - unfold tequality in k; exrepnd.
    exists (@true_per o).
    apply CL_teq; unfold per_teq.
    fold (@nuprl o).
    exists A B A B eq; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply nuprl_refl in k0; auto.
    apply nuprl_sym in k0; apply nuprl_refl in k0; auto.
Qed.

Lemma tequality_mkc_tequality {o} :
  forall lib (A B C D : @CTerm o),
    tequality lib (mkc_tequality A B) (mkc_tequality C D)
    <=> (tequality lib A C # tequality lib B D # tequality lib A B).
Proof.
  introv.
  split; intro k.

  - unfold tequality in k; exrepnd.
    inversion k0; subst; try not_univ.
    allunfold_per; computes_to_value_isvalue; allfold (@nuprl o).
    dands; exists eqa; auto.

  - unfold tequality in k; exrepnd.
    exists (@true_per o).
    apply CL_teq; unfold per_teq.
    fold (@nuprl o).

    assert (eq1 <=2=> eq)
      as eqs1
        by (apply nuprl_refl in k1; apply nuprl_refl in k2;
            generalize (nuprl_uniquely_valued lib A eq1 eq); intro k;
            repeat (autodimp k hyp)).

    assert (eq0 <=2=> eq)
      as eqs2
        by (apply nuprl_sym in k2; apply nuprl_refl in k3; apply nuprl_refl in k2;
            generalize (nuprl_uniquely_valued lib B eq0 eq); intro k;
            repeat (autodimp k hyp)).

    exists A B C D eq; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply @nuprl_ext with (eq1 := eq1); auto.
    apply @nuprl_ext with (eq1 := eq0); auto.
Qed.

Lemma mkc_tequality_equality_in_uni {o} :
  forall lib (A B C D : @CTerm o) i,
    tequalityi lib i (mkc_tequality A B) (mkc_tequality C D)
    <=> (tequalityi lib i A C # tequalityi lib i B D # tequalityi lib i A B).
Proof.
  introv.
  split; intro k.

  - unfold tequalityi, equality in k; exrepnd.
    inversion k1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    inversion h2; subst; try not_univ.
    allunfold_per; computes_to_value_isvalue; allfold (@nuprl o).
    dands; exists eq; sp; allrw; exists eqa0; auto.

  - unfold tequalityi, equality in k; exrepnd.
    generalize (nuprl_uniquely_valued lib (mkc_uni i) eq0 eq k1 k3); intro eqs1.
    generalize (nuprl_uniquely_valued lib (mkc_uni i) eq1 eq k0 k3); intro eqs2.
    clear k0 k1.
    rw eqs1 in k4; clear eqs1.
    rw eqs2 in k5; clear eqs2.
    exists eq; dands; auto.
    inversion k3; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    fold (@nuprli o lib j0) in h2, h3, h4.
    rw h0; exists (@true_per o).
    dup h2 as na1; apply nuprli_refl in na1.
    dup h4 as na2; apply nuprli_refl in na2.
    generalize (nuprli_uniquely_valued lib j0 j0 A A eqa1 eqa na1 na2); clear na1 na2; intro eqs1.
    dup h3 as nb1; apply nuprli_refl in nb1.
    dup h4 as nb2; apply nuprli_sym in nb2; apply nuprli_refl in nb2.
    generalize (nuprli_uniquely_valued lib j0 j0 B B eqa0 eqa nb1 nb2); clear nb1 nb2; intro eqs2.
    apply CL_teq; fold (@nuprli o lib j0).
    exists A B C D eqa; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply nuprli_ext with (eq1 := eqa1); auto.
    apply nuprli_ext with (eq1 := eqa0); auto.
Qed.

Lemma equality_in_mkc_tequality {o} :
  forall lib (a b A B : @CTerm o),
    equality lib a b (mkc_tequality A B) <=> tequality lib A B.
Proof.
  introv; split; intro k.

  - apply inhabited_implies_tequality in k.
    rw @tequality_iff_mkc_tequality in k; auto.

  - exists (@true_per o); dands; auto; try (complete (unfold true_per; auto)).
    unfold tequality in k; exrepnd.
    apply CL_teq.
    exists A B A B eq; fold (@nuprl o); sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply nuprl_refl in k0; auto.
    apply nuprl_sym in k0; apply nuprl_refl in k0; auto.
Qed.