From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Ranalysis1.
Require Import MVT.
Require Import Max.
Require Import Even.
Require Import Fourier.
Local Open Scope R_scope.

Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.

Lemma Boule_convex : forall c d x y z,
Boule c d x -> Boule c d y -> x <= z <= y -> Boule c d z.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.Boule_convex".
intros c d x y z bx b_y intz.
unfold Boule in bx, b_y; apply Rabs_def2 in bx;
apply Rabs_def2 in b_y; apply Rabs_def1;
[apply Rle_lt_trans with (y - c);[apply Rplus_le_compat_r|]|
apply Rlt_le_trans with (x - c);[|apply Rplus_le_compat_r]];tauto.
Qed.

Definition boule_of_interval x y (h : x < y) :
{c :R & {r : posreal | c - r = x /\ c + r = y}}.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.boule_of_interval".
exists ((x + y)/2).
assert (radius : 0 < (y - x)/2).
unfold Rdiv; apply Rmult_lt_0_compat.
apply Rlt_Rminus; assumption.
now apply Rinv_0_lt_compat, Rlt_0_2.
exists (mkposreal _ radius).
simpl; split; unfold Rdiv; field.
Qed.

Definition boule_in_interval x y z (h : x < z < y) :
{c : R & {r | Boule c r z /\  x < c - r /\ c + r < y}}.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.boule_in_interval".
assert (cmp : x * /2 + z * /2 < z * /2 + y * /2).
destruct h as [h1 h2].
rewrite Rplus_comm; apply Rplus_lt_compat_l, Rmult_lt_compat_r.
apply Rinv_0_lt_compat, Rlt_0_2.
apply Rlt_trans with z; assumption.
destruct (boule_of_interval _ _ cmp) as [c [r [P1 P2]]].
assert (0 < /2) by (apply Rinv_0_lt_compat, Rlt_0_2).
exists c, r; split.
destruct h; unfold Boule; simpl; apply Rabs_def1.
apply Rplus_lt_reg_l with c; rewrite P2;
replace (c + (z - c)) with (z * / 2 + z * / 2) by field.
apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption.
apply Rplus_lt_reg_l with c; change (c + - r) with (c - r);
rewrite P1;
replace (c + (z - c)) with (z * / 2 + z * / 2) by field.
apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption.
destruct h; split.
replace x with (x * / 2 + x * / 2) by field; rewrite P1.
apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption.
replace y with (y * / 2 + y * /2) by field; rewrite P2.
apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption.
Qed.

Lemma Ball_in_inter : forall c1 c2 r1 r2 x,
Boule c1 r1 x -> Boule c2 r2 x ->
{r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.Ball_in_inter".
intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2.
assert (Rmax (c1 - r1)(c2 - r2) < x).
apply Rmax_lub_lt;[revert in1 | revert in2]; intros h;
apply Rabs_def2 in h; destruct h as [_ u];
apply (fun h => Rplus_lt_reg_r _ _ _ (Rle_lt_trans _ _ _ h u)), Req_le; ring.
assert (x < Rmin (c1 + r1) (c2 + r2)).
apply Rmin_glb_lt;[revert in1 | revert in2]; intros h;
apply Rabs_def2 in h; destruct h as [u _];
apply (fun h => Rplus_lt_reg_r _ _ _ (Rlt_le_trans _ _ _ u h)), Req_le; ring.
assert (t: 0 < Rmin (x - Rmax (c1 - r1) (c2 - r2))
(Rmin (c1 + r1) (c2 + r2) - x)).
apply Rmin_glb_lt; apply Rlt_Rminus; assumption.
exists (mkposreal _ t).
apply Rabs_def2 in in1; destruct in1.
apply Rabs_def2 in in2; destruct in2.
assert (c1 - r1 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_l.
assert (c2 - r2 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_r.
assert (Rmin (c1 + r1) (c2 + r2) <= c1 + r1) by apply Rmin_l.
assert (Rmin (c1 + r1) (c2 + r2) <= c2 + r2) by apply Rmin_r.
assert (Rmin (x - Rmax (c1 - r1) (c2 - r2))
(Rmin (c1 + r1) (c2 + r2) - x) <= x - Rmax (c1 - r1) (c2 - r2))
by apply Rmin_l.
assert (Rmin (x - Rmax (c1 - r1) (c2 - r2))
(Rmin (c1 + r1) (c2 + r2) - x) <= Rmin (c1 + r1) (c2 + r2) - x)
by apply Rmin_r.
simpl.
intros y h; apply Rabs_def2 in h; destruct h as [h h'].
apply Rmin_Rgt in h; destruct h as [cmp1 cmp2].
apply Rplus_lt_reg_r in cmp2; apply Rmin_Rgt in cmp2.
rewrite Ropp_Rmin, Ropp_minus_distr in h'.
apply Rmax_Rlt in h'; destruct h' as [cmp3 cmp4];
apply Rplus_lt_reg_r in cmp3; apply Rmax_Rlt in cmp3;
split; apply Rabs_def1.
apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj1 cmp2))), Req_le;
ring.
apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj1 cmp3) h)), Req_le;
ring.
apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj2 cmp2))), Req_le;
ring.
apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj2 cmp3) h)), Req_le;
ring.
Qed.

Lemma Boule_center : forall x r, Boule x r x.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.Boule_center".
intros x [r rpos]; unfold Boule, Rminus; simpl; rewrite Rplus_opp_r.
rewrite Rabs_pos_eq;[assumption | apply Rle_refl].
Qed.

Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R)
(r:posreal) : Prop :=
forall eps:R,
0 < eps ->
exists N : nat,
(forall (n:nat) (y:R),
(N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps).

Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type :=
{ An:nat -> R &
{ l:R |
Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n) l /\
(forall (n:nat) (y:R), Boule 0 r y -> Rabs (fn n y) <= An n) } }.

Definition CVN_R (fn:nat -> R -> R) : Type := forall r:posreal, CVN_r fn r.

Definition SFL (fn:nat -> R -> R)
(cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l })
(y:R) : R := let (a,_) := cv y in a.

Lemma CVN_CVU :
forall (fn:nat -> R -> R)
(cv:forall x:R, {l:R | Un_cv (fun N:nat => SP fn N x) l })
(r:posreal), CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL fn cv) 0 r.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.CVN_CVU".
intros; unfold CVU; intros.
unfold CVN_r in X.
elim X; intros An X0.
elim X0; intros s H0.
elim H0; intros.
cut (Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n - s) 0).
intro; unfold Un_cv in H3.
elim (H3 eps H); intros N0 H4.
exists N0; intros.
apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)).
rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Rabs (An k)) n - s));
rewrite Ropp_minus_distr';
rewrite (Rabs_right (s - sum_f_R0 (fun k:nat => Rabs (An k)) n)).
eapply sum_maj1.
unfold SFL; case (cv y); intro.
trivial.
apply H1.
intro; elim H0; intros.
rewrite (Rabs_right (An n0)).
apply H8; apply H6.
apply Rle_ge; apply Rle_trans with (Rabs (fn n0 y)).
apply Rabs_pos.
apply H8; apply H6.
apply Rle_ge;
apply Rplus_le_reg_l with (sum_f_R0 (fun k:nat => Rabs (An k)) n).
rewrite Rplus_0_r; unfold Rminus; rewrite (Rplus_comm s);
rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l;
apply sum_incr.
apply H1.
intro; apply Rabs_pos.
unfold R_dist in H4; unfold Rminus in H4; rewrite Ropp_0 in H4.
assert (H7 := H4 n H5).
rewrite Rplus_0_r in H7; apply H7.
unfold Un_cv in H1; unfold Un_cv; intros.
elim (H1 _ H3); intros.
exists x; intros.
unfold R_dist; unfold R_dist in H4.
rewrite Rminus_0_r; apply H4; assumption.
Qed.

Lemma CVU_continuity :
forall (fn:nat -> R -> R) (f:R -> R) (x:R) (r:posreal),
CVU fn f x r ->
(forall (n:nat) (y:R), Boule x r y -> continuity_pt (fn n) y) ->
forall y:R, Boule x r y -> continuity_pt f y.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.CVU_continuity".
intros; unfold continuity_pt; unfold continue_in;
unfold limit1_in; unfold limit_in;
simpl; unfold R_dist; intros.
unfold CVU in H.
cut (0 < eps / 3);
[ intro
| unfold Rdiv; apply Rmult_lt_0_compat;
[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
elim (H _ H3); intros N0 H4.
assert (H5 := H0 N0 y H1).
cut (exists del : posreal, (forall h:R, Rabs h < del -> Boule x r (y + h))).
intro.
elim H6; intros del1 H7.
unfold continuity_pt in H5; unfold continue_in in H5; unfold limit1_in in H5;
unfold limit_in in H5; simpl in H5; unfold R_dist in H5.
elim (H5 _ H3); intros del2 H8.
set (del := Rmin del1 del2).
exists del; intros.
split.
unfold del; unfold Rmin; case (Rle_dec del1 del2); intro.
apply (cond_pos del1).
elim H8; intros; assumption.
intros;
apply Rle_lt_trans with (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - f y)).
replace (f x0 - f y) with (f x0 - fn N0 x0 + (fn N0 x0 - f y));
[ apply Rabs_triang | ring ].
apply Rle_lt_trans with
(Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - fn N0 y) + Rabs (fn N0 y - f y)).
rewrite Rplus_assoc; apply Rplus_le_compat_l.
replace (fn N0 x0 - f y) with (fn N0 x0 - fn N0 y + (fn N0 y - f y));
[ apply Rabs_triang | ring ].
replace eps with (eps / 3 + eps / 3 + eps / 3).
repeat apply Rplus_lt_compat.
apply H4.
apply le_n.
replace x0 with (y + (x0 - y)); [ idtac | ring ]; apply H7.
elim H9; intros.
apply Rlt_le_trans with del.
assumption.
unfold del; apply Rmin_l.
elim H8; intros.
apply H11.
split.
elim H9; intros; assumption.
elim H9; intros; apply Rlt_le_trans with del.
assumption.
unfold del; apply Rmin_r.
rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H4.
apply le_n.
assumption.
apply Rmult_eq_reg_l with 3.
do 2 rewrite Rmult_plus_distr_l; unfold Rdiv; rewrite <- Rmult_assoc;
rewrite Rinv_r_simpl_m.
ring.
discrR.
discrR.
cut (0 < r - Rabs (x - y)).
intro; exists (mkposreal _ H6).
simpl; intros.
unfold Boule; replace (y + h - x) with (h + (y - x));
[ idtac | ring ]; apply Rle_lt_trans with (Rabs h + Rabs (y - x)).
apply Rabs_triang.
apply Rplus_lt_reg_l with (- Rabs (x - y)).
rewrite <- (Rabs_Ropp (y - x)); rewrite Ropp_minus_distr'.
replace (- Rabs (x - y) + r) with (r - Rabs (x - y)).
replace (- Rabs (x - y) + (Rabs h + Rabs (x - y))) with (Rabs h).
apply H7.
ring.
ring.
unfold Boule in H1; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr';
apply Rplus_lt_reg_l with (Rabs (y - x)).
rewrite Rplus_0_r; replace (Rabs (y - x) + (r - Rabs (y - x))) with (pos r);
[ apply H1 | ring ].
Qed.

Lemma continuity_pt_finite_SF :
forall (fn:nat -> R -> R) (N:nat) (x:R),
(forall n:nat, (n <= N)%nat -> continuity_pt (fn n) x) ->
continuity_pt (fun y:R => sum_f_R0 (fun k:nat => fn k y) N) x.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.continuity_pt_finite_SF".
intros; induction  N as [| N HrecN].
simpl; apply (H 0%nat); apply le_n.
simpl;
replace (fun y:R => sum_f_R0 (fun k:nat => fn k y) N + fn (S N) y) with
((fun y:R => sum_f_R0 (fun k:nat => fn k y) N) + (fun y:R => fn (S N) y))%F;
[ idtac | reflexivity ].
apply continuity_pt_plus.
apply HrecN.
intros; apply H.
apply le_trans with N; [ assumption | apply le_n_Sn ].
apply (H (S N)); apply le_n.
Qed.

Lemma SFL_continuity_pt :
forall (fn:nat -> R -> R)
(cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l })
(r:posreal),
CVN_r fn r ->
(forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y) ->
forall y:R, Boule 0 r y -> continuity_pt (SFL fn cv) y.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.SFL_continuity_pt".
intros; eapply CVU_continuity.
apply CVN_CVU.
apply X.
intros; unfold SP; apply continuity_pt_finite_SF.
intros; apply H.
apply H1.
apply H0.
Qed.

Lemma SFL_continuity :
forall (fn:nat -> R -> R)
(cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }),
CVN_R fn -> (forall n:nat, continuity (fn n)) -> continuity (SFL fn cv).
Proof. hammer_hook "PSeries_reg" "PSeries_reg.SFL_continuity".
intros; unfold continuity; intro.
cut (0 < Rabs x + 1);
[ intro | apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ] ].
cut (Boule 0 (mkposreal _ H0) x).
intro; eapply SFL_continuity_pt with (mkposreal _ H0).
apply X.
intros; apply (H n y).
apply H1.
unfold Boule; simpl; rewrite Rminus_0_r;
pattern (Rabs x) at 1; rewrite <- Rplus_0_r;
apply Rplus_lt_compat_l; apply Rlt_0_1.
Qed.

Lemma CVN_R_CVS :
forall fn:nat -> R -> R,
CVN_R fn -> forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.CVN_R_CVS".
intros; apply R_complete.
unfold SP; set (An := fun N:nat => fn N x).
change (Cauchy_crit_series An).
apply cauchy_abs.
unfold Cauchy_crit_series; apply CV_Cauchy.
unfold CVN_R in X; cut (0 < Rabs x + 1).
intro; assert (H0 := X (mkposreal _ H)).
unfold CVN_r in H0; elim H0; intros Bn H1.
elim H1; intros l H2.
elim H2; intros.
apply Rseries_CV_comp with Bn.
intro; split.
apply Rabs_pos.
unfold An; apply H4; unfold Boule; simpl;
rewrite Rminus_0_r.
pattern (Rabs x) at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
apply Rlt_0_1.
exists l.
cut (forall n:nat, 0 <= Bn n).
intro; unfold Un_cv in H3; unfold Un_cv; intros.
elim (H3 _ H6); intros.
exists x0; intros.
replace (sum_f_R0 Bn n) with (sum_f_R0 (fun k:nat => Rabs (Bn k)) n).
apply H7; assumption.
apply sum_eq; intros; apply Rabs_right; apply Rle_ge; apply H5.
intro; apply Rle_trans with (Rabs (An n)).
apply Rabs_pos.
unfold An; apply H4; unfold Boule; simpl;
rewrite Rminus_0_r; pattern (Rabs x) at 1;
rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1.
apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ].
Qed.

Lemma CVU_cv : forall f g c d, CVU f g c d ->
forall x, Boule c d x -> Un_cv (fun n => f n x) (g x).
Proof. hammer_hook "PSeries_reg" "PSeries_reg.CVU_cv".
intros f g c d cvu x bx eps ep; destruct (cvu eps ep) as [N Pn].
exists N; intros n nN; rewrite R_dist_sym; apply Pn; assumption.
Qed.

Lemma CVU_ext_lim :
forall f g1 g2 c d, CVU f g1 c d -> (forall x, Boule c d x -> g1 x = g2 x) ->
CVU f g2 c d.
Proof. hammer_hook "PSeries_reg" "PSeries_reg.CVU_ext_lim".
intros f g1 g2 c d cvu q eps ep; destruct (cvu _ ep) as [N Pn].
exists N; intros; rewrite <- q; auto.
Qed.

Lemma CVU_derivable :
forall f f' g g' c d,
CVU f' g' c d ->
(forall x, Boule c d x -> Un_cv (fun n => f n x) (g x)) ->
(forall n x, Boule c d x -> derivable_pt_lim (f n) x (f' n x)) ->
forall x, Boule c d x -> derivable_pt_lim g x (g' x).
Proof. hammer_hook "PSeries_reg" "PSeries_reg.CVU_derivable".
intros f f' g g' c d cvu cvp dff' x bx.
set (rho_ :=
fun n y =>
if Req_EM_T y x then
f' n x
else ((f n y - f n x)/ (y - x))).
set (rho := fun y =>
if Req_EM_T y x then
g' x
else (g y - g x)/(y - x)).
assert (ctrho : forall n z, Boule c d z -> continuity_pt (rho_ n) z).
intros n z bz.
destruct (Req_EM_T x z) as [xz | xnz].
rewrite <- xz.
intros eps' ep'.
destruct (dff' n x bx eps' ep') as [alp Pa].
exists (pos alp);split;[apply cond_pos | ].
intros z'; unfold rho_, D_x, dist, R_met; simpl; intros [[_ xnz'] dxz'].
destruct (Req_EM_T z' x) as [abs | _].
case xnz'; symmetry; exact abs.
destruct (Req_EM_T x x) as [_ | abs];[ | case abs; reflexivity].
pattern z' at 1; replace z' with (x + (z' - x)) by ring.
apply Pa;[intros h; case xnz';
replace z' with (z' - x + x) by ring; rewrite h, Rplus_0_l;
reflexivity | exact dxz'].
destruct (Ball_in_inter c c d d z bz bz) as [delta Pd].
assert (dz :  0 < Rmin delta (Rabs (z - x))).
now apply Rmin_glb_lt;[apply cond_pos | apply Rabs_pos_lt; intros zx0; case xnz;
replace z with (z - x + x) by ring; rewrite zx0, Rplus_0_l].
assert (t' : forall y : R,
R_dist y z < Rmin delta (Rabs (z - x)) ->
(fun z : R => (f n z - f n x) / (z - x)) y = rho_ n y).
intros y dyz; unfold rho_; destruct (Req_EM_T y x) as [xy | xny].
rewrite xy in dyz.
destruct (Rle_dec  delta (Rabs (z - x))).
rewrite Rmin_left, R_dist_sym in dyz; unfold R_dist in dyz; fourier.
rewrite Rmin_right, R_dist_sym in dyz; unfold R_dist in dyz;
[case (Rlt_irrefl _ dyz) |apply Rlt_le, Rnot_le_gt; assumption].
reflexivity.
apply (continuity_pt_locally_ext (fun z => (f n z - f n x)/(z - x))
(rho_ n) _ z dz t'); clear t'.
apply continuity_pt_div.
apply continuity_pt_minus.
apply derivable_continuous_pt; eapply exist; apply dff'; assumption.
apply continuity_pt_const; intro; intro; reflexivity.
apply continuity_pt_minus;
[apply derivable_continuous_pt; exists 1; apply derivable_pt_lim_id
| apply continuity_pt_const; intro; reflexivity].
intros zx0; case xnz; replace z with (z - x + x) by ring.
rewrite zx0, Rplus_0_l; reflexivity.
assert (CVU rho_ rho c d ).
intros eps ep.
assert (ep8 : 0 < eps/8).
fourier.
destruct (cvu _ ep8) as [N Pn1].
assert (cauchy1 : forall n p, (N <= n)%nat -> (N <= p)%nat ->
forall z, Boule c d z -> Rabs (f' n z - f' p z) < eps/4).
intros n p nN pN z bz; replace (eps/4) with (eps/8 + eps/8) by field.
rewrite <- Rabs_Ropp.
replace (-(f' n z - f' p z)) with (g' z - f' n z - (g' z - f' p z)) by ring.
apply Rle_lt_trans with (1 := Rabs_triang _ _); rewrite Rabs_Ropp.
apply Rplus_lt_compat; apply Pn1; assumption.
assert (step_2 : forall n p, (N <= n)%nat -> (N <= p)%nat ->
forall y, Boule c d y -> x <> y ->
Rabs ((f n y - f n x)/(y - x) - (f p y - f p x)/(y - x)) < eps/4).
intros n p nN pN y b_y xny.
assert (mm0 : (Rmin x y = x /\ Rmax x y = y) \/
(Rmin x y = y /\ Rmax x y = x)).
destruct (Rle_dec x y) as [H | H].
rewrite Rmin_left, Rmax_right.
left; split; reflexivity.
assumption.
assumption.
rewrite Rmin_right, Rmax_left.
right; split; reflexivity.
apply Rlt_le, Rnot_le_gt; assumption.
apply Rlt_le, Rnot_le_gt; assumption.
assert (mm : Rmin x y < Rmax x y).
destruct mm0 as [[q1 q2] | [q1 q2]]; generalize (Rminmax x y); rewrite q1, q2.
intros h; destruct h;[ assumption| contradiction].
intros h; destruct h as [h | h];[assumption | rewrite h in xny; case xny; reflexivity].
assert (dm : forall z, Rmin x y <= z <= Rmax x y ->
derivable_pt_lim (fun x => f n x - f p x) z (f' n z - f' p z)).
intros z intz; apply derivable_pt_lim_minus.
apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y);
destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros;
try assumption.
apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y);
destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros;
try assumption.

replace ((f n y - f n x) / (y - x) - (f p y - f p x) / (y - x))
with (((f n y - f p y) - (f n x - f p x))/(y - x)) by
(field; intros yx0; case xny; replace y with (y - x + x) by ring;
rewrite yx0, Rplus_0_l; reflexivity).
destruct (MVT_cor2 (fun x => f n x - f p x) (fun x => f' n x - f' p x)
(Rmin x y) (Rmax x y) mm dm) as [z [Pz inz]].
destruct mm0 as [[q1 q2] | [q1 q2]].
replace ((f n y - f p y - (f n x - f p x))/(y - x)) with
((f n (Rmax x y) - f p (Rmax x y) - (f  n (Rmin x y) - f p (Rmin x y)))/
(Rmax x y - Rmin x y)) by (rewrite q1, q2; reflexivity).
unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r.
apply cauchy1; auto.
apply Boule_convex with (Rmin x y) (Rmax x y);
revert inz; rewrite ?q1, ?q2; intros;
try assumption.
split; apply Rlt_le; tauto.
rewrite q1, q2; apply Rminus_eq_contra, not_eq_sym; assumption.
replace ((f n y - f p y - (f n x - f p x))/(y - x)) with
((f n (Rmax x y) - f p (Rmax x y) - (f  n (Rmin x y) - f p (Rmin x y)))/
(Rmax x y - Rmin x y)).
unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r.
apply cauchy1; auto.
apply Boule_convex with (Rmin x y) (Rmax x y);
revert inz; rewrite ?q1, ?q2; intros;
try assumption; split; apply Rlt_le; tauto.
rewrite q1, q2; apply Rminus_eq_contra; assumption.
rewrite q1, q2; field; split;
apply Rminus_eq_contra;[apply not_eq_sym |]; assumption.
assert (unif_ac :
forall n p, (N <= n)%nat -> (N <= p)%nat ->
forall y, Boule c d y ->
Rabs (rho_ n y - rho_ p y) <= eps/2).
intros n p nN pN y b_y.
destruct (Req_dec x y) as [xy | xny].
destruct (Ball_in_inter c c d d x bx bx) as [delta Pdelta].
destruct (ctrho n y b_y _ ep8) as [d' [dp Pd]].
destruct (ctrho p y b_y _ ep8) as [d2 [dp2 Pd2]].
assert (mmpos : 0 < (Rmin (Rmin d' d2) delta)/2).
apply Rmult_lt_0_compat; repeat apply Rmin_glb_lt; try assumption.
apply cond_pos.
apply Rinv_0_lt_compat, Rlt_0_2.
apply Rle_trans with (1 := R_dist_tri _ _ (rho_ n (y + Rmin (Rmin d' d2) delta/2))).
replace (eps/2) with (eps/8 + (eps/4 + eps/8)) by field.
apply Rplus_le_compat.
rewrite R_dist_sym; apply Rlt_le, Pd;split;[split;[exact I | ] | ].
apply Rminus_not_eq_right; rewrite Rplus_comm; unfold Rminus;
rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r; apply Rgt_not_eq; assumption.
simpl; unfold R_dist.
unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r.
rewrite Rabs_pos_eq;[ |apply Rlt_le; assumption ].
apply Rlt_le_trans with (Rmin (Rmin d' d2) delta);[fourier | ].
apply Rle_trans with (Rmin d' d2); apply Rmin_l.
apply Rle_trans with (1 := R_dist_tri _ _ (rho_ p (y + Rmin (Rmin d' d2) delta/2))).
apply Rplus_le_compat.
apply Rlt_le.
replace (rho_ n (y + Rmin (Rmin d' d2) delta / 2)) with
((f n (y + Rmin (Rmin d' d2) delta / 2) - f n x)/
((y + Rmin (Rmin d' d2) delta / 2) - x)).
replace (rho_ p (y + Rmin (Rmin d' d2) delta / 2)) with
((f p (y + Rmin (Rmin d' d2) delta / 2) - f p x)/
((y + Rmin (Rmin d' d2) delta / 2) - x)).
apply step_2; auto; try fourier.
assert (0 < pos delta) by (apply cond_pos).
apply Boule_convex with y (y + delta/2).
assumption.
destruct (Pdelta (y + delta/2)); auto.
rewrite xy; unfold Boule; rewrite Rabs_pos_eq; try fourier; auto.
split; try fourier.
apply Rplus_le_compat_l, Rmult_le_compat_r;[ | apply Rmin_r].
now apply Rlt_le, Rinv_0_lt_compat, Rlt_0_2.
apply Rminus_not_eq_right; rewrite xy; apply Rgt_not_eq; fourier.
unfold rho_.
destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta/2) x) as [ymx | ymnx].
case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); fourier.
reflexivity.
unfold rho_.
destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta / 2) x) as [ymx | ymnx].
case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); fourier.
reflexivity.
apply Rlt_le, Pd2; split;[split;[exact I | apply Rlt_not_eq; fourier] | ].
simpl; unfold R_dist.
unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r.
rewrite Rabs_pos_eq;[ | fourier].
apply Rlt_le_trans with (Rmin (Rmin d' d2) delta); [fourier |].
apply Rle_trans with (Rmin d' d2).
solve[apply Rmin_l].
solve[apply Rmin_r].
apply Rlt_le, Rlt_le_trans with (eps/4);[ | fourier].
unfold rho_; destruct (Req_EM_T y x); solve[auto].
assert (unif_ac' : forall p, (N <= p)%nat ->
forall y, Boule c d y -> Rabs (rho y - rho_ p y) < eps).
assert (cvrho : forall y, Boule c d y -> Un_cv (fun n => rho_ n y) (rho y)).
intros y b_y; unfold rho_, rho; destruct (Req_EM_T y x).
intros eps' ep'; destruct (cvu eps' ep') as [N2 Pn2].
exists N2; intros n nN2; rewrite R_dist_sym; apply Pn2; assumption.
apply CV_mult.
apply CV_minus.
apply cvp; assumption.
apply cvp; assumption.
intros eps' ep'; simpl; exists 0%nat; intros; rewrite R_dist_eq; assumption.
intros p pN y b_y.
replace eps with (eps/2 + eps/2) by field.
assert (ep2 : 0 < eps/2) by fourier.
destruct (cvrho y b_y _ ep2) as [N2 Pn2].
apply Rle_lt_trans with (1 := R_dist_tri _ _ (rho_ (max N N2) y)).
apply Rplus_lt_le_compat.
solve[rewrite R_dist_sym; apply Pn2, Max.le_max_r].
apply unif_ac; auto; solve [apply Max.le_max_l].
exists N; intros; apply unif_ac'; solve[auto].
intros eps ep.
destruct (CVU_continuity _ _ _ _ H ctrho x bx eps ep) as [delta [dp Pd]].
exists (mkposreal _ dp); intros h hn0 dh.
replace ((g (x + h) - g x) / h) with (rho (x + h)).
replace (g' x) with (rho x).
apply Pd; unfold D_x, no_cond;split;[split;[solve[auto] | ] | ].
intros xxh; case hn0; replace h with (x + h - x) by ring; rewrite <- xxh; ring.
simpl; unfold R_dist; replace (x + h - x) with h by ring; exact dh.
unfold rho; destruct (Req_EM_T x x) as [ _ | abs];[ | case abs]; reflexivity.
unfold rho; destruct (Req_EM_T (x + h) x) as [abs | _];[ | ].
case hn0; replace h with (x + h - x) by ring; rewrite abs; ring.
replace (x + h - x) with h by ring; reflexivity.
Qed.


Add LoadPath "/Users/alex/Documents/Research/projects/brass15/teee/teee/Models/Measuring/cpdt/src" as Cpdt.
Add LoadPath "/home/paul/Documents/TEEE/teee/Models/Measuring/cpdt/src" as Cpdt.
Add LoadPath "C:\Users\Paul\Documents\coqStuff\TEEE\teee\Models\Measuring\cpdt\src" as Cpdt.

Require Import BareNecessities.
Require Import Bool.
Require Import Nat.
(** A Better Units Library
This library gives innate equality-- no axioms needed (well, one I suppose).
The cost is pretty printing.
 *)

Inductive BaseUnit :=
 | Ampere
 | Candela
 | Kelvin
 | KiloGram
 | Meter
 | Mole
 | Second.

Theorem eq_dec_BaseUnit : equality BaseUnit.
Proof. equal. Defined.

Inductive mZ :=
 | pos : nat -> mZ
 | neg : nat -> mZ.
Axiom posNegZero : neg 0 = pos 0.

Theorem eq_dec_mZ : equality mZ.
Proof. equal. Defined.
(*
Inductive DerivedUnit :=
 | Void : DerivedUnit
 | Mult : DerivedUnit -> DerivedUnit -> DerivedUnit
 | Div : DerivedUnit -> DerivedUnit -> DerivedUnit.
 *)

Inductive DerivedUnit :=
 | derivedUnit : mZ -> mZ ->mZ ->mZ ->mZ ->mZ ->mZ -> DerivedUnit.

Definition Void := derivedUnit (pos 0) (pos 0) (pos 0) (pos 0) (pos 0) (pos 0) (pos 0).

Definition mkUnit (b : BaseUnit) : DerivedUnit :=
 match b with
 | Ampere =>    derivedUnit (pos 1) (pos 0) (pos 0) (pos 0) (pos 0) (pos 0) (pos 0)
 | Candela =>   derivedUnit (pos 0) (pos 1) (pos 0) (pos 0) (pos 0) (pos 0) (pos 0)
 | Kelvin =>       derivedUnit (pos 0) (pos 0) (pos 1) (pos 0) (pos 0) (pos 0) (pos 0)
 | KiloGram => derivedUnit (pos 0) (pos 0) (pos 0) (pos 1) (pos 0) (pos 0) (pos 0)
 | Meter =>      derivedUnit (pos 0) (pos 0) (pos 0) (pos 0) (pos 1) (pos 0) (pos 0)
 | Mole =>        derivedUnit (pos 0) (pos 0) (pos 0) (pos 0) (pos 0) (pos 1) (pos 0)
 | Second =>    derivedUnit (pos 0) (pos 0) (pos 0) (pos 0) (pos 0) (pos 0) (pos 1)
end.
Hint Unfold mkUnit.

Theorem eq_dec_DerivedUnit : equality DerivedUnit.
Proof. equal. Defined.

Definition zadd (x y : mZ) : mZ :=
 match (x,y) with
  | (pos xv, pos yv) => pos (xv + yv)
  | (neg xv, neg yv) => neg (xv + yv)
  | (pos xv, neg yv) => if eqb xv yv then
      pos 0 else
       if ltb xv yv then
          neg (yv - xv) else
          pos (xv - yv)
  | (neg xv, pos yv) => if eqb xv yv then
      pos 0 else
       if ltb xv yv then
          pos (yv - xv) else
          neg (xv - yv)
  end.

Definition Mult (x y : DerivedUnit) : DerivedUnit :=
 match (x,y) with
  | (derivedUnit a b c d e f g, derivedUnit a' b' c' d' e' f' g') =>
      derivedUnit (zadd a a') (zadd b b') (zadd c c')
                  (zadd d d') (zadd e e') (zadd f f')
                  (zadd g g')
 end.

Definition invert (z : mZ) : mZ :=
match z with
 | pos x => neg x
 | neg x => pos x
end.

Definition flipPowers (du : DerivedUnit) : DerivedUnit :=
match du with
 | derivedUnit a b c d e f g => derivedUnit (invert a) (invert b) (invert c)
                                            (invert d) (invert e) (invert f)
                                            (invert g)
end.

Definition Div (x y : DerivedUnit) : DerivedUnit :=
 Mult x (flipPowers y).

Definition mkPosZero (z : mZ) : mZ :=
match z with
 | neg 0 => pos 0
 | _ => z
end.

Definition mkPosZeros (x : DerivedUnit) : DerivedUnit :=
match x with
 | derivedUnit a b c d e f g =>
    derivedUnit (mkPosZero a) (mkPosZero b) (mkPosZero c)
                (mkPosZero d) (mkPosZero e) (mkPosZero f)
                (mkPosZero g)
end.

Notation "x \ y" := (Div x y) (at level 60).
Notation "x ** y" := (Mult x y) (at level 60).

Definition mult_nat (x : mZ) (n : nat) : mZ :=
match x with
 | pos v => pos (v * n)
 | neg v => neg (v * n)
end.

Fixpoint Pow_nat (du : DerivedUnit) (n : nat) : DerivedUnit :=
match du with
 | derivedUnit a b c d e f g =>
     derivedUnit (mult_nat a n) (mult_nat b n) (mult_nat c n)
                 (mult_nat d n) (mult_nat e n) (mult_nat f n)
                 (mult_nat g n)
  end.

Notation "x ^ y" := (Pow_nat x y).
Notation "x ^- y" := (Pow_nat (flipPowers x) y)  (at level 60).

Section PopularUnits.
  Definition meter := mkUnit Meter.
  Definition kelvin := mkUnit Kelvin.
  Definition second := mkUnit Second.
  Definition candela := mkUnit Candela.
  Definition amp := mkUnit Ampere.
  Definition kilogram := mkUnit KiloGram.
  Definition mole := mkUnit Mole.

  Definition Newton := (kilogram ** meter) \ (second^2).
  Definition Volt   := (kilogram ** (meter ^2)) \ ((second^3) ** amp).
  Definition Newton2 :=(Mult meter kilogram) \ (second^2).
  Definition VolumetricFlow := meter^3 \ second.
End PopularUnits.
 Example Newtons_Same :  Newton = Newton2.
 Proof. compute. reflexivity.
 Qed.


From Coq Require Import ZifyClasses ZArith_base.
From elpi Require Import elpi.
From HB Require Import structures.
From mathcomp Require Import all_ssreflect ssralg ssrnum ssrint rat intdiv.
From mathcomp Require Import ssrZ zify ring lra.

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

Import GRing.Theory.

Local Delimit Scope Z_scope with coqZ.
(** #
#
* Lesson 8: Proof automation

** Goals
- This lecture explains how to use proof-automation tactics in MathComp
- ... and how to implement such proof-automation tactics for MathComp, but very
  briefly (because this is still an active research subject and intricate.)

** Tools we use
- The #Mczify# library adapts the
  #lia# and
  #nia#
  tactics to MathComp.
  - This adaptation is done by relying on the
    #zify#
    tactic, which provides an extensible preprocessing facility for the [lia]
    tactic.
- The #Algebra Tactics#
  library provides a reimplementation of
  #ring#,
  #field#,
  #lra#,
  #nra#, and
  #psatz#
  tactics for MathComp.
  - These tactics ([lia] too) use _large-scale_ Boolean reflection (cf. Lesson
    1): they have proof procedures implemented in Coq, and run them inside the
    Coq kernel to check that the goal propositions hold.
  - This reimplementation is done by reimplementing reification procedures in
    #Coq-Elpi# and reusing the
    proof procedures bundled in Coq.
    A reification procedure is a _meta_-function that takes the goal and
    produces a syntax tree representing the goal, that we can manipulate inside
    Coq.
    Coq-Elpi allows us to write Coq plugins in
    #Elpi#, a dialect of a
    higher-order logic programming language called λProlog.

#
# *)
(** -------------------------------------------- *)
(** #
#

** [lia]: linear integer arithmetic (a.k.a. Presburger arithmetic) solver

This tactic provides a certifying decision procedure for quantifier-free linear
integer arithmetic.

 *)
Goal forall m n : nat, n <= m -> n.*2 <= m + n.
Proof.
lia.
(*
move=> m n lenm.
Zify.zify.
lia.
*)
Qed.

Goal forall m n : int, (n <= m -> n * 2 <= m + n)%R.
Proof. lia. Qed.

(* A complicated example taken from the Coq reference manual. *)
Goal forall m n : int,
  (27 <= 11 * m + 13 * n <= 45)%R -> (-10 <= 7 * m - 9 * n <= 4)%R -> False.
Proof. lia. Qed.
(** #
#

The [zify] and [lia] tactics support some [bool] operators.

#
# *)
Goal forall m n : nat, (n <= m) = ~~ (m.*2 < n.*2).
Proof. lia. Qed.
(** #

# *)
(** -------------------------------------------- *)
(** #
#

** Some advanced features of the [lia] tactic

The [lia] tactic performs normalization with respect to (semi)ring axioms, and
can actually solve some non-linear problems.

#
# *)
Goal forall m n : nat, m * n = n * m.
Proof. lia. Qed.

Goal forall m n : nat, (m + n) ^ 2 = m ^ 2 + n ^ 2 + 2 * m * n.
Proof. lia. Qed.
(** #
#

The Mczify library also pre-processes Euclidean division and the divisibility
relation.

#
# *)
Goal forall m : nat, m %/ 2 <= m.
Proof.
lia.
(*
move=> m.
Zify.zify.
lia.
*)
Qed.

Goal forall m : nat, 6 %| m -> 4 %| m -> 12 %| m.
Proof. lia. Qed.

Goal forall m : nat, (6 %| m) && (4 %| m) = (12 %| m).
Proof. lia. Qed.
(** #

# *)
(** -------------------------------------------- *)
(** #
#

** [nia]: non-linear integer arithmetic solver

The [nia] tactic is an extension of the [lia] tactic that allows for some
non-linear reasoning by propagating positivity and negativity conditions through
multiplication and exponentiation.

#
# *)
Goal forall m n : int, (0 <= m -> 0 <= n -> 0 <= m * n)%R.
Proof. nia. Qed.

Goal forall (m : int) (n : nat), (0 <= (m ^+ 2) ^+ n)%R.
Proof. nia. Qed.

Goal forall m n : nat, n <= m -> n ^ 2 <= m * n.
Proof. nia. Qed.

Goal forall m n p : int,
  (0 <= n)%R -> (m %/ (n * p))%Z = ((m %/ n) %/ p)%Z.
Proof.
(* Too slow in jsCoq: *)
(* nia. *)
Abort.
(** #

# *)
(** -------------------------------------------- *)
(** #
#

** Instructing the [zify] tactic to pre-process new arithmetic operators

The [zify] and [lia] tactics do not recognize user-defined operators out of the box:

#
# *)
Definition triple (n : nat) : nat := n * 3.

Goal forall n, triple (triple n) = n * 9.
Proof.
Fail lia.
Zify.zify.
Abort.
(** #
#

Declare an instance of type [UnOp triple], and register it through the
[Add Zify UnOp] command:

#
# *)
Fact Op_triple_subproof (n : nat) : Z.of_nat (triple n) = (3 * Z.of_nat n)%coqZ.
Proof. rewrite /triple; lia. Qed.

#[global]
Instance Op_triple : UnOp triple :=
  { TUOp := Z.mul 3; TUOpInj := Op_triple_subproof }.
Add Zify UnOp Op_triple.
(** #
#

Then, the [zify] tactic starts recognizing the new operator [triple]:

#
# *)
Goal forall n, triple (triple n) = n * 9.
Proof. lia. Qed.
(** #

# *)
(** -------------------------------------------- *)
(** #
#

** [ring]: polynomial equation solver

This tactic provides a certified decision procedure for polynomial equations
over commutative rings.

#
# *)
Goal forall a b : int, ((a + b) ^+ 2 = a ^+ 2 + b ^+ 2 + 2 * a * b :> int)%R.
Proof. move=> a b; ring. Qed.
(** #
#

It works for any abstract or concrete commutative rings:

#
# *)
Goal forall a b : rat, ((a + b) ^+ 2 = a ^+ 2 + b ^+ 2 + 2 * a * b :> rat)%R.
Proof. move=> a b; ring. Qed.

Goal forall (R : comRingType) (a b : R),
    ((a + b) ^+ 2 = a ^+ 2 + b ^+ 2 + 2 * a * b :> R)%R.
Proof. move=> R a b; ring. Qed.

Goal forall (R : comRingType) (a : R) (b : R * int),
    (((a, 1) + b) ^+ 2 = (a, 1) ^+ 2 + b ^+ 2 + 2 * (a, 1) * b :> R * int)%R.
Proof. move=> R a b; ring. Qed.
(** #

# *)
(** -------------------------------------------- *)
(** #
#

** Some advanced features of the [ring] tactic

The [ring] tactic can prove polynomial equations modulo monomial equalities:

#
# *)
Goal forall a b : int, (a * b = 15 -> (a + b) ^+ 2 = a ^+ 2 + b ^+ 2 + 30)%R.
Proof.
move=> a b H.
ring: H.
Qed.
(** #
#

The Algebra Tactics library implements preprocessors to push down homomorphism
applications:

#
# *)
Goal forall (R : ringType) (S : comRingType) (f : {rmorphism R -> S}) (a b : R),
    (f ((a + b) ^+ 2) = f a ^+ 2 + f b ^+ 2 + 2 * f a * f b)%R.
Proof.
move=> R S f a b.
rewrite rmorphX rmorphD. (* This line can be removed. *)
ring.
Qed.
(** #

# *)
(** -------------------------------------------- *)
(** #
#

** [field]: rational equation solver

This tactic provides a certified decision procedure for rational equations over
fields.

#
# *)
Goal forall (F : fieldType) (x : F),
    (x != 0 -> (1 - 1 / x) * x - x + 1 = 0)%R.
Proof.
move=> F x x_neq0.
field.
(*
The field tactic leaves a proof obligation saying that the denominators in the
input are non-zero.
*)
exact: x_neq0.
Qed.

Goal forall (F : fieldType) (n : nat),
    (n%:R != 0 :> F -> (2 * n)%:R / n%:R = 2 :> F)%R.
Proof.
move=> F n n_neq0.
field.
exact: n_neq0.
Qed.
(** #
#

For a partially ordered field ([numFieldType]), non-nullity conditions of the
form [n%:R != 0] and [n%:~R != 0] where [n] is a non-zero constant are trivial,
and thus are not generated.

#
# *)
Goal forall (F : numFieldType) (x : F), ((x / 2) * 2)%R = x.
Proof.
move=> F x.
field.
by [].
Qed.
(** #
#

As in the [ring] tactic, the [field] tactic supports homomorphisms and reasoning
modulo monomial equalities.

#
# *)
(** -------------------------------------------- *)
(** #
#

** [lra] and [nra]: linear and non-linear real arithmetic

_NB_: The support for the [lra] and [nra] tactics in Algebra Tactics is
experimental for the moment.

#
# *)
Goal forall (x y : int), (y <= x -> 0 <= x -> y <= x * 2)%R.
Proof. move=> R x y; lra. Qed.
(** #
#

For [realFieldType]s, division and multiplicative inverse are avairable.

#
# *)
Goal forall (x y : rat), (y <= x -> 0 <= x -> y / 2 <= x)%R.
Proof. move=> R x y; lra. Qed.
(** #
#

These tactics work for any abstract or concrete [realDomainType] or
[realFieldType].

#
# *)
Goal forall (R : realDomainType) (x y : R),
  (x + 2 * y <= 3 -> 2 * x + y <= 3 -> x + y <= 2)%R.
Proof. move=> R x y; lra. Qed.
(** #

# *)
(** -------------------------------------------- *)
(** #
#

** How do they work? -- proof by large-scale reflection

We first prove the following reflection lemma (but do not try to understand the
formal statement and proof).

#
# *)
Import Ring_polynom.

Lemma ring_correct
  (R : comRingType)
  (* `l` below is called a variable map, whose i-th item gives the            *)
  (* interpretation of the variable i.                                        *)
  (l : seq R)
  (* `pe1` and `pe2` below are polynomial expressions with integer            *)
  (* coefficients, representing the LHS and RHS of the equation to prove.     *)
  (pe1 pe2 : PExpr Z) :
  (* If `pe1` and `pe2` normalized to polynomials (in horner normal form) are *)
  (* equal,                                                                   *)
  Peq Z.eqb (norm_subst 0%R 1%R Z.add Z.mul Z.sub Z.opp Z.eqb
               (triv_div 0%R 1%R Z.eqb) 0 [::] pe1)
            (norm_subst 0%R 1%R Z.add Z.mul Z.sub Z.opp Z.eqb
               (triv_div 0%R 1%R Z.eqb) 0 [::] pe2) ->
  (* `pe1` and `pe2` interpreted as values of the ring `R` are equal.         *)
  PEeval 0%R 1%R +%R *%R (fun x y => (x - y)%R) -%R%R
    (fun n => ((int_of_Z n)%:~R)%R) id (fun x n => (x ^+ N.to_nat n)%R) l pe1 =
  PEeval 0%R 1%R +%R *%R (fun x y => (x - y)%R) -%R%R
    (fun n => ((int_of_Z n)%:~R)%R) id (fun x n => (x ^+ N.to_nat n)%R) l pe2.
Proof. exact: (@Internals.Rcorrect R 0 l [::]). Qed.
(** #
#

Let us apply the above lemma to the example below.

#
# *)
Goal forall a b : int, ((a + b) ^+ 2 = a ^+ 2 + b ^+ 2 + 2 * a * b :> int)%R.
Proof.
move=> a b.
(* Variable map:                                                              *)
pose l := [:: a; b].
(* Polynomial expressions representing the LHS and RHS, where numbers `1` and *)
(* `2` given as arguments of `PEX` represents 1st and 2nd variables, namely,  *)
(* `a` and `b`:                                                               *)
pose pe1 : PExpr Z := PEpow (PEadd (PEX _ 1) (PEX _ 2)) 2.
pose pe2 : PExpr Z := PEadd (PEadd (PEpow (PEX _ 1) 2) (PEpow (PEX _ 2) 2))
                        (PEmul (PEmul (PEc 2%coqZ) (PEX _ 1)) (PEX _ 2)).
(* Apply the reflection lemma with the variable map and polynomial            *)
(* expressions given above:                                                   *)
apply: (@ring_correct _ [:: a; b] pe1 pe2).
(* By reducing some subterms, we notice that we are comparing the same normal *)
(* form:                                                                      *)
rewrite /norm_subst [p1 in Peq _ p1 _]/= [p2 in Peq _ _ p2]/=.
(* Actually, the entire goal reduces to `true`:                               *)
rewrite /=.
by [].
Qed.
(** #
#

The only missing piece in turning this methodology into a fully-automated tactic
is how to obtain the variable map and the polynomial expressions from the goal,
which is called _reification_.

#
# *)
(** -------------------------------------------- *)
(** #
#

** Further reading

- Benjamin Grégoire, Assia Mahboubi.
  #Proving Equalities in a Commutative Ring Done Right in Coq#.
  In: TPHOLs 2005.

  This paper explains the implementation of the [ring] tactic.
- Frédéric Besson.
  #Fast Reflexive Arithmetic Tactics the Linear Case and Beyond#.
  In: TYPES 2006.

  This paper explains the implementation of the [lia], [nia], [lra], [nra], and
  [psatz] tactics.

- Kazuhiko Sakaguchi.
  #Reflexive tactics for algebra, revisited#.
  In: ITP 2022.

  This paper explains:
  - a toy reflexive tactic for [zmodType] equations,
  - its reification procedure implemented in Coq-Elpi, that works in the
    presence of an inheritance hierarchy and overloaded operators
    (cf. Lesson 5),
  - how to preprocess homomorphisms by reflection efficiently, and
  - the application of Mczify and Algebra Tactics to
    #the formal proof of the irrationality of ζ(3)#.

  The insights from the following papers are the key ingredients of reification
  in the presence of overloaded operators:
  - Reynald Affeldt, Cyril Cohen, Marie Kerjean, Assia Mahboubi,
    Damien Rouhling, Kazuhiko Sakaguchi.
    #Competing Inheritance Paths in Dependent Type Theory: A Case Study in Functional Analysis#.
    In: IJCAR 2020.
  - Georges Gonthier, Enrico Tassi.
    #A Language of Patterns for Subterm Selection#.
    In: ITP 2012.

- Enrico Tassi. #Coq-Elpi#.

#

#

** A takeaway

A better understanding of the principles of MathComp leads us to better design
and implementation of tools for MathComp. In my opinion, the principles of
MathComp are that:
- relying on the computational power of the logic (dependent type theory) makes
  formal proofs easier and more efficient to check, and
- to properly do so, we have to carefully design computational behaviors of our
  definitions.

#
# *)


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : extension for Z.
  author    : ZhengPu Shi
  date      : 2022.04
*)

Require Export BasicConfig.

Require Export ZArith.
Open Scope Z.

(* ######################################################################### *)
(** * Conversion between Z and other types *)
Definition nat2Z (n : nat) : Z := Z.of_nat n.
Definition Z2nat (z : Z) : nat := Z.to_nat z.

(* ######################################################################### *)
(** * Properties for Zeqb and Zeq *)

Definition Zeqb := Z.eqb.

Infix     "=?"          := Zeqb           : Z_scope.

(** Reflection of (=) and (=?) *)
Lemma Zeqb_true_iff : forall x y, x =? y = true <-> x = y.
Proof.
  apply Z.eqb_eq.
Qed.

Lemma Zeqb_false_iff : forall x y, x =? y = false <-> x <> y.
Proof.
  apply Z.eqb_neq.
Qed.

(* ######################################################################### *)
(** * Other properties *)

(** Boolean equality of Zadd satisfy right cancelling rule *)
Lemma Zadd_eqb_cancel_r : forall (z1 z2 a : Z),
  (z1 + a =? z2 + a)%Z = (z1 =? z2)%Z.
Proof.
  intros.
  remember (z1 =? z2)%Z as b1 eqn : H1.
  remember (z1 + a =? z2 + a)%Z as b2 eqn : H2.
  destruct b1,b2; auto.
  - apply eq_sym in H1,H2. apply Z.eqb_eq in H1. apply Z.eqb_neq in H2.
    subst. auto.
  - apply eq_sym in H1,H2. apply Z.eqb_neq in H1. apply Z.eqb_eq in H2.
    apply Z.add_cancel_r in H2. apply H1 in H2. easy.
Qed.


Require Import Modal.
Require Import SecOrder.
Require Import p_is_pos.
Require Import p_occurs_in.
Require Import P_occurs_in_alpha.
Require Import ST_setup.
Require Import Correctness_ST.
Require Import Arith.EqNat.
Require Import List_machinery_impl.

(* Uniform_Mod_Defns *)

(* -------------------------------------------------------------------- *)

Fixpoint nlist_full (n : nat) : nlist n :=
  match n with
  | 0 => niln
  | S m => consn _ (eqFO (Var 1) (Var 1)) (nlist_full m)
  end.

Fixpoint nlist_empty (n : nat) : nlist n :=
  match n with
  | 0 => niln
  | S m => consn _ (negSO (eqFO (Var 1) (Var 1))) (nlist_empty m)
  end.

Fixpoint nlist_Var1 (n : nat) : nlist n :=
  match n with
  | 0 => niln
  | S m => consn _ (Var 1) (nlist_Var1 m)
  end.

Lemma nlist_Var1_length : forall n : nat,
  length (nlist_list _ (nlist_Var1 n)) = n.
Proof.
  induction n.
    reflexivity.

    simpl.
    rewrite IHn.
    reflexivity.
Qed.

Definition pa_f {W : Set} (w : W) : Prop := False.

Definition pa_t {W : Set} (w : W) : Prop := True.

Fixpoint nlist_pa_f (W : Set) (n : nat) : nlist n:=
  match n with
  | 0 => niln
  | S m => consn _ (@pa_f W) (nlist_pa_f W m)
  end.

Fixpoint nlist_pa_t (W : Set) (n : nat) : nlist n:=
  match n with
  | 0 => niln
  | S m => consn _ (@pa_t W) (nlist_pa_t W m)
  end.

Fixpoint alt_Ip_l {W : Set} (Ip : predicate -> W -> Prop) (l : list predicate)
                  (lpa : list (W -> Prop)) :=
  match l, lpa with
  | nil, _ => Ip
  | _, nil => Ip
  | cons P l', cons pa lpa' => alt_Ip_l (alt_Ip Ip pa P) l' lpa'
  end.

Definition alt_Ip_pa_f {W : Set} (Ip : predicate -> W -> Prop)
                       (l : list predicate) :=
  alt_Ip_l Ip l (nlist_list _ (nlist_pa_f W (length l))).


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

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

Print Assumptions add.


(* Ps_add.v *)

Require Import Utf8.
Require Import QArith.
Require Import NPeano.

Require Import NbarM.
Require Import Misc.
Require Import Field2.
Require Import Power_series.
Require Import Puiseux_series.

Set Implicit Arguments.

Definition adjust_ps α {R : ring α} n k ps :=
  {| ps_terms := series_shift n (series_stretch k (ps_terms ps));
     ps_ordnum := ps_ordnum ps * Zpos k - Z.of_nat n;
     ps_polydo := ps_polydo ps * k |}.

Section first_theorems.

Variable α : Type.
Variable R : ring α.
Variable K : field R.

Theorem ncrl_inf_gsxp : ∀ s n,
  series_order s (S n) = ∞
  → greatest_series_x_power K s n = O.
Proof.
intros s n Hn.
apply greatest_series_x_power_iff.
rewrite Hn; reflexivity.
Qed.

Theorem greatest_series_x_power_stretch_inf : ∀ s b k,
  series_order s (S b) = ∞
  → greatest_series_x_power K (series_stretch k s) (b * Pos.to_nat k) = O.
Proof.
intros s b k Hs.
remember (greatest_series_x_power K s b) as n eqn:Hn .
symmetry in Hn.
apply greatest_series_x_power_iff in Hn.
apply greatest_series_x_power_iff.
rewrite Hs in Hn.
rewrite series_order_stretch_succ_inf; auto.
Qed.

Theorem gcd_ps_0_m : ∀ n (ps : puiseux_series α),
  gcd_ps n O ps = Z.abs (Z.gcd (ps_ordnum ps + Z.of_nat n) (Zpos (ps_polydo ps))).
Proof.
intros n ps.
unfold gcd_ps.
rewrite Z.gcd_0_r; reflexivity.
Qed.

Theorem ps_normal_adjust_eq : ∀ ps n k,
  normalise_ps ps ≐ normalise_ps (adjust_ps n k ps).
Proof.
intros ps n k.
unfold normalise_ps; simpl.
rewrite series_order_shift.
rewrite series_order_stretch_0.
rewrite Nbar.add_comm, Nbar.mul_comm.
remember (series_order (ps_terms ps) 0) as m eqn:Hm .
symmetry in Hm.
destruct m as [m| ]; simpl; [ idtac | reflexivity ].
rewrite greatest_series_x_power_shift.
rewrite Nat2Z.inj_add, Z.add_assoc.
rewrite Z.add_shuffle0.
rewrite Z.sub_add.
rewrite Nat2Z.inj_mul, positive_nat_Z.
rewrite <- Z.mul_add_distr_r.
rewrite Z.mul_comm.
remember (series_order (ps_terms ps) (S m)) as p eqn:Hp .
symmetry in Hp.
remember (greatest_series_x_power K (ps_terms ps) m) as x.
pose proof (gcd_ps_is_pos m x ps) as Hgp; subst x.
destruct p as [p| ].
 erewrite greatest_series_x_power_stretch.
  unfold gcd_ps.
  remember (Zpos k)%Z as kp; simpl.
  rewrite Nat2Z.inj_add.
  rewrite Z.sub_add_simpl_r_r.
  rewrite Nat2Z.inj_mul.
  rewrite Nat2Z.inj_mul.
  rewrite positive_nat_Z.
  rewrite <- Z.mul_add_distr_r.
  rewrite Pos2Z.inj_mul.
  rewrite Z.gcd_mul_mono_r_nonneg; [ idtac | apply Pos2Z.is_nonneg ].
  subst kp.
  rewrite Z.mul_comm.
  rewrite Z.gcd_mul_mono_l_nonneg; [ idtac | apply Pos2Z.is_nonneg ].
  rewrite Z.div_mul_cancel_l.
   rewrite <- Pos2Z.inj_mul, Pos.mul_comm, Pos2Z.inj_mul.
   rewrite Z.div_mul_cancel_l.
    unfold normalise_series.
    rewrite Z2Pos.inj_mul; [ idtac | apply Pos2Z.is_pos | idtac ].
     rewrite Pos.mul_comm.
     rewrite series_shrink_shrink.
     rewrite series_left_shift_shift.
      rewrite Nat.add_sub.
      rewrite series_left_shift_stretch.
      rewrite series_shrink_stretch.
      reflexivity.

      rewrite Nat.add_comm; apply Nat.le_add_r.

     assumption.

    unfold gcd_ps in Hgp.
    intros H; rewrite H in Hgp.
    revert Hgp; apply Z.lt_irrefl.

    apply Pos2Z_ne_0.

   unfold gcd_ps in Hgp.
   intros H; rewrite H in Hgp.
   revert Hgp; apply Z.lt_irrefl.

   apply Pos2Z_ne_0.

  intros H; rewrite H in Hp; discriminate Hp.

 rewrite ncrl_inf_gsxp; [ idtac | assumption ].
 rewrite greatest_series_x_power_stretch_inf; auto.
 rewrite gcd_ps_0_m.
 rewrite gcd_ps_0_m.
 remember Z.mul as g; simpl; subst g.
 rewrite Nat2Z.inj_add.
 rewrite Nat2Z.inj_mul.
 rewrite positive_nat_Z.
 rewrite Z.sub_add_simpl_r_r.
 rewrite <- Z.mul_add_distr_r.
 rewrite Pos2Z.inj_mul.
 rewrite Z.gcd_mul_mono_r_nonneg; [ idtac | apply Pos2Z.is_nonneg ].
 rewrite Z.mul_comm.
 rewrite Z.abs_mul.
 remember Z.mul as g; simpl; subst g.
 rewrite Z.div_mul_cancel_l.
  rewrite <- Pos2Z.inj_mul, Pos.mul_comm, Pos2Z.inj_mul.
  rewrite Z.div_mul_cancel_l.
   unfold normalise_series.
   rewrite Z2Pos.inj_mul; [ idtac | apply Pos2Z.is_pos | idtac ].
    rewrite Pos.mul_comm.
    rewrite series_shrink_shrink.
    rewrite series_left_shift_shift.
     rewrite Nat.add_sub.
     rewrite series_left_shift_stretch.
     rewrite series_shrink_stretch.
     reflexivity.

     rewrite Nat.add_comm; apply Nat.le_add_r.

    apply Z.abs_pos.
    intros H.
    apply Z.gcd_eq_0_r in H.
    revert H; apply Pos2Z_ne_0.

   intros H.
   apply -> Z.abs_0_iff in H.
   apply Z.gcd_eq_0_r in H.
   revert H; apply Pos2Z_ne_0.

   apply Pos2Z_ne_0.

  intros H.
  apply -> Z.abs_0_iff in H.
  apply Z.gcd_eq_0_r in H.
  revert H; apply Pos2Z_ne_0.

  apply Pos2Z_ne_0.
Qed.

Theorem ps_adjust_eq : ∀ ps n k, (ps = adjust_ps n k ps)%ps.
Proof.
intros ps n k.
constructor.
apply ps_normal_adjust_eq.
Qed.

End first_theorems.

Definition adjust_series α {R : ring α} n k s :=
  series_shift n (series_stretch k s).

Definition ps_terms_add α {R : ring α} (ps₁ ps₂ : puiseux_series α) :=
  let k₁ := cm_factor ps₁ ps₂ in
  let k₂ := cm_factor ps₂ ps₁ in
  let v₁ := (ps_ordnum ps₁ * Zpos k₁)%Z in
  let v₂ := (ps_ordnum ps₂ * Zpos k₂)%Z in
  let n₁ := Z.to_nat (v₁ - Z.min v₁ v₂) in
  let n₂ := Z.to_nat (v₂ - Z.min v₂ v₁) in
  let s₁ := adjust_series n₁ k₁ (ps_terms ps₁) in
  let s₂ := adjust_series n₂ k₂ (ps_terms ps₂) in
  series_add s₁ s₂.

Definition ps_ordnum_add α (ps₁ ps₂ : puiseux_series α) :=
  let k₁ := cm_factor ps₁ ps₂ in
  let k₂ := cm_factor ps₂ ps₁ in
  let v₁ := (ps_ordnum ps₁ * Zpos k₁)%Z in
  let v₂ := (ps_ordnum ps₂ * Zpos k₂)%Z in
  Z.min v₁ v₂.

Definition ps_add {α} {r : ring α} (ps₁ ps₂ : puiseux_series α) :=
  {| ps_terms := ps_terms_add ps₁ ps₂;
     ps_ordnum := ps_ordnum_add ps₁ ps₂;
     ps_polydo := cm ps₁ ps₂ |}.

(* I prefer this other version for addition; proved strongly equal to
   ps_add below; could be the main and only one, perhaps ? *)

Definition adjusted_ps_add α {R : ring α} ps₁ ps₂ :=
  {| ps_terms := series_add (ps_terms ps₁) (ps_terms ps₂);
     ps_ordnum := ps_ordnum ps₁;
     ps_polydo := ps_polydo ps₁ |}.

Definition adjust_ps_from α {R : ring α} (ps₁ ps₂ : puiseux_series α) :=
  let k₁ := ps_polydo ps₂ in
  let k₂ := ps_polydo ps₁ in
  let v₁ := (ps_ordnum ps₁ * Zpos k₁)%Z in
  let v₂ := (ps_ordnum ps₂ * Zpos k₂)%Z in
  adjust_ps (Z.to_nat (v₂ - Z.min v₁ v₂)) k₂ ps₂.

Definition ps_add₂ {α} {r : ring α} (ps₁ ps₂ : puiseux_series α) :=
  adjusted_ps_add (adjust_ps_from ps₂ ps₁) (adjust_ps_from ps₁ ps₂).

Notation "a + b" := (ps_add a b) : ps_scope.
Notation "a ++ b" := (ps_add₂ a b) : ps_scope.

Definition ps_opp {α} {r : ring α} ps :=
  {| ps_terms := (- ps_terms ps)%ser;
     ps_ordnum := ps_ordnum ps;
     ps_polydo := ps_polydo ps |}.

Notation "- a" := (ps_opp a) : ps_scope.
Notation "a - b" := (ps_add a (ps_opp b)) : ps_scope.

Section theorems_add.

Variable α : Type.
Variable R : ring α.
Variable K : field R.

Theorem series_stretch_add_distr : ∀ k s₁ s₂,
  (series_stretch k (s₁ + s₂) =
   series_stretch k s₁ + series_stretch k s₂)%ser.
Proof.
intros kp s₁ s₂.
constructor; intros i; simpl.
remember (Pos.to_nat kp) as k.
assert (k ≠ O) as Hk by (subst k; apply Pos2Nat_ne_0).
destruct (zerop (i mod k)); [ reflexivity | idtac ].
rewrite rng_add_0_l; reflexivity.
Qed.

Theorem ps_terms_add_comm : ∀ ps₁ ps₂,
  (ps_terms_add ps₁ ps₂ = ps_terms_add ps₂ ps₁)%ser.
Proof.
intros ps₁ ps₂.
unfold ps_terms_add.
rewrite series_add_comm; reflexivity.
Qed.

Theorem eq_strong_ps_add_comm : ∀ ps₁ ps₂,
  (ps₁ + ps₂)%ps ≐ (ps₂ + ps₁)%ps.
Proof.
intros ps₁ ps₂.
constructor; simpl.
 apply Z.min_comm.

 apply Pos.mul_comm.

 apply ps_terms_add_comm.
Qed.

Theorem ps_add_comm : ∀ ps₁ ps₂, (ps₁ + ps₂ = ps₂ + ps₁)%ps.
Proof.
intros ps₁ ps₂.
constructor.
rewrite eq_strong_ps_add_comm; reflexivity.
Qed.

Theorem series_shift_add_distr : ∀ s₁ s₂ n,
  (series_shift n (s₁ + s₂) =
   series_shift n s₁ + series_shift n s₂)%ser.
Proof.
intros s₁ s₂ n.
constructor; intros i; simpl.
destruct (lt_dec i n) as [H₁| H₁]; [ idtac | reflexivity ].
rewrite rng_add_0_l; reflexivity.
Qed.

Theorem ps_terms_add_assoc : ∀ ps₁ ps₂ ps₃,
  (ps_terms_add (ps₁ + ps₂)%ps ps₃ =
   ps_terms_add ps₁ (ps₂ + ps₃)%ps)%ser.
Proof.
intros ps₁ ps₂ ps₃.
constructor; intros i.
unfold ps_terms_add.
remember adjust_series as g; simpl.
unfold cm_factor, cm.
unfold ps_terms_add; simpl.
unfold ps_ordnum_add; simpl.
unfold cm_factor, cm.
remember (ps_ordnum ps₁) as v₁ eqn:Hv₁ .
remember (ps_ordnum ps₂) as v₂ eqn:Hv₂ .
remember (ps_ordnum ps₃) as v₃ eqn:Hv₃ .
remember (ps_polydo ps₁) as c₁.
remember (ps_polydo ps₂) as c₂.
remember (ps_polydo ps₃) as c₃.
subst g; unfold adjust_series.
do 2 rewrite series_stretch_add_distr.
do 2 rewrite series_shift_add_distr.
do 4 rewrite stretch_shift_series_distr.
do 4 rewrite <- series_stretch_stretch; try apply Pos2Nat_ne_0.
do 4 rewrite series_shift_shift.
do 4 rewrite <- Z2Nat_inj_mul_pos_r.
do 4 rewrite Z.mul_sub_distr_r.
do 2 rewrite Pos2Z.inj_mul, Z.mul_assoc.
rewrite <- Z.mul_min_distr_nonneg_r; [ idtac | apply Pos2Z.is_nonneg ].
rewrite <- Z.mul_min_distr_nonneg_r; [ idtac | apply Pos2Z.is_nonneg ].
rewrite <- Z.mul_min_distr_nonneg_r; [ idtac | apply Pos2Z.is_nonneg ].
rewrite <- Z.mul_min_distr_nonneg_r; [ idtac | apply Pos2Z.is_nonneg ].
remember (v₁ * Zpos c₂ * Zpos c₃)%Z as vcc eqn:Hvcc .
remember (v₂ * Zpos c₁ * Zpos c₃)%Z as cvc eqn:Hcvc .
remember (v₃ * Zpos c₂ * Zpos c₁)%Z as ccv eqn:Hccv .
do 2 rewrite Z.min_assoc.
rewrite Z.mul_shuffle0, <- Hccv.
rewrite Z.mul_shuffle0, <- Hcvc.
rewrite Pos.mul_comm.
replace (c₃ * c₁)%positive with (c₁ * c₃)%positive by apply Pos.mul_comm.
do 6 rewrite Z2Nat_sub_min.
do 2 rewrite Z2Nat_sub_min1.
do 2 rewrite Z2Nat_sub_min2.
do 2 rewrite <- Z.min_assoc.
do 2 rewrite Z2Nat_sub_min.
simpl; rewrite rng_add_assoc; reflexivity.
Qed.

Theorem gcd_ps_add_assoc : ∀ ps₁ ps₂ ps₃ n k,
  gcd_ps n k ((ps₁ + ps₂) + ps₃)%ps =
  gcd_ps n k (ps₁ + (ps₂ + ps₃))%ps.
Proof.
intros ps₁ ps₂ ps₃ n k.
unfold gcd_ps; simpl.
unfold ps_ordnum_add; simpl.
unfold ps_ordnum_add; simpl.
rewrite <- Z.mul_min_distr_nonneg_r; [ idtac | apply Pos2Z.is_nonneg ].
rewrite <- Z.mul_min_distr_nonneg_r; [ idtac | apply Pos2Z.is_nonneg ].
rewrite Z.min_assoc.
unfold cm_factor, cm; simpl; unfold cm; simpl.
do 6 rewrite Pos2Z.inj_mul.
do 3 rewrite Z.mul_assoc.
do 3 f_equal.
f_equal; [ idtac | rewrite Z.mul_shuffle0; reflexivity ].
f_equal; rewrite Z.mul_shuffle0; reflexivity.
Qed.

Theorem ps_normal_add_assoc : ∀ ps₁ ps₂ ps₃,
  normalise_ps ((ps₁ + ps₂) + ps₃)%ps ≐
  normalise_ps (ps₁ + (ps₂ + ps₃))%ps.
Proof.
intros ps₁ ps₂ ps₃.
unfold normalise_ps; simpl.
rewrite ps_terms_add_assoc.
remember (ps₂ + ps₃)%ps as x.
remember (series_order (ps_terms_add ps₁ x) 0) as n.
subst x.
rename Heqn into Hn.
symmetry in Hn.
destruct n as [n| ]; [ constructor; simpl | reflexivity ].
 rewrite ps_terms_add_assoc.
 rewrite gcd_ps_add_assoc.
 do 2 f_equal.
 unfold ps_ordnum_add; simpl.
 unfold ps_ordnum_add; simpl.
 unfold cm_factor, cm; simpl.
 rewrite <- Z.mul_min_distr_nonneg_r; [ idtac | apply Pos2Z.is_nonneg ].
 rewrite <- Z.mul_min_distr_nonneg_r; [ idtac | apply Pos2Z.is_nonneg ].
 rewrite Z.min_assoc.
 do 2 rewrite Pos2Z.inj_mul.
 do 2 rewrite Z.mul_assoc.
 f_equal; [ idtac | rewrite Z.mul_shuffle0; reflexivity ].
 f_equal; rewrite Z.mul_shuffle0; reflexivity.

 rewrite ps_terms_add_assoc.
 rewrite gcd_ps_add_assoc.
 unfold cm_factor, cm; simpl; unfold cm; simpl.
 do 4 rewrite Pos2Z.inj_mul.
 rewrite Z.mul_assoc.
 reflexivity.

 rewrite ps_terms_add_assoc.
 rewrite gcd_ps_add_assoc.
 reflexivity.
Qed.

Theorem ps_add_assoc : ∀ ps₁ ps₂ ps₃,
  (ps₁ + (ps₂ + ps₃) = (ps₁ + ps₂) + ps₃)%ps.
Proof.
intros ps₁ ps₂ ps₃; symmetry.
constructor.
apply ps_normal_add_assoc.
Qed.

Theorem ps_add_0_l : ∀ ps, (0 + ps = ps)%ps.
Proof.
intros ps.
unfold ps_add; simpl.
constructor.
unfold ps_terms_add; simpl.
rewrite Z.mul_1_r.
unfold cm_factor.
unfold cm; simpl.
unfold ps_ordnum_add; simpl.
rewrite Z.mul_1_r.
unfold adjust_series.
rewrite series_stretch_series_0.
rewrite series_stretch_1.
rewrite series_shift_series_0.
rewrite series_add_0_l.
rewrite <- Z2Nat_sub_min2.
rewrite Z.min_id, Z.sub_0_r.
rewrite Z.sub_diag, Nat.add_0_r.
symmetry.
remember (Z.to_nat (ps_ordnum ps)) as n eqn:Hn .
rewrite ps_normal_adjust_eq with (n := n) (k := xH) in |- * at 1.
subst n.
unfold adjust_ps; simpl.
rewrite Pos.mul_1_r, Z.mul_1_r.
rewrite series_stretch_1.
rewrite Z2Nat_id_max.
rewrite <- Z.sub_min_distr_l.
rewrite Z.sub_0_r, Z.sub_diag, Z.min_comm.
reflexivity.
Qed.

Theorem ps_add_0_r : ∀ ps, (ps + 0 = ps)%ps.
Proof. intros ps; rewrite ps_add_comm; apply ps_add_0_l. Qed.

Theorem ps_add_opp_r : ∀ ps, (ps - ps = 0)%ps.
Proof.
intros ps.
unfold ps_zero.
unfold ps_add; simpl.
constructor; simpl.
unfold ps_opp; simpl.
unfold ps_terms_add; simpl.
unfold cm_factor; simpl.
rewrite Z.min_id.
rewrite Z.sub_diag; simpl.
unfold adjust_series.
do 2 rewrite series_shift_0.
rewrite <- series_stretch_add_distr.
rewrite series_add_opp_r.
rewrite series_stretch_series_0.
unfold ps_ordnum_add; simpl.
unfold cm_factor, cm; simpl.
rewrite Z.min_id.
symmetry.
remember (ps_polydo ps * ps_polydo ps)%positive as k eqn:Hk .
rewrite ps_normal_adjust_eq with (n := O) (k := k); subst k.
unfold adjust_ps; simpl.
rewrite series_shift_0.
rewrite series_stretch_series_0.
remember (ps_ordnum ps) as v eqn:Hv .
symmetry in Hv.
destruct v as [| v| v].
 reflexivity.

 symmetry.
 remember (Z.to_nat (ps_ordnum ps * Zpos (ps_polydo ps))) as n.
 rewrite ps_normal_adjust_eq with (n := n) (k := xH); subst n.
 unfold adjust_ps.
 remember Z.sub as g; simpl; subst g.
 rewrite series_stretch_series_0.
 rewrite series_shift_series_0.
 do 2 rewrite Pos.mul_1_r.
 rewrite Hv.
 rewrite Z2Nat.id; [ idtac | apply Pos2Z.is_nonneg ].
 rewrite Z.sub_diag; reflexivity.

 remember (Z.to_nat (Zpos v * Zpos (ps_polydo ps))) as n.
 rewrite ps_normal_adjust_eq with (n := n) (k := xH); subst n.
 unfold adjust_ps.
 remember Z.sub as g; simpl; subst g.
 rewrite series_stretch_series_0.
 rewrite series_shift_series_0.
 rewrite positive_nat_Z; simpl.
 rewrite Pos.mul_1_r.
 reflexivity.
Qed.

Theorem ps_add_opp_l : ∀ ps, (- ps + ps = 0)%ps.
Proof.
intros ps.
rewrite ps_add_comm.
apply ps_add_opp_r.
Qed.

Theorem eq_strong_ps_add_add₂ : ∀ ps₁ ps₂,
  (ps₁ + ps₂)%ps ≐ ps_add₂ ps₁ ps₂.
Proof.
intros ps₁ ps₂.
constructor; [ simpl | reflexivity | simpl ].
 unfold ps_ordnum_add.
 rewrite Z2Nat.id.
  rewrite Z.sub_sub_distr.
  rewrite Z.sub_diag; simpl.
  apply Z.min_comm.

  rewrite <- Z.sub_max_distr_l.
  rewrite Z.sub_diag.
  apply Z.le_max_r.

 unfold ps_terms_add.
 unfold adjust_series.
 unfold cm_factor.
 remember (ps_ordnum ps₂ * Zpos (ps_polydo ps₁))%Z as vc₂₁.
 remember (ps_ordnum ps₁ * Zpos (ps_polydo ps₂))%Z as vc₁₂.
 remember (Z.min vc₁₂ vc₂₁) as m eqn:Hm .
 rewrite Z.min_comm, <- Hm.
 reflexivity.
Qed.

Theorem eq_strong_ps_normal_add_add₂ : ∀ ps₁ ps₂,
  normalise_ps (ps₁ + ps₂)%ps ≐ normalise_ps (ps_add₂ ps₁ ps₂).
Proof.
intros ps₁ ps₂.
rewrite eq_strong_ps_add_add₂; reflexivity.
Qed.

Theorem eq_ps_add_add₂ : ∀ ps₁ ps₂, (ps₁ + ps₂ = ps_add₂ ps₁ ps₂)%ps.
Proof.
intros ps₁ ps₂.
constructor.
apply eq_strong_ps_normal_add_add₂.
Qed.

Theorem ps_monom_add : ∀ a b n,
  (ps_monom a n + ps_monom b n = ps_monom (a + b)%K n)%ps.
Proof.
intros a b n.
symmetry.
unfold ps_add; simpl.
unfold cm; simpl.
unfold ps_ordnum_add; simpl.
unfold ps_terms_add; simpl.
rewrite ps_adjust_eq with (n := O) (k := Qden n).
unfold adjust_ps; simpl.
rewrite Z.sub_0_r.
rewrite Z.min_id.
apply mkps_morphism; try reflexivity.
rewrite series_shift_0.
rewrite Z.sub_diag; simpl.
unfold adjust_series; simpl.
do 2 rewrite series_shift_0.
constructor; intros i; simpl.
destruct (zerop (i mod Pos.to_nat (Qden n))) as [H₁| H₁].
 apply Nat.mod_divides in H₁; [ idtac | apply Pos2Nat_ne_0 ].
 destruct H₁ as (c, Hc).
 rewrite Nat.mul_comm in Hc; rewrite Hc.
 rewrite Nat.div_mul; [ idtac | apply Pos2Nat_ne_0 ].
 destruct c; [ reflexivity | simpl ].
 rewrite rng_add_0_l; reflexivity.

 rewrite rng_add_0_l; reflexivity.
Qed.

End theorems_add.

Add Parametric Morphism α (R : ring α) : (@adjusted_ps_add _ R)
  with signature eq_ps_strong ==> eq_ps_strong ==> eq_ps_strong
  as adjusted_ps_add_morph.
Proof.
intros ps₁ ps₃ Heq₁ ps₂ ps₄ Heq₂.
unfold adjusted_ps_add.
induction Heq₁, Heq₂.
rewrite H, H0.
constructor; simpl; try reflexivity.
rewrite H1, H4; reflexivity.
Qed.

Add Parametric Morphism α (R : ring α) : (@adjust_series _ R)
  with signature eq ==> eq ==> eq_series ==> eq_series
  as adjust_series_morph.
Proof.
intros n k s₁ s₂ Heq.
constructor; intros; simpl.
induction Heq.
destruct (lt_dec i n) as [H₁| H₁]; [ reflexivity | idtac ].
destruct (zerop ((i - n) mod Pos.to_nat k)); [ apply H | reflexivity ].
Qed.


Require Import compcert.lib.Integers.
Require Import compcert.lib.Floats.
Require Import compcert.common.Values. (* C Values and definition of block *)

Definition haskell_int := int64. (* TODO: Should become a parameter *)

Inductive hval : Type := (* This should be a parameter too *)
| HSundef : hval
| HSint : haskell_int -> hval
| HSsingle : float32 -> hval
| HSdouble : float -> hval
| HSptr : block -> ptrofs -> hval
.

Definition HStrue: hval := HSint Int64.one.
Definition HSfalse: hval := HSint Int64.zero.

Definition from_bool (b :bool) : hval :=
  if b then HStrue else HSfalse.

Module HaskellVal.

  Definition eq (x y : hval) : {x=y} + {x<>y}.
  Proof.
    decide equality.
    apply Int64.eq_dec.
    apply Float32.eq_dec.
    apply Float.eq_dec.
    apply Ptrofs.eq_dec.
    apply eq_block.
  Defined.
  Global Opaque eq.

  Definition add (v1 v2 : hval) : hval :=
    match v1, v2 with
    | HSint n1, HSint n2 => HSint (Int64.add n1 n2)
    | _, _ => HSundef
    end. (* TODO: add pointer arithmetic *)

  Definition sub (v1 v2 : hval) : hval :=
    match v1, v2 with
    | HSint n1, HSint n2 => HSint (Int64.sub n1 n2)
    | _, _ => HSundef
    end. (* TODO: add pointer arithmetic *)

  Definition mul (v1 v2 : hval) : hval :=
    match v1, v2 with
    | HSint n1, HSint n2 => HSint (Int64.mul n1 n2)
    | _, _ => HSundef
    end.

  Section COMPARISONS.

    Definition cmp_bool (c : comparison) (v1 v2 : hval) : option bool :=
      match v1, v2 with
      | HSint n1, HSint n2 => Some (Int64.cmp c n1 n2)
      | _, _ => None
      end.

    Definition of_optbool (ob: option bool): hval :=
      match ob with
      | Some b => from_bool b
      | None => HSundef
      end.

    Definition cmp (c: comparison) (v1 v2: hval): hval :=
      of_optbool (cmp_bool c v1 v2).

  End COMPARISONS.

End HaskellVal.