Require Export trigo.
Set  Implicit Arguments.
Unset Strict Implicit.
(* Formules de trigonometrie necessaires.*)

Lemma prod_sin:
 forall (a b : R),  2 * (sin (a + b) * sin (a - b)) = cos (2 * b) - cos (2 * a).
intros.
assert
 (cos ((a + b) + (a - b)) =
  cos (a + b) * cos (a - b) - sin (a + b) * sin (a - b)).
rewrite cos_som; auto.
assert
 (cos ((a + b) - (a - b)) =
  cos (a + b) * cos (a - b) + sin (a + b) * sin (a - b)).
rewrite <- cos_diff; auto.
assert
 (2 * (sin (a + b) * sin (a - b)) =
  cos ((a + b) - (a - b)) - cos ((a + b) + (a - b))).
rewrite H0; rewrite H.
ring.
rewrite H1.
RReplace ((a + b) - (a - b)) (2 * b).
RReplace ((a + b) + (a - b)) (2 * a); auto.
Qed.

Lemma sin_3_a: forall (a : R),  sin (3 * a) = sin a * (2 * cos (2 * a) + 1).
intros.
RReplace (3 * a) (a + 2 * a).
rewrite sin_som.
rewrite duplication_sin.
RReplace (sin a * cos (2 * a) + (2 * (sin a * cos a)) * cos a)
         (sin a * (cos (2 * a) + 2 * (cos a * cos a))).
assert (2 * Rsqr (cos a) = cos (2 * a) + 1).
rewrite duplication_cos.
ring.
RReplace (cos a * cos a) (Rsqr (cos a)).
rewrite H.
ring.
Qed.

Lemma Al_Kashi_sin_cos:
 forall (a b c : R),
 (a + b) + c = pi ->
  Rsqr (sin c) = (Rsqr (sin a) + Rsqr (sin b)) - ((2 * sin a) * sin b) * cos c.
intros.
RReplace ((Rsqr (sin a) + Rsqr (sin b)) - ((2 * sin a) * sin b) * cos c)
         (((Rsqr (sin a) * Rsqr (cos c) + Rsqr (sin b)) -
           ((2 * sin a) * sin b) * cos c) - Rsqr (sin a) * (Rsqr (cos c) - 1)).
replace
 ((Rsqr (sin a) * Rsqr (cos c) + Rsqr (sin b)) - ((2 * sin a) * sin b) * cos c)
     with (Rsqr (sin a * cos c - sin b)).
2:unfold Rsqr; ring.
rewrite <- (trigo_Pythagore c).
RReplace (Rsqr (cos c) - (Rsqr (cos c) + Rsqr (sin c))) (- Rsqr (sin c)).
elim pi_moins_x with ( x := a + c ); [intros H0 H1].
replace b with (pi + - (a + c)).
rewrite H1.
rewrite sin_som.
RReplace (sin a * cos c - (sin a * cos c + sin c * cos a)) (- (sin c * cos a)).
replace (Rsqr (- (sin c * cos a))) with (Rsqr (sin c) * Rsqr (cos a)).
2:unfold Rsqr; ring.
RReplace (Rsqr (sin c) * Rsqr (cos a) - Rsqr (sin a) * - Rsqr (sin c))
         (Rsqr (sin c) * (Rsqr (cos a) + Rsqr (sin a))).
rewrite trigo_Pythagore.
ring.
rewrite <- H; ring.
Qed.
(* Definition de pisurtrois et formules de trigonometrie.*)
Parameter pisurtrois : R.

Axiom pisurtrois_def : 3 * pisurtrois = pi.

Axiom sin_pisurtrois_non_zero : sin pisurtrois <> 0.

Lemma cos_2_pisurtrois: 2 * cos (2 * pisurtrois) + 1 = 0.
RReplace (2 * cos (2 * pisurtrois) + 1) (sin pi * / sin pisurtrois).
rewrite sin_pi; ring.
rewrite <- pisurtrois_def.
rewrite sin_3_a.
field.
apply sin_pisurtrois_non_zero.
Qed.

Lemma sin_3_a_pisurtrois:
 forall (a : R),
  sin (3 * a) = 4 * (sin a * (sin (pisurtrois + a) * sin (pisurtrois - a))).
intros.
rewrite sin_3_a.
RReplace (4 * (sin a * (sin (pisurtrois + a) * sin (pisurtrois - a))))
         ((2 * sin a) * (2 * (sin (pisurtrois + a) * sin (pisurtrois - a)))).
rewrite prod_sin.
RReplace ((2 * sin a) * (cos (2 * a) - cos (2 * pisurtrois)))
         (sin a * (2 * cos (2 * a) - 2 * cos (2 * pisurtrois))).
assert (2 * cos (2 * pisurtrois) = - 1).
RReplace (- 1) (- 1 + 0).
rewrite <- cos_2_pisurtrois.
ring.
rewrite H.
ring.
Qed.

Lemma Al_Kashi_pisurtrois:
 forall a b c,
 (a + b) + c = pisurtrois ->
  Rsqr (sin b) =
  (Rsqr (sin (pisurtrois + a)) + Rsqr (sin (pisurtrois + c))) -
  ((2 * sin (pisurtrois + a)) * sin (pisurtrois + c)) * cos b.
intros.
apply Al_Kashi_sin_cos.
rewrite <- pisurtrois_def.
RReplace (((pisurtrois + a) + (pisurtrois + c)) + b)
         (((a + b) + c) + (pisurtrois + pisurtrois)).
rewrite H; ring.
Qed.
Require Export cocyclicite.
(* lemme a mettre dans distance_euclidienne apres colinearite_distance*)

Lemma distance_double_milieu:
 forall (B C A' : PO), A' = milieu B C ->  distance B C = 2 * distance A' C.
intros.
rewrite <- (milieu_distance H); auto.
assert (vec B C = mult_PP 2 (vec B A')).
apply milieu_vecteur_double; auto.
rewrite (distance_sym A' B).
RReplace 2 (Rabs 2).
apply colinearite_distance; auto.
rewrite Rabs_right; auto.
lra.
Qed.
(* corollaire du theoreme de l'angle inscrit et de l'angle au centre
   on utilise le triangle rectangle forme par un cote et sa mediatrice*)

Lemma demi_angle_centre:
 forall (A B C A' O : PO),
 triangle A B C ->
 O <> A' ->
 A' = milieu B C ->
 circonscrit O A B C ->
  double_AV (cons_AV (vec A B) (vec A C)) =
  double_AV (cons_AV (vec O A') (vec O C)).
intros.
deroule_triangle A B C.
deroule_circonscrit A B C O.
assert (double_AV (cons_AV (vec A B) (vec A C)) = cons_AV (vec O B) (vec O C)).
apply angle_inscrit; auto.
rewrite H10.
assert (double_AV (cons_AV (vec O A') (vec O C)) = cons_AV (vec O B) (vec O C)).
unfold double_AV.
replace (cons_AV (vec O B) (vec O C))
     with (plus (cons_AV (vec O B) (vec O A')) (cons_AV (vec O A') (vec O C))).
assert (cons_AV (vec O B) (vec O A') = cons_AV (vec O A') (vec O C)).
apply isocele_mediane_bissectrice; auto.
apply (circonscrit_isocele H2).
rewrite H11; auto.
apply Chasles; auto.
rewrite H11; auto.
Qed.
(*deux angles ayant des mesures differant d'un multiple de pi ont des sinus egaux ou opposes*)

Axiom
   egalite_double_abs_Sin :
   forall A B C E F G,
   double_AV (cons_AV (vec A B) (vec A C)) =
   double_AV (cons_AV (vec E F) (vec E G)) ->
    Rabs (Sin (cons_AV (vec A B) (vec A C))) =
    Rabs (Sin (cons_AV (vec E F) (vec E G))).

Require Export complements_cercle.
(* theoreme : dans un triangle avec les notations habituelles  a = 2 R sin A
   cas particulier : le cote est un diametre du cercle circonscrit*)

Lemma diametre_Sinus:
 forall (A B C O : PO),
 triangle A B C ->
 O = milieu B C ->
 circonscrit O A B C ->
  distance B C = 2 * (distance O C * Rabs (Sin (cons_AV (vec A B) (vec A C)))).
intros.
assert (orthogonal (vec A B) (vec A C)).
apply triangle_diametre with O; auto.
deroule_triangle A B C.
elim droit_direct_ou_indirect with ( A := A ) ( B := B ) ( C := C );
 (intros; auto).
rewrite <- (egalite_sin_Sin (A:=A) (B:=B) (C:=C) (x:=pisurdeux)); auto.
rewrite sin_pisurdeux.
rewrite Rabs_right; auto.
rewrite (distance_double_milieu H0); ring.
lra.
rewrite <- (egalite_sin_Sin (A:=A) (B:=B) (C:=C) (x:=- pisurdeux)); auto.
rewrite sin_impaire.
rewrite sin_pisurdeux.
rewrite Rabs_left; auto.
rewrite (distance_double_milieu H0); ring.
lra.
Qed.
(* cas general*)

Lemma rayon_Sinus_general:
 forall (A B C A' O : PO),
 triangle A B C ->
 O <> A' ->
 A' = milieu B C ->
 circonscrit O A B C ->
  distance B C = 2 * (distance O C * Rabs (Sin (cons_AV (vec A B) (vec A C)))).
intros.
deroule_triangle A B C.
deroule_circonscrit A B C O.
assert (orthogonal (vec O A') (vec B C)).
apply milieu_centrecirconscrit_orthogonal_segment with A; auto.
rewrite (distance_double_milieu H1).
replace (distance O C * Rabs (Sin (cons_AV (vec A B) (vec A C))))
     with (distance C O * Rabs (Sin (cons_AV (vec O A') (vec O C)))).
rewrite <- triangle_rectangle_absolu_Sin; auto.
rewrite (distance_sym A' C); auto.
rewrite H1.
generalize (milieu_distinct2 H5); auto.
apply ortho_sym.
rewrite <- (milieu_vecteur H1); auto.
rewrite (milieu_vecteur2 H1); auto.
Simplortho.
rewrite distance_sym.
assert
 (double_AV (cons_AV (vec A B) (vec A C)) =
  double_AV (cons_AV (vec O A') (vec O C))).
apply demi_angle_centre; auto.
rewrite (egalite_double_abs_Sin H11); auto.
Qed.
(* Ce theoreme montre que dans un triangle  a = 2R sin A  avec les notations habituelles.*)

Theorem rayon_Sinus:
 forall A B C O,
 triangle A B C ->
 circonscrit O A B C ->
  distance B C = 2 * (distance O C * Rabs (Sin (cons_AV (vec A B) (vec A C)))).
intros.
deroule_triangle A B C.
soit_milieu B C A'.
elim (classic (A' = O)); intros.
apply diametre_Sinus; auto.
rewrite <- H8; auto.
apply rayon_Sinus_general with A'; auto.
Qed.

Lemma existence_rayon_circonscrit:
 forall A B C,
 triangle A B C ->
  (exists O : PO , circonscrit O A B C /\ (exists r : R , r = distance O C ) ).
intros.
elim existence_cercle_circonscrit with ( A := A ) ( B := B ) ( C := C );
 [intros O H0; (try clear existence_cercle_circonscrit); (try exact H0) | auto].
exists O.
split; [try assumption | idtac].
exists (distance O C); auto.
Qed.

Ltac
soit_rayon_circonscrit A B C O r :=
elim (existence_rayon_circonscrit (A:=A) (B:=B) (C:=C)); [intros O | auto];
 intros toto; elim toto; clear toto; intro; intros toto; elim toto; clear toto;
 intros r; intro.
(* on doit pouvoir le demontrer*)

Axiom
   triangle_Sin_not_0 :
   forall A B C, triangle A B C ->  (Sin (cons_AV (vec A B) (vec A C)) <> 0).
#[export] Hint Resolve triangle_Sin_not_0 :geo.

Lemma triangle_abs_Sin_not_0:
 forall A B C,
 triangle A B C ->  (Rabs (Sin (cons_AV (vec A B) (vec A C))) <> 0).
intros.
apply Rabs_no_R0.
auto with geo.
Qed.
#[export] Hint Resolve triangle_abs_Sin_not_0 :geo.
(* Theoreme connu sous le nom de loi des Sinus.*)

Theorem loi_Sinus:
 forall A B C,
 triangle A B C ->
  and
   (distance B C / Rabs (Sin (cons_AV (vec A B) (vec A C))) =
    distance A B / Rabs (Sin (cons_AV (vec C A) (vec C B))))
   (distance B C / Rabs (Sin (cons_AV (vec A B) (vec A C))) =
    distance C A / Rabs (Sin (cons_AV (vec B C) (vec B A)))).
intros.
deroule_triangle A B C.
soit_rayon_circonscrit A B C D a.
rewrite (rayon_Sinus (A:=A) (B:=B) (C:=C) (O:=D)); auto.
rewrite <- H5; auto.
generalize H4; unfold circonscrit, isocele; intros.
elim H6; [intros H7 H8; (try clear H6); (try exact H8)].
split; [try assumption | idtac].
rewrite (rayon_Sinus (A:=C) (B:=A) (C:=B) (O:=D)); auto with geo.
rewrite <- H7; rewrite H8; rewrite H5.
field.
split; auto with geo.
apply circonscrit_permute; auto.
rewrite (rayon_Sinus (A:=B) (B:=C) (C:=A) (O:=D)); auto with geo.
rewrite H8; rewrite H5.
field.
split; auto with geo.
unfold circonscrit, isocele.
split; auto.
rewrite <- H7; rewrite H8; auto.
Qed.

Definition rayon_circonscrit (A B C : PO) (r : R) : Prop :=
   exists O : PO , circonscrit O A B C /\ r = distance O C .

Lemma triangle_sin_not_0:
 forall A B C x,
 triangle A B C -> image_angle x = cons_AV (vec A B) (vec A C) ->  (sin x <> 0).
intros.
deroule_triangle A B C.
rewrite (egalite_sin_Sin (A:=A) (B:=B) (C:=C) (x:=x)); auto.
auto with geo.
Qed.
(* consequence de l'enroulement de la droite des reels sur le cercle trigonometrique dans le sens positif*)

Axiom sin_pos : forall (x : R), ( 0 <= x <= pi ) ->  (sin x >= 0).

Axiom
   non_multiple_pi_triangle :
   forall a A B C,
   ( 0 < a < pi ) ->
   A <> B ->
   A <> C -> image_angle a = cons_AV (vec A B) (vec A C) ->  triangle A B C.
(* debut de la demonstration du theoreme de Morley*)

Lemma pisurtrois_utile:
 forall a b c,
 0 < a -> 0 < b -> 0 < c -> (a + b) + c = pisurtrois ->  ( 0 <= 3 * a <= pi ).
intros.
rewrite <- pisurtrois_def.
split.
lra.
lra.
Qed.

Lemma pisurtrois_utile1:
 forall a b c,
 0 < a -> 0 < b -> 0 < c -> (a + b) + c = pisurtrois ->  ( 0 <= b + c <= pi ).
intros.
rewrite <- pisurtrois_def.
split.
lra.
lra.
Qed.

Lemma pisurtrois_utile2:
 forall a b c,
 0 < a -> 0 < b -> 0 < c -> (a + b) + c = pisurtrois ->  ( 0 <= c <= pi ).
intros.
rewrite <- pisurtrois_def.
split.
lra.
lra.
Qed.
#[export] Hint Resolve pisurtrois_utile sin_pos pisurtrois_utile1 pisurtrois_utile2 :geo.

Lemma pisurtrois_triangle_utile:
 forall a b c A B C,
 0 < a ->
 0 < b ->
 0 < c ->
 (a + b) + c = pisurtrois ->
 A <> B ->
 A <> C -> image_angle (3 * a) = cons_AV (vec A B) (vec A C) ->  triangle A B C.
intros.
apply non_multiple_pi_triangle with (3 * a); auto.
rewrite <- pisurtrois_def.
split.
lra.
lra.
Qed.

Lemma pisurtrois_triangle_utile2:
 forall a b c B C P,
 0 < a ->
 0 < b ->
 0 < c ->
 (a + b) + c = pisurtrois ->
 B <> C ->
 B <> P -> image_angle b = cons_AV (vec B C) (vec B P) ->  triangle B C P.
intros.
apply non_multiple_pi_triangle with b; auto.
split.
lra.
rewrite <- pisurtrois_def.
lra.
Qed.

Lemma Rabs_neg: forall (r : R), r <= 0 ->  Rabs r = - r.
intros.
elim H; intros.
rewrite Rabs_left; auto.
rewrite H0.
rewrite Rabs_R0; ring.
Qed.
(* Application des theoremes rayon_Sinus et loi_Sinus dans un triangle forme par un cote et deux trissectrices.
   Calcul de la longueur du cote BP dans le triangle BPC.*)

Lemma Morley_1:
 forall (a b c r : R) (A B C P : PO),
 0 < a ->
 0 < b ->
 0 < c ->
 (a + b) + c = pisurtrois ->
 A <> B ->
 A <> C ->
 B <> C ->
 B <> P ->
 rayon_circonscrit A B C r ->
 image_angle b = cons_AV (vec B C) (vec B P) ->
 image_angle c = cons_AV (vec C P) (vec C B) ->
 image_angle (3 * a) = cons_AV (vec A B) (vec A C) ->
  distance B P = (2 * (r * sin (3 * a))) * (sin c / sin (pisurtrois - a)).
unfold rayon_circonscrit; intros.
elim H7; [intros O [H13 H12]].
assert (triangle A B C).
apply (pisurtrois_triangle_utile (a:=a) (b:=b) (c:=c) (A:=A) (B:=B) (C:=C));
 auto.
assert (triangle B C P).
apply (pisurtrois_triangle_utile2 (a:=a) (b:=b) (c:=c) (B:=B) (C:=C) (P:=P));
 auto.
deroule_triangle B C P.
clear H18 H16 H15.
assert (distance B C = 2 * (r * sin (3 * a))).
rewrite (rayon_Sinus (A:=A) (B:=B) (C:=C) (O:=O)); auto.
rewrite H12.
rewrite <- (egalite_sin_Sin (A:=A) (B:=B) (C:=C) (x:=3 * a)); auto.
rewrite Rabs_right; eauto with geo.
rewrite <- H15.
rewrite <- H2.
RReplace (((a + b) + c) - a) (b + c).
elim pi_moins_x with ( x := b + c ); [intros].
rewrite <- H18.
elim (loi_Sinus (A:=C) (B:=B) (C:=P)); intros; auto with geo.
assert
 (distance B P =
  (distance C B / Rabs (Sin (cons_AV (vec P C) (vec P B)))) *
  Rabs (Sin (cons_AV (vec C B) (vec C P)))).
rewrite <- H19.
field.
auto with geo.
rewrite H21.
rewrite distance_sym.
assert (image_angle (- c) = cons_AV (vec C B) (vec C P)).
apply mes_oppx; auto.
rewrite <- (egalite_sin_Sin (A:=C) (B:=B) (C:=P) (x:=- c)); auto.
rewrite sin_impaire.
rewrite (Rabs_neg (r:=- sin c)).
assert (image_angle (- b) = cons_AV (vec B P) (vec B C)).
apply mes_oppx; auto.
assert (image_angle (pi + (b + c)) = cons_AV (vec P C) (vec P B)).
rewrite <- (angle_triangle (A:=C) (B:=B) (C:=P)); auto.
rewrite <- H23.
rewrite <- H22.
rewrite <- add_mes_compatible.
rewrite <- mes_opp.
rewrite <- add_mes_compatible.
RReplace (- (- c + - b)) (b + c); auto.
rewrite <- (egalite_sin_Sin (A:=P) (B:=C) (C:=B) (x:=pi + (b + c))); auto.
rewrite H18.
elim pi_plus_x with ( x := b + c ); intros.
rewrite H26.
rewrite Rabs_neg.
field.
assert (- sin (b + c) <> 0).
rewrite <- H26.
apply (triangle_sin_not_0 (A:=P) (B:=C) (C:=B) (x:=pi + (b + c))); auto with geo.
auto with real.
assert (sin (b + c) >= 0); eauto with geo.
lra.
assert (sin c >= 0); eauto with geo.
lra.
Qed.
(* application de la formule sin 3 a  qui utilise pisurtrois dons le calcul de BP*)

Lemma Morley_2:
 forall (a b c r : R) (A B C P : PO),
 0 < a ->
 0 < b ->
 0 < c ->
 (a + b) + c = pisurtrois ->
 A <> B ->
 A <> C ->
 B <> C ->
 B <> P ->
 rayon_circonscrit A B C r ->
 image_angle b = cons_AV (vec B C) (vec B P) ->
 image_angle c = cons_AV (vec C P) (vec C B) ->
 image_angle (3 * a) = cons_AV (vec A B) (vec A C) ->
  distance B P = (8 * (r * sin a)) * (sin c * sin (pisurtrois + a)).
intros.
assert (triangle B C P).
apply (pisurtrois_triangle_utile2 (a:=a) (b:=b) (c:=c) (B:=B) (C:=C) (P:=P));
 auto.
deroule_triangle B C P.
clear H13 H12 H15.
rewrite (Morley_1 (a:=a) (b:=b) (c:=c) (r:=r) (A:=A) (B:=B) (C:=C) (P:=P)); auto.
rewrite sin_3_a_pisurtrois; auto.
field.
rewrite <- H2.
RReplace (((a + b) + c) + - a) (b + c); auto.
assert (image_angle (- c) = cons_AV (vec C B) (vec C P)).
apply mes_oppx; auto.
assert (image_angle (- b) = cons_AV (vec B P) (vec B C)).
apply mes_oppx; auto.
assert (image_angle (pi + (b + c)) = cons_AV (vec P C) (vec P B)).
rewrite <- (angle_triangle (A:=C) (B:=B) (C:=P)); auto.
rewrite <- H13.
rewrite <- H12.
rewrite <- add_mes_compatible.
rewrite <- mes_opp.
rewrite <- add_mes_compatible.
RReplace (- (- c + - b)) (b + c); auto.
elim pi_plus_x with ( x := b + c ); intros.
assert (- sin (b + c) <> 0).
rewrite <- H17.
apply (triangle_sin_not_0 (A:=P) (B:=C) (C:=B) (x:=pi + (b + c))); auto with geo.
replace (a + b + c - a) with (b + c) by ring.
auto with real.
Qed.
(* calcul de la longueur du cote  CP dans le triangle BPC*)

Lemma Morley_3:
 forall (a b c r : R) (A B C P : PO),
 0 < a ->
 0 < b ->
 0 < c ->
 (a + b) + c = pisurtrois ->
 A <> B ->
 A <> C ->
 B <> C ->
 B <> P ->
 rayon_circonscrit A B C r ->
 image_angle b = cons_AV (vec B C) (vec B P) ->
 image_angle c = cons_AV (vec C P) (vec C B) ->
 image_angle (3 * a) = cons_AV (vec A B) (vec A C) ->
  distance C P = (8 * (r * sin a)) * (sin b * sin (pisurtrois + a)).
unfold rayon_circonscrit; intros.
elim H7; clear H7; [intros O [H13 H12]].
assert (triangle A B C).
apply (pisurtrois_triangle_utile (a:=a) (b:=b) (c:=c) (A:=A) (B:=B) (C:=C));
 auto.
assert (triangle B C P).
apply (pisurtrois_triangle_utile2 (a:=a) (b:=b) (c:=c) (B:=B) (C:=C) (P:=P));
 auto.
deroule_triangle B C P.
clear H17 H14 H15.
assert (distance C P = (2 * (r * sin (3 * a))) * (sin b / sin (pisurtrois - a))).
assert (distance B C = 2 * (r * sin (3 * a))).
rewrite (rayon_Sinus (A:=A) (B:=B) (C:=C) (O:=O)); auto.
rewrite H12.
rewrite <- (egalite_sin_Sin (A:=A) (B:=B) (C:=C) (x:=3 * a)); auto.
rewrite Rabs_right; eauto with geo.
rewrite <- H14.
rewrite <- H2.
RReplace (((a + b) + c) - a) (b + c).
elim pi_moins_x with ( x := b + c ); [intros].
rewrite <- H17.
elim (loi_Sinus (A:=C) (B:=B) (C:=P)); intros; auto with geo.
assert
 (distance C B / Rabs (Sin (cons_AV (vec P C) (vec P B))) =
  distance P C / Rabs (Sin (cons_AV (vec B P) (vec B C)))).
rewrite <- H19; auto.
assert
 (distance P C =
  (distance C B / Rabs (Sin (cons_AV (vec P C) (vec P B)))) *
  Rabs (Sin (cons_AV (vec B P) (vec B C)))).
rewrite H20.
field.
auto with geo.
rewrite distance_sym.
rewrite H21.
rewrite distance_sym.
assert (image_angle (- b) = cons_AV (vec B P) (vec B C)).
apply mes_oppx; auto.
assert (image_angle (- c) = cons_AV (vec C B) (vec C P)).
apply mes_oppx; auto.
rewrite <- (egalite_sin_Sin (A:=B) (B:=P) (C:=C) (x:=- b)); auto.
rewrite sin_impaire.
rewrite (Rabs_neg (r:=- sin b)).
assert (image_angle (pi + (b + c)) = cons_AV (vec P C) (vec P B)).
rewrite <- (angle_triangle (A:=C) (B:=B) (C:=P)); auto.
rewrite <- H23.
rewrite <- H22.
rewrite <- add_mes_compatible.
rewrite <- mes_opp.
rewrite <- add_mes_compatible.
RReplace (- (- c + - b)) (b + c); auto.
rewrite <- (egalite_sin_Sin (A:=P) (B:=C) (C:=B) (x:=pi + (b + c))); auto.
rewrite H17.
elim pi_plus_x with ( x := b + c ); intros.
rewrite H26.
rewrite Rabs_neg.
field.
assert (- sin (b + c) <> 0).
rewrite <- H26.
apply (triangle_sin_not_0 (A:=P) (B:=C) (C:=B) (x:=pi + (b + c))); auto with geo.
auto with real.
assert (sin (b + c) >= 0); eauto with geo.
lra.
assert (sin b >= 0).
apply sin_pos.
apply (pisurtrois_utile2 H H1 H0); auto with real.
rewrite <- H2; ring.
lra.
rewrite H14.
rewrite sin_3_a_pisurtrois; auto.
field.
rewrite <- H2.
RReplace (((a + b) + c) + - a) (b + c); auto.
assert (image_angle (- c) = cons_AV (vec C B) (vec C P)).
apply mes_oppx; auto.
assert (image_angle (- b) = cons_AV (vec B P) (vec B C)).
apply mes_oppx; auto.
assert (image_angle (pi + (b + c)) = cons_AV (vec P C) (vec P B)).
rewrite <- (angle_triangle (A:=C) (B:=B) (C:=P)); auto.
rewrite <- H15.
rewrite <- H17.
rewrite <- add_mes_compatible.
rewrite <- mes_opp.
rewrite <- add_mes_compatible.
RReplace (- (- c + - b)) (b + c); auto.
elim pi_plus_x with ( x := b + c ); intros.
assert (- sin (b + c) <> 0).
rewrite <- H20.
apply (triangle_sin_not_0 (A:=P) (B:=C) (C:=B) (x:=pi + (b + c))); auto with geo.
replace (a + b + c - a) with (b + c) by ring.
auto with real.
Qed.
(* on applique le lemme precedent dans un autre triangle ABQ forme par un cote et deux trissectrices*)

Lemma Morley_4:
 forall (a b c r : R) (A B C Q : PO),
 0 < a ->
 0 < b ->
 0 < c ->
 (a + b) + c = pisurtrois ->
 A <> B ->
 A <> C ->
 B <> C ->
 A <> Q ->
 rayon_circonscrit A B C r ->
 image_angle b = cons_AV (vec B Q) (vec B A) ->
 image_angle a = cons_AV (vec A B) (vec A Q) ->
 image_angle (3 * c) = cons_AV (vec C A) (vec C B) ->
  distance B Q = (8 * (r * sin c)) * (sin a * sin (pisurtrois + c)).
intros.
rewrite <- (Morley_3 (a:=c) (b:=a) (c:=b) (r:=r) (A:=C) (B:=A) (C:=B) (P:=Q));
 auto with geo.
rewrite <- H2; ring.
generalize H7; unfold rayon_circonscrit, circonscrit, isocele; intros.
elim H11; [intros O [H13 H14]].
elim H13; [intros H12 H15].
exists O.
split; auto.
split; auto.
rewrite <- H12; auto.
rewrite H14; rewrite <- H15; auto.
Qed.
(*dans le triangle BPQ on peut caculer le 3eme cote en utilisant Al_Kashi*)

Lemma Morley_5:
 forall (a b c r : R) (A B C P Q : PO),
 0 < a ->
 0 < b ->
 0 < c ->
 (a + b) + c = pisurtrois ->
 A <> B ->
 A <> C ->
 B <> C ->
 B <> P ->
 B <> Q ->
 A <> Q ->
 rayon_circonscrit A B C r ->
 image_angle b = cons_AV (vec B Q) (vec B A) ->
 image_angle b = cons_AV (vec B C) (vec B P) ->
 image_angle b = cons_AV (vec B P) (vec B Q) ->
 image_angle c = cons_AV (vec C P) (vec C B) ->
 image_angle a = cons_AV (vec A B) (vec A Q) ->
 image_angle (3 * a) = cons_AV (vec A B) (vec A C) ->
 image_angle (3 * c) = cons_AV (vec C A) (vec C B) ->
  Rsqr (distance P Q) =
  (Rsqr 8 * (Rsqr r * (Rsqr (sin a) * Rsqr (sin c)))) *
  ((Rsqr (sin (pisurtrois + a)) + Rsqr (sin (pisurtrois + c))) -
   2 * (sin (pisurtrois + a) * (sin (pisurtrois + c) * cos b))).
intros.
rewrite (Al_Kashi (A:=B) (B:=P) (C:=Q) (a:=b)); auto.
rewrite (Morley_2 (a:=a) (b:=b) (c:=c) (r:=r) (A:=A) (B:=B) (C:=C) (P:=P)); auto.
rewrite (Morley_4 (a:=a) (b:=b) (c:=c) (r:=r) (A:=A) (B:=B) (C:=C) (Q:=Q)); auto.
replace (Rsqr ((8 * (r * sin a)) * (sin c * sin (pisurtrois + a))))
     with
      ((Rsqr 8 * (Rsqr r * (Rsqr (sin a) * Rsqr (sin c)))) *
       Rsqr (sin (pisurtrois + a))).
2:unfold Rsqr; ring.
replace (Rsqr ((8 * (r * sin c)) * (sin a * sin (pisurtrois + c))))
     with
      ((Rsqr 8 * (Rsqr r * (Rsqr (sin a) * Rsqr (sin c)))) *
       Rsqr (sin (pisurtrois + c))).
2:unfold Rsqr; ring.
replace
 (((8 * (r * sin a)) * (sin c * sin (pisurtrois + a))) *
  (((8 * (r * sin c)) * (sin a * sin (pisurtrois + c))) * cos b))
     with
      ((Rsqr 8 * (Rsqr r * (Rsqr (sin a) * Rsqr (sin c)))) *
       (sin (pisurtrois + a) * (sin (pisurtrois + c) * cos b))).
2:unfold Rsqr; ring.
ring.
Qed.
(* utilisation de la formule de trigonometrie Al_Kashi_pisurtrois pour simplifier le calcul.*)

Lemma Morley_6:
 forall (a b c r : R) (A B C P Q : PO),
 0 < a ->
 0 < b ->
 0 < c ->
 (a + b) + c = pisurtrois ->
 A <> B ->
 A <> C ->
 B <> C ->
 B <> P ->
 B <> Q ->
 A <> Q ->
 rayon_circonscrit A B C r ->
 image_angle b = cons_AV (vec B Q) (vec B A) ->
 image_angle b = cons_AV (vec B C) (vec B P) ->
 image_angle b = cons_AV (vec B P) (vec B Q) ->
 image_angle c = cons_AV (vec C P) (vec C B) ->
 image_angle a = cons_AV (vec A B) (vec A Q) ->
 image_angle (3 * a) = cons_AV (vec A B) (vec A C) ->
 image_angle (3 * c) = cons_AV (vec C A) (vec C B) ->
  Rsqr (distance P Q) =
  (Rsqr 8 * (Rsqr r * (Rsqr (sin a) * Rsqr (sin b)))) * Rsqr (sin c).
intros.
rewrite (Morley_5 (a:=a) (b:=b) (c:=c) (r:=r) (A:=A) (B:=B) (C:=C) (P:=P) (Q:=Q));
 auto.
rewrite (Al_Kashi_pisurtrois (a:=a) (b:=b) (c:=c)); auto.
ring.
Qed.

Definition equilateral (A B C : PO) := and (isocele A B C) (isocele B C A).
(*Theoreme de Morley : utilisation de la symetrie de la formule pour conclure.*)

Theorem Morley:
 forall (a b c : R) (A B C P Q T : PO),
 0 < a ->
 0 < b ->
 0 < c ->
 (a + b) + c = pisurtrois ->
 A <> B ->
 A <> C ->
 B <> C ->
 B <> P ->
 B <> Q ->
 A <> T ->
 C <> T ->
 image_angle b = cons_AV (vec B C) (vec B P) ->
 image_angle b = cons_AV (vec B P) (vec B Q) ->
 image_angle b = cons_AV (vec B Q) (vec B A) ->
 image_angle c = cons_AV (vec C P) (vec C B) ->
 image_angle c = cons_AV (vec C T) (vec C P) ->
 image_angle a = cons_AV (vec A B) (vec A Q) ->
 image_angle a = cons_AV (vec A Q) (vec A T) ->
 image_angle a = cons_AV (vec A T) (vec A C) ->  equilateral P Q T.
intros.
assert (triangle B C P).
  apply (pisurtrois_triangle_utile2 (a:=a) (b:=b) (c:=c) (B:=B) (C:=C) (P:=P));
  auto.
deroule_triangle B C P.
assert (triangle B Q A).
  apply (pisurtrois_triangle_utile2 (a:=a) (b:=b) (c:=c) (B:=B) (C:=Q) (P:=A));
  auto.
deroule_triangle B Q A.
assert (image_angle (3 * a) = cons_AV (vec A B) (vec A C)).
  RReplace (3 * a) (a + (a + a)).
  replace (cons_AV (vec A B) (vec A C))
     with (plus (cons_AV (vec A B) (vec A Q)) (cons_AV (vec A Q) (vec A C))).
  replace (cons_AV (vec A Q) (vec A C))
     with (plus (cons_AV (vec A Q) (vec A T)) (cons_AV (vec A T) (vec A C))).
  rewrite <- H15; rewrite <- H16; rewrite <- H17.
  rewrite <- add_mes_compatible.
  rewrite <- add_mes_compatible; auto.
  apply Chasles; auto.
  apply Chasles; auto.
assert (triangle A B C).
  apply (pisurtrois_triangle_utile (a:=a) (b:=b) (c:=c) (A:=A) (B:=B) (C:=C));
  auto.
assert (image_angle (3 * b) = cons_AV (vec B C) (vec B A)).
  RReplace (3 * b) (b + (b + b)).
  replace (cons_AV (vec B C) (vec B A))
     with (plus (cons_AV (vec B C) (vec B P)) (cons_AV (vec B P) (vec B A))).
  replace (cons_AV (vec B P) (vec B A))
     with (plus (cons_AV (vec B P) (vec B Q)) (cons_AV (vec B Q) (vec B A))).
  rewrite <- H12; rewrite <- H11; rewrite <- H10.
  rewrite <- add_mes_compatible.
  rewrite <- add_mes_compatible; auto.
  apply Chasles; auto.
  apply Chasles; auto.
assert (image_angle (3 * c) = cons_AV (vec C A) (vec C B)).
  rewrite <- (angle_triangle (A:=A) (B:=B) (C:=C)); auto.
  rewrite <- H28.
  rewrite <- H30.
  rewrite <- add_mes_compatible.
  rewrite <- mes_opp.
  rewrite <- add_mes_compatible.
  rewrite <- pisurtrois_def.
  rewrite <- H2.
  RReplace (3 * ((a + b) + c) + - (3 * a + 3 * b)) (3 * c); auto.
assert (image_angle c = cons_AV (vec C A) (vec C T)).
  RReplace c ((3 * c + - c) + - c).
  rewrite add_mes_compatible.
  rewrite add_mes_compatible.
  rewrite H31.
  assert (image_angle (- c) = cons_AV (vec C B) (vec C P)).
    apply mes_oppx; auto.
  pattern (image_angle (- c)) at 1.
  rewrite H32.
  replace (plus (cons_AV (vec C A) (vec C B)) (cons_AV (vec C B) (vec C P)))
     with (cons_AV (vec C A) (vec C P)).
  assert (image_angle (- c) = cons_AV (vec C P) (vec C T)).
    apply mes_oppx; auto.
  rewrite H33.
  apply Chasles; auto.
  symmetry; apply Chasles; auto.
elim existence_rayon_circonscrit with ( A := A ) ( B := B ) ( C := C );
 [intros O [H33 [r H34]] | auto].
assert (rayon_circonscrit A B C r).
  unfold rayon_circonscrit.
  exists O; (split; auto).
assert
 (and
   (Rsqr (distance P Q) = Rsqr (distance T P))
   (Rsqr (distance P Q) = Rsqr (distance Q T))).
  rewrite (Morley_6 (a:=a) (b:=b) (c:=c) (r:=r) (A:=A) (B:=B) (C:=C) (P:=P) (Q:=Q));
  auto.
  rewrite (Morley_6 (a:=b) (b:=c) (c:=a) (r:=r) (A:=B) (B:=C) (C:=A) (P:=T) (Q:=P));
  auto.
  rewrite (Morley_6 (a:=c) (b:=a) (c:=b) (r:=r) (A:=C) (B:=A) (C:=B) (P:=Q) (Q:=T));
  auto.
  split; ring.
  rewrite <- H2; ring.
  exists O.
  rewrite H34.
  generalize H33; unfold circonscrit, isocele; intros.
  elim H36; [intros; (split; auto)].
  rewrite <- H38; auto.
  rewrite <- H37; auto.
  rewrite <- H2; ring.
  exists O.
  rewrite H34.
  generalize H33; unfold circonscrit, isocele; intros.
  elim H36; [intros; (split; auto)].
  rewrite <- H38; auto.
unfold equilateral, isocele.
elim H36; [intros].
split.
  rewrite (distance_sym P T); auto with geo.
rewrite (distance_sym Q P); auto with geo.
Qed.


Require Coq.Arith.Compare_dec.
Require Coq.FSets.FMapFacts.

Require Import Coq.Structures.OrderedType.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.FSets.FSetAVL.
Require Import Coq.Arith.Peano_dec.
Require Import Aniceto.Map.

Require Import HJ.Mid.
Require Import HJ.Tid.

Notation dep := (mid + tid)%type.

Notation d_mid := (@inl mid tid).

Notation d_tid := (@inr mid tid).

Module SumOrderedType (O1 O2:OrderedType) <: OrderedType.
  Definition t := sum O1.t O2.t.
  Definition eq o1 o2 :=
    match o1 with
    | inl l =>
      match o2 with
      | inl r => O1.eq l r
      | inr r => False
      end
    | inr l =>
      match o2 with
      | inl r => False
      | inr r => O2.eq l r
      end
    end.

  Definition lt o1 o2 :=
    match o1 with
    | inl l =>
      match o2 with
      | inl r => O1.lt l r
      | inr r => True
      end
    | inr l =>
      match o2 with
      | inl r => False
      | inr r => O2.lt l r
      end
    end.

  Lemma eq_refl:
    forall x,
    eq x x.
  Proof.
    intros.
    destruct x; simpl; eauto using O1.eq_refl, O2.eq_refl.
  Qed.

  Lemma eq_sym:
    forall x y,
    eq x y ->
    eq y x.
  Proof.
    intros.
    destruct x, y; simpl in *; eauto using O1.eq_sym, O2.eq_sym.
  Qed.

  Lemma eq_trans :
    forall x y z,
    eq x y ->
    eq y z ->
    eq x z.
  Proof.
    intros.
    destruct x, y, z; simpl in *.
    - eauto using O1.eq_trans.
    - inversion H0.
    - inversion H0.
    - inversion H.
    - inversion H.
    - inversion H.
    - inversion H0.
    - eauto using O2.eq_trans.
  Qed.

  Lemma lt_trans:
    forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    intros.
    unfold lt in *.
    destruct x, y, z; auto.
    - eauto using O1.lt_trans.
    - inversion H0.
    - inversion H.
    - eauto using O2.lt_trans.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    intros.
    destruct x, y; simpl in *.
    - eauto using O1.lt_not_eq.
    - intuition; inversion H0.
    - inversion H.
    - eauto using O2.lt_not_eq.
  Qed.

  Import Coq.Arith.Compare_dec.
  Lemma compare:
    forall x y, Compare lt eq x y.
  Proof.
    intros.
    destruct x, y.
    - assert (C: Compare O1.lt O1.eq t0 t1) by eauto using O1.compare.
      destruct C; eauto using LT, EQ, GT.
    - apply LT.
      simpl.
      trivial.
    - apply GT.
      simpl.
      trivial.
    - assert (C: Compare O2.lt O2.eq t0 t1) by eauto using O2.compare.
      destruct C; eauto using LT, EQ, GT.
  Qed.

  Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    intros.
    destruct x, y; simpl; eauto using O1.eq_dec, O2.eq_dec.
  Qed.

  Lemma eq_rw
    (o1_eq_rw: forall x y, O1.eq x y <-> x = y)
    (o2_eq_rw: forall x y, O2.eq x y <-> x = y):
    forall x y, eq x y <-> x = y.
  Proof.
    intros.
    destruct x, y; simpl in *.
    - split.
      + intros.
        apply o1_eq_rw in H; subst.
        trivial.
      + intros.
        inversion H; subst.
        rewrite o1_eq_rw.
        trivial.
    - split; intros; inversion H.
    - split; intros; inversion H.
    - split.
      + intros.
        apply o2_eq_rw in H; subst.
        trivial.
      + intros.
        inversion H; subst.
        rewrite o2_eq_rw.
        trivial.
  Qed.

End SumOrderedType.

Module DEP := SumOrderedType MID TID.

Lemma dep_eq_rw:
  forall x y, DEP.eq x y <-> x = y.
Proof.
  intros.
  split;
  intros;
  apply DEP.eq_rw in H; auto using mid_eq_rw, tid_eq_rw.
Qed.

Lemma dep_eq_dec:
  forall (x y:dep),
  { x = y } + { x <> y }.
Proof.
  intros.
  destruct (DEP.eq_dec x y); rewrite dep_eq_rw in *; auto.
Qed.

Module SD := FSetAVL.Make DEP.
Module SD_Facts := FSetFacts.Facts SD.
Definition set_dep := SD.t.


Require Export ProjectiveGeometry.Dev.matroid_properties.
Require Export ProjectiveGeometry.Dev.projective_space_rank_axioms.

(*****************************************************************************)
(** Rank space or higher properties **)

Section s_rankProperties_1.

Context `{M : RankProjectiveSpace}.
Context `{EP : EqDecidability Point}.

Lemma rk_singleton : forall p : Point, rk (singleton p) = 1.
Proof.
intros.
assert (rk (singleton p)<= 1).
apply (rk_singleton_le);auto.
assert (rk (singleton p)>= 1).
apply (rk_singleton_ge);auto.
omega.
Qed.

Lemma rk_couple1 : forall p q : Point,~ p [==] q -> rk(couple p q)=2.
Proof.
intros.
assert (rk(couple p q)<=2).
apply (rk_couple_2).
assert (rk(couple p q)>=2).
apply (rk_couple_ge);auto.
omega.
Qed.

Lemma couple_rk1 : forall p q : Point, rk(couple p q) = 2 -> ~ p [==] q.
Proof.
intros.
unfold not;intro.
assert (rk (couple p q) = 1).
setoid_replace (couple p q) with (singleton p).
apply rk_singleton.
rewrite H1.
clear H0 H1.
fsetdecide.
rewrite H0 in H2.
inversion H2.
Qed.

Lemma couple_rk2 : forall p q : Point, rk (couple p q) = 1 -> p [==] q.
Proof.
intros.
case_eq(eq_dec p q).
intros.
assumption.
intro.
assert (rk(couple p q)=2).
apply rk_couple1;assumption.
rewrite H0 in H1.
assert False.
intuition.
intuition.
Qed.

Lemma rk_couple2 : forall p q : Point, p [==] q -> rk(couple p q) = 1.
Proof.
intros.
setoid_replace (couple p q) with (singleton p).
apply (rk_singleton).
rewrite H0.
fsetdecide.
Qed.

Lemma rk_couple_1 : forall p q, 1 <= rk (couple p q).
Proof.
intros.
case_eq(eq_dec p q).
intro.
rewrite rk_couple2.
omega.
assumption.
intro.
rewrite rk_couple1.
omega.
assumption.
Qed.

Lemma couple_rk_degen : forall p, rk (couple p p) = 2 -> False.
Proof.
intros.
assert (rk (couple p p) = 1).
setoid_replace (couple p p) with (singleton p).
apply rk_singleton.
fsetdecide.
intuition.
Qed.

Hint Resolve rk_singleton rk_couple1 rk_couple2 couple_rk1 couple_rk2 couple_rk_degen : rk.

Lemma base_points_distinct_1 : ~ P0 [==] P1.
Proof.
assert (T:= rk_lower_dim).
unfold not;intro.
rewrite H0 in T.
setoid_replace (quadruple P1 P1 P2 P3) with (triple P1 P2 P3) in T by fsetdecide.
assert (rk (triple P1 P2 P3) <= 3).
apply rk_triple_le.
omega.
Qed.

Lemma base_points_distinct_2 : ~ P2 [==] P3.
Proof.
assert (T:= rk_lower_dim).
unfold not;intro.
rewrite H0 in T.
setoid_replace (quadruple P0 P1 P3 P3) with (triple P0 P1 P3) in T by fsetdecide.
assert (rk (triple P0 P1 P3) <= 3).
apply rk_triple_le.
omega.
Qed.

Lemma rk_lemma_1 : forall A B P Q,
rk (couple A B) = 2 ->
rk (triple A B P) = 2 ->
rk (triple A B Q) = 2 ->
rk (quadruple A B P Q) = 2.
Proof.
intros.
assert (rk (union (triple A B P) (triple A B Q)) + rk (couple A B) <=
           rk (triple A B P) + rk (triple A B Q)).
apply (matroid3_useful (triple A B P) (triple A B Q) (couple A B)).
clear_all;fsetdecide.

assert (rk (union (triple A B P) (triple A B Q)) <= 2).
omega.
setoid_replace (union (triple A B P) (triple A B Q)) with (quadruple A B P Q) in H4.
apply le_antisym.
auto.
cut (rk (couple A B) <= rk (quadruple A B P Q)).
omega.
apply matroid2.
clear_all;fsetdecide.
clear_all;fsetdecide.
Qed.

Lemma rk_quadruple_max_4_wc : forall A B C D : Point,
~ A[==]B -> ~ C[==]D -> rk(quadruple A B C D) <= 4.
Proof.
intros.
apply rk_quadruple_le.
Qed.

Lemma rk_quadruple_3_or_higher : forall A B C D,
~ A[==]B ->
~ C[==]D ->
rk(quadruple A B C D) <> 2 ->
rk(quadruple A B C D) > 2.
Proof.
intros.
assert(HH := rk_quadruple_max_4_wc A B C D H0 H1).
assert(HH0 : rk(quadruple A B C D) <> 1).
intro.
assert(HH1 := rk_couple1 A B H0).
assert(HH2 : (couple A B [<=] quadruple A B C D)%set).
fsetdecide.
assert(HH3 := matroid2 (couple A B) (quadruple A B C D) HH2).
omega.
assert(HH1 := rk_couple1 A B H0).
assert(HH2 : rk (couple A B) >= 2).
intuition.
assert(HH3 : (couple A B [<=] quadruple A B C D)%set).
fsetdecide.
assert(HH4 := matroid2 (couple A B) (quadruple A B C D) HH3).
assert(HH5 : rk(quadruple A B C D) >= 2).
omega.
omega.
Qed.

Lemma rk_line_unification : forall A B C,
rk(couple A B) = 2 -> rk(couple A C) = 2 ->
rk(couple B C) = 2 -> rk(triple A B C) <= 2 -> rk(triple A B C) = 2.
Proof.
intros.
assert(HH : (couple A B [<=] triple A B C)%set).
fsetdecide.
assert(HH1 := matroid2 (couple A B) (triple A B C) HH).
omega.
Qed.

End s_rankProperties_1.

Section s_rankProperties_2.

Context `{M : RankProjectiveSpace}.
Context `{EP : EqDecidability Point}.

Lemma intersecting_lines_rank_3 : forall A B C D I,
rk (triple A B I) <= 2 ->
rk (triple C D I) <= 2 ->
rk (union (singleton I) (quadruple A B C D)) <= 3.
Proof.
intros.
assert (rk (union (triple A B I) (triple C D I)) +
       rk (singleton I) <=
       rk (triple A B I) + rk (triple C D I)).
apply (matroid3_useful (triple A B I) (triple C D I) (singleton I)).
fsetdecide.
rewrite rk_singleton in H2.
setoid_replace (union (triple A B I) (triple C D I))
with (union (singleton I) (quadruple A B C D)) in H2.
omega.
unfold Equal; split;clear_all;fsetdecide.
Qed.

End s_rankProperties_2.

Hint Resolve rk_singleton rk_couple1 rk_couple2 couple_rk1 couple_rk2 couple_rk_degen : rk_base.


Require Import Logic_utils.
Require Import Relation.
Require Import Ordering.
Require Import NatProps.

Inductive Z : Type :=
  | z ( n m : nat).

Axiom z_eq : forall (n0 n1 m0 m1 : nat),
n0 + m1 = n1 + m0 <-> z n0 m0 = z n1 m1.

Definition z_plus (z1 : Z)(z2 : Z) : Z :=
  match z1 with
  | z a b => match z2 with
    | z c d => z (a+c) (b+d)
    end
  end.

Definition z_neg (z1 : Z) : Z :=
  match z1 with
  | z a b => z b a
  end.

Definition z_minus (z1 : Z)(z2 : Z) :=
  z_plus z1 (z_neg z2).

Definition z_mul (z1 : Z)(z2 : Z) :=
  match z1 with
  | z a b => match z2 with
    | z c d => z (a*c + b*d) (a*d + b*c)
    end
  end.

Definition z_0 := z 0 0.
Definition z_1 := z 1 0.
Notation "a +z b" := (z_plus a b) (at level 50, left associativity).
Notation "a -z b" := (z_minus a b) (at level 50, left associativity).
Notation "a *z b" := (z_mul a b) (at level 40, left associativity).
Notation "-z a" := (z_neg a) (at level 35, right associativity).

Theorem z_eq_neg : forall (a b : Z),
  -za = -zb -> a = b.
Proof.
destruct a, b. simpl. intros. apply z_eq in H. apply z_eq.
rewrite n_plus_comm. rewrite n_plus_comm with (m:=m). rewrite H. reflexivity.
Qed.

Theorem z_plus_identity : forall (a : Z),
  a +z z_0 = a.
Proof.
intros. destruct a. simpl. rewrite n_plus_identity. rewrite n_plus_identity with (n:=m). reflexivity.
Qed.

Theorem z_plus_inverse : forall (a : Z),
  a +z -za = z_0.
Proof.
destruct a. simpl. apply z_eq.
rewrite n_plus_identity. simpl. apply n_plus_comm.
Qed.

Theorem z_plus_comm : forall (a b : Z),
  a +z b = b +z a.
Proof.
destruct a, b. simpl. rewrite n_plus_comm. rewrite n_plus_comm with (n:=m0). reflexivity.
Qed.

Theorem z_plus_assoc : forall (a b c : Z),
  (a +z b) +z c = a +z (b +z c).
Proof.
destruct a, b, c. simpl. rewrite n_plus_assoc. rewrite n_plus_assoc with (n:=m). reflexivity.
Qed.

Theorem z_plus_cancel : forall (a b c : Z),
  a +z c = b +z c -> a = b.
Proof.
intros. destruct a, b, c. simpl in H. apply z_eq in H. apply z_eq.
rewrite n_plus_assoc in H. rewrite n_plus_assoc in H.
apply n_plus_cancel in H.
rewrite <- n_plus_assoc in H. rewrite <- n_plus_assoc in H.
rewrite n_plus_comm with (n:=n1) in H. rewrite n_plus_comm with (n:=n1) in H.
rewrite n_plus_assoc in H. rewrite n_plus_assoc in H.
apply n_plus_cancel in H. apply H.
Qed.

Theorem z_mul_identity : forall (a : Z),
  a *z z_1 = a.
Proof.
destruct a. simpl.
rewrite n_mul_identity. rewrite n_mul_identity with (n:=m).
rewrite n_mul_zero. rewrite n_mul_zero. simpl.
rewrite n_plus_identity. reflexivity.
Qed.

Theorem z_mul_zero : forall (a : Z),
  a *z z_0 = z_0.
Proof.
destruct a. simpl.
rewrite n_mul_zero. rewrite n_mul_zero.
rewrite n_plus_identity. reflexivity.
Qed.

Theorem z_mul_neg : forall (a b : Z),
  a *z (-zb) = -z(a *z b).
Proof.
destruct a, b. simpl. apply z_eq. reflexivity.
Qed.

Theorem z_mul_comm : forall (a b : Z),
  a *z b = b *z a.
Proof.
intros. destruct a, b. simpl.
rewrite n_mul_comm. rewrite n_mul_comm with(n:=m).
rewrite n_mul_comm with (m:=m0). rewrite n_mul_comm with (m:=n0).
rewrite n_plus_comm with (n:=m0*n). reflexivity.
Qed.

Theorem z_distributive : forall (a b c : Z),
  a *z (b +z c) = a *z b +z a *z c.
Proof.
intros. destruct a, b, c. simpl.
assert (H: forall (k k0 k1 l l0 l1: nat),
  k * (k0 + k1) + l * (l0 + l1) = k * k0 + l * l0 + (k * k1 + l * l1)).
{ intros.
rewrite n_distributive with (n:=k). rewrite n_distributive with (n:=l).
set (a:=k*k0). set (b:=k*k1). set (c:=l*l0). set (d:=l*l1).
rewrite n_plus_assoc. rewrite <- n_plus_assoc with (k:=c). rewrite n_plus_comm with (n:=b).
rewrite n_plus_assoc. rewrite <- n_plus_assoc with (k:=d). reflexivity. }
rewrite H. rewrite H with (k:=n)(l:=m). reflexivity.
Qed.

Theorem z_mul_assoc : forall (a b c : Z),
  a *z (b *z c) = (a *z b) *z c.
Proof.
intros. destruct a, b, c. simpl.
assert (H : forall (k k0 k1 l l0 l1: nat),
  k * (k0 * k1 + l0 * l1) + l * (k0 * l1 + l0 * k1) = (k * k0 + l * l0) * k1 + (k * l0 + l * k0) * l1).
intros.
{ rewrite n_distributive with (n:=k). rewrite n_distributive with (n:=l).
rewrite n_right_distributive with (k:=k1). rewrite n_right_distributive with (k:=l1).
rewrite n_mul_assoc. set (a:=k*k0*k1).
rewrite n_mul_assoc. set (b:=k*l0*l1).
rewrite n_mul_assoc. set (c:=l*k0*l1).
rewrite n_mul_assoc. set (d:=l*l0*k1).
rewrite <- n_plus_assoc with (k:=b+c). rewrite n_plus_comm with (n:=d).
rewrite <- n_plus_assoc with (n:=a). rewrite n_plus_assoc with (n:=b).
reflexivity. }
rewrite H. rewrite H with (k:=n)(l:=m). reflexivity.
Qed.

(* inequality *)

Definition z_le : Relation Z Z :=
fun p => match p with
| (a, b) => ( match a with
  | z n0 m0 => match b with
    | z n1 m1 => n0 + m1 <= n1 + m0
    end
  end)
end.

Definition z_lt : Relation Z Z :=
fun p => match p with
| (a, b) => ( match a with
  | z n0 m0 => match b with
    | z n1 m1 => n0 + m1 < n1 + m0
    end
  end)
end.

Definition z_ge : Relation Z Z :=
fun p => match p with
| (a, b) => z_le (b, a)
end.

Definition z_gt : Relation Z Z :=
fun p => match p with
| (a, b) => z_lt (b, a)
end.

Notation "a <=z b" := (z_le (a, b)) (at level 70, no associativity).
Notation "a <z b"  := (z_lt (a, b)) (at level 70, no associativity).
Notation "a >=z b" := (z_ge (a, b)) (at level 70, no associativity).
Notation "a >z b"  := (z_gt (a, b)) (at level 70, no associativity).

Theorem z_le_reflexive : forall (a : Z),
  a <=z a.
Proof.
destruct a. simpl. apply le_n.
Qed.

Theorem z_le_transitive : forall (a b c : Z),
  a <=z b -> b <=z c -> a <=z c.
Proof.
destruct a, b, c. simpl. intros ab bc.
pose (H:=n_le_sum (n+m0) (n0+m) (n0+m1) (n1+m0) ab bc).
rewrite n_plus_comm in H. rewrite n_plus_assoc in H. rewrite n_plus_assoc in H.
apply n_le_plus in H.
rewrite <- n_plus_assoc in H. rewrite <- n_plus_assoc in H.
rewrite n_plus_comm in H. rewrite n_plus_comm with (n:=n0) in H.
apply n_le_plus in H.
rewrite n_plus_comm. rewrite n_plus_comm with (n:=n1). apply H.
Qed.

Theorem z_le_antisymmetric : forall (a b : Z),
  a <=z b -> b <=z a -> a = b.
Proof.
destruct a, b. simpl. intros ab ba.
apply n_le_antisymmetric in ba. apply z_eq. apply ba. apply ab.
Qed.

Theorem z_le_total_ordering : forall (a b : Z),
  a <=z b \/ b <=z a.
Proof.
intros. destruct a, b. simpl. apply n_le_total_partial_ordering.
Qed.

Theorem z_le_total_partial_ordering : total_partial_ordering z_le.
Proof.
unfold total_partial_ordering. apply conj.
- unfold partial_ordering. apply conj.
  + unfold reflexive. apply z_le_reflexive.
  + apply conj.
    * unfold antisymmetric. apply z_le_antisymmetric.
    * unfold transitive. apply z_le_transitive.
- apply z_le_total_ordering.
Qed.

Theorem z_lt_is_strict_z_le : z_lt = partial_to_strict z_le.
Proof.
assert (nl : forall (n m: nat), n_lt (n, m) <-> partial_to_strict n_le (n, m)).
{ apply Relation_eq. apply n_lt_is_strict_n_le. }

apply Relation_eq. intros. unfold partial_to_strict.
destruct a, b.
assert (zneq : z n m <> z n0 m0 <-> n + m0 <> n0 + m).
{ apply not_iff_compat. apply iff_sym. apply z_eq. }
apply and_iff_compat_l with (A:=n+m0<=n0+m) in zneq.
apply iff_iff_compat_l with (A:=n+m0<n0+m) in zneq.
apply zneq. apply nl.
Qed.

Theorem z_le_is_partial_z_lt : z_le = strict_to_partial z_lt.
Proof.
rewrite z_lt_is_strict_z_le. apply eq_sym.
apply partial_to_strict_to_partial_identity.
apply z_le_total_partial_ordering.
Qed.

Theorem z_lt_total_strict_ordering : total_strict_ordering z_lt.
Proof.
rewrite z_lt_is_strict_z_le.
apply partial_to_strict_preserves_totality.
apply z_le_total_partial_ordering.
Qed.

Theorem z_le_neg : forall (a b : Z),
  a <=z b -> -zb <=z -za.
Proof.
  destruct a, b. simpl. intros.
  rewrite n_plus_comm. rewrite n_plus_comm with (n:=m). apply H.
Qed.

Theorem z_lt_neg : forall (a b : Z),
  a <z b -> -zb <z -za.
Proof.
  destruct a, b. simpl. intros.
  rewrite n_plus_comm. rewrite n_plus_comm with (n:=m). apply H.
Qed.

Theorem z_le_plus : forall (a b c : Z),
  a <=z b <-> a +z c <=z b +z c.
Proof.
destruct a, b, c. simpl. unfold iff. apply conj.
- intros. rewrite n_plus_assoc. rewrite n_plus_assoc.
  apply n_le_plus.
  rewrite <- n_plus_assoc. rewrite <- n_plus_assoc.
  rewrite n_plus_comm with (n:=n1). rewrite n_plus_comm with (n:=n1).
  rewrite n_plus_assoc. rewrite n_plus_assoc.
  apply n_le_plus. apply H.
- intros. rewrite n_plus_assoc in H. rewrite n_plus_assoc in H.
  apply n_le_plus in H.
  rewrite <- n_plus_assoc in H. rewrite <- n_plus_assoc in H.
  rewrite n_plus_comm with (n:=n1) in H. rewrite n_plus_comm with (n:=n1) in H.
  rewrite n_plus_assoc in H. rewrite n_plus_assoc in H.
  apply n_le_plus in H. apply H.
Qed.

Theorem z_le_sum : forall (a b c d : Z),
  a <=z b -> c <=z d -> a +z c <=z b +z d.
Proof.
destruct a, b, c, d. simpl. intros ab cd.
pose (H:=n_le_sum (n+m0) (n0+m) (n1+m2) (n2+m1) ab cd).
rewrite <- n_plus_assoc. rewrite <- n_plus_assoc.
rewrite n_plus_assoc with (n:=n1). rewrite n_plus_assoc with (n:=n2).
rewrite n_plus_comm with (n:=n1). rewrite n_plus_comm with (n:=n2).
rewrite <- n_plus_assoc. rewrite <- n_plus_assoc.
rewrite n_plus_assoc. rewrite n_plus_assoc with (n:=n0). apply H.
Qed.

Theorem z_lt_plus : forall (a b c : Z),
  a <z b <-> a +z c <z b +z c.
Proof.
intros. apply conj.
- rewrite z_lt_is_strict_z_le. intros ab. apply conj.
  + apply z_le_plus. apply ab.
  + intros eqacbc. apply z_plus_cancel in eqacbc. apply ab in eqacbc. contradiction.
- rewrite z_lt_is_strict_z_le. intros acbc. apply conj.
  + apply proj1 in acbc. apply z_le_plus in acbc. apply acbc.
  + intros eqab. rewrite eqab in acbc. apply acbc. reflexivity.
Qed.

Theorem z_le_lt_sum : forall (a b c d : Z),
  a <z b -> c <=z d -> a +z c <z b +z d.
Proof.
intros a b c d ab cd.
rewrite z_lt_is_strict_z_le in ab. rewrite z_lt_is_strict_z_le. apply conj.
- apply z_le_sum. apply ab. apply cd.
- intros ac_eq_bd. apply z_le_plus with (c:=a) in cd. rewrite z_plus_comm in cd. rewrite z_plus_comm with (a:=d) in cd.
  rewrite ac_eq_bd in cd. apply z_le_plus in cd.
  pose (leH := z_le_total_partial_ordering). destruct leH as [partial total].
  destruct partial as [refl anti]. apply proj1 in anti.
  destruct ab as [ab a_neq_b]. apply a_neq_b in anti. contradiction.
  apply ab. apply cd.
Qed.

Theorem z_lt_sum : forall (a b c d : Z),
  a <z b -> c <z d -> a +z c <z b +z d.
Proof.
intros a b c d ab cd.
rewrite z_lt_is_strict_z_le in cd. apply z_le_lt_sum. apply ab. apply cd.
Qed.

Theorem z_lt_mul : forall (a b c : Z),
  a <z b -> z_0 <z c -> a *z c <z b *z c.
Proof.
destruct a, b, c. simpl. intros ab cpos. rewrite n_plus_identity in cpos.
rewrite <- n_plus_assoc. rewrite n_plus_assoc with (n:=m*m1).
rewrite <- n_right_distributive. rewrite n_plus_comm with (m:=m0*n1).
rewrite n_plus_assoc. rewrite <- n_right_distributive. rewrite n_plus_comm with (n:=m).

rewrite <- n_plus_assoc. rewrite n_plus_assoc with (n:=m0*m1).
rewrite <- n_right_distributive. rewrite n_plus_comm with (m:=m*n1).
rewrite n_plus_assoc. rewrite <- n_right_distributive. rewrite n_plus_comm with (m:=n).
rewrite n_plus_comm with (n:=(n0+m)*n1).

apply n_lt_lemma1. apply ab. apply cpos.
Qed.

Theorem z_lt_mul2 : forall (a b c : Z),
  a *z c <z b *z c -> z_0 <z c -> a <z b.
Proof.
intros a b c acbc cpos.
destruct z_lt_total_strict_ordering as [strict total].
destruct (total a b) as [ab|ba].
- apply ab.
- destruct ba as [ba|eq].
  + pose (bcac := z_lt_mul b a c ba cpos). apply strict in bcac. contradiction.
  + rewrite eq in acbc. apply strict in acbc as bcac. contradiction.
Qed.

Theorem z_le_mul : forall (a b c : Z),
  a <=z b -> z_0 <=z c -> a *z c <=z b *z c.
Proof.
intros a b c ab cpos.
rewrite z_le_is_partial_z_lt in ab. destruct ab as [ab|eqab].
- rewrite z_le_is_partial_z_lt in cpos. destruct cpos as [cpos|c0].
  + rewrite z_le_is_partial_z_lt. left. apply z_lt_mul. apply ab. apply cpos.
  + rewrite <- c0. rewrite z_mul_zero. rewrite z_mul_zero. simpl. apply le_n.
- rewrite eqab. apply z_le_total_partial_ordering.
Qed.

Theorem z_le_mul2 : forall (a b c : Z),
  a *z c <=z b *z c -> z_0 <z c -> a <=z b.
Proof.
intros a b c acbc cpos.
destruct z_lt_total_strict_ordering as [strict total].
destruct (total a b) as [ab|ba].
- rewrite z_lt_is_strict_z_le in ab. apply ab.
- destruct ba as [ba|eq].
  + pose (bcac := z_lt_mul b a c ba cpos).
    rewrite z_lt_is_strict_z_le in bcac. destruct bcac.
    apply z_le_total_partial_ordering in acbc. apply acbc in H. apply eq_sym in H. contradiction.
  + rewrite eq. apply z_le_total_partial_ordering.
Qed.

Theorem z_pos_nonzero : forall (a : Z),
  z_0 <z a -> a <> z_0.
Proof.
intros. intro. rewrite H0 in H. inversion H.
Qed.

Theorem z_mul_cancel : forall (a b c : Z),
  a *z c = b *z c /\ ~ c = z_0 -> a = b.
Proof.
intros a b c.
pose z_lt_total_strict_ordering as H. destruct H as [strict total].
intros eqacbc. destruct (total z_0 c) as [c_pos|c_neg].
- apply proj1 in eqacbc. destruct (total a b) as [ab|ba].
  + pose (acbc:= z_lt_mul a b c ab c_pos). rewrite eqacbc in acbc.
    apply z_lt_total_strict_ordering in acbc as bcac. contradiction.
  + destruct ba as [ba|eqab].
    * pose (bcac:= z_lt_mul b a c ba c_pos). rewrite eqacbc in bcac.
      apply z_lt_total_strict_ordering in bcac as acbc. contradiction.
    * apply eqab.
- destruct c_neg as [c_neg|c0].
  + apply proj1 in eqacbc. set (nc := z_neg c). apply z_lt_neg in c_neg. simpl z_neg in c_neg.
    replace c with (z_neg (z_neg c)) in eqacbc.
    rewrite z_mul_neg in eqacbc. rewrite z_mul_neg with (a:=b) in eqacbc.
    apply z_eq_neg in eqacbc.
    destruct (total a b) as [ab|ba].
    * pose (acbc:= z_lt_mul a b (-z c) ab c_neg). rewrite eqacbc in acbc.
      apply z_lt_total_strict_ordering in acbc as bcac. contradiction.
    * destruct ba as [ba|eqab].
      --  pose (bcac:= z_lt_mul b a (-z c) ba c_neg). rewrite eqacbc in bcac.
          apply z_lt_total_strict_ordering in bcac as acbc. contradiction.
      -- apply eqab.
    * destruct c. reflexivity.
  + apply proj2 in eqacbc. apply eq_sym in c0. contradiction.
Qed.

Theorem z_mul_a_b_zero : forall (a b : Z),
  a *z b = z_0 <-> a = z_0 \/ b = z_0.
Proof.
intros. unfold iff. apply conj.
- destruct (law_of_excluded_middle (b=z_0)).
  + right. apply H.
  + left. apply z_mul_cancel with (c:=b). apply conj.
    * rewrite H0. rewrite z_mul_comm. rewrite z_mul_zero. reflexivity.
    * apply H.
- intros. destruct H as [a0|b0].
  + rewrite a0. destruct b. apply z_eq. reflexivity.
  + rewrite b0. destruct a. apply z_eq. rewrite n_mul_zero. rewrite n_mul_zero. reflexivity.
Qed.

Theorem z_mul_a_b_nonzero : forall (a b : Z),
  a <> z_0 -> b <> z_0 -> a *z b <> z_0.
Proof.
intros a b an0 bn0. intros ab0. apply z_mul_a_b_zero in ab0. destruct ab0 as [a0|b0].
apply an0 in a0. contradiction. apply bn0 in b0. contradiction.
Qed.

Theorem z_mul_a_b_nonzero2 : forall (a b : Z),
  a *z b <> z_0 -> a <> z_0 /\ b <> z_0.
Proof.
intros. apply conj.
- intro. rewrite H0 in H. destruct b. simpl in H. contradiction.
- intro. rewrite H0 in H. destruct a. rewrite z_mul_comm in H. simpl in H. contradiction.
Qed.


Load Coq_book_ontology.
(** Dealing with multidimensional adjectives. Health as an inductive type
 where  the dimensions are enumerated. This is just an enumerated type*)
Definition   Degree:= Set.
Inductive Health: Degree:= Heart|Blood|Cholesterol.
Parameter Healthy: Health->Human->Prop.
Definition sick:=fun y : Human => ~ (forall x : Health, Healthy x y).
Definition healthy:= fun y : Human => forall x : Health, Healthy x y.

Theorem HEALTHY:
    healthy John -> Healthy Heart John /\ Healthy Blood John
    /\ Healthy Cholesterol John.
    cbv. intros. split. apply H.
    split. apply H. apply H. Qed.

Theorem HEALTHY2:
    healthy John -> not (sick John).
    cbv. firstorder. Qed.

Theorem HEALTHY3:
    (exists x: Health, Healthy x John) -> healthy John.
    cbv. firstorder. Abort.

Theorem HEALTHY4:
    (exists x: Health, not (Healthy x John)) -> healthy John.
    cbv. firstorder. Abort.

Theorem HEALTHY5:
    (exists x: Health, not (Healthy x John))  -> sick John.
  cbv. firstorder.  Qed.

Inductive art: Degree:= a1|a2|a3|a4.
Parameter F: art -> nat.
Definition DIM_CN := fun  h: Human => fun a: art => F a.
Parameter STND_art: nat.
Record Artist: Set:= mkartist{h:> Human; EI :  forall a: art, gt (DIM_CN h a) STND_art }.


From Coqprime Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma primo42 : prime 6701029.
Proof.
 apply (Pocklington_refl
         (Pock_certif 6701029 2 ((127, 1)::(2,2)::nil) 998)
        ((Proof_certif 127 prime127) ::
         (Proof_certif 2 prime2) ::
          nil)).
 native_cast_no_check (refl_equal true).
Qed.


Lemma L1 : forall (X Y:Prop), ~~(X -> Y) <-> (~~X -> ~~Y).
Proof.
    intros X Y. split; intros H1 H2.
    - intros H3. apply H1. intros H4. apply H2. intros H5.
      apply H3, H4. assumption.
    - assert (~Y) as H3.
        { intros H3. apply H2. intros H4. assumption. }
      apply H2. intros H4. exfalso. apply H1.
            + intro H5. apply H5. assumption.
            + assumption.
Qed.

Lemma L2 : forall (X Y:Prop), ~~(X /\ Y) <-> ~~X /\ ~~Y.
Proof.
    intros  X Y. split.
    - intros H1. split; intros H2;
      apply H1; intros [H3 H4]; apply H2; assumption.
    - intros [H1 H2] H3. apply H1. intros H4. apply H2. intros H5.
      apply H3. split; assumption.
Qed.

Lemma L3 : ~~True <-> True.
Proof.
    split; intros H1.
    - trivial.
    - intros H2. apply H2. trivial.
Qed.

Lemma L4 : ~~False <-> False.
Proof.
    split; intros H1.
    - apply H1. intros H2. contradiction.
    - contradiction.
Qed.

Lemma L5 : forall (X Y:Prop), ~(X /\ Y) <-> ~~(~X \/ ~Y).
Proof.
    intros X Y. split; intros H1.
    - intros H2.
      assert (~~X) as H3. { intros H3. apply H2. left. assumption. }
      assert (~~Y) as H4. { intros H4. apply H2. right. assumption. }
      apply H3. intros H5. apply H4. intros H6. apply H1. split; assumption.
    - intros [H2 H3]. apply H1. intros [H4|H4]; apply H4; assumption.
Qed.

Lemma L6 : forall (X Y:Prop), (~X -> ~Y) <-> ~~(Y -> X).
Proof.
    intros X Y. split; intros H1 H2.
    - assert (~X) as H3. { intros H3. apply H2. intros H4. assumption. }
      assert (~~Y) as H4.
        { intros H4. apply H2. intros H5. exfalso. apply H4. assumption. }
      apply H4, H1, H3.
    - intros H3. apply H1. intros H4. apply H2, H4, H3.
Qed.

Lemma L7 : forall (X Y:Prop), (~X -> ~Y) <-> (Y -> ~~X).
Proof.
    intros X Y. split; intros H1 H2 H3; apply H1; assumption.
Qed.

Lemma L8 : forall (X Y:Prop), (X -> Y) -> ~~(~X \/ Y).
Proof.
    intros X Y H1 H2.
    assert (~Y) as H3. { intros H3. apply H2. right. assumption. }
    assert (~~X) as H4. {intros H4. apply H2. left. assumption. }
    assert (~X) as H5. { intros H5. apply H3, H1. assumption. }
    apply H4. assumption.
Qed.

Lemma L9 : forall (a:Type) (p:a -> Prop),
    ~(forall (x:a), ~p x) <-> ~~ exists (x:a), p x.
Proof.
    intros a p. split; intros H1 H2; apply H1.
    - intros x H3. apply H2. exists x. assumption.
    - intros [x H3]. apply (H2 x). assumption.
Qed.

Lemma L10 : forall (X Y:Prop), ~~X \/ ~~Y -> ~~(X \/ Y).
Proof.
    intros X Y [H1|H1] H2; apply H1; intros H3; apply H2.
    - left. assumption.
    - right. assumption.
Qed.

Lemma L11 : forall (a:Type) (p:a -> Prop),
    (exists (x:a), ~~ p x) -> ~~ exists (x:a), p x.
Proof.
    intros a p [x H1] H2. apply H1. intros H3. apply H2. exists x. assumption.
Qed.

Lemma L12 : forall (a:Type) (p:a -> Prop),
    ~~(forall (x:a), p x) -> forall (x:a), ~~ p x.
Proof.
    intros a p H1 x H2. apply H1. intros H3. apply H2, H3.
Qed.

(* Coq meta-property not provable in Coq: The double negation of a quantifier   *)
(* free proposition which is provable using LEM, is provable.                   *)

(* X \/ ~X is provable using LEM, hence ...                                     *)
Lemma L13 : forall (X:Prop), ~~(X \/ ~X).
Proof.
    intros X H1.
    assert (~X) as H2.  { intros H2. apply H1. left.  assumption. }
    assert (~~X) as H3. { intros H3. apply H1. right. assumption. }
    apply H3. assumption.
Qed.

(* ~~X -> X is provable using LEM, hence...                                     *)
Lemma L14 : forall (X:Prop), ~~(~~X -> X).
Proof.
    intros X H1. apply H1. intros H2. exfalso. apply H2. intros H3. apply H1.
    intros H4. assumption.
Qed.

Lemma L15 : forall (X Y:Prop), ~~(~(X /\ Y) -> ~X \/ ~Y).
Proof.
    intros X Y H1. apply H1. intros H2.
    assert (~~X) as H3. { intros H3. apply H1. intros H4. left.  assumption. }
    assert (~~Y) as H4. { intros H4. apply H1. intros H5. right. assumption. }
    exfalso. apply H3. intros H5. apply H4. intro H6. apply H2.
    split; assumption.
Qed.

Lemma L16 : forall (X Y:Prop), ~~((~X -> ~Y) -> Y -> X).
Proof.
    intros X Y H1. apply H1. intros H2 H3. exfalso. apply H2.
    - intros H4. apply H1. intros H5 H6. assumption.
    - assumption.
Qed.

Lemma L17 : forall (X Y:Prop), ~~(((X -> Y) -> X) -> X).
Proof.
    intros X Y H1. apply H1. intros H2.
    assert (~X) as H3. { intros H3. apply H1. intros H4. assumption. }
    apply H2. intros H4. exfalso. apply H3. assumption.
Qed.

Lemma L18 : forall (X Y:Prop), ~~((X -> Y) -> ~X \/ Y).
Proof.
    intros X Y H1. apply H1. intros H2.
    assert (~(~X \/ Y)) as H3. { intros H3. apply H1. intros H4. assumption. }
    assert (~Y) as H4. {intros H4. apply H3. right. assumption. }
    assert (~~X) as H5. { intros H5. apply H3. left. assumption. }
    exfalso. apply H5. intros H6. apply H4, H2. assumption.
Qed.

Lemma L19 : forall (X Y:Prop), ~~((X -> Y) \/ (Y -> X)).
Proof.
    intros X Y H1. apply H1.
    assert (~(X -> Y)) as H2. { intros H2. apply H1. left. assumption. }
    assert (~(Y -> X)) as H3. { intros H3. apply H1. right. assumption. }
    assert (~X) as H4. { intros H4. apply H3. intros H5. assumption. }
    exfalso. apply H2. intros H5. exfalso. apply H4. assumption.
Qed.


(** **** Exercise: (some_term_is_stuck)  *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (tsucc ttrue). unfold stuck. split.
  - unfold step_normal_form, not. intros. inversion H.
    inversion H0. inversion H2.
  - unfold not, value. intros [A | B].
    inversion A. inversion B. inversion H0.
Qed.

(** **** Exercise: (value_is_nf)  *)
Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  unfold normal_form. unfold not. intros. destruct H0.
  generalize dependent x.
  induction t; intros; try solve_by_invert;
  try (solve_by_invert 2);
  try (inversion H; try solve_by_invert; inversion H1; subst;
  inversion H0; subst; eauto).
Qed.

(** **** Exercise: (succ_hastype_nat__hastype_nat)  *)
Example succ_hastype_nat__hastype_nat : forall t,
  |- tsucc t \in TNat ->
  |- t \in TNat.
Proof.
  intros. inversion H. assumption.
Qed.

(** **** Exercise: (finish_progress)  *)
(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the informal proof fragment in the following
    exercise before starting -- this will save you a lot of time.) *)

Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t ==> t'.
Proof with auto.
  intros t T HT.
  induction HT; auto.
  (* The cases that were obviously values, like T_True and
     T_False, were eliminated immediately by auto *)
  - (* T_If *)
    right. inversion IHHT1; clear IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2. apply ST_IfTrue.
      exists t3. apply ST_IfFalse.
    + (* t1 can take a step *)
      inversion H as [t1' H1].
      exists (tif t1' t2 t3). apply ST_If with (t2:=t2) (t3 := t3) in H1 .
      assumption.
  - (* T_Succ *) destruct IHHT.
    left. right. constructor.
     + apply (nat_canonical t1 HT) in H. auto.
     + right. inversion H. exists (tsucc x). apply ST_Succ in H0.
        assumption.
  - (* T_Pred *)
    destruct IHHT.
    + right.
    apply (nat_canonical t1 HT) in H.
    inversion H. exists tzero. apply ST_PredZero.
    exists t. apply ST_PredSucc. assumption.
    + right. inversion H. exists (tpred x). apply ST_Pred in H0. assumption.
  - (* T_Zero *)
    destruct IHHT.
    + right. apply (nat_canonical t1 HT) in H. inversion H.
    exists ttrue. apply ST_IszeroZero.
    exists tfalse. apply ST_IszeroSucc. assumption.
    + right.
    destruct H. exists (tiszero x). apply ST_Iszero. assumption.
Qed.

Theorem preservation : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.

(** **** Exercise: (finish_preservation)  *)
(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)

Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try solve_by_invert.
    - (* T_If *) inversion HE; subst; clear HE.
      + (* ST_IFTrue *) assumption.
      + (* ST_IfFalse *) assumption.
      + (* ST_If *) apply T_If; try assumption.
        apply IHHT1; assumption.
    - (* T_Succ *) inversion HE; subst; clear HE.
      apply T_Succ. apply IHHT. assumption.
    - (* T_Pred *) inversion HE; subst; clear HE.
      + assumption.
      + apply succ_hastype_nat__hastype_nat in HT. assumption.
      + apply IHHT in H0. apply T_Pred in H0. assumption.
    - (* T_Bool *) inversion HE; subst; clear HE; constructor.
      apply IHHT in H0. assumption.
Qed.

(** **** Exercise: (normalize_ex)  *)
Theorem normalize_ex : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  eapply ex_intro. normalize. Qed.

(** **** Exercise: (normalize_ex')  *)
(** For comparison, prove it using [apply] instead of [eapply]. *)

Theorem normalize_ex' : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  eapply ex_intro. normalize.
Qed.


Require Import XR_R.
Require Import XR_Rsqr.
Require Import XR_Rsqr_neg.
Require Import XR_Rabs.
Require Import XR_Rcase_abs.

Local Open Scope R_scope.

Lemma Rsqr_abs : forall x:R, Rsqr x = Rsqr (Rabs x).
Proof.
  intro x.
  unfold Rabs.
  destruct (Rcase_abs x) as [ h | h ].
  {
  rewrite <- Rsqr_neg.
  reflexivity.
  }
  { reflexivity. }
Qed.


(*=========================================================================
  Setup & Sorting
*)

Require Import Coq.Structures.Orders.
Require Import Coq.Sorting.Sorting.
Require Import Orders.
Require Import Sorting.
Require Import Sorted.
Require Import Sorting.Mergesort.
Require Import Coq.Init.Nat.
Require Import Arith.
Require Import Omega.
Require Export List.

(* From Coq.Structures.Orders. *)
Local Coercion is_true : bool >-> Sortclass.
Hint Unfold is_true.

Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(* From Coq.Sorting.Mergesort NatOrder example. Highest priority is 0. *)
Module PriorityOrder <: TotalLeBool.
  Definition t := nat.
  Fixpoint leb x y :=
    match x, y with
    | 0, _ => true
    | _, 0 => false
    | S x', S y' => leb x' y'
    end.
  (*Infix "<=?" := leb (at level 35).*)
  Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1.
  Proof. induction a1; destruct a2; simpl; auto. Qed.
End PriorityOrder.
Module Import PrioritySort := Sort PriorityOrder.

(*Compute (Sorted leb [ 1 :: 2 :: 3 ]).
Compute (Sorted PointOrderByX_le [p1;p2;p3;p4;p5]).*)

(*Example test_not_Sorted : Sorted leb [2; 1; 3] -> False.
Proof.
  (* Name the hypothesis on the left side of "->" and break Sorted down by cases. *)
  intros contra. inversion contra.

  (* Look for an obviously false hypothesis, break it down, and repeat. *)
  repeat match goal with
    | [ H : HdRel _ 2 [1; 3] |- False ] => inversion_clear H
    | [ H : is_true (2 <=? 1) |- False ] => inversion_clear H
  end.
Qed.*)

(*=========================================================================
  Theorems about inequality

  Much of this machinery exists to translate between boolean expressions
  like `leb a b` and logical propositions like `a <= b`.
*)

(* Deal with implications of the form `ObviouslyFalse -> P` by introducting
  `ObviouslyFalse` as a hypotheses and inverting it. There's probably a
  built-in which does this, but I can't find it. *)
Ltac antecedent_is_false :=
  (* Use solve to make sure we either prove our goal completely, or fail
     atomically and leave the hypotheses unchanged. *)
  solve [ intros contra; inversion contra ].

Theorem leb_true : forall n m,
  n <=? m = true -> n <= m.
Proof.
  (* Dispose of most cases mechanically using built-in hypotheses. *)
  induction n; destruct m; simpl; auto using le_0_n, le_n_S.
  (* The remaining case is an obvious contradiction. *)
  antecedent_is_false.
Qed.

Theorem le_implies_leb_true : forall n m, n <= m -> n <=? m.
Proof.
  induction n; destruct m; simpl; auto using le_S_n.
  antecedent_is_false.
Qed.

(* Alternate: https://github.com/timjb/software-foundations/blob/master/Logic.v
   This gave me the hint to induct on m. *)
Theorem leb_false : forall n m,
  n <=? m = false -> ~(n <= m).
Proof.
  intros n m. generalize dependent n.
  (* Give the pattern of our proof, and simplify. *)
  induction m; destruct n; simpl;
    (* Eliminate cases with obvious contractions. *)
    try antecedent_is_false.
 auto using le_Sn_0.
     (* Use our induction hypothesis to rewrite the left-hand side,
        then use omega for logic crunching. *)
    intros H_not_leq_n_m. apply IHm in H_not_leq_n_m. omega.
Qed.

(* As a general rule, we can solve any trivial theorem about inequalities using
   the omega tactic. *)
Lemma flip_not_le : forall (a b : nat), not (a <= b) -> b <= a.
Proof. intros. omega. Qed.

(* This is somewhat specific (and deliberately weak) lemma that turns
   up a lot in our main proof. *)
Lemma flip_not_leb : forall (a b : nat), (a <=? b) = false -> b <=? a.
Proof.
  intros. apply leb_false in H. apply flip_not_le in H.
  apply le_implies_leb_true. assumption.
Qed.

(*=========================================================================
  Insertion
*)

Fixpoint insert_sorted (n : nat) (l : list nat) : list nat :=
  match l with
    | [] => [n]
    | n' :: l' =>
      if n <=? n'
      then n :: l
      else n' :: insert_sorted n l'
  end.

(* It's worth writing unit tests before trying to prove something really
   complicated, because doing so will make basic failures obvious, and
   you won't watch a proof fall apart mysteriously on some subclause. *)
(*Example test_insert_3_1_2 :
  insert_sorted 2 (insert_sorted 1 (insert_sorted 3 [])) = [1:: 2:: 3].
Proof. reflexivity. Qed.

Example test_insert_2_1_3 :
  insert_sorted 3 (insert_sorted 1 (insert_sorted 2 [])) = [1; 2; 3].
Proof. reflexivity. Qed.

Example test_insert_2_1_1 :
  insert_sorted 1 (insert_sorted 1 (insert_sorted 2 [])) = [1; 1; 2].
Proof. reflexivity. Qed. *)

(*=========================================================================
  Proof: Insertion preserves sorting
*)

Hint Resolve flip_not_leb.
Hint Constructors Sorted.
Hint Constructors HdRel.

Theorem insert_sorted_stays_sorted : forall n l,
  Sorted leb l -> Sorted leb (insert_sorted n l).
Proof.
  intros n l H_sorted_l.
  induction l as [|n' l']; simpl; auto.
 (*  Case "l = n' :: l'". *)
    destruct (n <=? n') eqn:H_n_le_n'; auto.
    (* SCase "n <=? n' = false". *)
      apply Sorted_inv in H_sorted_l.
      inversion H_sorted_l as [H_sorted_l' HdRel_n'_l'].

      apply Sorted_cons.
     (*  SSCase "Sorted (insert_sorted n l')".  *)apply IHl'. auto.
      (* SSCase "HdRel n' (insert_sorted n l')". *)
        apply IHl' in H_sorted_l'.
        destruct l'; simpl; auto.
        destruct (n <=? n0); auto.
        inversion HdRel_n'_l'. auto.
Qed.

(*=========================================================================
  Generating Haskell code
*)

Extraction Language Haskell.
Extract Inductive list => "([])" [ "[]" "(:)" ].
Extract Inductive bool => "Bool" [ "True" "False" ].
Extract Inductive nat => "Int" ["0" "(1+)"].
Extraction insert_sorted.

(*

Haskell supporting bits.

leb :: Int -> Int -> Bool
leb = (<=)

main :: IO ()
main = do
  print $ insert_sorted 5 (insert_sorted 3 [])

*)


From mathcomp Require Import ssreflect ssrnat ssrbool.
Set Bullet Behavior "Strict Subproofs".

From MonadicEffect Require Import Trees.

(** * Extrinsic and Intrinsic Proofs

    There are two types of proofs: _extrinsic_ ones and _intrisic_
    ones. An extrinsic proof is what most people familiar with in Coq:
    you write down a function, and then prove some properties about
    it. In a intrinsic proof, however, you write the properties in the
    type of the function.

    Let's just jump into an example to show what they look like. We
    start with the more familiar extrinsic approach. *)

Section ExtrinsicProof.

  Variable A : Set.

  (** We import state monads from coq-ext-lib. *)
  From ExtLib Require Import Structures.Monads Data.Monads.StateMonad.
  Import MonadNotation.
  Local Open Scope monad_scope.

  (** Consider the following [relabel] function. It labels all leaves
      in a tree in with [nat]s in an increasing order. It maintains a
      counter using the state monad. *)
  Fixpoint relabel (t : Tree A) : state nat (Tree nat) :=
    match t with
    | Leaf x =>
      n <- get ;;
      put (n + 1) ;;
      ret (Leaf n)
    | Node l r =>
      l' <- relabel l ;;
      r' <- relabel r ;;
      ret (Node l' r')
    end.

  (** Now we can write down a specification of this function and prove
      it. *)
  Theorem relabel_spec : forall t s,
      let: (t', s') := runState (relabel t) s in
      s' = s + size t' /\ flatten t' = seq s (size t').
  Proof.
    (** The proof starts by doing induction on the tree. The [Leaf]
        case is trivial, and can be dischagred automatically. *)
    elim => // => l IHt1 r IHt2 s.
    (** In the [Node] case, we do some rewriting to expose the
        computation on left and right children, so we can use our
        induction hypotheses. *)
    rewrite /relabel /= -/relabel.
    (** Now we need a bit boilerplates to destruct the [let]s
        generated from [bind]s, and pass the states through. *)
    specialize (IHt1 s).
    destruct (runState (relabel l) s) as [t' s'].
    specialize (IHt2 s').
    destruct (runState (relabel r) s') as [t'' s''].
    split => /=; intuition; subst.
    - by rewrite addnA.
    - by rewrite H0 H2 seq_split.
  Qed.
End ExtrinsicProof.
  (** The proof is quite standard. There are a bit boilerplates with
      [bind]s. Can we make use of the monadic structure to propagate
      the proof?

      The intrinsic approach offers one solution to that. Let's see
      how we prove the same thing in that style. *)

(* begin hide *)
Reset ExtrinsicProof.
(* end hide *)
Section IntrinsicProof.

  Variable A : Set.

  (** Here we use something called [Dijkstra] monads we have already
      defined. We will show to define it later. *)
  From MonadicEffect Require Import Dijkstra.

  (** This time, we enhance the type of the [relabel] function, by
      putting a pre- and post-condition in its type. By using the
      [Program] feature provided by Coq, we can define this function
      with the function body exactly the same as before. One
      difference is that now Coq will ask us to prove that the result
      of this function indeed satisfies the post-condition. *)
  Program Fixpoint relabel {A : Set} (t : Tree A) :
    ST nat return (Tree nat)
         requires [fun _ => True]
         ensures  [fun s t s' => s' = s + size t /\ flatten t = seq s (size t)] :=
  match t with
  | Leaf x =>
    n <- get ;;
    put (n + 1) ;;
    ret (Leaf n)
  | Node l r =>
    l' <- relabel l ;;
    r' <- relabel r ;;
    ret (Node l' r')
  end.
  (** Coq will try to automatically prove some simple proof
      obligations for us. For this function, the case when [t] is a
      [Leaf] is trivial, so Coq has already proved it for us.

      We only need to consider the case when [t] is a [Node]. The
      proof is quite similar to the last part of the extrinsic
      proof. *)
  Next Obligation.
    repeat split => //.
    intros; destruct H0; destruct H; subst.
    apply x1. split => /=.
    - by rewrite addnA.
    - by rewrite H2 H1 seq_split.
  Defined.
End IntrinsicProof.

(* begin hide *)
Reset IntrinsicProof.
(* end hide *)
(** * Intrinsic Proofs in Coq

    Before we jump into the details how the above example is
    implemented in Coq, let's check a little bit technical details in
    Coq. *)
Section IntrinsicProof.

  Fail Definition sqr (x : nat) : { s : nat | s = x * x } :=
    x * x.

  Print sig.

(** The signature of subset types:
<<
Inductive sig (A : Type) (P : A -> Prop) : Type :=
    exist : forall x : A, P x -> {x : A | P x}

For sig: Argument A is implicit
For exist: Argument A is implicit
For sig: Argument scopes are [type_scope type_scope]
For exist: Argument scopes are [type_scope function_scope _ _]
>> *)

  Definition sqr (x : nat) : { s : nat | s = x * x } :=
    exist (fun s => s = x * x) (x * x) eq_refl.

  Reset sqr.

  Definition sqr (x : nat) : { s : nat | s = x * x }.
    refine (exist _ (x * x) _).
    reflexivity.
  Defined.

  Reset sqr.

  (** Coq's [Program] feature allows us to program with subset types
      without worrying about passing the proof objects. *)
  Program Definition sqr (x : nat) : { s : nat | s = x * x } := x * x.

End IntrinsicProof.

(* begin hide *)
Reset IntrinsicProof.
(* end hide *)
Require Import Program.

(** * The Hoare State Monad

    Most of this section is based on [Swierstra, W. (2009). A Hoare
    Logic for the State Monad]. *)

Section HoareStateMonads.

  Variable S : Set.

  Definition Pre : Type := S -> Prop.
  Definition Post (A : Set) : Type := S -> A -> S -> Prop.

  Program Definition HoareState (pre : Pre) (A : Set) (post : Post A) : Set :=
    forall s: { s : S | pre s }, { (a, s') : A * S | post s a s' }.

  Definition top : Pre := fun _ => True.

  (** Recall the type of [ret] for an ordinary state monad is

      <<
      A -> state S A
      >> *)
  Program Definition ret (A : Set) :
    forall a, HoareState top A (fun s a' s' => s = s' /\ a = a') :=
    fun a s => (a, s).

  (** Recall the type of [bind] for an ordinary state monad is

      << state S A -> (A -> state S B) -> state S B >>

      Note the use of dependent type in our second parameter
      below. The reason is that we would like to refer to [a] in the
      pre- and post-conditions of the second parametr!  *)
  Program Definition bind : forall A B P1 P2 Q1 Q2,
      HoareState P1 A Q1 ->
      (forall (a : A), HoareState (P2 a) B (Q2 a)) ->
      HoareState (fun s1 => P1 s1 /\ forall a s2, Q1 s1 a s2 -> P2 a s2)
                  B
                  (fun s1 b s3 => exists a, exists s2, Q1 s1 a s2 /\ Q2 a s2 b s3) :=
    fun A B P1 P2 Q1 Q2 m1 m2 s1 =>
      let: (a, s2) := m1 s1 in m2 a s2.
  Next Obligation.
    (** The first obligation is proving that [a] and [s2] satisfies
        the precontion of [m2]. *)
    elim: m1 Heq_anonymous => t /= H0 Heq_anonymous.
    subst. by apply p0.
  Defined.
  Next Obligation.
    (** The second obligation is proving that [m2 a s2] satisfies the
        post condition of [bind]. *)
    elim (m2 a) => /=. elim => a' s3 H.
    exists a. exists s2. split; auto.
    elim: m1 Heq_anonymous => t /= H0 Heq_anonymous.
    subst. by apply H0.
  Defined.

  (** [get] and [put] are straightforward. *)
  Program Definition get : HoareState top S (fun s a s' => s = s' /\ a = s) :=
    fun s => (s, s).
  Program Definition put (x : S) : HoareState top unit (fun _ _ s' => x = s') :=
    fun _ => (tt, x).
End HoareStateMonads.

(* begin hide *)
Arguments ret {S} {A}.
Arguments bind {S} {A} {B} {P1} {P2} {Q1} {Q2}.
Arguments get {S}.
Arguments put {S}.
(* end hide *)
(** We define some notations to use this monad more easily. *)
Notation "c >>= f" := (bind c f) (at level 50, left associativity).
Notation "f =<< c" := (bind c f) (at level 51, right associativity).
Notation "x <- c1 ;; c2" := (bind c1 (fun x => c2)) (at level 100, c1 at next level, right associativity).
Notation "e1 ;; e2" := (_ <- e1 ;; e2) (at level 100, right associativity).

(** Now we can do an intrinsic proof to show that our [relabel]
    function is correct with respect to its specification again. *)
Program Fixpoint relabel {A : Set} (t : Tree A) :
  HoareState nat
             (@top nat)
             (Tree nat)
             (fun i t f => f = i + size t /\ flatten t = seq i (size t)) :=
  match t with
  | Leaf x =>
    n <- get ;;
    put (n + 1) ;;
    ret (Leaf n)
  | Node l r =>
    l' <- relabel l ;;
    r' <- relabel r ;;
    ret (Node l' r')
  end.
Next Obligation.
  case (relabel A l >>= _) => /=.
  case=> a s' [a1] [s1] [[H0 H1] H2].
  case: H2 => a2 [s2] [[H3 H4] [H5 H6]].
  subst. split => /=.
  - by rewrite addnA.
  - by rewrite H1 H4 seq_split.
Defined.

(** * Dijkstra Monads

    The Hoare state monad we have implemented have a few
    disadvantages, according to [Swamy, N., Weinberger, J.,
    Schlesinger, C., Chen, J., & Livshits, B. (2013). Verifying
    higher-order programs with the dijkstra monad]:

    - There are some existential quantifiers in it. Reasoning with
      these quantifiers, particularly using automated SMT solvers, can
      be problematic.

    - It requires the post-condition to be a two-state relation,
      though sometimes it is not necessary to compare the two states
      in the specification.

    Therefore, they propose another monad called "Dijkstra monad" to
    resolve the above issues (name after Edsger W. Dijkstra, for his
    discoveries in his paper [Dijkstra, E. W. (1975). Guarded
    Commands, Nondeterminacy and Formal Derivation of Programs].

    A Dijkstra monad is parameterized over a weakest precondition
    transformer. It can be seen as a Hoare state monad: *)

Definition DST S A wp :=
  forall p, HoareState S (fun h => wp p h) A (fun h x h' => p x h').

(** But let's define it properly. *)
Reset HoareStateMonads.

Section DijkstraMonads.

  Variables S : Set.

  (** The weakest precondition transformer. As its name suggested, it
      takes a post-condition and transform it into the weakest
      precondition. *)
  Definition WP {A} : Type := (A -> S -> Prop) -> S -> Prop.

  Program Definition DST A (wp : WP) :=
    forall p, { s : S | wp p s } -> { (a, s') : A * S | p a s' }.

  Program Definition ret { A } (a : A) :
    DST A (fun p => p a) :=
    fun _ s => (a, s).

  Program Definition bind : forall A wp1 B wp2,
      DST A wp1 -> (forall a : A, DST B (wp2 a)) ->
      DST B (fun p => wp1 (fun a => wp2 a p)) :=
    fun A wp1 B wp2 c1 c2 p s1 =>
      (** The function body should be

          <<
          let: (a, s2) := c1 (fun a => wp2 a p) s1 in c2 a p s2.
          >>
          But we can also just write this: *)
  let: (a, s2) := c1 _ s1 in c2 a _ s2.
  Next Obligation.
    elim: c1 Heq_anonymous => a' H' /= Heq_anonymous.
    subst; done.
  Defined.

  Program Definition get : DST S (fun p s => p s s) :=
    fun _ s => (s, s).

  Program Definition put : forall s, DST unit (fun p _ => p tt s) :=
    fun s _ _ => (tt, s).

End DijkstraMonads.

Arguments ret {S} {A}.
Arguments bind {S} {A} {wp1} {B} {wp2}.
Arguments get {S}.
Arguments put {S}.

Notation "c >>= f" := (bind c f) (at level 50, left associativity).
Notation "f =<< c" := (bind c f) (at level 51, right associativity).
Notation "x <- c1 ;; c2" := (bind c1 (fun x => c2)) (at level 100, c1 at next level, right associativity).
Notation "e1 ;; e2" := (_ <- e1 ;; e2) (at level 100, right associativity).

(** Let's see how it works with our [relabel] function: *)
Program Fixpoint relabel {A : Set} (t : Tree A) :
  DST nat (Tree nat) (fun post s =>
                    forall t s', s' = s + size t /\ flatten t = seq s (size t) ->
                    post t s' ) :=
  match t with
  | Leaf x =>
    n <- get ;;
    put (n + 1) ;;
    ret (Leaf n)
  | Node l r =>
    l' <- relabel l ;;
    r' <- relabel r ;;
    ret (Node l' r')
  end.
Next Obligation.
  (** We show the function satisfies the post-condition. To do that,
      we show that it satisfies the weakest precondition. *)
  apply H3. split => /=.
  - by rewrite addnA.
  - by rewrite H2 H1 seq_split.
Defined.

(** Writing with weakest precondition transformer can sometimes be
    hard. We can define some notations to make it more intuitive. *)
Reset relabel.

Notation "'ST' s 'return' a 'requires' [ P ] 'ensures' [ Q ]" :=
  (DST s a (fun p s1 => P s1 /\ (forall c s2, Q s1 c s2 -> p c s2)))
    (at level 99, P at next level, Q at next level).

Notation "'ST' s 'return' a 'ensures' [ Q ]" :=
  (DST s a (fun p s1 => forall c s2, Q s1 c s2 -> p c s2))
    (at level 99, Q at next level).

Check (ST nat return (Tree nat) requires [fun _ => True] ensures [fun _ _ _ => True]).

(** Now the specification for [relabel] looks quite similar to that in
    the form of a Hoare state monad, but notice that the proof is
    simpler than that for a Hoare state monad. *)
Program Fixpoint relabel {A : Set} (t : Tree A) :
  ST nat return (Tree nat)
       ensures  [fun i t f => f = i + size t /\ flatten t = seq i (size t)] :=
match t with
| Leaf x =>
  n <- get ;;
  put (n + 1) ;;
  ret (Leaf n)
| Node l r =>
  l' <- relabel l ;;
  r' <- relabel r ;;
  ret (Node l' r')
end.
Next Obligation.
  apply H3. split => /=.
  - by rewrite addnA.
  - by rewrite H2 H1 seq_split.
Defined.


Require Import SetoidClass.
Require Import Raxiom.

Module Rconvenient (Import T : CReals).

Open Scope R_scope.

Section Req.

(** * Useful and basics results on <, ==, # *)

Lemma Req_sym : forall x y, Req x y -> Req y x.
Proof.
compute; intuition.
Qed.

Lemma Req_refl : forall r, Req r r.
Proof.
intros r [H|H]; apply (Rlt_asym r r); apply H.
Qed.

Lemma Rlt_irrefl : forall r, r < r -> False.
Proof.
pose Rlt_asym; eauto.
Qed.

Lemma Rdiscr_irrefl : forall r, r ## r -> False.
Proof.
intros ? [|]; eapply Rlt_irrefl; eauto.
Qed.

Lemma Req_trans : forall r1 r2 r3 : R, Req r1 r2 -> Req r2 r3 -> Req r1 r3.
Proof.
intros r1 r2 r3 Hl Hr [H|H].
 eapply Req_lt_compat_l in H; [|eexact Hl].
 eapply Req_lt_compat_l in H; [|eexact Hr].
 apply (Rlt_irrefl _ H).

 eapply Req_lt_compat_l in H; [|apply Req_sym; eexact Hr].
 eapply Req_lt_compat_l in H; [|apply Req_sym; eexact Hl].
 apply (Rlt_irrefl _ H).
Qed.

Lemma Rlt_le_trans : forall x y z, Rlt x y -> Rle y z -> Rlt x z.
Proof.
intros ? ? ? ? [|?].
 eapply Rlt_trans; eauto.
 eapply Req_lt_compat_r; eauto.
Qed.

Lemma Rle_lt_trans : forall x y z, Rle x y -> Rlt y z -> Rlt x z.
Proof.
intros ? ? ? [?|].
 apply Rlt_trans; auto.
 intros; eapply Req_lt_compat_l.
  apply Req_sym; eauto.
  auto.
Qed.

Lemma Rle_trans : forall x y z, Rle x y -> Rle y z -> Rle x z.
Proof.
intros x y z [xy|xy] [yz|yz].
 left; eapply Rlt_trans; eauto.
 left; eapply Req_lt_compat_r; eauto.
 left; eapply Req_lt_compat_l; eauto; apply Req_sym, xy.
 right; eapply Req_trans; eauto.
Qed.

(** * Setoid **)

Global Instance Equivalence_Req : Equivalence Req.
Proof.
split; red.
  apply Req_refl.
  apply Req_sym.
  apply Req_trans.
Qed.

Global Instance Setoid_R : Setoid R := { equiv := Req }.

End Req.

Lemma Radd_eq_compat_r : forall (x1 x2 y : R), Req x1 x2 -> Req (x1 + y) (x2 + y).
Proof.
intros x1 x2 y Hx.
eapply Req_trans; [ apply Radd_comm | ].
eapply Req_trans; [ | apply Radd_comm ].
apply Radd_eq_compat_l; assumption.
Qed.

Lemma Rmul_eq_compat_r : forall x1 x2 y, Req x1 x2 -> Req (x1 * y) (x2 * y).
Proof.
intros x1 x2 y Hx.
eapply Req_trans; [ apply Rmul_comm | ].
eapply Req_trans; [ | apply Rmul_comm ].
apply Rmul_eq_compat_l; assumption.
Qed.

Lemma Rmul_add_distr_r : forall x y z : R, Req ((x + y) * z) (x * z + y * z).
Proof.
intros x y z.
etransitivity; [apply Rmul_comm|].
etransitivity; [|apply Radd_eq_compat_l; apply Rmul_comm].
etransitivity; [|apply Radd_eq_compat_r; apply Rmul_comm].
apply Rmul_add_distr_l.
Qed.

Instance Proper_Req_add : Proper (Req ==> Req ==> Req) Radd.
Proof.
intros x x' Hx y y' Hy.
eapply Req_trans.
 eapply Radd_eq_compat_l; eassumption.
 eapply Radd_eq_compat_r; eassumption.
Qed.

Instance Proper_Req_mul : Proper (Req ==> Req ==> Req) Rmul.
Proof.
intros x x' Hx y y' Hy.
eapply Req_trans.
  eapply Rmul_eq_compat_l; eassumption.
  eapply Rmul_eq_compat_r; eassumption.
Qed.

Lemma Radd_0_r : forall x, x + R0 == x.
Proof.
intro.
rewrite Radd_comm.
apply Radd_0_l.
Qed.

Lemma Radd_lt_compat_r : forall x y1 y2 : R, y1 < y2 -> y1 + x < y2 + x.
Proof.
intros x a b ab.
eapply Req_lt_compat_l; try apply Radd_comm.
eapply Req_lt_compat_r; try apply Radd_comm.
apply Radd_lt_compat_l; auto.
Qed.

Lemma Radd_lt_compat : forall x1 x2 y1 y2 : R, x1 < x2 -> y1 < y2 -> x1 + y1 < x2 + y2.
Proof.
intros.
eapply Rlt_trans.
 eapply Radd_lt_compat_l; eauto.
 eapply Radd_lt_compat_r; eauto.
Qed.

Lemma Radd_le_compat_l : forall x y1 y2 : R, y1 <= y2 -> x + y1 <= x + y2.
Proof.
  intros x y1 y2 H. destruct H.
   left. apply Radd_lt_compat_l. now assumption.

   right. apply Radd_eq_compat_l. assumption.
Qed.

Lemma Radd_le_compat_r : forall x y1 y2 : R, y1 <= y2 -> y1 + x <= y2 + x.
Proof.
  intros x y1 y2 H. destruct H.
   left. apply Radd_lt_compat_r. now assumption.

   right. apply Radd_eq_compat_r. assumption.
Qed.

Lemma Radd_lt_le_compat : forall x1 x2 y1 y2 : R, x1 < x2 -> y1 <= y2 -> x1 + y1 < x2 + y2.
Proof.
  intros x1 x2 y1 y2 H1 H2. apply Rlt_le_trans with (x2 + y1).
   apply Radd_lt_compat_r. now apply H1.

   apply Radd_le_compat_l. apply H2.
Qed.

Lemma Radd_le_lt_compat : forall x1 x2 y1 y2 : R, x1 <= x2 -> y1 < y2 -> x1 + y1 < x2 + y2.
Proof.
  intros x1 x2 y1 y2 H1 H2. apply Rle_lt_trans with (x2 + y1).
   apply Radd_le_compat_r. now apply H1.

   apply Radd_lt_compat_l. apply H2.
Qed.

Lemma Radd_le_compat : forall x1 x2 y1 y2 : R, x1 <= x2 -> y1 <= y2 -> x1 + y1 <= x2 + y2.
Proof.
  intros x1 x2 y1 y2 H1 H2. apply Rle_trans with (x1 + y2).
   apply Radd_le_compat_l. now apply H2.

   apply Radd_le_compat_r. apply H1.
Qed.

Lemma Rlt_0_2 : R0 < R1 + R1.
Proof.
apply Req_lt_compat_l with (R0 + R0); try apply Radd_0_l.
apply Rlt_trans with (R0 + R1).
 eapply Radd_lt_compat_l; apply Rlt_0_1.
 eapply Radd_lt_compat_r; apply Rlt_0_1.
Qed.

Lemma Radd_eq_cancel_r : forall x x' y, x + y == x' + y -> x == x'.
Proof.
intros x x' y Hxy.
rewrite <- (Radd_0_r x), <- (Radd_0_r x').
rewrite <- (Radd_opp_r y).
repeat rewrite <- Radd_assoc.
rewrite <- Hxy.
apply Radd_eq_compat_l.
reflexivity.
Qed.

Instance Proper_Req_opp : Proper (Req ==> Req) Ropp.
Proof.
intros x x' Hx.
apply (Radd_eq_cancel_r _ _ x).
rewrite Hx at 3.
do 2 rewrite Radd_comm, Radd_opp_r; reflexivity.
Qed.

Lemma Rmul_1_r : forall x, x * R1 == x.
Proof.
intros; rewrite Rmul_comm; apply Rmul_1_l.
Qed.

Lemma Rinv_r : forall x (pr : x ## R0), x * Rinv x pr == R1.
Proof.
intros x pr; rewrite Rmul_comm; apply Rinv_l.
Qed.

Lemma Rmul_eq_cancel_r : forall x x' y, y ## R0 -> x * y == x' * y -> x == x'.
Proof.
intros x x' y Hy Hxy.
rewrite <- (Rmul_1_r x), <- (Rmul_1_r x'), <- (Rinv_r y Hy).
repeat rewrite <- Rmul_assoc; rewrite <- Hxy.
apply Rmul_eq_compat_l; reflexivity.
Qed.

Instance Proper_Req_inv : Proper
  (fun f g : forall x, x ## R0 -> R => forall x x' H H', x == x' -> f x H == f x' H') Rinv.
Proof.
intros x x' Hx Hx' Heq.
apply (Rmul_eq_cancel_r _ _ x Hx).
rewrite Heq at 3.
do 2 rewrite Rmul_comm, Rinv_r; reflexivity.
Qed.

Definition R_ring : ring_theory R0 R1 Radd Rmul Rsub Ropp Req.
Proof.
split.
  apply Radd_0_l.
  apply Radd_comm.
  intros; apply Req_sym, Radd_assoc.
  apply Rmul_1_l.
  apply Rmul_comm.
  intros; apply Req_sym, Rmul_assoc.
  apply Rmul_add_distr_r.
  reflexivity.
  apply Radd_opp_r.
Qed.

Add Ring R_ring : R_ring.

Lemma Req_lt_compat : forall x y x' y', x == x' -> y == y' -> x < y -> x' < y'.
Proof.
intros.
eapply Req_lt_compat_l; eauto.
eapply Req_lt_compat_r; eauto.
Qed.

Lemma Req_le_compat : forall x y x' y', x == x' -> y == y' -> x <= y -> x' <= y'.
Proof.
  intros x y x' y' H1 H2 H3. destruct H3.
   left. now apply Req_lt_compat with x y; assumption.

   right. apply Req_trans with x.
    symmetry. now apply H1.

    apply Req_trans with y.
     now assumption.

     assumption.
Qed.

Lemma Radd_lt_cancel_l : forall x1 x2 y : R, y + x1 < y + x2 -> x1 < x2.
Proof.
intros x1 x2 y Hx.
cut (- y + (y + x1) < - y + (y + x2)).
  apply Req_lt_compat; try (ring_simplify; reflexivity).
  apply Radd_lt_compat_l, Hx.
Qed.

Lemma Radd_le_cancel_l : forall x1 x2 y : R, y + x1 <= y + x2 -> x1 <= x2.
Proof.
  intros x1 x2 y Hx. destruct Hx.
   left. apply Radd_lt_cancel_l with y. now assumption.

   right. assert (- y + ( y + x1) == - y + (y + x2)).
    apply Radd_eq_compat_l. now assumption.

    do 2 rewrite <- Radd_assoc in H. ring_simplify in H. apply H.
Qed.

Lemma Rlt_opp_1_0 : - R1 < R0.
Proof.
eapply Req_lt_compat_l; [ apply Radd_0_l | ].
eapply Req_lt_compat_r; [ apply Radd_opp_r | ].
apply Radd_lt_compat_r.
apply Rlt_0_1.
Qed.

Lemma Radd_lt_cancel_r : forall x1 x2 y : R, x1 + y < x2 + y -> x1 < x2.
Proof.
intros x1 x2 y H.
apply (Radd_lt_compat_l (- y)) in H.
eapply (Req_lt_compat_l _ x1) in H; [ | ring ].
eapply (Req_lt_compat_r _ x2) in H; [ auto | ring ].
Qed.

Lemma Radd_eq_cancel_l : forall x y1 y2, (x + y1 == x + y2) -> (y1 == y2).
Proof.
  intros x y1 y2 H1. apply (Radd_eq_compat_l (-x)) in H1. ring_simplify in H1. apply H1.
Qed.

Lemma Radd_le_cancel_r : forall x1 x2 y : R, x1 + y <= x2 + y -> x1 <= x2.
Proof.
  intros x1 x2 y H. destruct H.
   left. apply Radd_lt_cancel_r with y. now assumption.

   right. apply (Radd_eq_compat_r _ _ (-y)) in r. ring_simplify in r. apply r.
Qed.

Lemma Rmul_0_l : forall r:R, Req (R0 * r) R0.
Proof.
intros; ring.
Qed.

Lemma Rmul_0_r : forall r:R, Req (r * R0) R0.
Proof.
intros; ring.
Qed.

Definition Ppow2 := fix f n := match n with O => xH | S n' => xO (f n') end.
Definition Rpow2 n := IPR (Ppow2 n).

Lemma Rpos_pow2 : forall n, Rlt R0 (Rpow2 n).
Proof.
 intros n; induction n.
 apply Rlt_0_1.
 apply (Req_lt_compat_l _ _ _ (Radd_0_l R0)).
 apply Rlt_trans with (R0 + Rpow2 n).
  apply Radd_lt_compat_l; auto.

  simpl.
  unfold Rpow2; simpl.
  eapply Req_lt_compat_r; [ rewrite Rmul_add_distr_r; reflexivity | ].
  eapply Req_lt_compat_r; [ repeat rewrite Rmul_1_l; reflexivity | ].
  apply Radd_lt_compat_r; auto.
Qed.

Lemma Rnn_pow2 : forall n, Rpow2 n ## R0.
Proof.
 intros n; right; apply Rpos_pow2.
Qed.

Lemma Ropp_0 : - R0 == R0.
Proof.
  rewrite <- Radd_0_l.
  apply Radd_opp_r.
Qed.

Lemma Rmul_lt_cancel_l : forall x y1 y2 : R, R0 < x -> x * y1 < x * y2 -> y1 < y2.
Proof.
 intros r a b rpos Hab.
 assert (Hir := Rinv_0_lt_compat r rpos (inr rpos)).
 remember (Rinv r (inr rpos)) as ir.
 eapply Req_lt_compat_l; [ rewrite <- Rmul_1_l, <- (Rinv_l r (inr rpos)), Rmul_assoc; reflexivity | ].
 eapply Req_lt_compat_r; [ rewrite <- Rmul_1_l, <- (Rinv_l r (inr rpos)), Rmul_assoc; reflexivity | ].
 apply Rmul_lt_compat_l; subst; auto.
Qed.

Lemma Rmul_le_cancel_l : forall x y1 y2 : R, R0 < x -> x * y1 <= x * y2 -> y1 <= y2.
Proof.
  intros x y1 y2 H1 H2. destruct H2.
   left. now apply Rmul_lt_cancel_l with x; assumption.

   right. assert (H0: x ## R0).
    right. now assumption.

    apply (Rmul_eq_compat_l (Rinv x H0)) in r. do 2 rewrite <- Rmul_assoc in r. rewrite Rinv_l in r.
    ring_simplify in r. apply r.
Qed.

Lemma Rmul_lt_cancel_r : forall x1 x2 y : R, R0 < y -> x1 * y < x2 * y -> x1 < x2.
Proof.
intros x1 x2 y Hpos H.
eapply Req_lt_compat_l in H; [|apply Rmul_comm].
eapply Req_lt_compat_r in H; [|apply Rmul_comm].
apply Rmul_lt_cancel_l in H; auto.
Qed.

Lemma Rmul_le_cancel_r : forall x1 x2 y : R, R0 < y -> x1 * y <= x2 * y -> x1 <= x2.
Proof.
  intros x1 x2 y H1 H2. destruct H2.
   left. now apply Rmul_lt_cancel_r with y; assumption.

   right. assert (H0: y ## R0).
    right. now assumption.

    apply (Rmul_eq_compat_r _ _ (Rinv y H0)) in r. do 2 rewrite Rmul_assoc in r. rewrite Rinv_r in r.
    ring_simplify in r. apply r.
Qed.

Lemma Rmul_lt_compat_r : forall x y1 y2 : R, R0 < x -> y1 < y2 -> y1 * x < y2 * x.
Proof.
 intros x; intros.
 apply (Req_lt_compat_l _ _ _ (Rmul_comm x _)).
 apply (Req_lt_compat_r _ _ _ (Rmul_comm x _)).
 apply Rmul_lt_compat_l; auto.
Qed.

Lemma Rmul_le_compat_r : forall x y1 y2 : R, R0 <= x -> y1 <= y2 -> y1 * x <= y2 * x.
Proof.
  intros x y1 y2 H1 H2. destruct H1.
   destruct H2.
    left. now apply Rmul_lt_compat_r; assumption.

    right. rewrite r0. now ring.

  right. rewrite <- r. ring.
Qed.

Lemma Ropp_involutive : forall x, - - x == x.
Proof.
  intros x. eapply Radd_eq_cancel_r with (- x). rewrite Radd_opp_r. rewrite Radd_comm, Radd_opp_r.
  reflexivity.
Qed.

Lemma Ropp_lt_contravar : forall x y, x < y -> - y < - x.
Proof.
 intros x y Lxy.
 apply (Radd_lt_cancel_r _ _ (x + y)).
 eapply Req_lt_compat_l; [ | eapply Req_lt_compat_r; [ | apply Lxy ] ].
   (* ; ring : Error: Tactic failure: anomaly: Find_at (level 97). *)
   ring.
   ring.
Qed.

Lemma Ropp_le_contravar : forall x y, x <= y -> - y <= - x.
Proof.
  intros x y H1. destruct H1.
   left. apply Ropp_lt_contravar. now apply r.

   right. rewrite r. ring.
Qed.

Lemma Ropp_lt_contravar_reciprocal : forall x y, - y < - x -> x < y.
Proof.
 intros x y Lxy.
 apply (Req_lt_compat (- - x) (- - y)); try (ring_simplify; reflexivity).
    (* Again, we could use ring but we get a strange error *)
 apply Ropp_lt_contravar; auto.
Qed.

Lemma Ropp_le_contravar_reciprocal : forall x y, - y <= - x -> x <= y.
Proof.
  intros x y H. destruct H.
   left. apply Ropp_lt_contravar_reciprocal. now assumption.

   right. rewrite <- Ropp_involutive. rewrite <- (Ropp_involutive y). rewrite r. reflexivity.
Qed.

Lemma Rlt_opp_0 : forall x, R0 < x -> - x < R0.
Proof.
 intros x xpos.
 eapply Req_lt_compat_r; [ apply Ropp_0 | ].
 apply Ropp_lt_contravar; auto.
Qed.

Lemma Rle_opp_0 : forall x, R0 <= x -> - x <= R0.
Proof.
  intros x H. destruct H.
   left. apply Rlt_opp_0. now assumption.

   right. rewrite <- r. ring.
Qed.

Lemma Rlt_0_opp : forall x, x < R0 -> R0 < - x.
Proof.
 intros x xpos.
 eapply Req_lt_compat_l; [ apply Ropp_0 | ].
 apply Ropp_lt_contravar; auto.
Qed.

Lemma Rle_0_opp : forall x, x <= R0 -> R0 <= - x.
Proof.
  intros x H. destruct H.
   left. apply Rlt_0_opp. now assumption.

   right. rewrite r. ring.
Qed.

Lemma Rmul_lt_compat_neg_l : forall x y1 y2 : R, x < R0 -> y1 < y2 -> x * y2 < x * y1.
Proof.
 intros x; intros.
 apply Ropp_lt_contravar_reciprocal.
 apply (Req_lt_compat (- x * y1) (- x * y2)); try (ring_simplify; reflexivity).
 apply Rmul_lt_compat_l; try apply Rlt_0_opp; auto.
Qed.

Lemma Rmul_le_compat_neg_l : forall x y1 y2 : R, x <= R0 -> y1 <= y2 -> x * y2 <= x * y1.
Proof.
  intros x y1 y2 H1 H2. destruct H1.
   destruct H2.
    left. now apply Rmul_lt_compat_neg_l; assumption.

    right. rewrite r0. now reflexivity.

  right. rewrite r. ring.
Qed.

Lemma Rmul_lt_compat_neg_r : forall x y1 y2 : R, x < R0 -> y1 < y2 -> y2 * x < y1 * x.
Proof.
 intros x; intros.
 apply (Req_lt_compat_l _ _ _ (Rmul_comm x _)).
 apply (Req_lt_compat_r _ _ _ (Rmul_comm x _)).
 apply Rmul_lt_compat_neg_l; auto.
Qed.

Lemma Rmul_le_compat_neg_r : forall x y1 y2 : R, x <= R0 -> y1 <= y2 -> y2 * x <= y1 * x.
Proof.
  intros x y1 y2 H1 H2. destruct H1.
   destruct H2.
    left. now apply Rmul_lt_compat_neg_r; assumption.

    right. rewrite r0. now reflexivity.

  right. rewrite r. ring.
Qed.

Lemma Ropp_add : forall a b, - (a + b) == - a - b.
Proof.
intros a b.
apply Radd_eq_cancel_r with (a + b).
rewrite Radd_comm, Radd_opp_r.
unfold Rsub.
rewrite <- Radd_assoc, Radd_comm, (Radd_comm (- a)).
rewrite Radd_assoc, (Radd_comm  _ a), Radd_opp_r.
rewrite Radd_0_r, Radd_opp_r.
reflexivity.
Qed.

Lemma Ropp_sub : forall a b, - (a - b) == b - a.
Proof.
intros a b.
unfold Rsub.
rewrite Ropp_add.
unfold Rsub.
rewrite Ropp_involutive.
apply Radd_comm.
Qed.

Lemma Rdiv_mul_r : forall a b (bpos : b ## R0), Rdiv a b bpos * b == a.
Proof.
intros a b bpos.
unfold Rdiv.
rewrite Rmul_assoc, Rinv_l, Rmul_1_r; reflexivity.
Qed.

Lemma Rdiv_mul_l : forall a b (bpos : b ## R0), b * Rdiv a b bpos == a.
Proof.
intros; rewrite Rmul_comm; apply Rdiv_mul_r.
Qed.

Lemma Rinv_pos_compat : forall x (p : R0 < x) (p' : x ## R0), R0 < Rinv x p'.
Proof.
intros x xp xd.
apply Rmul_lt_cancel_l with x.
 auto.
 apply (Req_lt_compat R0 R1).
  ring_simplify; reflexivity.
  rewrite Rinv_r; reflexivity.
  apply Rlt_0_1.
Qed.

Lemma Req_le_compat_l : forall x1 x2 y : R, x1 == x2 -> x1 <= y -> x2 <= y.
Proof.
  intros x1 x2 y H1 H2. destruct H2.
   left. apply Rle_lt_trans with x1.
    right. symmetry. now apply H1.

    now assumption.

  right. rewrite <- H1. assumption.
Qed.

Lemma Req_le_compat_r : forall x1 x2 y : R, x1 == x2 -> y <= x1 -> y <= x2.
Proof.
  intros x1 x2 y H1 H2. destruct H2.
   left. apply Rlt_le_trans with x1.
    now assumption.

    right. now apply H1.

  right. rewrite <- H1. assumption.
Qed.

Lemma Rmul_le_compat_l : forall x y1 y2 : R, R0 <= x -> y1 <= y2 -> x * y1 <= x * y2.
Proof.
  intros x y1 y2 H1 H2. destruct H1.
   destruct H2.
    left. now apply Rmul_lt_compat_l; assumption.

    right. rewrite r0. now reflexivity.

  right. rewrite <- r. ring.
Qed.

Lemma Radd_pos_compat : forall x y, R0 < x -> R0 < y -> R0 < x + y.
Proof.
  intros. apply Rle_lt_trans with (R0 + R0).
   right. now ring.

   apply Rlt_trans with (x + R0).
    apply Radd_lt_compat_r. now assumption.

    apply Radd_lt_compat_l. assumption.
Qed.

Lemma Rpos_lt : forall x y, R0 < y - x -> x < y.
Proof.
  intros x y pxy.
  apply Radd_lt_cancel_r with (- x).
  eapply Req_lt_compat_l; [ | eauto ]; symmetry; apply Radd_opp_r.
Qed.

Lemma Rlt_pos : forall x y, x < y -> R0 < y - x.
Proof.
  intros x y pxy.
  apply Radd_lt_cancel_r with x.
  eapply Req_lt_compat with x y; auto; symmetry.
    apply Radd_0_l.
    ring_simplify; reflexivity.
Qed.

End Rconvenient.