(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008-2009                                      *)
(***************************************************************************)

Require Export euclidean_constructions.
Require Export area_elimination_lemmas.
Require Export ratios_elimination_lemmas.

(* lemme 3_2 chou *)
Lemma l_24_a : forall A B P D,
Col A D B -> perp A B P D ->
A<>B -> B<>D ->
 A**D / D**B = Py P A B / Py P B A.
Proof.
intros.
unfold Py.
unfold perp, Py4, Py in *.
uniformize_dir_seg.
basic_simpl.
IsoleVar (A ** P * A ** P) H0.
rewrite H0.
basic_simpl.
assert (A**D+D**B = A**B).
eapply chasles;auto.
assert (A**B * A**B = A**D * A**D + B**D* B**D + 2 * A**D*D**B).
rewrite <- H3.
uniformize_dir_seg.
basic_simpl.
ring.
uniformize_dir_seg.
rewrite H4.
cut (B ** P * B ** P + P ** D * P ** D - B ** D * B ** D + A ** D * A ** D -
 P ** D * P ** D +
 (A ** D * A ** D + B ** D * B ** D + 2 * A ** D * - B ** D) -
 B ** P * B ** P = 2* A**D * A**B).
intro Ha.
rewrite Ha.
cut ((B ** P * B ** P +
 (A ** D * A ** D + B ** D * B ** D + 2 * A ** D * - B ** D) -
 (B ** P * B ** P + P ** D * P ** D - B ** D * B ** D + A ** D * A ** D -
  P ** D * P ** D) = 2 * D**B * A**B)).
intro Hb.
rewrite Hb.
uniformize_dir_seg.
field;repeat split;auto with Geom.
rewrite <- H3.
uniformize_dir_seg.
ring.
rewrite <- H3.
uniformize_dir_seg.
ring.
Qed.

Lemma perp4_perp : forall A B P,
perp A B P A -> Py P A B = 0.
Proof.
intros.
unfold perp in H.
rewrite py4_simpl_6 in H.
assumption.
Qed.

Lemma perp_not_eq_not_perp : forall A B P D, perp A B P D ->
Col A D B ->
 A <> B ->  B <> D -> A <> D ->
Py P A B <> 0.
Proof.
intros.
unfold not;intro.
assert (perp A B P A).
unfold perp, Py4.
unfold Py in *.
uniformize_dir_seg.
basic_simpl.
IsoleVar (A ** B * A ** B) H4.
rewrite H4.
ring.
unfold perp, Py4, Py in *.
uniformize_dir_seg.
basic_simpl.
IsoleVar (B ** P * B ** P) H4.
rewrite H4 in H.
ring_simplify in H.
replace (A ** B) with (A**D + D**B) in H.
uniformize_dir_seg.
ring_simplify in H.
replace (- (2) * A ** D * A ** D + 2 * A ** D * B ** D ) with
(2* A**D * (B**D - A**D)) in H by ring.
assert ((2* A**D * B**A) <> 0).
repeat (apply nonzeromult);auto with Geom.
replace (B ** D - A ** D) with (B**D + D**A) in H.
replace (B ** D + D ** A) with (B**A) in H.
intuition.
symmetry;
auto with Geom.
uniformize_dir_seg;ring.
auto with Geom.
Qed.

(* lemma 3_2 chou *)
Lemma l_24_b : forall A B P D,
Col A D B -> perp A B P D ->
A<>B ->
 A**D / A**B = Py P A B / (2 * A**B * A**B).
Proof.
intros.
cases_equality B D.
subst D.
unfold Py.
field_simplify_eq; auto with Geom.
unfold perp, Py4, Py in H0.
basic_simpl.
uniformize_dir_seg.
IsoleVar (A ** B * A ** B) H0.
replace (2 * A ** B * A ** B) with (2* (A ** B * A ** B)) by ring.
rewrite H0.
ring.

cases_equality A D.
subst D.
basic_simpl.
rewrite perp4_perp by auto.
field.
split;auto with Geom.
assert (Py P A B <> 0).

eapply perp_not_eq_not_perp;eauto.
assert (Py P B A <> 0).
apply (perp_not_eq_not_perp B A P D);auto with Geom.

replace (A**D / A**B) with (1/ (A**B / A**D)) by (field;auto with Geom).
replace (2 * A ** B * A ** B) with (Py A B A) by (unfold Py;uniformize_dir_seg;basic_simpl;ring).
replace (A**B) with (A**D + D**B) by auto with Geom.
replace ((A ** D + D ** B) / A ** D) with (1 + D ** B / A ** D) by (field;auto with Geom).
replace (D ** B / A ** D) with (1/ (A**D / D**B)) by (field; auto with Geom).
rewrite (l_24_a A B P D) by auto.
replace (1 / (1 + 1 / (Py P A B / Py P B A))) with ((Py P A B / (Py P A B + Py P B A))).
replace (Py P A B + Py P B A) with (Py A B A).
auto.
unfold Py;basic_simpl;uniformize_dir_seg;ring.
field.
repeat split;auto.
replace (Py P A B + Py P B A) with (Py A B A).
unfold Py.
uniformize_dir_seg.
basic_simpl.
replace (A ** B * A ** B + A ** B * A ** B) with (2*  A ** B * A ** B) by ring.
repeat (apply nonzeromult);auto with Geom.
unfold Py;basic_simpl;uniformize_dir_seg;ring.
Qed.

(* lemma 3_2 chou *)
Lemma l_24_c : forall A B P D,
Col A D B -> perp A B P D ->
A<>B ->
 D**B / A**B = Py P B A / (2 * A**B * A**B).
Proof.
intros.
assert (B ** D / B ** A = Py P B A / (2 * B ** A * B ** A)).
apply l_24_b ;auto with Geom.
replace (D ** B / A ** B) with (B ** D / B ** A) by auto with Geom.
rewrite H2.
replace (2*B ** A * B ** A) with (2*A ** B * A ** B) .
auto.
uniformize_dir_seg;ring.
Qed.

Lemma l_24_c_on_foot : forall P U V Y,
on_foot Y P U V ->
U**Y / U**V = Py P U V / Py U V U.
Proof.
intros.
unfold on_foot in H.
use H.
replace (U ** Y / U ** V) with (Y**U/ V**U) by auto with Geom.
rewrite (l_24_c V U P) by auto with Geom.
replace (2 * V ** U * V ** U) with (Py U V U).
auto.
unfold Py;basic_simpl;uniformize_dir_seg;ring.
Qed.

Lemma per_area: forall A B C,
  per A B C ->
  2 * 2 * S A B C * S A B C = A**B * A**B * B**C * B**C.
Proof.
intros.
cases_equality B C.
subst.
basic_simpl.
auto.
assert (on_foot B A B C).
unfold on_foot.
repeat split.
cut (perp B C B A).
auto with Geom.
unfold perp, Py4.
basic_simpl.
replace (Py C B A) with (Py A B C) by auto with Geom.
rewrite H.
ring.
auto with Geom.
auto.
apply on_foot_area.
auto.
Qed.

Lemma per_col_eq : forall A B C,
 per A B C -> Col A B C -> A = B \/ B = C.
Proof.
intros.
unfold per in H.
rewrite col_pyth in H by assumption.
cases_equality A B.
left;auto.
right.
IsoleVar (B**C) H.
2:solve_conds;auto with Geom.
replace (0 / (2 * B ** A)) with 0 in H
  by (field;solve_conds;auto with Geom).
auto with Geom.
Qed.

Lemma perp_col_perp : forall P Q B C,
 Q<>B ->
 per P Q B -> Col Q B C -> per P Q C.
Proof.
intros.
cut (perp P Q Q C).
auto with Geom.
assert (perp P Q Q B) by auto with Geom.
cut (perp Q C P Q).
auto with Geom.
apply (perp_para_perp  Q B P Q Q C);auto with Geom.
Qed.

Lemma l_3_4 : forall A B C P,
 Col A B C -> Py P A C <> 0 ->
 Py P A B / Py P A C = A**B/ A**C.
Proof.
intros.
cases_equality A B.
subst.
basic_simpl.
field.
cases_equality B C.
subst.
basic_simpl;auto.
auto with Geom.
assert (A<>C).
intro.
subst.
basic_simpl;intuition.

elim (proj_ex P A B H1).
intros Q HQ.
unfold on_foot in *.
use HQ.

cases_equality A Q.
subst.
clear H5.
unfold perp, Py4 in H3.
basic_simpl.
IsoleVar (Py P Q B) H3.
basic_simpl.

assert (T:=perp_col_perp P Q B C H6 H3 H).
intuition.

assert (perp A C Q P).
apply (perp_para_perp A B Q P A C);auto with Geom.
unfold parallel.
basic_simpl.
auto with Geom.
assert (perp Q P A C)by auto with Geom.
unfold perp, Py4 in *.
IsoleVar (Py P A B) H3.
IsoleVar (Py P A C) H8.
basic_simpl.
rewrite H3.
rewrite H8.
rewrite (col_pyth Q A B) by assumption.
rewrite (col_pyth Q A C).
field.
repeat split;auto with Geom.
assert (Col A Q C).
apply  (col_trans_1 A B Q C H1); auto with Geom.
auto with Geom.
Qed.

Require Export Classical.

Lemma per_dec : forall A B C,
 per A B C \/ ~ per A B C.
Proof.
intros.
elim (classic (Py A B C = 0));
intuition.
Qed.

Ltac cases_per A B C := elim (per_dec A B C);intros.

Lemma l_3_4_b : forall A B C P,
 Col A B C ->
 Py P A B * A**C =  Py P A C * A**B.
Proof.
intros.
cases_per P A C.
unfold per in H0.

rewrite H0.
cases_equality A C.
subst;basic_simpl;auto.
assert (Py P A B = 0).
apply (perp_col_perp P A C B H1);auto with Geom.
rewrite H2.
basic_simpl;auto.

assert (T:=l_3_4 A B C P H H0).
IsoleVar (Py P A B) T.
rewrite T.
field.
intro.
assert (A=C).
auto with Geom.
subst.
basic_simpl.
auto.
auto.
Qed.

Lemma l_28_b : forall A B U V Y,
U <> V ->
Col Y U V ->
Py A B Y = U**Y/U**V * Py A B V + Y**V/U**V * Py A B U.
Proof.
intros.
set (r1 := U ** Y / U ** V).
set (r2 := Y ** V / U ** V).
assert (r2 = 1 -r1).
   unfold r1, r2.
   rewrite <- (chasles Y U V).
   uniformize_dir_seg.
   field;auto with Geom.
   assumption.

cut (B**Y * B**Y = r2 * U**B * U**B + r1 * V**B * V**B - r1 * r2 * U**V * U**V).
intro Ha.
cut (A**Y * A**Y = r2 * U**A * U**A + r1 * V**A * V**A - r1 * r2 * U**V * U**V).
intro Hb.
unfold Py.
rewrite Ha.
rewrite Hb.
uniformize_dir_seg.
basic_simpl.
assert ( (A ** B * A ** B) = (r1 + r2) * (A ** B * A ** B)) by (rewrite H1;ring).
rewrite H2 at 1.
field.

(* first cut *)
rewrite H1.
replace ((1 - r1) * U ** A * U ** A + r1 * V ** A * V ** A -
r1 * (1 - r1) * U ** V * U ** V)
with (U ** A * U ** A + r1 * (V ** A * V ** A - U ** A * U ** A - U ** V * U ** V)
      + r1 *r1 *  U ** V * U ** V) by ring.
replace (U ** A * U ** A + r1 * (V ** A * V ** A - U ** A * U ** A - U ** V * U ** V) +
r1 * r1 * U ** V * U ** V) with
(U ** A * U ** A + r1 * r1 * U**V * U**V - r1 * Py A U V)
by (unfold Py; uniformize_dir_seg; ring).

cut (r1 * Py A U V = Py A U Y).
intro Hab.
rewrite Hab.
unfold Py.
uniformize_dir_seg.
basic_simpl.
cut (r1 * U**V = U**Y).
intro Hb.
assert (r1 * r1 * U ** V * U ** V = U**Y * U**Y)
by (rewrite <- Hb;ring).

rewrite H2.
ring.

unfold r1;field; auto with Geom.

assert (Py A U V * U ** Y = Py A U Y * U ** V).
apply (l_3_4_b U V Y A).
auto with Geom.

rename H2 into T.
IsoleVar (Py A U Y) T.
rewrite T.
unfold r1;field; auto with Geom.
auto with Geom.

(* second cut *)
rewrite H1.
replace ((1 - r1) * U ** B * U ** B + r1 * V ** B * V ** B -
r1 * (1 - r1) * U ** V * U ** V)
with (U ** B * U ** B + r1 * (V ** B * V ** B - U ** B * U ** B - U ** V * U ** V)
      + r1 *r1 *  U ** V * U ** V) by ring.
replace (U ** B * U ** B + r1 * (V ** B * V ** B - U ** B * U ** B - U ** V * U ** V) +
r1 * r1 * U ** V * U ** V) with
(U ** B * U ** B + r1 * r1 * U**V * U**V - r1 * Py B U V)
by (unfold Py; uniformize_dir_seg; ring).

cut (r1 * Py B U V = Py B U Y).
intro Hab.
rewrite Hab.
unfold Py.
uniformize_dir_seg.
basic_simpl.
cut (r1 * U**V = U**Y).
intro Hb.
assert (r1 * r1 * U ** V * U ** V = U**Y * U**Y)
by (rewrite <- Hb;ring).

rewrite H2.
ring.

unfold r1;field; auto with Geom.
assert (Py B U V * U ** Y = Py B U Y * U ** V).
apply (l_3_4_b U V Y B).
auto with Geom.
rename H2 into T.
IsoleVar (Py B U Y) T.
rewrite T.
unfold r1;field; auto with Geom.
auto with Geom.
Qed.

Lemma l3_5_py : forall A B U V Y,
  U <> V ->
  Col Y U V ->
  Py A Y B = U**Y / U**V * Py A V B + Y**V/ U**V * Py A U B
  - (U**Y/ U**V) * (Y**V / U**V) * Py U V U.
Proof.
intros.
set (r1 := U ** Y / U ** V).
set (r2 := Y ** V / U ** V).
assert (r2 = 1 -r1).
   unfold r1, r2.
   rewrite <- (chasles Y U V).
   uniformize_dir_seg.
   field;auto with Geom.
   assumption.

cut (B**Y * B**Y = r2 * U**B * U**B + r1 * V**B * V**B - r1 * r2 * U**V * U**V).
intro Hb.
cut (A**Y * A**Y = r2 * U**A * U**A + r1 * V**A * V**A - r1 * r2 * U**V * U**V).
intro Ha.
unfold Py.
rewrite Ha.
replace (Y ** B * Y ** B) with (B ** Y * B ** Y)
  by (uniformize_dir_seg;field).
rewrite Hb.
uniformize_dir_seg.
basic_simpl.
rewrite H1.
ring.

rewrite H1.
replace ((1 - r1) * U ** A * U ** A + r1 * V ** A * V ** A -
r1 * (1 - r1) * U ** V * U ** V)
with (U ** A * U ** A + r1 * (V ** A * V ** A - U ** A * U ** A - U ** V * U ** V)
      + r1 *r1 *  U ** V * U ** V) by ring.
replace (U ** A * U ** A + r1 * (V ** A * V ** A - U ** A * U ** A - U ** V * U ** V) +
r1 * r1 * U ** V * U ** V) with
(U ** A * U ** A + r1 * r1 * U**V * U**V - r1 * Py A U V)
by (unfold Py; uniformize_dir_seg; ring).

(* first cut *)
cut (r1 * Py A U V = Py A U Y).
intro Hab.
rewrite Hab.
unfold Py.
uniformize_dir_seg.
basic_simpl.
cut (r1 * U**V = U**Y).
intro Hbb.
assert (r1 * r1 * U ** V * U ** V = U**Y * U**Y)
by (rewrite <- Hbb;ring).

rewrite H2.
ring.

unfold r1;field; auto with Geom.

assert (Py A U V * U ** Y = Py A U Y * U ** V).
apply (l_3_4_b U V Y A).
auto with Geom.

rename H2 into T.
IsoleVar (Py A U Y) T.
rewrite T.
unfold r1;field; auto with Geom.
auto with Geom.

(* second cut *)
rewrite H1.
replace ((1 - r1) * U ** B * U ** B + r1 * V ** B * V ** B -
r1 * (1 - r1) * U ** V * U ** V)
with (U ** B * U ** B + r1 * (V ** B * V ** B - U ** B * U ** B - U ** V * U ** V)
      + r1 *r1 *  U ** V * U ** V) by ring.
replace (U ** B * U ** B + r1 * (V ** B * V ** B - U ** B * U ** B - U ** V * U ** V) +
r1 * r1 * U ** V * U ** V) with
(U ** B * U ** B + r1 * r1 * U**V * U**V - r1 * Py B U V)
by (unfold Py; uniformize_dir_seg; ring).

cut (r1 * Py B U V = Py B U Y).
intro Hab.
rewrite Hab.
unfold Py.
uniformize_dir_seg.
basic_simpl.
cut (r1 * U**V = U**Y).
intro Hb.
assert (r1 * r1 * U ** V * U ** V = U**Y * U**Y)
by (rewrite <- Hb;ring).

rewrite H2.
ring.

unfold r1;field; auto with Geom.
assert (Py B U V * U ** Y = Py B U Y * U ** V).
apply (l_3_4_b U V Y B).
auto with Geom.
rename H2 into T.
IsoleVar (Py B U Y) T.
rewrite T.
unfold r1;field; auto with Geom.
auto with Geom.
Qed.

Lemma midpoint_ratio_1 : forall O B D,
mid_point O B D ->  B<>D -> B ** O / B ** D = 1/2.
Proof.
intros.
unfold mid_point in *.
use H.
assert (B**D = B**O + O**D).
symmetry;auto with Geom.
rewrite H.
rewrite H2.
field.
split;auto with Geom.
replace (O ** D + O ** D) with (2*O**D) by ring.
apply nonzeromult.
auto with Geom.
intro.
assert (O=D);auto with Geom.
subst O.
basic_simpl.
assert (B=D); auto with Geom.
Qed.

Lemma midpoint_ratio_2 : forall O B D,
mid_point O B D ->  B<>D -> O ** D / B ** D = 1/2.
Proof.
intros.
unfold mid_point in *.
use H.
rewrite <- H2.
apply midpoint_ratio_1.
unfold mid_point;auto.
auto.
Qed.

Lemma l_28_midpoint : forall O A B P Q,
 mid_point O A B ->
 2 * Py O P Q = Py A P Q + Py B P Q.
Proof.
intros.
cases_equality A B.
subst A.
assert (O=B).
auto with Geom.
subst O.
ring.

assert (Col O A B).
unfold mid_point in *.
use H;auto with Geom.
assert (T:=l_28_b Q P A B O H0 H1).
replace (Py O P Q) with (Py Q P O) by auto with Geom.
rewrite T.
uniformize_pys.
replace (A ** O / A ** B) with (1/2).
replace (O ** B / A ** B) with (1/2).
field;auto with Geom.
symmetry.
apply (midpoint_ratio_2);auto.
symmetry.
apply (midpoint_ratio_1);auto.
Qed.

Lemma l_28_b_midpoint : forall O A B P Q,
 mid_point O A B ->
 2 * Py P O Q = Py P A Q + Py P B Q - 1/ 2 * Py A B A.
Proof.
intros.
cases_equality A B.
subst A.
basic_simpl.
assert (O=B) by auto with Geom.
subst O.
ring.
rewrite ( l3_5_py P Q A B O) by
 (unfold mid_point in *;intuition;auto with Geom).
replace (A ** O / A ** B) with (1/2)
 by (symmetry;apply (midpoint_ratio_1);auto).
replace (O ** B / A ** B) with (1/2)
 by (symmetry;apply (midpoint_ratio_2);auto).
field.
auto with Geom.
Qed.

Lemma l_27_a : forall A B C D P Q, weak_3_parallelogram A B C D ->
Py A P Q + Py C P Q = Py B P Q + Py D P Q.
Proof.
intros.
unfold weak_3_parallelogram in H.
elim H; intros O HO; clear H.
use HO.
assert (T:= l_28_midpoint O A C P Q H).
assert (U:= l_28_midpoint O B D P Q H0).
congruence.
Qed.

Lemma l_27_b : forall A B C D P Q, weak_3_parallelogram A B C D ->
Py4 A P B Q = Py4 D P C Q.
Proof.
intros.
unfold Py4.
apply (l_27_a A B C D P Q) in H.
IsoleVar (Py A P Q) H.
rewrite H.
ring.
Qed.

Lemma midpoint_is_midpoint: forall I A B,
 mid_point I A B -> A<>B -> is_midpoint I A B.
Proof.
intros.
assert (A ** I / A ** B = 1 / 2) by
(apply (midpoint_ratio_1 I A B);auto).
unfold is_midpoint, on_line_d, mid_point in *.
use H.
repeat split;auto with Geom.
IsoleVar (A**I) H1.
rewrite H1.
field;auto with Geom.
auto with Geom.
Qed.

Lemma midpoint_on_line_d: forall I A B,
 mid_point I A B -> A<>B -> on_line_d A I B (0-1).
Proof.
intros.
unfold mid_point in *.
unfold on_line_d.
use H.
repeat split;auto with Geom.
intro.
subst.
basic_simpl.
assert (A=B);auto with Geom.
rewrite <- H2.
uniformize_dir_seg.
ring.
Qed.

Lemma symmetric_point_unicity : forall O B C D,
 mid_point O B D ->
 mid_point O D C ->
 B=C.
Proof.
intros.
unfold mid_point in *.
use H.
use H0.
cases_equality D O.
 subst.
 basic_simpl.
 assert (O=C).
 auto with Geom.
 subst.
 auto with Geom.
assert (Col O B C) by
(apply (col_trans_1 O D B C);auto with Geom).
assert (O**B=O**C).
uniformize_dir_seg.
rewrite <- H3.
rewrite <- H2.
ring.

cases_equality O B.
subst.
basic_simpl.
auto with Geom.
symmetry.
apply (A2b O B C B 1);auto with Geom.
basic_simpl.
auto.
basic_simpl.
auto.
Qed.

Lemma weak_3_parallelogram_parallel : forall A B C D,
   weak_3_parallelogram A B C D -> parallel B C A D.
Proof.
intros.
unfold weak_3_parallelogram in H.
elim H;intros O HO;use HO;clear H.

cases_equality A D.
subst.
auto with Geom.

cases_equality B C.
subst.
auto with Geom.

cases_equality A C.
subst.
assert (O=C).
auto with Geom.
subst.
unfold mid_point in *.
use H1.
auto with Geom.

cases_equality B D.
subst.
assert (O=D).
auto with Geom.
subst.
unfold mid_point in *.
use H0.
auto with Geom.

apply (midpoint_is_midpoint) in H0.
2:auto.
apply (midpoint_on_line_d) in H1.
2:auto.
unfold is_midpoint in *.

unfold parallel, S4.
replace (S B A C) with (S A C B) by auto with Geom.
rewrite (elim_area_on_line_d A C O D B (0-1)).
2:auto.
replace (S B C D) with (S C D B) by auto with Geom.
rewrite (elim_area_on_line_d C D O D B (0-1)).
2:auto.
clear H1.
basic_simpl.
ring_simplify_eq.
unfold is_midpoint in *.
rewrite (elim_area_on_line_d A C A C O (1/2)) .
2:auto.
basic_simpl.
rewrite (elim_area_on_line_d C D A C O (1/2)) .
2:auto.
basic_simpl.
uniformize_signed_areas.
field;auto with Geom.
Qed.

Lemma eq_half_eq_zero : forall x : F, x = 1/2 * x -> x=0.
Proof.
intros.
assert (x-1/2 * x=0).
rewrite H at 1.
field;auto with Geom.
replace (x-1/2*x) with (1/2*x) in H0.
2:field;auto with Geom.
IsoleVar x H0.
replace ( 0 / (1 / 2)) with 0 in H0.
auto.
field;split;auto with Geom.
intro.
intuition.
intro.
assert (1/2*2=0*2).
rewrite H1.
auto.
ring_simplify in H2.
replace (2 * (1 / 2)) with 1 in H2.
intuition.
field;auto with Geom.
Qed.

Lemma weak_3_parallelogram_eq_side : forall A B C D,
   weak_3_parallelogram A B C D -> B**C= A**D.
Proof.
intros.
assert (T:=H).
unfold weak_3_parallelogram in H.
elim H;intros O HO;use HO;clear H.

assert (W0:=H0).
assert (W1:=H1).

cases_equality A D.
subst.
basic_simpl.
assert (B=C).
eauto using symmetric_point_unicity.
auto with Geom.

cases_equality B C.
subst.
basic_simpl.
assert (A=D).
eauto using symmetric_point_unicity.
symmetry;auto with Geom.

cases_equality A C.
subst.
assert (O=C).
auto with Geom.
subst.
unfold mid_point in *.
use H1.
auto.
cases_equality B D.
subst.
assert (O=D).
auto with Geom.
subst.
unfold mid_point in *.
use H0.
auto.
apply (midpoint_is_midpoint) in H0.
2:auto.
apply (midpoint_on_line_d) in H1.
2:auto.

assert (parallel B C A D).
apply (weak_3_parallelogram_parallel);auto.
cut (B**C/A**D= 1).
intros.
IsoleVar (B**C) H6.
rewrite H6.
ring.
auto with Geom.

unfold is_midpoint in *.
replace (B ** C / A ** D) with (C**B / D**A) by auto with Geom.

cases_col C O D.
rewrite (elim_length_ratio_on_line_d_1 C D A O D B (0-1));auto with Geom.

replace ((C ** O / O ** D + (0 - 1)) / (D ** A / O ** D) ) with
             ((C ** O / O ** D) / (D ** A / O ** D) + (0 - 1)/(D ** A / O ** D)).
2:field;split;unfold on_line_d in *; use H1;auto with Geom.

replace ((0 - 1) / (D ** A / O ** D)) with (D**O/D**A).
2:uniformize_dir_seg;field;split;unfold on_line_d in *; use H1;auto with Geom.
2:assert (D<>O) by auto with Geom;auto with Geom.

unfold on_line_d in *.
use H0. use H1.
field_simplify_eq.
2:auto with Geom.

cases_equality O C.
subst.
assert (A**C=0).
apply eq_half_eq_zero.
auto.
assert (A=C) by auto with Geom.
subst.
intuition.

assert (Col O D A).
apply (col_trans_1 O C D A);auto with Geom.

replace (D**O) with (D**A+A**O).
2:apply chasles;auto with Geom.

cut (C**O = O**A).
intro.
rewrite H13.
uniformize_dir_seg.
ring.

unfold mid_point in W0.
use W0.
uniformize_dir_seg.
rewrite H14.
ring.

rewrite (elim_length_ratio_on_line_d_2 C D A O D B (0-1));auto with Geom.
unfold S4.
replace (S C O D) with (S D C O) by auto with Geom.
replace (S D O A) with (S A D O) by auto with Geom.
basic_simpl.

rewrite (elim_area_on_line_d D C A C O (1/2)).
2:auto.
basic_simpl.
rewrite (elim_area_on_line_d A D A C O (1/2)).
2:auto.
basic_simpl.
uniformize_signed_areas.
field.
split;auto with Geom.
intro.
assert (Col C A D) by auto with Geom.
unfold on_line_d in *.
use H0.
assert (Col C A O) by auto with Geom.
assert (Col C O D).
apply (col_trans_1  C A O D);auto with Geom.
intuition.
Qed.

Lemma l3_6 : forall A B C D,
  weak_3_parallelogram A B C D ->
 A**C * A**C + B**D * B**D = 2*A**B * A**B + 2*B**C*B**C.
Proof.
intros.
cases_equality B D.

subst.
basic_simpl.
unfold weak_3_parallelogram in H.
use H.
unfold mid_point in H2.
use H2.
uniformize_dir_seg.
assert (D=x).
auto with Geom.
subst x.
unfold mid_point in H1.
use H1.
rewrite H3.
uniformize_dir_seg.
basic_simpl.
ring_simplify_eq.
rewrite <- (chasles A C D) in H3.
IsoleVar (A**C) H3.
rewrite H3.
ring.
auto.

assert (B**C= A**D).
apply weak_3_parallelogram_eq_side;auto.

unfold weak_3_parallelogram in H.
elim H;intros O (hA,hb);clear H.
assert (Py A O A =
       B ** O / B ** D * Py A D A + O ** D / B ** D * Py A B A -
       B ** O / B ** D * (O ** D / B ** D) * Py B D B).
apply (l3_5_py A A B D O);
unfold mid_point in *;intuition;auto with Geom.
replace (B ** O / B ** D) with (1/2) in *
  by (symmetry;apply midpoint_ratio_1;auto).
replace (O ** D / B ** D)  with (1/2) in *
  by (symmetry;apply midpoint_ratio_2;auto).
assert (A**C = 2* A**O).
unfold  mid_point in *.
use hA.
replace (A**C) with (A**O + O**C) by auto with Geom.
rewrite H3.
ring.
rewrite H2.
replace (2 * A ** O * (2 * A ** O)) with (2*(2*A ** O * A**O)) by ring.
replace (2*A ** O * A**O) with (Py A O A)
 by (unfold Py;uniformize_dir_seg;basic_simpl;try ring).
rewrite H.
unfold Py;uniformize_dir_seg;basic_simpl.
replace (A**D) with (B**C).
field;auto with Geom.
Qed.

Lemma l3_6_b : forall A B C D,
  weak_3_parallelogram A B C D ->
  Py A B C = - Py B A D.
Proof.
intros.
unfold Py.
assert (T:=l3_6 A B C D H).
IsoleVar (A ** C * A ** C) T.
rewrite T.
uniformize_dir_seg.
ring_simplify_eq.
replace (B**C) with (A**D).
ring.
symmetry;
apply weak_3_parallelogram_eq_side;auto.
Qed.

Lemma l_27_c : forall A B C D P Q, weak_3_parallelogram A B C D ->
Py P A Q + Py P C Q = Py P B Q + Py P D Q + 2 * Py B A D.
Proof.
intros.
assert (X:= H).
unfold weak_3_parallelogram in H.
elim H; intros O HO; clear H.
use HO.
assert (T:= l_28_b_midpoint O A C P Q H).
assert (U:= l_28_b_midpoint O B D P Q H0).
assert (Py P A Q + Py P C Q - 1 / 2 * Py A C A =  Py P B Q + Py P D Q - 1 / 2 * Py B D B) by congruence.
clear T U.
assert (2* Py B A D =  1/2 * (Py A C A - Py B D B)).
replace (2 * Py B A D) with (Py B A D + Py B A D) by ring.
replace (Py B A D) with (- Py A B C).
unfold Py.
uniformize_dir_seg;basic_simpl.
field_simplify_eq.
ring_simplify_eq.
2:auto with Geom.
assert (T:=l3_6 A B C D X).
IsoleVar (B ** D * B ** D) T.
replace (2 * B ** D * B ** D) with (2 * (B ** D * B ** D)) by ring.
rewrite T.
ring.
assert (U:=l3_6_b A B C D X).
rewrite U;ring.

rewrite H2.
IsoleVar (Py P A Q + Py P C Q) H1.
rewrite H1.
field.
auto with Geom.
Qed.

Lemma l3_8_a : forall A B C D P, weak_3_parallelogram A B C D ->
Py P A B = Py4 P D A C.
Proof.
intros.
replace (Py4 P D A C) with (Py4 C A D P) by auto with Geom.
unfold Py4.
assert (T:=l_27_a A B C D A P H).
basic_simpl.
rewrite T.
uniformize_pys.
ring.
Qed.

Lemma l3_8_b : forall A B C D P, weak_3_parallelogram A B C D ->
Py P A B = Py P D C - Py A D C.
Proof.
intros.
rewrite (l3_8_a A B C D) by auto.
auto with Geom.
Qed.

Lemma l_28_a : forall A B U V Y,
Col Y U V -> U <> V ->
S A B Y = U**Y/U**V * S A B V + Y**V/U**V * S A B U.
Proof.
intros.
replace (S A B Y) with (S Y A B) by auto with Geom.
rewrite (l2_9 A B U V Y) by auto.
uniformize_signed_areas.
auto.
Qed.

Lemma on_foot_per : forall A B C F,
  on_foot F A B C ->
  per A F B.
Proof.
intros.
unfold on_foot in H.
use H.
assert (perp A F B C) by auto with Geom.
cut (perp A F F B).
auto with Geom.
cut (perp F B A F).
auto with Geom.
apply (perp_para_perp B C A F F B);auto with Geom.
Qed.

Lemma herron_qin : forall A B C,
S A B C * S A B C = 1 / (2*2*2*2) * (Py A B A * Py A C A - Py B A C * Py B A C).
Proof.
intros.
cases_equality B C.
subst.
basic_simpl.
uniformize_pys.
basic_simpl.
ring.

elim (proj_ex A B C H).
intros F HF.

cases_equality B F.
subst.
assert (T:=on_foot_area A F C F HF).
field_simplify_eq.
2:repeat apply nonzeromult;auto with Geom.
replace (2 * (2 * (2 * 2)) * S A F C * S A F C) with
(2*2*(2 * 2 * S A F C * S A F C)) by ring.
rewrite T.

unfold on_foot in HF.
use HF.
clear H2 H3.
assert (perp F C A F) by auto with Geom.
unfold perp, Py4 in *.
IsoleVar (Py C A F) H1.
replace (Py C A F) with (Py F A C) in H1 by auto with Geom.
rewrite H1.
uniformize_pys.
basic_simpl.

assert (Py A C A = Py A F A + Py F C F).
unfold Py.
basic_simpl.
uniformize_dir_seg.
basic_simpl.
replace (A ** C * A ** C + A ** C * A ** C) with (2*(A**C*A**C)) by ring.
replace (A ** F * A ** F + A ** F * A ** F) with (2*(A ** F * A ** F)) by ring.
replace (C ** F * C ** F + C ** F * C ** F) with (2*(C**F*C**F)) by ring.
replace ( 2 * (A ** F * A ** F) + 2 * (C ** F * C ** F))
with (2*(A ** F * A ** F + C ** F * C ** F)) by ring.
assert (A ** C * A ** C = A ** F * A ** F + C ** F * C ** F).
assert (Py A F C = 0).
replace 0 with (-0) by ring.
rewrite <- H0.
ring.
unfold Py in H2.
uniformize_dir_seg.
basic_simpl.
IsoleVar (A ** F * A ** F + C ** F * C ** F) H2.
rewrite H2.
ring.
rewrite H2;auto.
rewrite H2.
unfold Py.
uniformize_dir_seg.
basic_simpl.
ring.

assert (Col B F C).
unfold on_foot in HF.
use HF;auto with Geom.
assert (T:= l_3_4_b B F C A H1).
replace (Py A B F) with (Py F B F) in T.

replace (Py F B F) with (2*B**F*B**F) in T.
2:unfold Py;uniformize_dir_seg;basic_simpl;ring.
IsoleVar (Py A B C) T.
2:auto with Geom.

replace (2 * B ** F * B ** F * B ** C / B ** F) with
 ( 2 * B ** F * B ** C) in T.
2:field;auto with Geom.

replace (S A B C * S A B C) with (1/2 *1/2*A**F*A**F*B**C*B**C).
2: replace (1 / 2 * 1/2*A**F*A**F*B**C* B ** C ) with
               (1/2 * 1/2 *  (A ** F * A**F * B ** C *B**C )) by ring.
2: (rewrite <- on_foot_area).
2:field;auto with Geom.
2:auto.

replace ( 1 / 2 * 1/2 *  A ** F * A ** F * B ** C * B**C ) with
((1/2)* (A**F * A**F) * (1/2)* (B**C * B**C))
   by (field;solve_conds;auto with Geom).

replace (A**F * A**F) with (A**B * A**B - B**F * B**F).
field_simplify_eq.
replace (2 * (2 * (2 * 2)) * B ** F * B ** F * B ** C * B ** C)
with ( 2 * 2 * (2*B ** F *B ** C) * (2*B ** F * B ** C)) by ring.
rewrite <- T.
unfold Py.
uniformize_dir_seg.
basic_simpl.
ring.
solve_conds.

assert (per A F B).
apply (on_foot_per A B C F);auto.
unfold per,Py in *.
uniformize_dir_seg.
IsoleVar (A**B*A**B) H3.
rewrite H3.
ring.

assert (per A F B).
apply (on_foot_per A B C F);assumption.
unfold Py;uniformize_dir_seg;basic_simpl.
unfold per, Py in H2.
IsoleVar (A**B*A**B) H2.
rewrite H2.
uniformize_dir_seg.
basic_simpl.
ring.

Qed.

Lemma l3_9_aux : forall B D P Q R S Y ,
 Col Y B D ->
 B<>D ->
 B ** Y = Q ** S ->
 weak_3_parallelogram B Y S Q ->
 Py4 P Q R S = Q ** S / B ** D * Py4 P B R D.
Proof.
intros.
rewrite <- H1.
replace (Py4 P Q R S) with (Py4 P B R Y).

2:replace (Py4 P B R Y) with (Py4 B P Y R) by auto with Geom.
2:rewrite (l_27_b B Y S Q P R H2).
2:auto with Geom.

unfold Py4.

assert ( Py P B Y * B ** D = Py P B D * B ** Y).
apply (l_3_4_b B Y D P); auto with Geom.
IsoleVar (Py P B Y) H3.
2:auto with Geom.
rewrite H3.
assert (Py R B Y * B ** D = Py R B D * B ** Y).
apply (l_3_4_b  B Y D R);auto with Geom.
IsoleVar (Py R B Y) H5.
rewrite H5.
field;auto with Geom.
Qed.

Lemma l3_9 : forall P Q R S A B C D,
  parallel P R A C ->
  parallel Q S B D ->
  B<>D -> A<>C -> ~ perp A C B D ->
  Py4 P Q R S / Py4 A B C D = (P**R / A**C) * (Q**S / B**D).
Proof.
intros.
assert (exists Y : Point,
         Col Y A C /\ A ** Y = P ** R /\ weak_3_parallelogram A Y R P).
apply (on_line_dex_spec_strong_f A C P R);auto with Geom.
elim H4;intros X HX;clear H4; use HX.
assert (exists Y : Point,
         Col Y B D /\ B ** Y = Q ** S /\ weak_3_parallelogram B Y S Q).
apply (on_line_dex_spec_strong_f B D Q S);auto with Geom.
elim H5;intros Y HY;clear H5; use HY.

assert (Ha:Py4 P Q R S  = Q**S / B**D * Py4 P B R D).

eapply l3_9_aux with (Y:=Y); auto with Geom.

assert (Hb:Py4 P B R D  = P**R / A**C * Py4 A B C D).

replace (Py4 P B R D) with (Py4 B P D R) by auto with Geom.
rewrite (l3_9_aux A C B P D R X H4 H2 H6 H7).
replace (Py4 B A D C) with (Py4 A B C D) by auto with Geom.
field;auto with Geom.

rewrite Ha.
rewrite Hb.
field;solve_conds;auto with Geom.
Qed.

Lemma l3_10 : forall A B C D,
 parallel A B C D ->
 C<>D ->
 A**B/C**D = Py4 A C B D / - Py C D C.
Proof.
intros.
replace (A ** B / C ** D) with ((A ** B / C ** D) * (C**D / C**D))
 by (field;auto with Geom).
rewrite <- (l3_9 A C B D C C D D);auto with Geom.
unfold Py4.
basic_simpl.
uniformize_pys.
field.
cut (Py C D C <> 0).
intuition.
auto with Geom.
unfold perp, Py4.
basic_simpl.
intro.
assert (Py D C D = 0).
replace (0) with (-0) by ring.
rewrite <- H1.
ring.
assert (D=C).
auto with Geom.
intuition.
Qed.

Lemma l3_10b : forall A B C D,
 parallel A B C D ->
 C<>D ->
 A**B/C**D = Py4 B C A D / Py C D C.
Proof.
intros.
rewrite l3_10 by assumption.
replace (Py4 B C A D) with (- Py4 A C B D) by auto with Geom.
field.
split;auto with Geom.
Qed.

Lemma perp_not_parallel : forall A B C D,
  perp A B C D ->
  A <> B -> C <> D ->
  ~ parallel A B C D.
Proof.
intros.
unfold perp in H.
intro.
assert (T:=l3_10 A B C D H2 H1).
rewrite H in T.
IsoleVar (A**B) T.
2:auto with Geom.
replace (C ** D * (0 / - Py C D C)) with 0 in T.
assert (A=B) by auto with Geom.
subst A.
intuition.
field.
cut (Py C D C <>  0).
intro.
intuition.
auto with Geom.
Qed.

Lemma not_perp_to_itself : forall A B,
A <> B ->~ perp A B A B.
Proof.
intros.
unfold perp, Py4 in *.
basic_simpl.
intro.
IsoleVar (Py B A B) H0.
basic_simpl.
assert (A=B).
unfold Py in *.
uniformize_dir_seg.
basic_simpl.
replace (A ** B * A ** B + A ** B * A ** B) with (2*(A ** B * A ** B)) in * by ring.
IsoleVar (A ** B) H0.
replace (0 / 2 / A ** B) with 0 in *.
auto with Geom.
field.
split;auto with Geom.
auto with Geom.
auto with Geom.
intuition.
Qed.

Lemma parallel_not_perp : forall A B C D,
  parallel A B C D ->
  A <> B -> C <> D ->
  ~ perp A B C D.
Proof.
intros.
intro.
assert (perp C D C D).
apply (perp_para_perp A B C D C D);assumption.
apply (not_perp_to_itself C D);auto.
Qed.

Lemma l_25_a : forall A B P Q Y,
  P<>Q -> Q<>Y -> Py Q A B <> 0 ->
 on_inter_line_perp Y A P Q A B ->
 P**Y / Q**Y = Py P A B / Py Q A B.
Proof.
intros.
unfold on_inter_line_perp in *.
use H2.
assert (A<>B).
intro;subst;basic_simpl;intuition.
elim (proj_ex P A B H2).
intros P1 HP1.
unfold on_foot in *.
use HP1.
elim (proj_ex Q A B H2).
intros P2 HP2.
unfold on_foot in *.
use HP2.
assert (Pa:=H5).
assert (Pb:=H4).
assert (Pc:=H7).
unfold perp, Py4 in H4, H5, H7.
IsoleVar (Py P A B) H4.
IsoleVar (Py Q A B) H7.
basic_simpl.
rewrite H4, H7.
rewrite col_pyth by assumption.
assert (A<>P2).
intro;subst;basic_simpl;intuition.
rewrite col_pyth by assumption.
replace (2 * A ** P1 * A ** B / (2 * A ** P2 * A ** B)) with (A**P1/A**P2)
 by (field;repeat split;auto with Geom).

assert (parallel P P1 Y A).
assert (T:=perp_perp_para Y A A B P1 P H12 Pa Pb).
auto with Geom.

assert (parallel Y A Q P2).
apply (perp_perp_para Y A A B Q P2 H12 Pa).
auto with Geom.

(* ici *)
cases_equality A Y.
subst.
clear H13 H14 Pa H5 H9 H12.
assert (parallel P1 P P2 Q).
apply (perp_perp_para P1 P Y B P2 Q H2 Pb Pc).

cases_col Y Q P2.
rename H9 into HCol.

assert (parallel P Q P2 Q).
unfold parallel, S4.
basic_simpl.

assert (Col Q P P2).
apply (col_trans_1 Q Y P P2);auto with Geom.
assert (Col P P2 Q).
auto with Geom.
auto.

cases_equality P2 Q.
subst.
clear H9 H5 H7 Pc.
assert (Col Y P B).
apply (col_trans_1 Y Q P B);auto with Geom.
assert (parallel P1 P Y B).
cut (parallel Y B P1 P).
auto with Geom.
unfold parallel, S4.
assert (Col Y B P) by auto with Geom.
rewrite H7.
basic_simpl.
assert (Col Y P1 B).
auto with Geom.
auto with Geom.

cases_equality P1 P.
subst.
uniformize_dir_seg.
field;split;auto with Geom.

cut False.
intuition.

apply parallel_not_perp in H7.
intuition.
auto with Geom.
auto with Geom.

assert (perp P Q Y B).
apply (perp_para_perp P2 Q  Y B P Q);auto with Geom.
assert (perp Y B P Q) by auto with Geom.
intuition.

assert (Y ** P / Y ** Q = Y ** P1 / Y ** P2).
apply (thales_2 Y Q P P2 P1);auto with Geom.
apply (col_trans_1 Y B P2 P1);auto with Geom.
rewrite <- H12.
uniformize_dir_seg.
field;split;auto with Geom.

rewrite (l1_25 P Y Q P1 A P2).

uniformize_dir_seg.
field;solve_conds.
cut (P2**A<>0).
auto with Geom.
auto with Geom.
auto with Geom.

intro.

assert (per B A Q).
apply (perp_col_perp B A Y Q); auto with Geom.
unfold per.
replace (Py B A Y) with (Py Y A B) by auto with Geom.
auto.
unfold per in H17.
replace (Py B A Q) with (Py Q A B) in H17 by auto with Geom.
intuition.

auto with Geom.
assert (Col A P1 P2).
apply (col_trans_1 A B P1 P2);auto with Geom.
auto with Geom.
auto.
auto.
Qed.

Lemma l_25_b : forall A B P Q Y,
  P<>Q -> Q<>Y -> Py Q A B <> 0 ->
 on_inter_line_perp Y A P Q A B ->
 P**Y / P**Q = Py P A B / Py4 P A Q B.
Proof.
intros.
assert (T:= l_25_a A B P Q Y H H0 H1 H2).
unfold on_inter_line_perp in *.
use H2.
replace (P**Y) with (P**Q + Q**Y) in T by auto with Geom.
replace ((P ** Q + Q ** Y) / Q ** Y) with (P**Q/Q**Y + 1) in T
  by (field;auto with Geom).
replace (P**Y) with (P**Q + Q**Y) by auto with Geom.

replace ((P ** Q + Q ** Y) / P ** Q) with (Q**Y/P**Q + 1)
  by (field;auto with Geom).
unfold Py4.
IsoleVar (Py P A B) T.
rewrite T.
field.
repeat split;auto with Geom.
replace (Py Q A B * (P ** Q + Q ** Y) - Py Q A B * Q ** Y) with
(Py Q A B *  (P ** Q)) by ring.
apply nonzeromult.
auto.
auto with Geom.
Qed.

Lemma l_25_c : forall A B P Q Y,
  P<>Q -> Q<>Y -> Py Q A B <> 0 ->
 on_inter_line_perp Y A P Q A B ->
 Q**Y / P**Q = Py Q A B / Py4 P A Q B.
Proof.
intros.
assert (T:= l_25_a A B P Q Y H H0 H1 H2).
unfold on_inter_line_perp in *.
use H2.
replace (P**Y) with (P**Q + Q**Y) in T by auto with Geom.
replace ((P ** Q + Q ** Y) / Q ** Y) with (P**Q/Q**Y + 1) in T
  by (field;auto with Geom).
replace (P**Y) with (P**Q + Q**Y) by auto with Geom.

replace ((P ** Q + Q ** Y) / P ** Q) with (Q**Y/P**Q + 1)
  by (field;auto with Geom).
unfold Py4.
IsoleVar (Py P A B) T.
rewrite T.
field.
repeat split;auto with Geom.
replace (Py Q A B * (P ** Q + Q ** Y) - Py Q A B * Q ** Y) with
(Py Q A B *  (P ** Q)) by ring.
apply nonzeromult.
auto.
auto with Geom.
Qed.


Require Export Quorum.
Require Export Process.

Section MinBFT_header.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc : @DTimeContext }.

 (* ===============================================================
    Parameters
    =============================================================== *)

  Class MinBFT_context :=
    {
       MinBFT_digest         : Set;
       MinBFT_digest_default : MinBFT_digest;
       MinBFT_digestdeq      : Deq MinBFT_digest;

       MinBFT_sending_key   : Set;
       MinBFT_receiving_key : Set;

       (* number of faults *)
       F : nat;

       (* ++++++++ Nodes (Replicas & Clients) ++++++++ *)

       (* We have 2F+1 replicas *)
       num_replicas := (2 * F) + 1;

       Rep : Set;
       rep_deq : Deq Rep;
       reps2nat : Rep -> nat_n num_replicas;
       reps_bij : bijective reps2nat;

       num_clients : nat;

       Client : Set;
       client_deq : Deq Client;
       clients2nat : Client -> nat_n num_clients;
       clients_bij : bijective clients2nat;

       (* ++++++++ replicated service ++++++++ *)
       MinBFT_data_message : Set;  (* in PBFT this is operation *)
       MinBFT_data_message_deq : Deq MinBFT_data_message;

       MinBFT_result : Set;
       MinBFT_resdeq : Deq MinBFT_result;

       MinBFT_sm_state : Set;
       MinBFT_sm_initial_state : MinBFT_sm_state;
       MinBFT_sm_update : Client -> MinBFT_sm_state -> MinBFT_data_message -> MinBFT_result * MinBFT_sm_state;
    }.

  Context { MinBFT_context : MinBFT_context }.

  (* ===============================================================
     Nodes
     =============================================================== *)

  Inductive MinBFT_node :=
  | MinBFT_replica (n : Rep)
  | MinBFT_client (n : Client).

  Coercion MinBFT_replica : Rep >-> MinBFT_node.

  Definition node2rep (n : MinBFT_node) : option Rep :=
    match n with
    | MinBFT_replica n => Some n
    | _ => None
    end.

  Definition node2client (n : MinBFT_node) : option Client :=
    match n with
    |MinBFT_client nn => Some nn
    | _ => None
    end.

  Lemma MinBFT_nodeDeq : Deq MinBFT_node.
  Proof.
    introv; destruct x as [r1|c1], y as [r2|c2];
    try (complete( right; intro xx; inversion xx; subst; tcsp)).
    - destruct (rep_deq r1 r2);[left|right]; subst; auto.
      intro xx; inversion xx; subst; tcsp.
    - destruct (client_deq c1 c2);[left|right]; subst; auto.
      intro xx; inversion xx; subst; tcsp.
  Defined.

  Global Instance MinBFT_I_Node : Node := MkNode MinBFT_node MinBFT_nodeDeq.

  (* ===============================================================
     Quorum
     =============================================================== *)

  Lemma MinBFT_replica_inj : injective MinBFT_replica.
  Proof.
    introv h; ginv; auto.
  Qed.

  Definition name2rep : name -> option Rep.
  Proof.
    introv n.
    destruct n.
    { exact (Some n). }
    { exact None. }
  Defined.

  Lemma node_cond1 : forall n : Rep, name2rep (MinBFT_replica n) = Some n.
  Proof.
    tcsp.
  Qed.

  Lemma node_cond2 : forall (n : Rep) (m : name), name2rep m = Some n -> MinBFT_replica n = m.
  Proof.
    introv h.
    destruct m; simpl in *; ginv; auto.
  Qed.

  Global Instance MinBFT_I_Quorum : Quorum_context :=
    MkQuorumContext
      Rep
      num_replicas
      rep_deq
      reps2nat
      reps_bij
      MinBFT_replica
      name2rep
      node_cond1
      node_cond2
      MinBFT_replica_inj.

  (* ===============================================================
     More about Nodes
     =============================================================== *)

  (* 0 is less than F+1 *)
  Definition nat_n_Fp1_0 : nat_n num_replicas.
  Proof.
    exists 0.
    apply leb_correct.
    unfold num_replicas.
    omega.
  Defined.

  Definition replica0 : Rep := bij_inv reps_bij nat_n_Fp1_0.

  (* We'll return the node as given by our bijection if n < num_nodes,
     otherwise we return a default value (replica0)
   *)
  Definition nat2rep (n : nat) : Rep.
  Proof.
    destruct reps_bij as [f a b].
    destruct (lt_dec n num_replicas) as [d|d].
    - exact (f (mk_nat_n d)). (* here we now that n < num_replicas so we can use our bijection *)
    - exact replica0. (* here num_replicas <= n, so we return a default value: replica0 *)
  Defined.

  Definition reps : list Rep := nodes.

  Definition nreps : list name := map MinBFT_replica reps.

  Lemma reps_prop : forall (x : Rep), In x reps.
  Proof.
    exact nodes_prop.
  Qed.

  Definition clients : list Client :=
    mapin
      (seq 0 num_clients)
      (fun n i => bij_inv clients_bij (mk_nat_n (seq_0_lt i))).

  Definition nclients : list name := map MinBFT_client clients.

  Lemma clients_prop : forall (x : Client), In x clients.
  Proof.
    introv.
    unfold clients.
    apply in_mapin.

    remember (clients2nat x) as nx.
    destruct nx as [nx condnx].

    pose proof (leb_complete _ _ condnx) as c.

    assert (In nx (seq O num_clients)) as i.
    { apply in_seq; omega. }

    exists nx i; simpl.

    unfold mk_nat_n.
    unfold bij_inv.
    destruct clients_bij.
    pose proof (bij_id1 x) as h.
    rewrite <- Heqnx in h; subst; simpl.

    f_equal; f_equal.
    apply UIP_dec; apply bool_dec.
  Qed.

  (* ===============================================================
     Views
     =============================================================== *)

  Inductive View :=
  | view (n : nat).

  Definition view2nat (v : View) : nat :=
    match v with
    | view n => n
    end.
  Coercion view2nat : View >-> nat.

  Definition next_view (v : View): View := view (S v).

  Definition pred_view (v : View): View := view (pred v).

  Lemma ViewDeq : Deq View.
  Proof.
    introv; destruct x, y; prove_dec.
    destruct (deq_nat n n0); prove_dec.
  Defined.

  Definition initial_view := view 0.

  Definition ViewLe (vn1 vn2 : View) : bool :=
    view2nat vn1 <=? view2nat vn2.

  Definition ViewLt (vn1 vn2 : View) : bool :=
    view2nat vn1 <? view2nat vn2.

  Definition max_view (v1 v2 : View) : View :=
    if ViewLe v1 v2 then v2 else v1.

  (* ===============================================================
     Sequence numbers
     =============================================================== *)

  Inductive SeqNum :=
  | seq_num (n : nat).
  Coercion seq_num : nat >-> SeqNum.

  Definition seqnum2nat (s : SeqNum) : nat :=
    match s with
    | seq_num n => n
    end.
  Coercion seqnum2nat : SeqNum >-> nat.

  Definition SeqNumLe (sn1 sn2 : SeqNum) : bool :=
    seqnum2nat sn1 <=? seqnum2nat sn2.

  Definition SeqNumLt (sn1 sn2 : SeqNum) : bool :=
    seqnum2nat sn1 <? seqnum2nat sn2.

  Definition next_seq (n : SeqNum): SeqNum := seq_num (S n).

  Lemma SeqNumDeq : Deq SeqNum.
  Proof.
    introv; destruct x, y; prove_dec.
    destruct (deq_nat n n0); prove_dec.
  Defined.

  Definition initial_sequence_number : SeqNum := seq_num 0.

  Definition min_seq_num (s1 s2 : SeqNum) : SeqNum :=
    if SeqNumLe s1 s2 then s1 else s2.

  Definition max_seq_num (s1 s2 : SeqNum) : SeqNum :=
    if SeqNumLe s1 s2 then s2 else s1.

  (* ===============================================================
     Authentication
     =============================================================== *)

  Definition MinBFT_tokens := MinBFT_digest.

  Global Instance MinBFT_I_AuthTok : AuthTok :=
    MkAuthTok
      MinBFT_digest
      MinBFT_digestdeq.

  (* ===============================================================
     Crypto
     =============================================================== *)

  Global Instance MinBFT_I_Key : Key := MkKey MinBFT_sending_key MinBFT_receiving_key.

  Class MinBFT_initial_keys :=
    MkMinBFT_initial_keys {
        minbft_initial_keys : key_map;
      }.
  Context { m_initial_keys : MinBFT_initial_keys }.

  Class USIG_initial_keys :=
    MkUSIG_initial_keys {
        usig_initial_keys : key_map;
      }.
  Context { u_initial_keys : USIG_initial_keys }.

  (* ===============================================================
     Primary
     =============================================================== *)

  (* @Ivnote: mod is already part of Coq standard library, and it's used as follows: a mod b *)
  (* primary p = v mod R, where v is number of current view and |R| is 2f+1 *)
  Definition MinBFTprimary_nat (v : View) : nat := v mod num_replicas. (* here we should return replica, not nat!!!*)

  Definition MinBFTprimary (v : View) : Rep := nat2rep (MinBFTprimary_nat v).

  Definition is_primary (v : View) (r : Rep) : bool :=
    if rep_deq r (MinBFTprimary v) then true else false.

  Definition not_primary (v : View) (r : Rep) : bool :=
    negb (is_primary v r).

  (* ===============================================================
     Timestamps
     =============================================================== *)

  Inductive Timestamp :=
  | time_stamp (q : nat).
  Coercion time_stamp : nat >-> Timestamp.

  Definition timestamp2nat (t : Timestamp) : nat :=
    match t with
    | time_stamp n => n
    end.
  Coercion timestamp2nat : Timestamp >-> nat.

  Definition timestamp0 := time_stamp 0.

  (* ===============================================================
     Bare messages
     =============================================================== *)

  (* FIX : Do we need here a null request? *)
  Record Bare_Request :=
    bare_request
      {
        bare_request_c : Client;
        bare_request_t : Timestamp;
        bare_request_m : MinBFT_data_message; (* this filed is called op in the paper, and m in the CRM *)
      }.

  Record Request :=
    request
      {
        request_b : Bare_Request;
        request_a : Tokens  (* [a] authenticate the client *)
      }.

  Record Bare_Reply :=
    bare_reply
      {
        bare_reply_r      : Request;
        bare_reply_result : nat;
        bare_reply_rep    : Rep;
        bare_reply_view   : View
      }.

  Record Reply :=
    reply
      {
        reply_b : Bare_Reply;
        reply_a : Tokens  (* [a] authenticate the replica *)
      }.

  Record Bare_Prepare :=
    bare_prepare
      {
        bare_prepare_v  : View;
        bare_prepare_m  : Request;
      }.

  Record Accept :=
    accept
      {
        accept_r : Request;
        accept_c : nat;
      }.

End MinBFT_header.


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

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

(*
Module Definitions := Definitions(VarTyp)(set).
Import Definitions.
*)
Require Import Extended_infrastructure.
Module Infrastructure := Infrastructure(VarTyp)(set).
Export Infrastructure.

(* Notes:

The syntax is encoded using Charguéraud's Locally nameless representation:

http://www.chargueraud.org/softs/ln/

We annotate the Coq theorems with the correnposing lemmas/theorems in the paper.
The reader can just look for:

Lemma 4

for example, to look for the proof of lemma 4 in the paper.

All lemmas and theorems are complete: there are no uses of admit or Admitted,
with the exceptions of "tlam" and "tylam" due to a technical limitation.

*)

Lemma ortho_ax_sym : forall A B, OrthoAx A B -> OrthoAx B A.
Proof.
  intros.
  destruct H as [a [b c]].
  unfold OrthoAx.
  auto.
Qed.

Lemma ortho_sym : forall Gamma A B, Ortho Gamma A B -> Ortho Gamma B A.
Proof.
  intros Gamma A B HOrtho.
  induction HOrtho; auto.
  - apply_fresh OForAll as x; apply H0; not_in_L x.
  - apply OVarSym with (A := A); auto.
  - apply OVar with (A := A); auto.
  - apply ortho_ax_sym in H0; now apply OAx.
Qed.

Lemma ortho_and_l : forall Gamma t1 t2 t0, Ortho Gamma (And t1 t2) t0 -> Ortho Gamma t1 t0.
Proof.
  intros.
  dependent induction H.
  - auto.
  - auto.
  - inversion H2; subst.
    apply OVarSym with (A := A); auto.
    apply sound_sub in H1.
    destruct H1.
    inversion H1; subst.
    apply complete_sub.
    eexists; apply H8.
    inversion H4.
    inversion H4.
  - orthoax_inv_l.
Qed.

Lemma ortho_and_r : forall Gamma t1 t2 t0, Ortho Gamma (And t1 t2) t0 -> Ortho Gamma t2 t0.
Proof.
  intros.
  dependent induction H.
  - auto.
  - auto.
  - inversion H2; subst.
    apply OVarSym with (A := A); auto.
    apply sound_sub in H1.
    destruct H1.
    inversion H1; subst.
    apply complete_sub.
    eexists; apply H10.
    inversion H4.
    inversion H4.
  - orthoax_inv_l.
Qed.

Lemma wfenv_no_refl : forall Gamma x, WFEnv Gamma -> not (List.In (x, TyDis (PFVarT x)) Gamma).
Proof.
  intros.
  induction H.
  - auto.
  - unfold not, extend; simpl in *; intros.
    destruct H2.
    inversion H2; subst.
    apply H0; simpl.
    now apply MSetProperties.Dec.F.singleton_2.
    contradiction.
  - unfold not, extend; simpl; intros [a | b]; apply IHWFEnv.
    inversion a. auto.
Qed.

Lemma wfenv_no_var_sub :
  forall Gamma x A, WFEnv Gamma -> Sub A (PFVarT x) -> not (List.In (x, TyDis A) Gamma).
Proof.
  intros.
  induction H.
  - auto.
  - unfold not, extend; simpl in *; intros.
    destruct H3.
    inversion H3; subst.
    inversion H0.
    clear IHWFEnv H2 H0 H.
    dependent induction H4.
    + simpl in *; apply IHsub; not_in_L x.
    + simpl in *; apply IHsub; not_in_L x.
    + apply H1; simpl; now apply MSetProperties.Dec.F.singleton_2.
    + contradiction.
  - unfold not, extend; simpl; intros [a | b]; apply IHWFEnv.
    inversion a. auto.
Qed.

Lemma ortho_no_sub :
  forall Gamma A B, WFTyp Gamma A -> WFTyp Gamma B -> Ortho Gamma A B -> not (Sub A B).
Proof.
  intros Gamma A B WFA WFB HOrtho HSub.

  inversion HSub.
  generalize dependent Gamma.
  induction H; intros.
  - inversion HOrtho; subst. destruct H0 as [a [b c]]; now apply c.
  - inversion HOrtho; subst.
    inversion WFA; inversion WFB; subst.
    apply IHsub2 with (Gamma := Gamma); auto.
    inversion HSub. inversion H1; subst.
    eexists; apply H13.
    destruct H2 as [a [b c]]; now apply c.
  - inversion WFB; subst.
    apply IHsub1 with (Gamma := Gamma); auto.
    eexists; apply H.
    apply ortho_sym.
    apply ortho_and_l with (t2 := t2); auto.
    now apply ortho_sym.
  - inversion WFA; subst; apply IHsub with (Gamma := Gamma); auto.
    eexists; apply H.
    apply ortho_and_l with (t2 := t2); auto.
  - inversion WFA; subst; apply IHsub with (Gamma := Gamma); auto.
    eexists; apply H.
    apply ortho_and_r with (t1 := t1); auto.
  - inversion HOrtho; subst.
    apply wfenv_no_var_sub with (Gamma := Gamma) (A := A) (x := v); auto.
    now apply sound_sub.
    apply wfenv_no_var_sub with (Gamma := Gamma) (A := A) (x := v); auto.
    now apply sound_sub.
    destruct H0 as [a [b c]]; now apply c.
  - inversion WFA; inversion WFB; subst.
    inversion HSub.
    inversion H1; subst.
    inversion HOrtho; subst.
    pick_fresh x.
    eapply H0 with (x := x).
    not_in_L x.
    eexists; apply H8.
    not_in_L x.
    apply H4.
    not_in_L x.
    apply H9.
    not_in_L x.
    apply H6.
    not_in_L x.
    destruct H3 as [a [b HH]]; now apply HH.
    inversion H5.
    inversion H9.
    inversion HSub; inversion H1; subst.
    inversion HOrtho; subst.
    pick_fresh x.
    eapply H0 with (x := x).
    not_in_L x.
    eexists; apply H9.
    not_in_L x.
    apply H3.
    not_in_L x.
    apply H7.
    not_in_L x.
    apply H6.
    not_in_L x.
    destruct H4 as [a [b HH]]; now apply HH.
Qed.

(* Unique subtype contributor: Lemma 2 *)

Lemma uniquesub :
  forall Gamma A B C, WFTyp Gamma A -> WFTyp Gamma B ->
             Ortho Gamma A B -> Sub (And A B) C -> not (Sub A C /\ Sub B C).
Proof.
  intros Gamma A B C WFA WFB HOrtho HSubAnd.
  unfold not; intros [HSubA HSubB].
  generalize dependent C.
  dependent induction HOrtho; intros.
  - induction C;
    try (inversion WFA; subst;
         inversion HSubA; inversion H; subst; [
           eapply IHHOrtho1; auto; [ apply sand3; apply HSubB |
                                     eexists; apply H5 |
                                     auto ] |
           eapply IHHOrtho2; auto; [ apply sand3; apply HSubB |
                                     eexists; apply H5 |
                                     auto ] ]).
    + inversion HSubA; inversion H; subst.
      inversion HSubB; inversion H0; subst.
      apply IHC1.
      apply sand2.
      eexists; apply H3.
      eexists; apply H3.
      eexists; apply H6.
      inversion H2.
      inversion H2.
      inversion H5.
      inversion H5.
  - induction C;
    try (inversion WFB; subst;
         inversion HSubB; inversion H; subst; [
           eapply IHHOrtho1; auto; [ apply sand2; apply HSubA |
                                     auto |
                                     eexists; apply H5 ] |
           eapply IHHOrtho2; auto; [ apply sand2; apply HSubA |
                                     auto |
                                     eexists; apply H5 ] ]).
    + inversion HSubA; inversion H; subst.
      inversion HSubB; inversion H0; subst.
      apply IHC1.
      apply sand2.
      eexists; apply H3.
      eexists; apply H3.
      eexists; apply H6.
      inversion H8.
      inversion H8.
      inversion H1.
      inversion H1.
  - induction C; try (now (inversion HSubA as [x HInv]; inversion HInv)).
    + inversion WFA; subst; inversion WFB; subst.
      inversion HSubA; inversion H; subst.
      inversion HSubB; inversion H0; subst.
      eapply IHHOrtho; auto; [ apply sand2; eexists; apply H10
                             | eexists; apply H10
                             | eexists; apply H13 ].
    + inversion WFA; subst; inversion WFB; subst.
      inversion HSubA; inversion H; subst.
      inversion HSubB; inversion H0; subst.
      apply IHC1.
      apply sand2; eexists; apply H7.
      eexists; apply H7.
      eexists; apply H10.
  - induction C; try (now (inversion HSubA as [x HInv]; inversion HInv)).
    + inversion HSubA; inversion H1; subst.
      inversion HSubB; inversion H2; subst.
      apply IHC1.
      apply sand2; eexists; apply H5.
      eexists; apply H5.
      eexists; apply H8.
    + inversion HSubA; inversion H1; subst.
      inversion HSubB; inversion H2; subst.
      inversion WFA; inversion WFB; subst.
      pick_fresh x.
      clear IHC1; clear IHC2; clear HSubAnd.
      eapply H0 with (x := x).
      not_in_L x; apply H7.
      apply H6; not_in_L x.
      apply H13; not_in_L x.
      apply sand2.
      eexists; apply H7; not_in_L x.
      eexists; apply H7; not_in_L x.
      eexists; apply H8; not_in_L x.
      inversion H9.
      inversion H13.
      pick_fresh x.
      clear IHC1; clear IHC2; clear HSubAnd.
      eapply H0 with (x := x).
      not_in_L x; apply H7.
      apply H5; not_in_L x.
      apply H11; not_in_L x.
      apply sand2.
      eexists; apply H7; not_in_L x.
      eexists; apply H7; not_in_L x.
      eexists; apply H8; not_in_L x.
  - induction C; try (now (inversion HSubA as [z HInv]; inversion HInv)).
    + destruct HSubA as [c HsubA]; inversion HsubA; subst.
      destruct HSubB as [c HsubB]; inversion HsubB; subst.
      apply IHC1.
      apply sand2; eexists; apply H6.
      eexists; apply H6.
      eexists; apply H7.
      inversion H4.
      inversion H4.
    + clear HSubAnd.
      destruct HSubA as [c HsubA]; inversion HsubA; subst.
      assert (Ha : Ortho Gamma ty (PFVarT v)).
      apply OVarSym with (A := A); auto.
      apply ortho_no_sub in Ha.
      contradiction.
      auto.
      auto.
  (* same as above (var_sym) *)
  - induction C; try (now (inversion HSubB as [z HInv]; inversion HInv)).
    + destruct HSubA as [c HsubA]; inversion HsubA; subst.
      destruct HSubB as [c HsubB]; inversion HsubB; subst.
      apply IHC1.
      apply sand2; eexists; apply H6.
      eexists; apply H6.
      eexists; apply H7.
      inversion H4.
      inversion H4.
    + clear HSubAnd.
      destruct HSubB as [c HsubB]; inversion HsubB; subst.
      assert (Ha : Ortho Gamma ty (PFVarT v)).
      apply OVarSym with (A := A); auto.
      apply ortho_no_sub in Ha.
      contradiction.
      auto.
      auto.
  - destruct H0 as [ PTypHd1 [ PTypHd2 PTypHd3 ]].
    induction C.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
      inversion HSubB as [x HsB]; inversion HsB; subst; try orthoax_inv PTypHd2.
      apply PTypHd3; auto.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
      inversion HSubB as [x HsB]; inversion HsB; subst; try orthoax_inv PTypHd2.
      apply PTypHd3; auto.
    + inversion HSubA as [x HInv1]; inversion HInv1; subst; try (now inversion H0).
      inversion HSubB as [x HInv2]; inversion HInv2; subst; try (now inversion H0).
      apply IHC1; [ apply sand2; eexists; apply H3
                  | eexists; apply H3
                  | eexists; apply H4 ].
    + inversion HSubA as [x HsA]; inversion HsA; subst; inversion H1.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
      inversion HSubB as [x HsB]; inversion HsB; subst; try orthoax_inv PTypHd2.
      apply PTypHd3; auto.
    + inversion HSubA as [x HsA]; inversion HsA; subst; try orthoax_inv PTypHd1.
Qed.

(* Coercive subtyping is coeherent: Lemma 3 *)

Lemma sub_coherent :
  forall {A Gamma}, WFTyp Gamma A ->
           forall {B}, WFTyp Gamma B ->
                  forall {C1}, sub A B C1 ->
                          forall {C2}, sub A B C2 -> C1 = C2.
Proof.
  intros.
  generalize dependent C2.
  generalize dependent Gamma.
  (* Case: Int <: Int *)
  induction H1; intros.
  - inversion H2.
    reflexivity.
  (* Case: Fun t1 t2 <: Fun t3 t4 *)
  - inversion H. inversion H0. inversion H2.
    assert (c2 = c3). apply IHsub2 with (Gamma := Gamma); auto.
    assert (c1 = c0). apply IHsub1 with (Gamma := Gamma); auto.
    now subst.
  (* Case: t <: And t1 t2 *)
  - inversion H2; inversion H0; subst.
    assert (c1 = c0) by (apply IHsub1 with (Gamma := Gamma); auto).
    assert (c2 = c3) by (apply IHsub2 with (Gamma := Gamma); auto).
    now subst.
    now subst.
    now subst.
  (* different coercion case*)
  - inversion H0; subst.
    inversion H3; subst.
    inversion H.
    assert (c = c0). apply IHsub with (Gamma := Gamma). inversion H0; subst. auto. auto.
    now subst.
    now subst.
    assert (HSub : Sub (And t1 t2) t0) by (apply sand2; eexists; apply H1).
    assert (Ha := uniquesub _ t1 t2 t0 H6 H8 H9 HSub).
    exfalso; apply Ha.
    split; eexists; [apply H1 | apply H7].
  - inversion H0; subst.
    inversion H3; subst.
    inversion H.
    assert (HSub : Sub (And t1 t2) t0) by (apply sand3; eexists; apply H1).
    assert (Ha := uniquesub _ t1 t2 t0 H6 H8 H9 HSub).
    exfalso; apply Ha.
    split; eexists; [apply H7 | apply H1].
    assert (c = c0). apply IHsub with (Gamma := Gamma). inversion H0; subst. auto. auto.
    now subst.
    now subst.
  - now inversion H2.
  - inversion H1; subst.
    inversion H2; subst.
    inversion H3; subst.
    pick_fresh x.
    assert (Ha : (open_typ_term c (STFVarT x)) = (open_typ_term c0 (STFVarT x))).
    assert (ty := Bot).
    eapply H0 with (Gamma := extend x (TyDis d) Gamma).
    not_in_L x.
    apply H7.
    not_in_L x.
    apply H9.
    not_in_L x.
    apply H12.
    not_in_L x.
    assert (c = c0).
    eapply open_typ_term_app_eq with (x := x) (n := 0).
    not_in_L x.
    not_in_L x.
    apply Ha.
    now subst.
    inversion H8.
    inversion H1; subst;
    inversion H2; subst;
    inversion H3; subst.
    inversion H11.
    inversion H9.
    inversion H10.
    pick_fresh x.
    assert (Ha : (open_typ_term c (STFVarT x)) = (open_typ_term c0 (STFVarT x))).
    assert (ty := Bot).
    eapply H0 with (Gamma := extend x (TyDis Bot) Gamma).
    not_in_L x.
    apply H7.
    not_in_L x.
    apply H8.
    not_in_L x.
    apply H11.
    not_in_L x.
    assert (c = c0).
    eapply open_typ_term_app_eq with (x := x) (n := 0).
    not_in_L x.
    not_in_L x.
    apply Ha.
    now subst.
Qed.

(*
End ExtendedSub.

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

Require Import Extended_infrastructure.
Module Infrastructure := Infrastructure(VarTyp)(set).
Export Infrastructure.

Module ExtendedSub := ExtendedSub(VarTyp)(set).
Import ExtendedSub.
 *)

(* Typing lemmas *)

Lemma typing_wf_source_alg:
  forall Gamma t T E dir, has_type_source_alg Gamma t dir T E -> WFTyp Gamma T.
Proof.
  intros Gamma t dir T E H.
  induction H; auto.
  - inversion IHhas_type_source_alg1; assumption.
  - inversion IHhas_type_source_alg; subst.
    apply open_body_wf_type with (d := d); auto.
    unfold body_wf_typ; eauto.
    inversion IHhas_type_source_alg; subst.
    inversion H7.
    apply open_body_wf_type_bot; auto.
    unfold body_wf_typ; eauto.
  - pick_fresh x.
    assert (Ha : not (M.In x L)) by (not_in_L x).
    apply WFFun.
    assumption.
    apply H0 in Ha.
    rewrite <- app_nil_l with (l := Gamma).
    eapply wf_strengthen_source with (z := x).
    not_in_L x.
    rewrite app_nil_l; apply Ha.
  - apply_fresh WFForAll as x.
    apply H1.
    not_in_L x.
    auto.
  - apply_fresh WFForAllBot as x.
    apply H0.
    not_in_L x.
Qed.

Lemma type_correct_alg_terms : forall Gamma E ty e dir, has_type_source_alg Gamma E dir ty e -> PTerm E.
Proof.
  intros.
  induction H; auto.
  - apply PTerm_TApp.
    auto.
    now apply wf_gives_types_source in H.
  - apply_fresh PTerm_Lam as x; auto.
    apply H0; not_in_L x.
  - apply_fresh PTerm_TLam as x.
    apply H1; not_in_L x.
  - apply_fresh PTerm_TLam as x.
    apply H0; not_in_L x.
Qed.

Lemma typing_alg_wf_env :
  forall Gamma E dir ty e, has_type_source_alg Gamma E dir ty e -> WFEnv Gamma.
Proof.
  intros.
  induction H; auto.
  - pick_fresh x;
    assert (Ha: not (In x L)) by not_in_L x;
    pose (H0 _ Ha) as HInv;
    inversion HInv; auto.
  - pick_fresh x.
    assert (Ha : not (In x L)) by not_in_L x.
    apply H1 in Ha.
    now inversion Ha.
  - pick_fresh x.
    assert (Ha : not (In x L)) by not_in_L x.
    apply H0 in Ha.
    now inversion Ha.
Qed.

(* Ignoring the generated expressions + smart constructors *)

Definition has_ty Gamma e d t := exists E, has_type_source_alg Gamma e d t E.

(* Uniqueness *)

Definition almost_unique (A B : PTyp) (d : Dir) : Prop :=
  match d with
    | Inf => A = B
    | Chk => True (* Is this result useful for checking: exists C, Sub C A /\ Sub C B*)
  end.

Lemma typ_unique : forall Gamma e d t1 E1, has_type_source_alg Gamma e d t1 E1 -> forall t2 E2, has_type_source_alg Gamma e d t2 E2 -> almost_unique t1 t2 d.
intros Gamma e d t1 E1 H.
induction H; intros; unfold almost_unique; auto.
(* case Var *)
- inversion H2; subst.
  assert (Ha : TermV ty = TermV t2).
  erewrite ok_unique_type with (x0 := x).
  reflexivity.
  apply wfenv_to_ok in H4.
  apply H4.
  apply (conj H5 H0).
  decide equality.
  now inversion Ha.
(* case Lit *)
- inversion H0. auto.
(* case App *)
- inversion H1.
  apply IHhas_type_source_alg1 in H5. simpl in H5.
  apply IHhas_type_source_alg2 in H6.
  injection H5. intros. auto.
(* Case Merge *)
- inversion H2.
  apply IHhas_type_source_alg1 in H5.
  apply IHhas_type_source_alg2 in H7.
  rewrite H5. rewrite H7. auto.
(* Case Ann *)
- inversion H0. auto.
(* Case TApp *)
- inversion H2; subst.
  apply IHhas_type_source_alg in H7.
  injection H7; intros.
  now subst.
Qed.

(* Theorem 5. Type inference always gives unique types *)

Lemma typ_inf_unique : forall {Gamma e t1 t2 E1 E2}, has_type_source_alg Gamma e Inf t1 E1 -> has_type_source_alg Gamma e Inf t2 E2 -> t1 = t2.
intros.
pose (@typ_unique _ _ _ _ _ H _ _ H0). simpl in a. auto.
Qed.

(* Theorem 6. *)
Lemma typ_coherence : forall Gamma e d t E1, has_type_source_alg Gamma e d t E1 -> forall E2, has_type_source_alg Gamma e d t E2 -> E1 = E2.
intros Gamma e d t E1 H.
induction H; intros.
(* case PFVar *)
- inversion H2; reflexivity.
(* case STLit *)
- inversion H0; reflexivity.
(* Case App *)
- inversion H1.
  assert (Fun A B = Fun A0 B).
  apply (typ_inf_unique H H5). injection H9. intros.
  rewrite <- H9 in H5. rewrite <- H10 in H6.
  apply IHhas_type_source_alg1 in H5.
  apply IHhas_type_source_alg2 in H6.
  rewrite H5. rewrite H6. auto.
(* Case Merge *)
- inversion H2.
  apply IHhas_type_source_alg1 in H8.
  apply IHhas_type_source_alg2 in H9.
  rewrite H8. rewrite H9. auto.
(* Case Ann *)
- inversion H0.
  apply IHhas_type_source_alg in H3. auto.
(* Case TApp *)
- inversion H2; subst.
  assert (Ha : ForAll d ty = ForAll d0 ty0).
  eapply typ_inf_unique.
  apply H0.
  apply H8.
  rewrite <- Ha in H8.
  apply IHhas_type_source_alg in H8.
  now subst.
(* Case Lam *)
- inversion H2; subst.
  apply f_equal.
  pick_fresh x.
  assert (Ha1: not (M.In x L0)) by (not_in_L x).
  apply H7 in Ha1.
  apply H0 in Ha1.
  assert (HNotE : not (In x (fv E))) by (not_in_L x).
  assert (HNotF : not (In x (fv E0))) by (not_in_L x).
  apply (open_app_eq _ _ _ _ HNotE HNotF Ha1).
  not_in_L x.
  inversion H3.
(* ATySub *)
- inversion H2.
  subst.
  inversion H.
  assert (A = A0).
  apply (typ_inf_unique H H3).
  subst.
  apply IHhas_type_source_alg in H3.
  subst.
  assert (WFTyp Gamma A0). now apply typing_wf_source_alg in H.
  assert (WFTyp Gamma B). assumption.
  assert (C = C0).
  apply (sub_coherent H3 H6 H0 H4).
  subst; reflexivity.
  subst; inversion H.
  subst; inversion H.
(* Case TLam *)
- inversion H2; subst.
  inversion H3.
  apply f_equal.
  pick_fresh x.
  apply open_typ_term_app_eq with (E := E) (F := E0) (x := x) (n := 0).
  not_in_L x.
  not_in_L x.
  apply H1.
  not_in_L x.
  apply H8.
  not_in_L x.
  inversion H.
- inversion H1; subst.
  inversion H2.
  inversion H6.
  apply f_equal.
  pick_fresh x.
  apply open_typ_term_app_eq with (E := E) (F := E0) (x := x) (n := 0).
  not_in_L x.
  not_in_L x.
  apply H0.
  not_in_L x.
  apply H5.
  not_in_L x.
Qed.

Lemma coercions_produce_terms :
  forall E A B, sub A B E -> STTerm E.
Proof.
  intros.
  induction H.
  (* Case SInt *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SFun *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply_fresh STTerm_Lam as y; cbn.
    apply STTerm_App.
    repeat rewrite <- open_rec_term; assumption.
    apply STTerm_App.
    apply STTerm_Var.
    apply STTerm_App; [ repeat rewrite <- open_rec_term; auto | apply STTerm_Var ].
  (* Case SAnd1 *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply STTerm_Pair.
    apply STTerm_App; repeat rewrite <- open_rec_term; auto.
    rewrite <- open_rec_term; auto.
  (* Case SAnd2 *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply STTerm_App; auto.
    rewrite <- open_rec_term; auto.
  (* Case SAnd3 *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply STTerm_App; auto.
    rewrite <- open_rec_term; auto.
  (* Case SVar *)
  - apply_fresh STTerm_Lam as x; cbn; auto.
  (* Case SForAll *)
  - apply_fresh STTerm_Lam as x; cbn.
    apply_fresh STTerm_TLam as y; cbn.
    apply STTerm_App; auto.
    assert (Ha : not (In y L)) by (not_in_L y).
    apply H0 in Ha.
    rewrite open_comm_open_typ_term.
    rewrite <- open_rec_term; auto.
Qed.

Hint Resolve coercions_produce_terms.

(* Subtyping rules produce type-correct coercions: Lemma 1 *)
Lemma type_correct_coercions :
  forall Gamma A B E, sub A B E ->
             WFEnv Gamma ->
             WFTyp Gamma A ->
             WFTyp Gamma B ->
             has_type_st (∥ Gamma ∥) E (STFun (|A|) (|B|)) .
Proof.
  intros.
  generalize dependent Gamma.
  induction H; intros.
  (* Case SInt *)
  - simpl.
    remember (∥ Gamma ∥).
    apply_fresh STTyLam as x; cbn; auto.
    apply STTyVar; auto.
    apply WFType_Int; auto.
    apply Ok_push; auto.
    subst; auto.
    apply wfenv_to_ok in H0; auto.
    not_in_L x.
    apply Ok_push; auto.
    subst; auto.
    not_in_L x.
    left; simpl; auto.
    apply WFType_Int.
    subst; auto.
  (* Case SFun *)
  - inversion H2; inversion H3.
    subst.
    remember (∥ Gamma ∥).
    apply_fresh STTyLam as x; cbn.
    apply_fresh STTyLam as y; cbn.
    apply STTyApp with (A := (| o2 |)).
    rewrite <- open_rec_term.
    rewrite <- open_rec_term.
    repeat apply typing_weaken_extend.
    subst; apply (IHsub2 _ H1 H8 H13).
    not_in_L x.
    not_in_L y.
    not_in_L x.
    now apply coercions_produce_terms in H0.
    rewrite <- open_rec_term.
    now apply coercions_produce_terms in H0.
    now apply coercions_produce_terms in H0.
    apply STTyApp with (A := (| o1 |)).
    apply STTyVar.
    repeat apply wf_weaken_extend.
    apply WFType_Fun.
    subst; now apply WFTyp_to_WFType.
    subst; now apply WFTyp_to_WFType.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    right; left; auto.
    rewrite <- open_rec_term.
    rewrite <- open_rec_term.
    eapply STTyApp.
    repeat apply typing_weaken_extend.
    subst; apply IHsub1; auto.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    apply STTyVar.
    repeat apply wf_weaken_extend.
    inversion H3.
    subst; now apply WFTyp_to_WFType.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    not_in_L y.
    not_in_L x.
    left; auto.
    now apply coercions_produce_terms in H.
    rewrite <- open_rec_term.
    now apply coercions_produce_terms in H.
    now apply coercions_produce_terms in H.
    apply wf_weaken_extend.
    subst; now apply WFTyp_to_WFType.
    not_in_L x.
    apply WFType_Fun; subst; now apply WFTyp_to_WFType.
  - remember (∥ Gamma ∥).
    inversion H3.
    apply_fresh STTyLam as x; cbn.
    apply STTyPair.
    + rewrite <- open_rec_term.
      apply STTyApp with (A := (| t0 |)).
      apply typing_weaken_extend.
      subst; apply IHsub1; auto.
      not_in_L x.
      apply STTyVar.
      apply wf_weaken_extend.
      subst; now apply WFTyp_to_WFType.
      not_in_L x.
      apply Ok_push.
      subst; auto.
      not_in_L x.
      left; auto.
      now apply coercions_produce_terms in H.
    + rewrite <- open_rec_term.
      apply STTyApp with (A := (| t0 |)).
      apply typing_weaken_extend.
      subst; apply IHsub2; auto.
      not_in_L x.
      apply STTyVar.
      apply wf_weaken_extend.
      subst; now apply WFTyp_to_WFType.
      not_in_L x.
      apply Ok_push.
      subst; auto.
      not_in_L x.
      left; auto.
      now apply coercions_produce_terms in H0.
    + subst; now apply WFTyp_to_WFType.
  - remember (∥ Gamma ∥).
    inversion H2.
    apply_fresh STTyLam as x; cbn.
    rewrite <- open_rec_term.
    apply STTyApp with (A := (| t1 |)).
    apply typing_weaken_extend.
    subst; apply IHsub; auto.
    not_in_L x.
    apply STTyProj1 with (B := (| t2 |)).
    apply STTyVar.
    apply wf_weaken_extend.
    apply WFType_Tuple; subst; now apply WFTyp_to_WFType.
    not_in_L x.
    apply Ok_push. subst; auto. not_in_L x.
    left; auto.
    now apply coercions_produce_terms in H.
    subst; apply WFType_Tuple; now apply WFTyp_to_WFType.
  - remember (∥ Gamma ∥).
    inversion H2.
    apply_fresh STTyLam as x; cbn.
    rewrite <- open_rec_term.
    apply STTyApp with (A := (| t2 |)).
    apply typing_weaken_extend.
    subst; apply IHsub; auto.
    not_in_L x.
    apply STTyProj2 with (A := (| t1 |)).
    apply STTyVar.
    apply wf_weaken_extend.
    apply WFType_Tuple; subst; now apply WFTyp_to_WFType.
    not_in_L x.
    apply Ok_push. subst; auto. not_in_L x.
    left; auto.
    now apply coercions_produce_terms in H.
    subst; apply WFType_Tuple; now apply WFTyp_to_WFType.
  - remember (∥ Gamma ∥).
    apply_fresh STTyLam as x.
    unfold open; simpl.
    apply STTyVar.
    apply wf_weaken_extend.
    subst; now apply WFTyp_to_WFType in H1.
    not_in_L x.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    left; auto.
    subst; now apply WFTyp_to_WFType in H1.
  - remember (∥ Gamma ∥).
    inversion H2.
    inversion H3.
    apply_fresh STTyLam as x.
    unfold open; simpl.
    apply_fresh STTyTLam as y.
    unfold open_typ_term; simpl.
    apply STTyApp with (A := (open_typ (| t1 |) (STFVarT y))).
    rewrite open_comm_open_typ_term.
    rewrite <- open_rec_term.
    unfold open_typ; simpl.
    unfold open_typ_source in H0; simpl in H0.
    subst.
    change (extend y (TyVar STyp)
                   (extend x (TermVar STyp (STForAll (| t1 |))) (∥ Gamma ∥))) with
    (∥ (extend y (TyDis d)
               (extend x (TermV (ForAll d t1)) Gamma)) ∥).
    change (STFVarT y) with (| PFVarT y |).
    rewrite <- open_rec_typ_eq_source.
    rewrite <- open_rec_typ_eq_source.
    apply H0.
    not_in_L y.
    apply WFPushV.
    apply WFPushT.
    auto.
    not_in_L x.
    not_in_L y.
    simpl.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.add_iff in HH.
    destruct HH; subst.
    not_in_L y.
    exfalso; apply H25; now apply MSetProperties.Dec.F.singleton_2.
    not_in_L y.
    unfold extend.
    apply wf_weaken_source.
    apply H7.
    not_in_L y.
    apply WFPushV.
    apply WFPushT.
    auto.
    not_in_L x.
    not_in_L y.
    simpl.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.add_iff in HH.
    destruct HH; subst.
    not_in_L y.
    exfalso; apply H25; now apply MSetProperties.Dec.F.singleton_2.
    not_in_L y.
    apply wf_weaken_source.
    apply H12.
    not_in_L y.
    apply WFPushV.
    apply WFPushT.
    auto.
    not_in_L x.
    not_in_L y.
    not_in_L y.
    not_in_L x.
    assert (Ha : not (In y L)) by not_in_L y.
    apply H in Ha.
    now apply coercions_produce_terms in Ha.
    apply STTyTApp.
    apply WFType_Var.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    unfold extend; not_in_L y.
    not_in_L x.
    left; auto.
    apply STTyVar.
    apply WFTyp_to_WFType in H2.
    repeat apply wf_weaken_extend.
    subst; apply H2.
    not_in_L x.
    unfold extend; not_in_L y.
    not_in_L x.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    unfold extend; not_in_L y.
    not_in_L x.
    right; left; auto.
    subst; now apply WFTyp_to_WFType in H2.
    subst; inversion H8.
    subst.

    inversion H2; inversion H3; subst.
    inversion H14.
    inversion H9.
    inversion H12.
    apply_fresh STTyLam as x.
    unfold open; simpl.
    apply_fresh STTyTLam as y.
    unfold open_typ_term; simpl.
    apply STTyApp with (A := (open_typ (| t1 |) (STFVarT y))).
    rewrite open_comm_open_typ_term.
    rewrite <- open_rec_term.
    unfold open_typ; simpl.
    unfold open_typ_source in H0; simpl in H0.
    subst.
    change (extend y (TyVar STyp)
                   (extend x (TermVar STyp (STForAll (| t1 |))) (∥ Gamma ∥))) with
    (∥ (extend y (TyDis Bot)
               (extend x (TermV (ForAll Bot t1)) Gamma)) ∥).
    change (STFVarT y) with (| PFVarT y |).
    rewrite <- open_rec_typ_eq_source.
    rewrite <- open_rec_typ_eq_source.
    apply H0.
    not_in_L y.
    apply WFPushV.
    apply WFPushT.
    auto.
    not_in_L x.
    not_in_L y.
    inversion H8.
    simpl.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.add_iff in HH.
    destruct HH; subst.
    not_in_L y.
    exfalso; apply H14; now apply MSetProperties.Dec.F.singleton_2.
    not_in_L y.
    unfold extend.
    apply wf_weaken_source.
    apply H6.
    not_in_L y.
    apply WFPushV.
    apply WFPushT.
    auto.
    not_in_L x.
    not_in_L y.
    inversion H8.
    simpl.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.add_iff in HH.
    destruct HH; subst.
    not_in_L y.
    exfalso; apply H14; now apply MSetProperties.Dec.F.singleton_2.
    not_in_L y.
    apply wf_weaken_source.
    apply H10.
    not_in_L y.
    apply WFPushV.
    apply WFPushT.
    auto.
    not_in_L x.
    unfold not; intros HH; inversion HH.
    not_in_L y.
    not_in_L y.
    not_in_L x.
    assert (Ha : not (In y L)) by not_in_L y.
    apply H in Ha.
    now apply coercions_produce_terms in Ha.
    apply STTyTApp.
    apply WFType_Var.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    (* TODO add this to not_in_L *)
    unfold conv_context in H4; rewrite <- dom_map_id in H4; contradiction.
    unfold extend; not_in_L y.
    not_in_L x.
    unfold conv_context in H8; rewrite <- dom_map_id in H8; contradiction.
    left; auto.
    apply STTyVar.
    apply WFTyp_to_WFType in H2.
    repeat apply wf_weaken_extend.
    subst; apply H2.
    not_in_L x.
    unfold conv_context in H4; rewrite <- dom_map_id in H4; contradiction.
    unfold extend; not_in_L y.
    not_in_L x.
    unfold conv_context in H8; rewrite <- dom_map_id in H8; contradiction.
    apply Ok_push.
    apply Ok_push.
    subst; auto.
    not_in_L x.
    unfold conv_context in H4; rewrite <- dom_map_id in H4; contradiction.
    unfold extend; not_in_L y.
    not_in_L x.
    unfold conv_context in H8; rewrite <- dom_map_id in H8; contradiction.
    right; left; auto.
    subst; now apply WFTyp_to_WFType in H2.
Qed.

(* Type preservation: Theorem 1 *)
Lemma type_preservation :
  forall x ty dir E (Gamma : context TyEnvSource) (H : has_type_source_alg Gamma x dir ty E),
  has_type_st (∥ Gamma ∥) E (|ty|).
Proof.
  intros.
  induction H; subst; auto.
  (* TyVar *)
  - apply STTyVar.
    now apply WFTyp_to_WFType.
    auto.
    now apply in_persists in H0.
  (* TyApp *)
  - simpl in *.
    apply STTyApp with (A := |A|).
    assumption.
    assumption.
  (* TyMerge *)
  - simpl; apply STTyPair; assumption.
  (* TyTApp *)
  - simpl in *.
    unfold open_typ_source; rewrite open_rec_typ_eq_source.
    apply STTyTApp.
    now apply WFTyp_to_WFType.
    apply IHhas_type_source_alg.
  (* TyLam *)
  - simpl.
    apply_fresh STTyLam as x.
    unfold open; simpl.
    assert (Ha : not (M.In x L)).
    not_in_L x.
    apply H0 in Ha.
    simpl in *.
    unfold extend.
    simpl.
    apply Ha.
    now apply WFTyp_to_WFType.
  (* ATySub *)
  - apply STTyApp with (|A|).
    apply type_correct_coercions.
    assumption.
    now apply typing_alg_wf_env in H.
    now apply typing_wf_source_alg in H.
    assumption.
    assumption.
  (* ATyTLam *)
  - simpl; apply_fresh STTyTLam as x.
    simpl in *.
    unfold open_typ.
    change (STFVarT x) with (| PFVarT x |).
    rewrite <- open_rec_typ_eq_source.
    apply H1.
    not_in_L x.
  (* ATyTLamBot *)
  - simpl; apply_fresh STTyTLam as x.
    simpl in *.
    unfold open_typ.
    change (STFVarT x) with (| PFVarT x |).
    rewrite <- open_rec_typ_eq_source.
    apply H0.
    not_in_L x.
Qed.

End Extended.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(*********************************************************)
(**     Definition of the derivative,continuity          *)
(*                                                       *)
(*********************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rlimit.
Require Import Lra.
Require Import Omega.
Local Open Scope R_scope.

(*********)
Definition D_x (D:R -> Prop) (y x:R) : Prop := D x /\ y <> x.

(*********)
Definition continue_in (f:R -> R) (D:R -> Prop) (x0:R) : Prop :=
  limit1_in f (D_x D x0) (f x0) x0.

(*********)
Definition D_in (f d:R -> R) (D:R -> Prop) (x0:R) : Prop :=
  limit1_in (fun x:R => (f x - f x0) / (x - x0)) (D_x D x0) (d x0) x0.

(*********)
Lemma cont_deriv :
  forall (f d:R -> R) (D:R -> Prop) (x0:R),
    D_in f d D x0 -> continue_in f D x0.
Proof.
  unfold continue_in; unfold D_in; unfold limit1_in;
    unfold limit_in; unfold Rdiv; simpl;
      intros; elim (H eps H0); clear H; intros; elim H;
        clear H; intros; elim (Req_dec (d x0) 0); intro.
  split with (Rmin 1 x); split.
  elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)).
  intros; elim H3; clear H3; intros;
    generalize (let (H1, H2) := Rmin_Rgt 1 x (R_dist x1 x0) in H1);
      unfold Rgt; intro; elim (H5 H4); clear H5;
        intros; generalize (H1 x1 (conj H3 H6)); clear H1;
          intro; unfold D_x in H3; elim H3; intros.
  rewrite H2 in H1; unfold R_dist; unfold R_dist in H1;
    cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)).
  intro; unfold R_dist in H5;
    generalize (Rmult_lt_compat_l eps (Rabs (x1 - x0)) 1 H0 H5);
      rewrite Rmult_1_r; intro; apply Rlt_trans with (r2 := eps * Rabs (x1 - x0));
        assumption.
  rewrite (Rminus_0_r ((f x1 - f x0) * / (x1 - x0))) in H1;
    rewrite Rabs_mult in H1; cut (x1 - x0 <> 0).
  intro; rewrite (Rabs_Rinv (x1 - x0) H9) in H1;
    generalize
      (Rmult_lt_compat_l (Rabs (x1 - x0)) (Rabs (f x1 - f x0) * / Rabs (x1 - x0))
        eps (Rabs_pos_lt (x1 - x0) H9) H1); intro; rewrite Rmult_comm in H10;
      rewrite Rmult_assoc in H10; rewrite Rinv_l in H10.
  rewrite Rmult_1_r in H10; rewrite Rmult_comm; assumption.
  apply Rabs_no_R0; auto.
  apply Rminus_eq_contra; auto.
(**)
  split with (Rmin (Rmin (/ 2) x) (eps * / Rabs (2 * d x0))); split.
  cut (Rmin (/ 2) x > 0).
  cut (eps * / Rabs (2 * d x0) > 0).
  intros; elim (Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) 0);
    intros a b; apply (b (conj H4 H3)).
  apply Rmult_gt_0_compat; auto.
  unfold Rgt; apply Rinv_0_lt_compat; apply Rabs_pos_lt;
    apply Rmult_integral_contrapositive; split.
  discrR.
  assumption.
  elim (Rmin_Rgt (/ 2) x 0); intros a b; cut (0 < 2).
  intro; generalize (Rinv_0_lt_compat 2 H3); intro; fold (/ 2 > 0) in H4;
    apply (b (conj H4 H)).
  lra.
  intros; elim H3; clear H3; intros;
    generalize
      (let (H1, H2) :=
        Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (R_dist x1 x0) in
        H1); unfold Rgt; intro; elim (H5 H4); clear H5;
      intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (R_dist x1 x0) in H1);
        unfold Rgt; intro; elim (H7 H5); clear H7;
          intros; clear H4 H5; generalize (H1 x1 (conj H3 H8));
            clear H1; intro; unfold D_x in H3; elim H3; intros;
              generalize (not_eq_sym H5); clear H5; intro H5;
                generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1;
                  pattern (d x0) at 1;
                    rewrite <- (let (H1, H2) := Rmult_ne (d x0) in H2);
                      rewrite <- (Rinv_l (x1 - x0) H9); unfold R_dist;
                        unfold Rminus at 1; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0)));
                          rewrite (Rmult_comm (/ (x1 - x0) * (x1 - x0)) (d x0));
                            rewrite <- (Ropp_mult_distr_l_reverse (d x0) (/ (x1 - x0) * (x1 - x0)));
                              rewrite (Rmult_comm (- d x0) (/ (x1 - x0) * (x1 - x0)));
                                rewrite (Rmult_assoc (/ (x1 - x0)) (x1 - x0) (- d x0));
                                  rewrite <-
                                    (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) ((x1 - x0) * - d x0))
                                    ; rewrite (Rabs_mult (/ (x1 - x0)) (f x1 - f x0 + (x1 - x0) * - d x0));
                                      clear H1; intro;
                                        generalize
                                          (Rmult_lt_compat_l (Rabs (x1 - x0))
                                            (Rabs (/ (x1 - x0)) * Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) eps
                                            (Rabs_pos_lt (x1 - x0) H9) H1);
                                          rewrite <-
                                            (Rmult_assoc (Rabs (x1 - x0)) (Rabs (/ (x1 - x0)))
                                              (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)));
                                            rewrite (Rabs_Rinv (x1 - x0) H9);
                                              rewrite (Rinv_r (Rabs (x1 - x0)) (Rabs_no_R0 (x1 - x0) H9));
                                                rewrite
                                                  (let (H1, H2) := Rmult_ne (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) in H2)
                                                  ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0));
                                                    intro; rewrite (Rmult_comm (x1 - x0) (- d x0));
                                                      rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0));
                                                        fold (f x1 - f x0 - d x0 * (x1 - x0));
                                                          rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1;
                                                            intro;
                                                              generalize
                                                                (Rle_lt_trans (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0)))
                                                                  (Rabs (f x1 - f x0 - d x0 * (x1 - x0))) (Rabs (x1 - x0) * eps) H10 H1);
                                                                clear H1; intro;
                                                                  generalize
                                                                    (Rplus_lt_compat_l (Rabs (d x0 * (x1 - x0)))
                                                                      (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) (
                                                                        Rabs (x1 - x0) * eps) H1); unfold Rminus at 2;
                                                                    rewrite (Rplus_comm (Rabs (f x1 - f x0)) (- Rabs (d x0 * (x1 - x0))));
                                                                      rewrite <-
                                                                        (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0)))
                                                                          (Rabs (f x1 - f x0))); rewrite (Rplus_opp_r (Rabs (d x0 * (x1 - x0))));
                                                                        rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2);
                                                                          clear H1; intro; cut (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps < eps).
  intro;
    apply
      (Rlt_trans (Rabs (f x1 - f x0))
        (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11).
  clear H1 H5 H3 H10; generalize (Rabs_pos_lt (d x0) H2); intro;
    unfold Rgt in H0;
      generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7);
        clear H7; intro;
          generalize
            (Rmult_lt_compat_l (Rabs (d x0)) (R_dist x1 x0) (
              eps * / Rabs (2 * d x0)) H1 H6); clear H6; intro;
            rewrite (Rmult_comm eps (R_dist x1 x0)) in H3; unfold R_dist in H3, H5;
              rewrite <- (Rabs_mult (d x0) (x1 - x0)) in H5;
                rewrite (Rabs_mult 2 (d x0)) in H5; cut (Rabs 2 <> 0).
  intro; fold (Rabs (d x0) > 0) in H1;
    rewrite
      (Rinv_mult_distr (Rabs 2) (Rabs (d x0)) H6
        (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
      in H5;
      rewrite (Rmult_comm (Rabs (d x0)) (eps * (/ Rabs 2 * / Rabs (d x0)))) in H5;
        rewrite <- (Rmult_assoc eps (/ Rabs 2) (/ Rabs (d x0))) in H5;
          rewrite (Rmult_assoc (eps * / Rabs 2) (/ Rabs (d x0)) (Rabs (d x0))) in H5;
            rewrite
              (Rinv_l (Rabs (d x0))
                (Rlt_dichotomy_converse (Rabs (d x0)) 0 (or_intror (Rabs (d x0) < 0) H1)))
              in H5; rewrite (let (H1, H2) := Rmult_ne (eps * / Rabs 2) in H1) in H5;
                cut (Rabs 2 = 2).
  intro; rewrite H7 in H5;
    generalize
      (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2)
        (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro;
      rewrite eps2 in H10; assumption.
  unfold Rabs; destruct (Rcase_abs 2) as [Hlt|Hge]; auto.
  cut (0 < 2).
  intro H7; elim (Rlt_asym 0 2 H7 Hlt).
  lra.
  apply Rabs_no_R0.
  discrR.
Qed.

(*********)
Lemma Dconst :
  forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0.
Proof.
  unfold D_in; intros; unfold limit1_in;
    unfold limit_in; unfold Rdiv; intros;
      simpl; split with eps; split; auto.
  intros; rewrite (Rminus_diag_eq y y (eq_refl y)); rewrite Rmult_0_l;
    unfold R_dist; rewrite (Rminus_diag_eq 0 0 (eq_refl 0));
      unfold Rabs; case (Rcase_abs 0); intro.
  absurd (0 < 0); auto.
  red; intro; apply (Rlt_irrefl 0 H1).
  unfold Rgt in H0; assumption.
Qed.

(*********)
Lemma Dx :
  forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0.
Proof.
  unfold D_in; unfold Rdiv; intros; unfold limit1_in;
    unfold limit_in; intros; simpl; split with eps;
      split; auto.
  intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros;
    rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3)));
      unfold R_dist; rewrite (Rminus_diag_eq 1 1 (refl_equal 1));
        unfold Rabs; case (Rcase_abs 0) as [Hlt|Hge].
  absurd (0 < 0); auto.
  red in |- *; intro; apply (Rlt_irrefl 0 Hlt).
  unfold Rgt in H; assumption.
Qed.

(*********)
Lemma Dadd :
  forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
    D_in f df D x0 ->
    D_in g dg D x0 ->
    D_in (fun x:R => f x + g x) (fun x:R => df x + dg x) D x0.
Proof.
  unfold D_in; intros;
    generalize
      (limit_plus (fun x:R => (f x - f x0) * / (x - x0))
        (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) (
          df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in;
      unfold limit_in; simpl; intros; elim (H eps H0);
        clear H; intros; elim H; clear H; intros; split with x;
          split; auto; intros; generalize (H1 x1 H2); clear H1;
            intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
              rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
                rewrite <- (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) (g x1 - g x0))
                  in H1;
                  rewrite (Rmult_comm (/ (x1 - x0)) (f x1 - f x0 + (g x1 - g x0))) in H1;
                    cut (f x1 - f x0 + (g x1 - g x0) = f x1 + g x1 - (f x0 + g x0)).
  intro; rewrite H3 in H1; assumption.
  ring.
Qed.

(*********)
Lemma Dmult :
  forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
    D_in f df D x0 ->
    D_in g dg D x0 ->
    D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0.
Proof.
  intros; unfold D_in; generalize H H0; intros; unfold D_in in H, H0;
    generalize (cont_deriv f df D x0 H1); unfold continue_in;
      intro;
        generalize
          (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) (
            fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3);
          intro; cut (limit1_in (fun x:R => g x0) (D_x D x0) (g x0) x0).
  intro;
    generalize
      (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
        fun _:R => g x0) (D_x D x0) (df x0) (g x0) x0 H H5);
      clear H H0 H1 H2 H3 H5; intro;
        generalize
          (limit_plus (fun x:R => (f x - f x0) * / (x - x0) * g x0)
            (fun x:R => (g x - g x0) * / (x - x0) * f x) (
              D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4);
          clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H;
            simpl in H; unfold limit1_in; unfold limit_in;
              simpl; intros; elim (H eps H0); clear H; intros;
                elim H; clear H; intros; split with x; split; auto;
                  intros; generalize (H1 x1 H2); clear H1; intro;
                    rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
                      rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1;
                        rewrite (Rmult_assoc (/ (x1 - x0)) (f x1 - f x0) (g x0)) in H1;
                          rewrite (Rmult_assoc (/ (x1 - x0)) (g x1 - g x0) (f x1)) in H1;
                            rewrite <-
                              (Rmult_plus_distr_l (/ (x1 - x0)) ((f x1 - f x0) * g x0)
                                ((g x1 - g x0) * f x1)) in H1;
                              rewrite
                                (Rmult_comm (/ (x1 - x0)) ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1))
                                in H1; rewrite (Rmult_comm (dg x0) (f x0)) in H1;
                                  cut
                                    ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1 = f x1 * g x1 - f x0 * g x0).
  intro; rewrite H3 in H1; assumption.
  ring.
  unfold limit1_in; unfold limit_in; simpl; intros;
    split with eps; split; auto; intros; elim (R_dist_refl (g x0) (g x0));
      intros a b; rewrite (b (eq_refl (g x0))); unfold Rgt in H;
        assumption.
Qed.

(*********)
Lemma Dmult_const :
  forall (D:R -> Prop) (f df:R -> R) (x0 a:R),
    D_in f df D x0 -> D_in (fun x:R => a * f x) (fun x:R => a * df x) D x0.
Proof.
  intros;
    generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H);
      unfold D_in; intros; rewrite (Rmult_0_l (f x0)) in H0;
        rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0;
          assumption.
Qed.

(*********)
Lemma Dopp :
  forall (D:R -> Prop) (f df:R -> R) (x0:R),
    D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0.
Proof.
  intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in;
    unfold limit1_in; unfold limit_in;
      intros; generalize (H0 eps H1); clear H0; intro; elim H0;
        clear H0; intros; elim H0; clear H0; simpl;
          intros; split with x; split; auto.
  intros; generalize (H2 x1 H3); clear H2; intro.
  replace (- f x1 - - f x0) with (-1 * f x1 - -1 * f x0) by ring.
  replace (- df x0) with (-1 * df x0) by ring.
  exact H2.
Qed.

(*********)
Lemma Dminus :
  forall (D:R -> Prop) (df dg f g:R -> R) (x0:R),
    D_in f df D x0 ->
    D_in g dg D x0 ->
    D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0.
Proof.
  unfold Rminus; intros; generalize (Dopp D g dg x0 H0); intro;
    apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0);
      assumption.
Qed.

(*********)
Lemma Dx_pow_n :
  forall (n:nat) (D:R -> Prop) (x0:R),
    D_in (fun x:R => x ^ n) (fun x:R => INR n * x ^ (n - 1)) D x0.
Proof.
  simple induction n; intros.
  simpl; rewrite Rmult_0_l; apply Dconst.
  intros; cut (n0 = (S n0 - 1)%nat);
    [ intro a; rewrite <- a; clear a | simpl; apply minus_n_O ].
  generalize
    (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) (
      fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) (
        H D x0)); unfold D_in; unfold limit1_in;
    unfold limit_in; simpl; intros; elim (H0 eps H1);
      clear H0; intros; elim H0; clear H0; intros; split with x;
        split; auto.
  intros; generalize (H2 x1 H3); clear H2 H3; intro;
    rewrite (let (H1, H2) := Rmult_ne (x0 ^ n0) in H2) in H2;
      rewrite (tech_pow_Rmult x1 n0) in H2; rewrite (tech_pow_Rmult x0 n0) in H2;
        rewrite (Rmult_comm (INR n0) (x0 ^ (n0 - 1))) in H2;
          rewrite <- (Rmult_assoc x0 (x0 ^ (n0 - 1)) (INR n0)) in H2;
            rewrite (tech_pow_Rmult x0 (n0 - 1)) in H2; elim (Peano_dec.eq_nat_dec n0 0) ; intros cond.
  rewrite cond in H2; rewrite cond; simpl in H2; simpl;
    cut (1 + x0 * 1 * 0 = 1 * 1);
      [ intro A; rewrite A in H2; assumption | ring ].
  cut (n0 <> 0%nat -> S (n0 - 1) = n0); [ intro | omega ];
    rewrite (H3 cond) in H2; rewrite (Rmult_comm (x0 ^ n0) (INR n0)) in H2;
      rewrite (tech_pow_Rplus x0 n0 n0) in H2; assumption.
Qed.

(*********)
Lemma Dcomp :
  forall (Df Dg:R -> Prop) (df dg f g:R -> R) (x0:R),
    D_in f df Df x0 ->
    D_in g dg Dg (f x0) ->
    D_in (fun x:R => g (f x)) (fun x:R => df x * dg (f x)) (Dgf Df Dg f) x0.
Proof.
  intros Df Dg df dg f g x0 H H0; generalize H H0; unfold D_in;
    unfold Rdiv; intros;
      generalize
        (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) (
          D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0);
        intro; generalize (cont_deriv f df Df x0 H); intro;
          unfold continue_in in H4; generalize (H3 H4 H2); clear H3;
            intro;
              generalize
                (limit_mul (fun x:R => (g (f x) - g (f x0)) * / (f x - f x0))
                  (fun x:R => (f x - f x0) * / (x - x0))
                  (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (dg (f x0)) (
                    df x0) x0 H3); intro;
                cut
                  (limit1_in (fun x:R => (f x - f x0) * / (x - x0))
                    (Dgf (D_x Df x0) (D_x Dg (f x0)) f) (df x0) x0).
  intro; generalize (H5 H6); clear H5; intro;
    generalize
      (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
        fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1
      (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0));
      intro; unfold limit1_in; unfold limit_in;
        simpl; unfold limit1_in in H5, H7; unfold limit_in in H5, H7;
          simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8);
            clear H5 H7; intros; elim H5; elim H7; clear H5 H7;
              intros; split with (Rmin x x1); split.
  elim (Rmin_Rgt x x1 0); intros a b; apply (b (conj H9 H5)); clear a b.
  intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (R_dist x2 x0));
    intros a b; clear b; unfold Rgt in a; elim (a H12);
      clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10;
        clear H12; elim (Req_dec (f x2) (f x0)); intro.
  elim H11; clear H11; intros; elim H11; clear H11; intros;
    generalize (H10 x2 (conj (conj H11 H14) H5)); intro;
      rewrite (Rminus_diag_eq (f x2) (f x0) H12) in H16;
        rewrite (Rmult_0_l (/ (x2 - x0))) in H16;
          rewrite (Rmult_0_l (dg (f x0))) in H16; rewrite H12;
            rewrite (Rminus_diag_eq (g (f x0)) (g (f x0)) (eq_refl (g (f x0))));
              rewrite (Rmult_0_l (/ (x2 - x0))); assumption.
  clear H10 H5; elim H11; clear H11; intros; elim H5; clear H5; intros;
    cut
      (((Df x2 /\ x0 <> x2) /\ Dg (f x2) /\ f x0 <> f x2) /\ R_dist x2 x0 < x1);
      auto; intro; generalize (H7 x2 H14); intro;
        generalize (Rminus_eq_contra (f x2) (f x0) H12); intro;
          rewrite
            (Rmult_assoc (g (f x2) - g (f x0)) (/ (f x2 - f x0))
              ((f x2 - f x0) * / (x2 - x0))) in H15;
            rewrite <- (Rmult_assoc (/ (f x2 - f x0)) (f x2 - f x0) (/ (x2 - x0)))
              in H15; rewrite (Rinv_l (f x2 - f x0) H16) in H15;
                rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15;
                  rewrite (Rmult_comm (df x0) (dg (f x0))); assumption.
  clear H5 H3 H4 H2; unfold limit1_in; unfold limit_in;
    simpl; unfold limit1_in in H1; unfold limit_in in H1;
      simpl in H1; intros; elim (H1 eps H2); clear H1; intros;
        elim H1; clear H1; intros; split with x; split; auto;
          intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4;
            intros; elim H4; clear H4; intros; exact (H3 x1 (conj H4 H5)).
Qed.

(*********)
Lemma D_pow_n :
  forall (n:nat) (D:R -> Prop) (x0:R) (expr dexpr:R -> R),
    D_in expr dexpr D x0 ->
    D_in (fun x:R => expr x ^ n)
    (fun x:R => INR n * expr x ^ (n - 1) * dexpr x) (
      Dgf D D expr) x0.
Proof.
  intros n D x0 expr dexpr H;
    generalize
      (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr (
        fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0)));
      intro; unfold D_in; unfold limit1_in;
        unfold limit_in; simpl; intros; unfold D_in in H0;
          unfold limit1_in in H0; unfold limit_in in H0; simpl in H0;
            elim (H0 eps H1); clear H0; intros; elim H0; clear H0;
              intros; split with x; split; intros; auto.
  cut
    (dexpr x0 * (INR n * expr x0 ^ (n - 1)) =
      INR n * expr x0 ^ (n - 1) * dexpr x0);
    [ intro Rew; rewrite <- Rew; exact (H2 x1 H3) | ring ].
Qed.