(* Software Foundations *)
(* Exercice 1 star, sillyex1 *)

Require Import Coq.Lists.List.
Import ListNotations.

Example sillyex1 : forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = z :: j ->
    y :: l = x :: j ->
    x = y.
Proof.
    intros. inversion H0. reflexivity.
Qed.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import Rcomplete.
Require Import Max.
Local Open Scope R_scope.

Lemma tech1 :
forall (An:nat -> R) (N:nat),
(forall n:nat, (n <= N)%nat -> 0 < An n) -> 0 < sum_f_R0 An N.
Proof. hammer_hook "PartSum" "PartSum.tech1".
intros; induction  N as [| N HrecN].
simpl; apply H; apply le_n.
simpl; apply Rplus_lt_0_compat.
apply HrecN; intros; apply H; apply le_S; assumption.
apply H; apply le_n.
Qed.

Lemma tech2 :
forall (An:nat -> R) (m n:nat),
(m < n)%nat ->
sum_f_R0 An n =
sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m).
Proof. hammer_hook "PartSum" "PartSum.tech2".
intros; induction  n as [| n Hrecn].
elim (lt_n_O _ H).
cut ((m < n)%nat \/ m = n).
intro; elim H0; intro.
replace (sum_f_R0 An (S n)) with (sum_f_R0 An n + An (S n));
[ idtac | reflexivity ].
replace (S n - S m)%nat with (S (n - S m)).
replace (sum_f_R0 (fun i:nat => An (S m + i)%nat) (S (n - S m))) with
(sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m) +
An (S m + S (n - S m))%nat); [ idtac | reflexivity ].
replace (S m + S (n - S m))%nat with (S n).
rewrite (Hrecn H1).
ring.
apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite S_INR;
rewrite minus_INR.
rewrite S_INR; ring.
apply lt_le_S; assumption.
apply INR_eq; rewrite S_INR; repeat rewrite minus_INR.
repeat rewrite S_INR; ring.
apply le_n_S; apply lt_le_weak; assumption.
apply lt_le_S; assumption.
rewrite H1; rewrite <- minus_n_n; simpl.
replace (n + 0)%nat with n; [ reflexivity | ring ].
inversion H.
right; reflexivity.
left; apply lt_le_trans with (S m); [ apply lt_n_Sn | assumption ].
Qed.

Lemma tech3 :
forall (k:R) (N:nat),
k <> 1 -> sum_f_R0 (fun i:nat => k ^ i) N = (1 - k ^ S N) / (1 - k).
Proof. hammer_hook "PartSum" "PartSum.tech3".
intros; cut (1 - k <> 0).
intro; induction  N as [| N HrecN].
simpl; rewrite Rmult_1_r; unfold Rdiv; rewrite <- Rinv_r_sym.
reflexivity.
apply H0.
replace (sum_f_R0 (fun i:nat => k ^ i) (S N)) with
(sum_f_R0 (fun i:nat => k ^ i) N + k ^ S N); [ idtac | reflexivity ];
rewrite HrecN;
replace ((1 - k ^ S N) / (1 - k) + k ^ S N) with
((1 - k ^ S N + (1 - k) * k ^ S N) / (1 - k)).
apply Rmult_eq_reg_l with (1 - k).
unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ (1 - k)));
repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
[ do 2 rewrite Rmult_1_l; simpl; ring | apply H0 ].
apply H0.
unfold Rdiv; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k));
repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
rewrite Rmult_1_r; reflexivity.
apply H0.
apply Rminus_eq_contra; red; intro; elim H; symmetry ;
assumption.
Qed.

Lemma tech4 :
forall (An:nat -> R) (k:R) (N:nat),
0 <= k -> (forall i:nat, An (S i) < k * An i) -> An N <= An 0%nat * k ^ N.
Proof. hammer_hook "PartSum" "PartSum.tech4".
intros; induction  N as [| N HrecN].
simpl; right; ring.
apply Rle_trans with (k * An N).
left; apply (H0 N).
replace (S N) with (N + 1)%nat; [ idtac | ring ].
rewrite pow_add; simpl; rewrite Rmult_1_r;
replace (An 0%nat * (k ^ N * k)) with (k * (An 0%nat * k ^ N));
[ idtac | ring ]; apply Rmult_le_compat_l.
assumption.
apply HrecN.
Qed.

Lemma tech5 :
forall (An:nat -> R) (N:nat), sum_f_R0 An (S N) = sum_f_R0 An N + An (S N).
Proof. hammer_hook "PartSum" "PartSum.tech5".
intros; reflexivity.
Qed.

Lemma tech6 :
forall (An:nat -> R) (k:R) (N:nat),
0 <= k ->
(forall i:nat, An (S i) < k * An i) ->
sum_f_R0 An N <= An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N.
Proof. hammer_hook "PartSum" "PartSum.tech6".
intros; induction  N as [| N HrecN].
simpl; right; ring.
apply Rle_trans with (An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N + An (S N)).
rewrite tech5; do 2 rewrite <- (Rplus_comm (An (S N)));
apply Rplus_le_compat_l.
apply HrecN.
rewrite tech5; rewrite Rmult_plus_distr_l; apply Rplus_le_compat_l.
apply tech4; assumption.
Qed.

Lemma tech7 : forall r1 r2:R, r1 <> 0 -> r2 <> 0 -> r1 <> r2 -> / r1 <> / r2.
Proof. hammer_hook "PartSum" "PartSum.tech7".
intros; red; intro.
assert (H3 := Rmult_eq_compat_l r1 _ _ H2).
rewrite <- Rinv_r_sym in H3; [ idtac | assumption ].
assert (H4 := Rmult_eq_compat_l r2 _ _ H3).
rewrite Rmult_1_r in H4; rewrite <- Rmult_assoc in H4.
rewrite Rinv_r_simpl_m in H4; [ idtac | assumption ].
elim H1; symmetry ; assumption.
Qed.

Lemma tech11 :
forall (An Bn Cn:nat -> R) (N:nat),
(forall i:nat, An i = Bn i - Cn i) ->
sum_f_R0 An N = sum_f_R0 Bn N - sum_f_R0 Cn N.
Proof. hammer_hook "PartSum" "PartSum.tech11".
intros; induction  N as [| N HrecN].
simpl; apply H.
do 3 rewrite tech5; rewrite HrecN; rewrite (H (S N)); ring.
Qed.

Lemma tech12 :
forall (An:nat -> R) (x l:R),
Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l ->
Pser An x l.
Proof. hammer_hook "PartSum" "PartSum.tech12".
intros; unfold Pser; unfold infinite_sum; unfold Un_cv in H;
assumption.
Qed.

Lemma scal_sum :
forall (An:nat -> R) (N:nat) (x:R),
x * sum_f_R0 An N = sum_f_R0 (fun i:nat => An i * x) N.
Proof. hammer_hook "PartSum" "PartSum.scal_sum".
intros; induction  N as [| N HrecN].
simpl; ring.
do 2 rewrite tech5.
rewrite Rmult_plus_distr_l; rewrite <- HrecN; ring.
Qed.

Lemma decomp_sum :
forall (An:nat -> R) (N:nat),
(0 < N)%nat ->
sum_f_R0 An N = An 0%nat + sum_f_R0 (fun i:nat => An (S i)) (pred N).
Proof. hammer_hook "PartSum" "PartSum.decomp_sum".
intros; induction  N as [| N HrecN].
elim (lt_irrefl _ H).
cut ((0 < N)%nat \/ N = 0%nat).
intro; elim H0; intro.
cut (S (pred N) = pred (S N)).
intro; rewrite <- H2.
do 2 rewrite tech5.
replace (S (S (pred N))) with (S N).
rewrite (HrecN H1); ring.
rewrite H2; simpl; reflexivity.
destruct (O_or_S N) as [(m,<-)|<-].
simpl; reflexivity.
elim (lt_irrefl _ H1).
rewrite H1; simpl; reflexivity.
inversion H.
right; reflexivity.
left; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
Qed.

Lemma plus_sum :
forall (An Bn:nat -> R) (N:nat),
sum_f_R0 (fun i:nat => An i + Bn i) N = sum_f_R0 An N + sum_f_R0 Bn N.
Proof. hammer_hook "PartSum" "PartSum.plus_sum".
intros; induction  N as [| N HrecN].
simpl; ring.
do 3 rewrite tech5; rewrite HrecN; ring.
Qed.

Lemma sum_eq :
forall (An Bn:nat -> R) (N:nat),
(forall i:nat, (i <= N)%nat -> An i = Bn i) ->
sum_f_R0 An N = sum_f_R0 Bn N.
Proof. hammer_hook "PartSum" "PartSum.sum_eq".
intros; induction  N as [| N HrecN].
simpl; apply H; apply le_n.
do 2 rewrite tech5; rewrite HrecN.
rewrite (H (S N)); [ reflexivity | apply le_n ].
intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ].
Qed.

Lemma uniqueness_sum :
forall (An:nat -> R) (l1 l2:R),
infinite_sum An l1 -> infinite_sum An l2 -> l1 = l2.
Proof. hammer_hook "PartSum" "PartSum.uniqueness_sum".
unfold infinite_sum; intros.
case (Req_dec l1 l2); intro.
assumption.
cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ].
elim (H (Rabs ((l1 - l2) / 2)) H2); intros.
elim (H0 (Rabs ((l1 - l2) / 2)) H2); intros.
set (N := max x0 x); cut (N >= x0)%nat.
cut (N >= x)%nat.
intros; assert (H7 := H3 N H5); assert (H8 := H4 N H6).
cut (Rabs (l1 - l2) <= R_dist (sum_f_R0 An N) l1 + R_dist (sum_f_R0 An N) l2).
intro; assert (H10 := Rplus_lt_compat _ _ _ _ H7 H8);
assert (H11 := Rle_lt_trans _ _ _ H9 H10); unfold Rdiv in H11;
rewrite Rabs_mult in H11.
cut (Rabs (/ 2) = / 2).
intro; rewrite H12 in H11; assert (H13 := double_var); unfold Rdiv in H13;
rewrite <- H13 in H11.
elim (Rlt_irrefl _ H11).
apply Rabs_right; left; change (0 < / 2); apply Rinv_0_lt_compat;
cut (0%nat <> 2%nat);
[ intro H20; generalize (lt_INR_0 2 (neq_O_lt 2 H20)); unfold INR;
intro; assumption
| discriminate ].
unfold R_dist; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1));
rewrite Ropp_minus_distr'.
replace (l1 - l2) with (l1 - sum_f_R0 An N + (sum_f_R0 An N - l2));
[ idtac | ring ].
apply Rabs_triang.
unfold ge; unfold N; apply le_max_r.
unfold ge; unfold N; apply le_max_l.
unfold Rdiv; apply prod_neq_R0.
apply Rminus_eq_contra; assumption.
apply Rinv_neq_0_compat; discrR.
Qed.

Lemma minus_sum :
forall (An Bn:nat -> R) (N:nat),
sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N.
Proof. hammer_hook "PartSum" "PartSum.minus_sum".
intros; induction  N as [| N HrecN].
simpl; ring.
do 3 rewrite tech5; rewrite HrecN; ring.
Qed.

Lemma sum_decomposition :
forall (An:nat -> R) (N:nat),
sum_f_R0 (fun l:nat => An (2 * l)%nat) (S N) +
sum_f_R0 (fun l:nat => An (S (2 * l))) N = sum_f_R0 An (2 * S N).
Proof. hammer_hook "PartSum" "PartSum.sum_decomposition".
intros.
induction  N as [| N HrecN].
simpl; ring.
rewrite tech5.
rewrite (tech5 (fun l:nat => An (S (2 * l))) N).
replace (2 * S (S N))%nat with (S (S (2 * S N))).
rewrite (tech5 An (S (2 * S N))).
rewrite (tech5 An (2 * S N)).
rewrite <- HrecN.
ring.
ring.
Qed.

Lemma sum_Rle :
forall (An Bn:nat -> R) (N:nat),
(forall n:nat, (n <= N)%nat -> An n <= Bn n) ->
sum_f_R0 An N <= sum_f_R0 Bn N.
Proof. hammer_hook "PartSum" "PartSum.sum_Rle".
intros.
induction  N as [| N HrecN].
simpl; apply H.
apply le_n.
do 2 rewrite tech5.
apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
apply Rplus_le_compat_l.
apply H.
apply le_n.
do 2 rewrite <- (Rplus_comm (Bn (S N))).
apply Rplus_le_compat_l.
apply HrecN.
intros; apply H.
apply le_trans with N; [ assumption | apply le_n_Sn ].
Qed.

Lemma Rsum_abs :
forall (An:nat -> R) (N:nat),
Rabs (sum_f_R0 An N) <= sum_f_R0 (fun l:nat => Rabs (An l)) N.
Proof. hammer_hook "PartSum" "PartSum.Rsum_abs".
intros.
induction  N as [| N HrecN].
simpl.
right; reflexivity.
do 2 rewrite tech5.
apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
apply Rabs_triang.
do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
apply Rplus_le_compat_l.
apply HrecN.
Qed.

Lemma sum_cte :
forall (x:R) (N:nat), sum_f_R0 (fun _:nat => x) N = x * INR (S N).
Proof. hammer_hook "PartSum" "PartSum.sum_cte".
intros.
induction  N as [| N HrecN].
simpl; ring.
rewrite tech5.
rewrite HrecN; repeat rewrite S_INR; ring.
Qed.

Lemma sum_growing :
forall (An Bn:nat -> R) (N:nat),
(forall n:nat, An n <= Bn n) -> sum_f_R0 An N <= sum_f_R0 Bn N.
Proof. hammer_hook "PartSum" "PartSum.sum_growing".
intros.
induction  N as [| N HrecN].
simpl; apply H.
do 2 rewrite tech5.
apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
apply Rplus_le_compat_l; apply H.
do 2 rewrite <- (Rplus_comm (Bn (S N))).
apply Rplus_le_compat_l; apply HrecN.
Qed.

Lemma Rabs_triang_gen :
forall (An:nat -> R) (N:nat),
Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N.
Proof. hammer_hook "PartSum" "PartSum.Rabs_triang_gen".
intros.
induction  N as [| N HrecN].
simpl.
right; reflexivity.
do 2 rewrite tech5.
apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
apply Rabs_triang.
do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
apply Rplus_le_compat_l; apply HrecN.
Qed.

Lemma cond_pos_sum :
forall (An:nat -> R) (N:nat),
(forall n:nat, 0 <= An n) -> 0 <= sum_f_R0 An N.
Proof. hammer_hook "PartSum" "PartSum.cond_pos_sum".
intros.
induction  N as [| N HrecN].
simpl; apply H.
rewrite tech5.
apply Rplus_le_le_0_compat.
apply HrecN.
apply H.
Qed.

Definition Cauchy_crit_series (An:nat -> R) : Prop :=
Cauchy_crit (fun N:nat => sum_f_R0 An N).

Lemma cauchy_abs :
forall An:nat -> R,
Cauchy_crit_series (fun i:nat => Rabs (An i)) -> Cauchy_crit_series An.
Proof. hammer_hook "PartSum" "PartSum.cauchy_abs".
unfold Cauchy_crit_series; unfold Cauchy_crit.
intros.
elim (H eps H0); intros.
exists x.
intros.
cut
(R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
(sum_f_R0 (fun i:nat => Rabs (An i)) m)).
intro.
apply Rle_lt_trans with
(R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
(sum_f_R0 (fun i:nat => Rabs (An i)) m)).
assumption.
apply H1; assumption.
destruct (lt_eq_lt_dec n m) as [[ | -> ]|].
rewrite (tech2 An n m); [ idtac | assumption ].
rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ].
unfold R_dist.
unfold Rminus.
do 2 rewrite Ropp_plus_distr.
do 2 rewrite <- Rplus_assoc.
do 2 rewrite Rplus_opp_r.
do 2 rewrite Rplus_0_l.
do 2 rewrite Rabs_Ropp.
rewrite
(Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S n + i)%nat)) (m - S n)))
.
set (Bn := fun i:nat => An (S n + i)%nat).
replace (fun i:nat => Rabs (An (S n + i)%nat)) with
(fun i:nat => Rabs (Bn i)).
apply Rabs_triang_gen.
unfold Bn; reflexivity.
apply Rle_ge.
apply cond_pos_sum.
intro; apply Rabs_pos.
unfold R_dist.
unfold Rminus; do 2 rewrite Rplus_opp_r.
rewrite Rabs_R0; right; reflexivity.
rewrite (tech2 An m n); [ idtac | assumption ].
rewrite (tech2 (fun i:nat => Rabs (An i)) m n); [ idtac | assumption ].
unfold R_dist.
unfold Rminus.
do 2 rewrite Rplus_assoc.
rewrite (Rplus_comm (sum_f_R0 An m)).
rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
do 2 rewrite Rplus_assoc.
do 2 rewrite Rplus_opp_l.
do 2 rewrite Rplus_0_r.
rewrite
(Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S m + i)%nat)) (n - S m)))
.
set (Bn := fun i:nat => An (S m + i)%nat).
replace (fun i:nat => Rabs (An (S m + i)%nat)) with
(fun i:nat => Rabs (Bn i)).
apply Rabs_triang_gen.
unfold Bn; reflexivity.
apply Rle_ge.
apply cond_pos_sum.
intro; apply Rabs_pos.
Qed.

Lemma cv_cauchy_1 :
forall An:nat -> R,
{ l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } ->
Cauchy_crit_series An.
Proof. hammer_hook "PartSum" "PartSum.cv_cauchy_1".
intros An (x,p).
unfold Un_cv in p.
unfold Cauchy_crit_series; unfold Cauchy_crit.
intros.
cut (0 < eps / 2).
intro.
elim (p (eps / 2) H0); intros.
exists x0.
intros.
apply Rle_lt_trans with (R_dist (sum_f_R0 An n) x + R_dist (sum_f_R0 An m) x).
unfold R_dist.
replace (sum_f_R0 An n - sum_f_R0 An m) with
(sum_f_R0 An n - x + - (sum_f_R0 An m - x)); [ idtac | ring ].
rewrite <- (Rabs_Ropp (sum_f_R0 An m - x)).
apply Rabs_triang.
apply Rlt_le_trans with (eps / 2 + eps / 2).
apply Rplus_lt_compat.
apply H1; assumption.
apply H1; assumption.
right; symmetry ; apply double_var.
unfold Rdiv; apply Rmult_lt_0_compat;
[ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
Qed.

Lemma cv_cauchy_2 :
forall An:nat -> R,
Cauchy_crit_series An ->
{ l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }.
Proof. hammer_hook "PartSum" "PartSum.cv_cauchy_2".
intros.
apply R_complete.
unfold Cauchy_crit_series in H.
exact H.
Qed.

Lemma sum_eq_R0 :
forall (An:nat -> R) (N:nat),
(forall n:nat, (n <= N)%nat -> An n = 0) -> sum_f_R0 An N = 0.
Proof. hammer_hook "PartSum" "PartSum.sum_eq_R0".
intros; induction  N as [| N HrecN].
simpl; apply H; apply le_n.
rewrite tech5; rewrite HrecN;
[ rewrite Rplus_0_l; apply H; apply le_n
| intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ] ].
Qed.

Definition SP (fn:nat -> R -> R) (N:nat) (x:R) : R :=
sum_f_R0 (fun k:nat => fn k x) N.

Lemma sum_incr :
forall (An:nat -> R) (N:nat) (l:R),
Un_cv (fun n:nat => sum_f_R0 An n) l ->
(forall n:nat, 0 <= An n) -> sum_f_R0 An N <= l.
Proof. hammer_hook "PartSum" "PartSum.sum_incr".
intros; destruct (total_order_T (sum_f_R0 An N) l) as [[Hlt|Heq]|Hgt].
left; apply Hlt.
right; apply Heq.
cut (Un_growing (fun n:nat => sum_f_R0 An n)).
intro; set (l1 := sum_f_R0 An N) in Hgt.
unfold Un_cv in H; cut (0 < l1 - l).
intro; elim (H _ H2); intros.
set (N0 := max x N); cut (N0 >= x)%nat.
intro; assert (H5 := H3 N0 H4).
cut (l1 <= sum_f_R0 An N0).
intro; unfold R_dist in H5; rewrite Rabs_right in H5.
cut (sum_f_R0 An N0 < l1).
intro; elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H7 H6)).
apply Rplus_lt_reg_l with (- l).
do 2 rewrite (Rplus_comm (- l)).
apply H5.
apply Rle_ge; apply Rplus_le_reg_l with l.
rewrite Rplus_0_r; replace (l + (sum_f_R0 An N0 - l)) with (sum_f_R0 An N0);
[ idtac | ring ]; apply Rle_trans with l1.
left; apply Hgt.
apply H6.
unfold l1; apply Rge_le;
apply (growing_prop (fun k:nat => sum_f_R0 An k)).
apply H1.
unfold ge, N0; apply le_max_r.
unfold ge, N0; apply le_max_l.
apply Rplus_lt_reg_l with l; rewrite Rplus_0_r;
replace (l + (l1 - l)) with l1; [ apply Hgt | ring ].
unfold Un_growing; intro; simpl;
pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r;
apply Rplus_le_compat_l; apply H0.
Qed.

Lemma sum_cv_maj :
forall (An:nat -> R) (fn:nat -> R -> R) (x l1 l2:R),
Un_cv (fun n:nat => SP fn n x) l1 ->
Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
(forall n:nat, Rabs (fn n x) <= An n) -> Rabs l1 <= l2.
Proof. hammer_hook "PartSum" "PartSum.sum_cv_maj".
intros; destruct (total_order_T (Rabs l1) l2) as [[Hlt|Heq]|Hgt].
left; apply Hlt.
right; apply Heq.
cut (forall n0:nat, Rabs (SP fn n0 x) <= sum_f_R0 An n0).
intro; cut (0 < (Rabs l1 - l2) / 2).
intro; unfold Un_cv in H, H0.
elim (H _ H3); intros Na H4.
elim (H0 _ H3); intros Nb H5.
set (N := max Na Nb).
unfold R_dist in H4, H5.
cut (Rabs (sum_f_R0 An N - l2) < (Rabs l1 - l2) / 2).
intro; cut (Rabs (Rabs l1 - Rabs (SP fn N x)) < (Rabs l1 - l2) / 2).
intro; cut (sum_f_R0 An N < (Rabs l1 + l2) / 2).
intro; cut ((Rabs l1 + l2) / 2 < Rabs (SP fn N x)).
intro; cut (sum_f_R0 An N < Rabs (SP fn N x)).
intro; assert (H11 := H2 N).
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)).
apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption.
destruct (Rcase_abs (Rabs l1 - Rabs (SP fn N x))) as [Hlt|Hge].
apply Rlt_trans with (Rabs l1).
apply Rmult_lt_reg_l with 2.
prove_sup0.
unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply Hgt.
discrR.
apply (Rminus_lt _ _ Hlt).
rewrite (Rabs_right _ Hge) in H7.
apply Rplus_lt_reg_l with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with
(Rabs l1 - Rabs (SP fn N x)).
unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l;
rewrite Rplus_0_r; apply H7.
unfold Rdiv; rewrite Rmult_plus_distr_r;
rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l;
repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1;
rewrite double_var; unfold Rdiv in |- *; ring.
destruct (Rcase_abs (sum_f_R0 An N - l2)) as [Hlt|Hge].
apply Rlt_trans with l2.
apply (Rminus_lt _ _ Hlt).
apply Rmult_lt_reg_l with 2.
prove_sup0.
rewrite (double l2); unfold Rdiv; rewrite (Rmult_comm 2);
rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l;
apply Hgt.
discrR.
rewrite (Rabs_right _ Hge) in H6; apply Rplus_lt_reg_l with (- l2).
replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2).
rewrite Rplus_comm; apply H6.
unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_r;
pattern l2 at 2; rewrite double_var;
repeat rewrite (Rmult_comm (/ 2)); rewrite Ropp_plus_distr;
unfold Rdiv; ring.
apply Rle_lt_trans with (Rabs (SP fn N x - l1)).
rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply Rabs_triang_inv2.
apply H4; unfold ge, N; apply le_max_l.
apply H5; unfold ge, N; apply le_max_r.
unfold Rdiv; apply Rmult_lt_0_compat.
apply Rplus_lt_reg_l with l2.
rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1);
[ apply Hgt | ring ].
apply Rinv_0_lt_compat; prove_sup0.
intros; induction  n0 as [| n0 Hrecn0].
unfold SP; simpl; apply H1.
unfold SP; simpl.
apply Rle_trans with
(Rabs (sum_f_R0 (fun k:nat => fn k x) n0) + Rabs (fn (S n0) x)).
apply Rabs_triang.
apply Rle_trans with (sum_f_R0 An n0 + Rabs (fn (S n0) x)).
do 2 rewrite <- (Rplus_comm (Rabs (fn (S n0) x))).
apply Rplus_le_compat_l; apply Hrecn0.
apply Rplus_le_compat_l; apply H1.
Qed.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(**
* On density of the image of [Q] in an arbitrary real number structure
In this file we introduce the image of the concrete rational numbers
(as defined earlier) in an arbitrary structure of type
[CReals]. At the end of this file we assign to any real number two
rational numbers for which the real number lies betwen image of them;
in other words we will prove that the image of rational numbers in
dense in any real number structure. *)

Require Export CoRN.model.reals.Cauchy_IR.
Require Export CoRN.model.monoids.Nmonoid.
Require Export CoRN.model.rings.Zring.
Require Import CoRN.algebra.CRing_Homomorphisms.
Require Import CoRN.algebra.Expon.
Require Import Coq.QArith.Qpower.
Require Import CoRN.tactics.CornTac.

Section Rational_sequence_prelogue.

(**
%\begin{convention}% Let [R1] be a real number structure.
%\end{convention}%
*)
Variable R1 : CReals.

(* We clone these proofs from CReals1.v just because there IR is an axiom *)
(* begin hide *)
Lemma CReals_is_CReals : is_CReals R1 (Lim (IR:=R1)).
Proof.
 unfold Lim in |- *.
 elim R1; intros.
 exact crl_proof.
Qed.

Lemma Lim_Cauchy : forall s : CauchySeq R1, SeqLimit s (Lim s).
Proof.
 elim CReals_is_CReals.
 intros.
 apply ax_Lim.
Qed.

Lemma Archimedes : forall x : R1, {n : nat | x [<=] nring n}.
Proof.
 elim CReals_is_CReals.
 intros.
 apply ax_Arch.
Qed.

Lemma Archimedes' : forall x : R1, {n : nat | x [<] nring n}.
Proof.
 intro x.
 elim (Archimedes (x[+][1])); intros n Hn.
 exists n.
 apply less_leEq_trans with (x[+][1]); auto.
 apply less_plusOne.
Qed.
(*--------------------------------------*)

Local Coercion nat_of_P : positive >-> nat.
(* end hide *)

(**
** Injection from [Q] to an arbitrary real number structure
 First we need to define the injection from [Q] to [R1]. Note that in [Cauchy_CReals] we defined [inject_Q] from an arbitray field [F] to [(R_COrdField F)] which was the set of Cauchy sequences of that field. But since [R1] is an %\emph{arbitrary}%#<i>arbitrary</i># real number structure we can not use [inject_Q].

 To define the injection we need one elemntary lemma about the denominator:
*)

Lemma den_is_nonzero : forall x : Q_as_COrdField, nring (R:=R1) (Qden x) [#] [0].
Proof.
 intro.
 apply nring_ap_zero.
 intro.
 absurd (0 < Qden x).
  rewrite H.
  auto with arith.
 apply lt_O_nat_of_P.
Qed.

(** And we define the injection in the natural way, using [zring] and [nring]. We call this [inj_Q], in contrast with [inject_Q] defined in [Cauchy_CReals]. *)

Definition inj_Q : Q_as_COrdField -> R1.
Proof.
 intro x.
 case x.
 intros num0 den0.
 exact (zring num0[/]nring (R:=R1) den0[//]den_is_nonzero (Qmake num0 den0)).
Defined.

(** Next we need some properties of [nring], on the setoid of natural numbers: *)

Lemma nring_strext : forall m n : nat_as_CMonoid,
 (nring (R:=R1) m [#] nring (R:=R1) n) -> m [#] n.
Proof.
 intros m n.
 case m.
  case n.
   intro H.
   simpl in |- *.
   red in |- *.
   simpl in H.
   cut (Not ([0] [#] ([0]:R1))).
    intro.
    intro.
    elim H0.
    assumption.
   apply eq_imp_not_ap.
   apply eq_reflexive_unfolded.
  intros.
  simpl in |- *.
  red in |- *.
  discriminate.
 case n.
  intros.
  simpl in |- *.
  red in |- *.
  discriminate.
 intros.
 simpl in |- *.
 red in |- *.
 intro.
 cut (Not (nring (R:=R1) (S n1) [#] nring (R:=R1) (S n0))).
  intro H1.
  elim H1.
  assumption.
 apply eq_imp_not_ap.
 rewrite H.
 apply eq_reflexive_unfolded.
Qed.

Lemma nring_wd : forall m n : nat_as_CMonoid,
 (m [=] n) -> nring (R:=R1) m [=] nring (R:=R1) n.
Proof.
 intros.
 simpl in H.
 rewrite H.
 apply eq_reflexive_unfolded.
Qed.

Lemma nring_eq : forall m n : nat, m = n -> nring (R:=R1) m [=] nring (R:=R1) n.
Proof.
 intros.
 rewrite H.
 apply eq_reflexive_unfolded.
Qed.

Lemma nring_leEq : forall (OF : COrdField) m n,
 m <= n -> nring (R:=OF) m [<=] nring (R:=OF) n.
Proof.
 intros.
 induction  m as [| m Hrecm].
  simpl in |- *.
  case n.
   simpl in |- *.
   apply leEq_reflexive.
  intro.
  apply less_leEq.
  apply pos_nring_S.
 case (le_lt_eq_dec (S m) n H).
  intro.
  apply less_leEq.
  apply nring_less.
  assumption.
 intro.
 rewrite e.
 apply leEq_reflexive.
Qed.

(** Similarly we prove some properties of [zring] on the ring of integers: *)

Lemma zring_strext : forall m n : Z_as_CRing,
 (zring (R:=R1) m [#] zring n) -> m [#] n.
Proof.
 intros m n.
 case m.
   case n.
     intro H.
     exfalso.
     cut ([0] [=] ([0]:R1)).
      change (~ ([0] [=] ([0]:R1))) in |- *.
      apply ap_imp_neq.
      simpl in H.
      assumption.
     apply eq_reflexive_unfolded.
    intros.
    simpl in |- *.
    red in |- *.
    discriminate.
   intros.
   simpl in |- *.
   red in |- *.
   discriminate.
  case n.
    intros.
    simpl in |- *.
    red in |- *.
    discriminate.
   intros.
   simpl in |- *.
   intro.
   cut (Not (zring (R:=R1) (BinInt.Zpos p0) [#] zring (R:=R1) (BinInt.Zpos p))).
    intro H1.
    elim H1.
    assumption.
   apply eq_imp_not_ap.
   rewrite H.
   apply eq_reflexive_unfolded.
  intros.
  simpl in |- *.
  red in |- *.
  discriminate.
 case n.
   intros.
   simpl in |- *.
   red in |- *.
   discriminate.
  intros.
  simpl in |- *.
  red in |- *.
  discriminate.
 intros.
 simpl in |- *.
 intro.
 cut (Not (zring (R:=R1) (Zneg p0) [#] zring (R:=R1) (Zneg p))).
  intro H1.
  elim H1.
  assumption.
 apply eq_imp_not_ap.
 rewrite H.
 apply eq_reflexive_unfolded.
Qed.

Lemma zring_wd : forall m n : Z_as_CRing,
 (m [=] n) -> zring (R:=R1) m [=] zring (R:=R1) n.
Proof.
 intros.
 simpl in H.
 rewrite H.
 apply eq_reflexive_unfolded.
Qed.

Lemma zring_less : forall m n : Z_as_CRing,
 (m < n)%Z -> zring (R:=R1) m [<] zring (R:=R1) n.
Proof.
 intros m n.
 case m.
   case n.
     intro.
     apply False_rect.
     generalize H.
     change (~ (0 < 0)%Z) in |- *.
     apply Z.lt_irrefl.
    intros.
    simpl in |- *.
    astepl (nring (R:=R1) 0).
    astepr (nring (R:=R1) (nat_of_P p)).
    apply nring_less.
    case (ZL4' p).
    intro a.
    intro H0.
    rewrite H0.
    apply lt_O_Sn.
   intros.
   apply False_rect.
   generalize H.
   change (~ (0 < Zneg p)%Z) in |- *.
   apply Zlt_asym.
   constructor.
  case n.
    intros.
    apply False_rect.
    generalize H.
    change (~ (BinInt.Zpos p < 0)%Z) in |- *.
    apply Zlt_asym.
    constructor.
   intros p1 p2.
   intro.
   simpl in |- *.
   astepl (nring (R:=R1) (nat_of_P p2)).
   astepr (nring (R:=R1) (nat_of_P p1)).
   apply nring_less.
   apply nat_of_P_lt_Lt_compare_morphism.
   red in H.
   simpl in H.
   assumption.
  intros p1 p2.
  intro.
  apply False_rect.
  generalize H.
  change (~ (BinInt.Zpos p2 < Zneg p1)%Z) in |- *.
  apply Zlt_asym.
  constructor.
 case n.
   intros.
   simpl in |- *.
   astepl [--](nring (R:=R1) (nat_of_P p)).
   astepr ([0]:R1).
   apply inv_cancel_less.
   astepl ([0]:R1).
   astepr (nring (R:=R1) (nat_of_P p)).
   case (ZL4' p).
   intro h.
   intros H0.
   rewrite H0.
   apply pos_nring_S.
  intros p1 p2.
  intro.
  simpl in |- *.
  case (ZL4' p1).
  intro h1.
  case (ZL4' p2).
  intro h2.
  intros.
  apply less_transitive_unfolded with (y := [0]:R1).
   astepl [--](nring (R:=R1) (nat_of_P p2)).
   apply inv_cancel_less.
   astepl ([0]:R1).
   astepr (nring (R:=R1) (nat_of_P p2)).
   rewrite e.
   apply pos_nring_S.
  astepr (nring (R:=R1) p1).
  rewrite e0.
  apply pos_nring_S.
 intros p1 p2.
 intro.
 simpl in |- *.
 astepl [--](nring (R:=R1) (nat_of_P p2)).
 astepr [--](nring (R:=R1) (nat_of_P p1)).
 apply inv_resp_less.
 apply nring_less.
 apply nat_of_P_lt_Lt_compare_morphism.
 red in H.
 simpl in H. now rewrite ZC4.
Qed.

(** Using the above lemmata we prove the basic properties of [inj_Q], i.e.%\% it is a setoid function and preserves the ring operations and oreder operation. *)

Lemma inj_Q_strext : forall q1 q2, (inj_Q q1 [#] inj_Q q2) -> q1 [#] q2.
Proof.
 intros q1 q2.
 generalize (den_is_nonzero q1).
 generalize (den_is_nonzero q2).
 case q1.
 intros n1 d1.
 case q2.
 intros n2 d2.
 intros H H0 H1.
 simpl in |- *.
 simpl in H.
 simpl in H0.
 unfold Qap in |- *.
 unfold Qeq in |- *.
 unfold Qnum in |- *.
 unfold Qden in |- *.
 intro.
 cut (~ (inj_Q (Qmake n1 d1) [=] inj_Q (Qmake n2 d2))).
  intro.
  elim H3.
  simpl in |- *.
  apply mult_cancel_lft with (z := nring (R:=R1) d1[*]nring (R:=R1) d2).
   apply mult_resp_ap_zero.
    assumption.
   assumption.
  rstepl (zring (R:=R1) n1[*]nring (R:=R1) d2).
  rstepr (zring (R:=R1) n2[*]nring (R:=R1) d1).
  astepr (zring (R:=R1) (n1 * d2)).
   astepr (zring (R:=R1) n1[*]zring (R:=R1) d2).
   apply mult_wdr.
   astepl (zring (R:=R1) (Z_of_nat (nat_of_P d2))).
   rewrite inject_nat_convert.
   algebra.
  rewrite H2.
  astepl (zring (R:=R1) n2[*]zring (R:=R1) d1).
  apply mult_wdr.
  astepr (zring (R:=R1) (Z_of_nat (nat_of_P d1))).
  rewrite inject_nat_convert.
  algebra.
 change (inj_Q (Qmake n1 d1)[~=]inj_Q (Qmake n2 d2)) in |- *.
 apply ap_imp_neq.
 assumption.
Qed.

Lemma inj_Q_wd : forall q1 q2, (q1 [=] q2) -> inj_Q q1 [=] inj_Q q2.
Proof.
 intros.
 apply not_ap_imp_eq.
 intro.
 cut (~ (q1 [=] q2)).
  intro H1.
  apply H1.
  assumption.
 change (q1[~=]q2) in |- *.
 apply ap_imp_neq.
 apply inj_Q_strext.
 assumption.
Qed.

Lemma inj_Q_plus : forall q1 q2, inj_Q (q1[+]q2) [=] inj_Q q1[+]inj_Q q2.
Proof.
 intros.
 generalize (den_is_nonzero q1).
 generalize (den_is_nonzero q2).
 case q1.
 intros n1 d1.
 case q2.
 intros n2 d2.
 simpl in |- *.
 intros.
 apply mult_cancel_lft with (z := nring (R:=R1) d1[*]nring (R:=R1) d2).
  apply mult_resp_ap_zero.
   assumption.
  assumption.
 astepr (zring (R:=R1) (n1 * d2 + n2 * d1)).
  astepr (nring (R:=R1) (d1 * d2)%positive[*]
    (zring (R:=R1) (n1 * d2 + n2 * d1)[/]nring (R:=R1) (d1 * d2)%positive[//]
      den_is_nonzero (Qmake (n1 * d2 + n2 * d1)%Z (d1 * d2)%positive))).
  apply mult_wdl.
  rewrite nat_of_P_mult_morphism.
  algebra.
 astepr (zring (R:=R1) n1[*]nring (R:=R1) d2[+]zring (R:=R1) n2[*]nring (R:=R1) d1).
  astepl (zring (R:=R1) (n1 * d2)[+]zring (R:=R1) (n2 * d1)).
  apply bin_op_wd_unfolded.
   astepr (zring (R:=R1) n1[*]zring (R:=R1) (Z_of_nat (nat_of_P d2))).
   rewrite inject_nat_convert.
   algebra.
  astepr (zring (R:=R1) n2[*]zring (R:=R1) (Z_of_nat (nat_of_P d1))).
  rewrite inject_nat_convert.
  algebra.
 rational.
Qed.

Lemma inj_Q_mult : forall q1 q2, inj_Q (q1[*]q2) [=] inj_Q q1[*]inj_Q q2.
Proof.
 intros.
 generalize (den_is_nonzero q1).
 generalize (den_is_nonzero q2).
 case q1.
 intros n1 d1.
 case q2.
 intros n2 d2.
 simpl in |- *.
 intros.
 apply mult_cancel_lft with (z := nring (R:=R1) d1[*]nring (R:=R1) d2).
  apply mult_resp_ap_zero.
   assumption.
  trivial.
 astepr (zring (R:=R1) (n1 * n2)).
  astepr (nring (R:=R1) (d1 * d2)%positive[*]
    (zring (R:=R1) (n1 * n2)[/]nring (R:=R1) (d1 * d2)%positive[//]
      den_is_nonzero (Qmake (n1 * n2)%Z (d1 * d2)%positive))).
  apply mult_wdl.
  rewrite nat_of_P_mult_morphism.
  algebra.
 astepr (zring (R:=R1) n1[*]zring (R:=R1) n2).
  apply zring_mult.
 rational.
Qed.

Lemma inj_Q_less : forall q1 q2, (q1 [<] q2) -> inj_Q q1 [<] inj_Q q2.
Proof.
 intros q1 q2.
 case q1.
 intros n1 d1.
 case q2.
 intros n2 d2.
 intro H.
 simpl in H.
 unfold Qlt in H.
 simpl in H.
 simpl in |- *.
 apply mult_cancel_less with (z := nring (R:=R1) d1[*]nring (R:=R1) d2).
  apply mult_resp_pos.
   elim (ZL4' d1); intros.
   rewrite p.
   apply pos_nring_S.
  elim (ZL4' d2); intros.
  rewrite p.
  apply pos_nring_S.
 rstepl (zring (R:=R1) n1[*]nring (R:=R1) d2).
 rstepr (zring (R:=R1) n2[*]nring (R:=R1) d1).
 apply less_wdl with (x := zring (R:=R1) n1[*]zring (R:=R1) (Z_of_nat d2)).
  apply less_wdr with (y := zring (R:=R1) n2[*]zring (R:=R1) (Z_of_nat d1)).
   apply less_wdl with (x := zring (R:=R1) (n1 * d2)).
    apply less_wdr with (y := zring (R:=R1) (n2 * d1)).
     apply zring_less.
     apply CZlt_to.
     assumption.
    rewrite inject_nat_convert.
    apply zring_mult.
   rewrite inject_nat_convert.
   apply zring_mult.
  algebra.
 algebra.
Qed.

Lemma less_inj_Q : forall q1 q2, (inj_Q q1 [<] inj_Q q2) -> q1 [<] q2.
Proof.
 intros.
 cut (q1 [#] q2).
  intro H0.
  case (ap_imp_less _ q1 q2 H0).
   intro.
   assumption.
  intro.
  exfalso.
  cut (inj_Q q2 [<] inj_Q q1).
   change (Not (inj_Q q2 [<] inj_Q q1)) in |- *.
   apply less_antisymmetric_unfolded.
   assumption.
  apply inj_Q_less.
  assumption.
 apply inj_Q_strext.
 apply less_imp_ap.
 assumption.
Qed.

Lemma inj_Q_ap : forall q1 q2, (q1 [#] q2) -> inj_Q q1 [#] inj_Q q2.
Proof.
 intros q1 q2 H.
 destruct (ap_imp_less _ _ _ H); [apply less_imp_ap|apply Greater_imp_ap];
   apply inj_Q_less; assumption.
Qed.

Lemma leEq_inj_Q : forall q1 q2, (inj_Q q1 [<=] inj_Q q2) -> q1 [<=] q2.
Proof.
 intros.
 rewrite -> leEq_def; intro.
 apply less_irreflexive_unfolded with (x := inj_Q q2).
 eapply less_leEq_trans.
  2: apply H.
 apply inj_Q_less.
 auto.
Qed.

Lemma inj_Q_leEq : forall q1 q2, (q1 [<=] q2) -> inj_Q q1 [<=] inj_Q q2.
Proof.
 intros.
 rewrite -> leEq_def; intro.
 rewrite -> leEq_def in H; apply H.
 apply less_inj_Q.
 assumption.
Qed.

Lemma inj_Q_inv : forall q1, inj_Q [--]q1 [=] [--](inj_Q q1).
Proof.
 intro.
 apply cg_cancel_lft with (x := inj_Q q1).
 astepr (inj_Q (q1[+][--]q1)).
  apply eq_symmetric_unfolded.
  apply inj_Q_plus.
 astepr (inj_Q [0]).
  apply inj_Q_wd.
  algebra.
 simpl in |- *.
 rstepl ([0]:R1).
 algebra.
Qed.

Lemma inj_Q_minus : forall q1 q2, inj_Q (q1[-]q2) [=] inj_Q q1[-]inj_Q q2.
Proof.
 intros.
 astepl (inj_Q (q1[+][--]q2)).
 astepr (inj_Q q1[+]inj_Q [--]q2).
  apply inj_Q_plus.
 astepr (inj_Q q1[+][--](inj_Q q2)).
 apply plus_resp_eq.
 apply inj_Q_inv.
Qed.

Lemma inj_Q_div : forall q1 q2 H, inj_Q (q1/q2)%Q [=] (inj_Q q1[/]inj_Q q2[//]H).
Proof.
 intros.
 apply mult_cancel_rht with (inj_Q q2);[apply H|].
 apply eq_symmetric.
 eapply eq_transitive;[|apply inj_Q_mult].
 eapply eq_transitive;[apply div_1|].
 apply inj_Q_wd.
 simpl.
 field.
 apply inj_Q_strext.
 stepr ([0]:R1).
  apply H.
 rstepl (inj_Q q1[-]inj_Q q1).
 apply eq_symmetric.
 eapply eq_transitive;[|apply inj_Q_minus].
 apply inj_Q_wd.
 unfold cg_minus.
 simpl.
 ring.
Qed.

Hint Resolve inj_Q_plus inj_Q_mult inj_Q_inv inj_Q_minus inj_Q_div : algebra.

(** Moreover, and as expected, the [AbsSmall] predicate is also
preserved under the [inj_Q] *)

Lemma inj_Q_AbsSmall : forall q1 q2,
 AbsSmall q1 q2 -> AbsSmall (inj_Q q1) (inj_Q q2).
Proof.
 intros.
 red in |- *.
 elim H.
 intros.
 split.
  astepl (inj_Q [--]q1).
  apply inj_Q_leEq.
  assumption.
 apply inj_Q_leEq.
 assumption.
Qed.

Lemma AbsSmall_inj_Q : forall q e,
 AbsSmall (inj_Q e) (inj_Q q) -> AbsSmall e q.
Proof.
 intros.
 elim H.
 intros.
 split.
  apply leEq_inj_Q.
  apply leEq_wdl with (x := [--](inj_Q e)).
   assumption.
  apply eq_symmetric_unfolded.
  apply inj_Q_inv.
 apply leEq_inj_Q.
 assumption.
Qed.

(**
** Injection preserves Cauchy property
We apply the above lemmata to obtain following theorem, which says
that a Cauchy sequence of elemnts of [Q] will be Cauchy in [R1].
*)

Theorem inj_Q_Cauchy : forall g : CauchySeq Q_as_COrdField,
 Cauchy_prop (fun n => inj_Q (g n)).
Proof.
 intros.
 case g.
 intros g_ pg.
 simpl in |- *.
 red in |- *.
 intros e H.
 cut {n : nat | ([1][/]e[//]Greater_imp_ap _ e [0] H) [<] nring (R:=R1) n}.
  intro H0.
  case H0.
  intros N1 H1.
  unfold Cauchy_prop in pg.
  cut {N : nat | forall m : nat, N <= m ->
    AbsSmall (R:=Q_as_COrdField) (Qmake 1%Z (P_of_succ_nat N1)) (g_ m[-]g_ N)}.
   intro H2.
   case H2.
   intro N.
   intro.
   exists N.
   intros.
   apply AbsSmall_leEq_trans with (e1 := inj_Q (Qmake 1%Z (P_of_succ_nat N1))).
    apply less_leEq.
    apply mult_cancel_less with (z := nring (R:=R1) (S N1)[*]([1][/]e[//]Greater_imp_ap _ e [0] H)).
     apply mult_resp_pos.
      apply pos_nring_S.
     apply div_resp_pos.
      assumption.
     apply pos_one.
    unfold inj_Q in |- *.
    rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ with N1.
    rstepl ([1][/]e[//]Greater_imp_ap _ e [0] H).
    rstepr (nring (R:=R1) (P_of_succ_nat N1)).
    apply less_transitive_unfolded with (y := nring (R:=R1) N1).
     assumption.
    apply nring_less.
    rewrite nat_of_P_o_P_of_succ_nat_eq_succ.
    apply lt_n_Sn.
   astepr (inj_Q (g_ m[-]g_ N)).
   apply inj_Q_AbsSmall.
   apply a.
   assumption.
  apply pg.
  simpl in |- *.
  red in |- *.
  simpl in |- *.
  constructor.
 apply Archimedes'.
Qed.

(** Furthermore we prove that applying [nring] (which is adding the
ring unit [n] times) is the same whether we do it in [Q] or in [R1]:
*)

Lemma inj_Q_nring : forall n, inj_Q (nring n) [=] nring (R:=R1) n.
Proof.
 intro.
 simpl in |- *.
 induction  n as [| n Hrecn].
  simpl in |- *.
  rational.
 change (inj_Q (nring n[+][1]) [=] nring (R:=R1) n[+][1]) in |- *.
 astepr (inj_Q (nring n)[+]inj_Q [1]).
  apply inj_Q_plus.
 apply bin_op_wd_unfolded.
  assumption.
 simpl in |- *.
 unfold pring in |- *; simpl in |- *.
 rational.
Qed.

Lemma inj_Q_pring : forall n, inj_Q (pring _ n) [=] pring R1 n.
Proof.
 intros n.
 change (inj_Q (zring n)[=]zring n).
 stepr (inj_Q (nring n)).
  apply inj_Q_wd.
  rewrite <- inject_nat_convert.
  apply zring_plus_nat.
 stepr (nring n:R1).
  apply inj_Q_nring.
 apply eq_symmetric.
 rewrite <- inject_nat_convert.
 apply zring_plus_nat.
Qed.

Lemma inj_Q_zring : forall n, inj_Q (zring n) [=] zring (R:=R1) n.
Proof.
 intros [|n|n].
   simpl.
   rational.
  simpl.
  apply inj_Q_pring.
 change (inj_Q ([--](pring _ n))[=][--](pring _ n)).
 stepl ([--](inj_Q (zring (R:=Q_as_COrdField) n))).
  apply un_op_wd_unfolded.
  simpl.
  apply inj_Q_pring.
 apply eq_symmetric.
 apply inj_Q_inv.
Qed.

Lemma inj_Q_One : inj_Q [1] [=] [1].
Proof.
 rstepr ((nring 1):R1).
 apply (inj_Q_nring 1).
Qed.

Lemma inj_Q_Zero : inj_Q [0] [=] [0].
Proof.
 rstepr ((nring 0):R1).
 apply (inj_Q_nring 0).
Qed.

Hint Resolve inj_Q_nring inj_Q_pring inj_Q_zring inj_Q_One inj_Q_Zero : algebra.

Definition inj_Q_hom : RingHom Q_as_CRing R1.
Proof.
 exists (Build_CSetoid_fun _ _ _ inj_Q_strext).
   refine inj_Q_plus.
  refine inj_Q_mult.
 refine inj_Q_One.
Defined.

Lemma inj_Q_power : forall q1 (n:nat), inj_Q (q1^n)%Q [=] (inj_Q q1[^]n).
Proof.
 intros q.
 induction n.
  apply inj_Q_One.
 rewrite inj_S.
 unfold Z.succ.
 stepr (inj_Q (q^n*q)%Q).
  apply inj_Q_wd.
  simpl.
  apply Qpower_plus'.
  auto with *.
 stepr (inj_Q (q^n)%Q[*]inj_Q q).
  apply inj_Q_mult.
 simpl.
 apply mult_wdl.
 assumption.
Qed.

Lemma inj_Q_power_Z : forall q1 (n:Z) H, inj_Q (q1^n)%Q [=] ((inj_Q q1)[//]H)[^^]n.
Proof.
 intros q [|n|n] H.
   change (inj_Q (q ^ 0)%Q[=][1]).
   apply inj_Q_One.
  simpl.
  change (inj_Q (q ^ n)%Q[=]inj_Q q[^]n).
  csetoid_rewrite_rev (inj_Q_power q n).
  rewrite inject_nat_convert.
  apply eq_reflexive.
 change ((inj_Q (/q ^ n))%Q[=]([1][/]inj_Q q[//]H)[^]n).
 stepl (inj_Q ((1/q)^n)%Q).
  stepr ((inj_Q (1/q)%Q)[^]n).
   csetoid_rewrite_rev (inj_Q_power (1/q)%Q n).
   rewrite inject_nat_convert.
   apply eq_reflexive.
  apply nexp_wd.
  stepr (inj_Q 1%Q[/]_[//]H).
   apply inj_Q_div.
  apply div_wd.
   rstepr (nring 1:R1).
   apply (inj_Q_nring 1).
  apply eq_reflexive.
 apply inj_Q_wd.
 change (((1 * / q) ^ n)%Q==(/ q ^ n))%Q.
 rewrite <- Qinv_power.
 rewrite -> Qmult_1_l.
 reflexivity.
Qed.

Hint Resolve inj_Q_power inj_Q_power_Z : algebra.

(**
** Injection of [Q] is dense
Finally we are able to prove the density of image of [Q] in [R1]. We
state this fact in two different ways. Both of them have their
specific use.

The first theorem states the fact that any real number can be bound by
the image of two rational numbers. This is called [start_of_sequence]
because it can be used as an starting point for the typical "interval
trisection" argument, which is ubiquitous in constructive analysis.
*)

Theorem start_of_sequence : forall x : R1,
 {q1 : Q_as_COrdField | {q2 : Q_as_COrdField | inj_Q q1 [<] x | x [<] inj_Q q2}}.
Proof.
 intros.
 cut {n : nat | x [<] nring (R:=R1) n}.
  intro H.
  cut {n : nat | [--]x [<] nring (R:=R1) n}.
   intro H0.
   case H.
   intro n2.
   intro.
   case H0.
   intro n1.
   intro.
   exists (Qmake (- n1) 1).
   exists (Qmake n2 1).
    simpl in |- *.
    rstepl (zring (R:=R1) (- Z_of_nat n1)).
    astepl [--](nring (R:=R1) n1).
    apply inv_cancel_less.
    astepr (nring (R:=R1) n1).
    assumption.
   simpl in |- *.
   rstepr (zring (R:=R1) (Z_of_nat n2)).
   astepr (nring (R:=R1) n2).
   assumption.
  apply Archimedes'.
 apply Archimedes'.
Qed.

(** The second version of the density of [Q] in [R1] states that given
any positive real number, there is a rational number between it and
zero. This lemma can be used to prove the more general fact that there
is a rational number between any two real numbers. *)

Lemma Q_dense_in_CReals : forall e : R1,
 [0] [<] e -> {q : Q_as_COrdField | [0] [<] inj_Q q | inj_Q q [<] e}.
Proof.
 intros e H.
 cut {n : nat | ([1][/] e[//]Greater_imp_ap _ e [0] H) [<] nring (R:=R1) n}.
  intro H0.
  case H0.
  intro N.
  intros.
  exists (Qmake 1 (P_of_succ_nat N)).
   simpl in |- *.
   unfold pring in |- *; simpl in |- *.
   apply mult_cancel_less with (z := nring (R:=R1) N[+][1]).
    change ([0] [<] nring (R:=R1) (S N)) in |- *.
    apply pos_nring_S.
   astepl ([0]:R1).
   astepr (([0][+][1][-][0][/] nring (P_of_succ_nat N)[//]
     den_is_nonzero (Qmake 1%positive (P_of_succ_nat N)))[*] nring (S N)).
    rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ with N.
    rstepr ([1]:R1).
    apply pos_one.
   apply bin_op_wd_unfolded.
    rational.
   algebra.
  simpl in |- *.
  apply swap_div with (z_ := Greater_imp_ap _ e [0] H).
    rewrite nat_of_P_o_P_of_succ_nat_eq_succ.
    apply pos_nring_S.
   assumption.
  unfold pring in |- *; simpl in |- *.
  rstepl ([1][/] e[//]Greater_imp_ap _ e [0] H).
  apply less_transitive_unfolded with (y := nring (R:=R1) N).
   assumption.
  rewrite nat_of_P_o_P_of_succ_nat_eq_succ.
  apply nring_less_succ.
 apply Archimedes'.
Qed.

Lemma Q_dense_in_CReals' : forall a b : R1,
 a [<] b -> {q : Q_as_COrdField | a [<] inj_Q q | inj_Q q [<] b}.
Proof.
 cut (forall a b : R1, [0][<]b -> a[<]b -> {q : Q_as_COrdField | a[<]inj_Q q | inj_Q q[<]b}).
  intros H a b Hab.
  destruct (less_cotransitive_unfolded _ _ _ Hab [0]);[|apply H;assumption].
  assert (X:[0][<][--]a).
   rstepl ([--][0]:R1).
   apply inv_resp_less.
   assumption.
  assert (Y:=inv_resp_less _ _ _ Hab).
  destruct (H _ _ X Y) as [q Hqa Hqb].
  exists (-q)%Q.
   stepr ([--](inj_Q q)).
    apply inv_cancel_less.
    stepl (inj_Q q);[assumption|apply eq_symmetric; apply cg_inv_inv].
   apply eq_symmetric; apply inj_Q_inv.
  stepl ([--](inj_Q q)).
   apply inv_cancel_less.
   stepr (inj_Q q);[assumption|apply eq_symmetric; apply cg_inv_inv].
  apply eq_symmetric; apply inj_Q_inv.
 cut  (forall a b : R1, [0][<]b -> (a[+][1])[<]b -> {n : nat | a[<]nring n | nring n[<]b}).
  intros H a b Hb Hab.
  destruct (Q_dense_in_CReals _ (shift_zero_less_minus _ _ _ Hab)) as [q Haq Hbq].
  assert (X0 := pos_ap_zero _ _ Haq).
  assert (X1 : [0][<](b[/]inj_Q q[//]X0)).
   apply div_resp_pos; assumption.
  assert (X2 : (a[/]inj_Q q[//]X0)[+][1][<](b[/]inj_Q q[//]X0)).
   apply shift_plus_less'.
   rstepr ((b[-]a)[/]inj_Q q[//]X0).
   apply shift_less_div.
    assumption.
   rstepl (inj_Q q).
   assumption.
  destruct (H _ _ X1 X2) as [r Hra Hrb].
  exists ((nring r)[*]q)%Q; csetoid_rewrite (inj_Q_mult (nring r) q).
   eapply shift_less_mult.
    assumption.
   stepr (nring (R:=R1) r).
    apply Hra.
   apply eq_symmetric. apply inj_Q_nring.
  eapply shift_mult_less.
   assumption.
  stepl (nring (R:=R1) r).
   apply Hrb.
  apply eq_symmetric. apply inj_Q_nring.
 intros a b Hb Hab.
 destruct (Archimedes' a) as [n Hn].
 induction n.
  exists 0; try assumption.
 destruct (less_cotransitive_unfolded _ _ _ Hab (nring (R:=R1) (S n))).
  apply IHn.
  apply plus_cancel_less with [1].
  apply c.
 exists (S n); assumption.
Qed.

End Rational_sequence_prelogue.

#[global]
Hint Resolve inj_Q_plus inj_Q_mult inj_Q_inv inj_Q_minus inj_Q_div : algebra.
#[global]
Hint Resolve inj_Q_nring inj_Q_pring inj_Q_zring : algebra.
#[global]
Hint Resolve inj_Q_power inj_Q_power_Z : algebra.


(*
REFERENCES:
The code contained in this file is heavily based on the code from
    - "Software Foundations 1: Logical Foundations, Imp.v, Maps.v"
        "https://softwarefoundations.cis.upenn.edu/lf-current/Imp.html"
    - "Software Foundations 2: Programming Language Foundations, Hoare.v"
        "https://softwarefoundations.cis.upenn.edu/plf-current/Hoare.html"
Both by Benjamin C. Pierce, et al. 2021.
The base of this code has been taken directly from these files,
    and some code has been taken and edited to fit our project.
All additions and edits to the code has been by, or in coorporation with, ITU associate professor Alessandro Bruni.
The project has been supervised by course teacher Jesper Bengtson.

Code comments are provided to indicate authorship of the code.
  'Edited' mean code taken and edited from the books,
  no comment means code taken directly from the book.
*)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".

From mathcomp.ssreflect Require Import all_ssreflect.
From infotheo Require Import convex fsdist Reals_ext ssrR proba .
From mathcomp Require Import finmap Rstruct.
Require Import Nat Reals List.
Open Scope R_scope.
Open Scope nat_scope.
Open Scope proba_scope.
Open Scope convex_scope.

(*Added by Alessandro*)
Definition var := ordinal 8.

(*Edited by Alessandro*)
Definition state := {ffun var -> nat}.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AId (x : var)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Definition X: var := inord 0.
Definition Y: var := inord 1.

(*Added by group in collaboration w. Alessandro*)
Definition one_aexp := ANum 1.
Definition two_aexp := ANum 2.
Definition three_aexp := ANum 3.

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Coercion AId : var >-> aexp.
Coercion ANum : nat >-> aexp.

Declare Custom Entry com.
Declare Scope com_scope.
Notation "<{ e }>" := e (at level 0, e custom com at level 99) : com_scope.
Notation "( x )" := x (in custom com, x at level 99) : com_scope.
Notation "x" := x (in custom com at level 0, x constr at level 0) : com_scope.
Notation "f x .. y" := (.. (f x) .. y)
                  (in custom com at level 0, only parsing,
                  f constr at level 0, x constr at level 9,
                  y constr at level 9) : com_scope.
Notation "x + y" := (APlus x y) (in custom com at level 50, left associativity).
Notation "x - y" := (AMinus x y) (in custom com at level 50, left associativity).
Notation "x * y" := (AMult x y) (in custom com at level 40, left associativity).
Notation "'true'"  := true (at level 1).
Notation "'true'"  := BTrue (in custom com at level 0).
Notation "'false'"  := false (at level 1).
Notation "'false'"  := BFalse (in custom com at level 0).
Notation "x <= y" := (BLe x y) (in custom com at level 70, no associativity).
Notation "x = y"  := (BEq x y) (in custom com at level 70, no associativity).
Notation "x && y" := (BAnd x y) (in custom com at level 80, left associativity).
Notation "'~' b"  := (BNot b) (in custom com at level 75, right associativity).

Open Scope com_scope.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | <{a1 + a2}> => (aeval st a1) + (aeval st a2)
  | <{a1 - a2}> => (aeval st a1) - (aeval st a2)
  | <{a1 * a2}> => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | <{true}> => true
  | <{false}> => false
  | <{a1 = a2}> => (aeval st a1) =? (aeval st a2)
  | <{a1 <= a2}> => (aeval st a1) <=? (aeval st a2)
  | <{~ b1}> => negb (beval st b1)
  | <{b1 && b2}> => andb (beval st b1) (beval st b2)
  end.

(*Edited by Alessandro*)
Definition t_empty v : state := [ffun x => v].

(*Edited by Alessandro*)
Definition t_update st i v : state :=
  [ffun x => if i == x then v else st x].

Notation "'_' '!->' v " := (t_empty v)
  (at level 100, right associativity).

Notation "x '!->' v ';' m" := (t_update m x v)
  (at level 100, v at next level, right associativity).

(*Edited and proved by Alessandro*)
Lemma t_apply_empty : forall x v,
  (_ !-> v) x = v.
  Proof.
    move => x v.
    rewrite /t_empty=> /=.
    by rewrite ffunE.
  Qed.

(*Edited by Alessandro*)
Inductive com : Type :=
  | CSkip
  | CAsgn (x : var) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CPlus (p : Reals_ext.Prob.t) (c1 c2 : com).

Notation "'skip'"  :=
    CSkip (in custom com at level 0) : com_scope.
Notation "x := y"  :=
    (CAsgn x y)
       (in custom com at level 0, x constr at level 0,
        y at level 85, no associativity) : com_scope.
Notation "x ; y" :=
    (CSeq x y)
      (in custom com at level 90, right associativity) : com_scope.
Notation "'if' x 'then' y 'else' z 'end'" :=
    (CIf x y z)
      (in custom com at level 89, x at level 99,
       y at level 99, z at level 99) : com_scope.

(*Made by Alessandro*)
Notation "c1 '[+' p ']' c2" := (CPlus p c1 c2)
       (in custom com at level 90, p at level 85, right associativity) : com_scope.

(*Made by Alessandro*)
Fixpoint sample x a1 as_ :=
  match as_ with
  | nil => (<{x := a1}>)
  | (a2::as__) =>
      (let l := List.length as_ in
      let p := (divRnnm 1 l)%:pr in
      <{ x := a1 [+ p ] (sample x a2 as__)}>)
  end.

(*Made by Alessandro*)
Notation "x '$=' { a1 ; a2 ; .. ; an }" := (sample x a1 (cons a2 .. (cons an nil) ..))
  (in custom com at level 0, x constr at level 0,
  a1 at level 85, a2 at level 85, an at level 85, no associativity) : com_scope.

(*Edited by group in collaboration w. Alessandro*)
Fixpoint ceval (st : state) (c : com) : {dist state} :=
  match c with
  | <{ skip }> => FSDist1.d st
  | <{ x := a }> => FSDist1.d (x !-> (aeval st a) ; st)
  | <{ c1 ; c2 }> =>
      let dst' := ceval st c1 in
      FSDistBind.d dst' (fun st => ceval st c2)
  | <{ if b then c1 else c2 end }> =>
      if (beval st b)
        then ceval st c1
        else ceval st c2
  | <{ c1 [+ p] c2}> => (ceval st c1) <|p|> (ceval st c2)
  end.

(* ####### HOARE TRIPLE ####### *)

(*Edited by Alessandro*)
Definition Assertion := {dist state} -> bool.

(*Added by Alessandro*)
Definition hoare (P : Assertion) (c : com) (Q : Assertion) : Prop :=
    forall dst,
        (P dst -> Q (FSDistBind.d dst (fun st => ceval st c))) = true.

(*Edited by Alessandro*)
Notation "{{ P }}  c  {{ Q }}" :=
    (hoare P c Q) (at level 90, c custom com at level 99)
    : com_scope.

(*Added by Alessandro*)
Open Scope proba_scope.

(* ####### HOARE RULES ####### *)

(*Added by Alessandro*)
Definition conva : Assertion -> Assertion -> prob -> Assertion.
Admitted.

(*Edited by group in collaboration w. Alessandro*)
Definition assn_sub (X: var) (a: nat) (P: Assertion) : Assertion :=
  fun (dst : {dist state}) =>
    P (FSDistfmap (fun (st: state) => t_update st X a ) dst).

Notation "P [ X |-> a ]" := (assn_sub X a P)
  (at level 10, X at next level, a custom com).

(*Added by Alessandro*)
Axiom convaE : forall P d Q dst1 dst2,
    P dst1 = true ->
    Q dst2 = true ->
    conva P Q d (dst1 <| d |> dst2) = true.

(*Added by Alessandro*)
Axiom hskip:
    forall P, {{ P }} skip {{ P }}.

(*Edited by group in collaboration w. Alessandro*)
Axiom hasgn:
  forall Q X a,
  {{Q [X |-> a]}} X := a {{Q}}.

(*Added by Alessandro*)
Axiom hprob:
    forall P c1 c2 Q Q' d,
    {{ P }} c1 {{ Q }} ->
    {{ P }} c2 {{ Q' }} ->
    {{ P }} c1 [+ d ] c2 {{ conva Q Q' d }}.

(*Added by Alessandro*)
Axiom hseq:
    forall P Q R c1 c2,
    {{ P }} c1 {{ Q }} ->
    {{ Q }} c2 {{ R }} ->
    {{ P }} c1 ; c2 {{ R }}.

(*Added by Alessandro*)
Axiom hcons_left:
    forall P Q R c,
    (forall dst, P dst = true -> Q dst = true) ->
    {{ Q }} c {{ R }} ->
    {{ P }} c {{ R }}.

(*Added by Alessandro*)
Axiom hcons_right:
    forall P Q R c,
    (forall dst, Q dst = true -> R dst = true) ->
    {{ P }} c {{ Q }} ->
    {{ P }} c {{ R }}.

(* ####### HELPERS ####### *)

(*Added by group in collaboration w. Alessandro*)
Definition preq exp p dst :=
  eqr (Pr (fdist_of_FSDist.d dst) [set st | beval (val st) exp ]) p.

(*Added by Alessandro*)
Lemma preq_assn: forall x v dst,
  ((preq <{ AId x = ANum v }> 1%R) [x |-> v]) dst = true.
Proof.
  intros.
  rewrite /assn_sub /preq.
  case: eqrP => //.
Admitted.

(*Added by Alessandro*)
Axiom conva_preq: forall be1 be2 (p1 p2: prob) d,
  conva (preq be1 p1) (preq be2 p2) d =1 fun dst => preq be1 (d * p1)%R dst && preq be2 ((1-d) * p2) dst.

(*Added and proved by Alessandro*)
Lemma divRnnm_1_1_inv2 : divRnnm 1 1 = /2.
Proof. by rewrite /divRnnm /addn div1R. Qed.

(*Added by group*)
Lemma two_times_quarter : forall exp dst,
preq exp (/ 2 * / 2) dst /\
preq exp ((1 - / 2) * / 2) dst ->
preq exp (/ 2) dst = true.
Proof. Admitted.

(*Added by group*)
Lemma x_one_and_two_y_1: forall x y dst,
preq <{ AId x = one_aexp}> (1 / 2) dst /\
preq <{ AId x = two_aexp}> (1 - 1/2) dst ->
((preq <{ x + y = three_aexp }> (/ 2)) [y |-> 1]) dst = true.
Proof. Admitted.

(*Added by group*)
Lemma x_one_and_two_y_2: forall x y dst,
preq <{ AId x = one_aexp}> (1 / 2) dst /\
preq <{ AId x = two_aexp}> (1 - 1/2) dst ->
((preq <{ x + y = three_aexp }> (/ 2)) [y |-> 2]) dst = true.
Proof. Admitted.

(*Added and proved in collaboration between Alessandro and group*)
Lemma twocoins: {{ xpredT }}
X $= {ANum 1; ANum 2}; Y $= {ANum 1; ANum 2}
{{ preq <{ X + Y = three_aexp }> (/2)%R }}.
Proof.
eapply (hseq _ (conva (preq <{ X = one_aexp }> 1) (preq <{ X = two_aexp}> 1) _)).
- apply hprob;
    try eapply hcons_left;
    last first;
    try apply hasgn;
    try intros;
    try apply preq_assn.
- eapply (hcons_right _ (conva (preq <{ X + Y = three_aexp }> (/2)%R) (preq <{ X + Y = three_aexp }> (/2)%R) _)); last first.
 -- apply hprob.
  --- eapply hcons_left; last first.
    ---- apply hasgn.
    ---- intros dst. rewrite conva_preq.
          case: andP.
      ----- simpl. rewrite !mulR1. intros h1 h2. unfold divRnnm in h1. unfold addn in h1. simpl in *. apply x_one_and_two_y_1. auto.
      ----- intros. discriminate H.
  --- eapply hcons_left; last first.
    ---- apply hasgn.
    ---- intros dst. rewrite conva_preq. case: andP.
      ----- simpl. rewrite !mulR1. intros. apply x_one_and_two_y_2. auto.
      ----- intros. discriminate H.
  --- intros dst. rewrite conva_preq. case: andP.
    ---- intros. simpl in p. rewrite divRnnm_1_1_inv2 in p. apply two_times_quarter. auto.
    ---- intros. discriminate H.
Qed.