(**
This example is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2014-2018 Sylvie Boldo

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

From Coq Require Import Reals Psatz.
From Flocq Require Import Core Relative Sterbenz Operations.
From Interval Require Import Tactic.

Section Delta_FLX.
Open Scope R_scope.

Variables a b c:R.

Lemma Triangle_equiv_expressions: let s:=((a+b+c)/2) in
  sqrt (s*(s-a)*(s-b)*(s-c)) = /4*sqrt ((a+(b+c))*(a+(b-c))*(c+(a-b))*(c-(a-b))).
Proof.
intros s.
assert (0 <= /4).
assert (0 < 2).
apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
left; apply Rinv_0_lt_compat.
now repeat apply Rmult_lt_0_compat.
assert (0 <= /16).
apply Rle_trans with (/4*/4).
now apply Rmult_le_pos.
right; field.
replace (/4) with (sqrt (/16)).
rewrite <- sqrt_mult_alt.
apply f_equal.
unfold s; field.
exact H0.
apply sqrt_lem_1.
exact H0.
exact H.
field.
Qed.

(***********************  FLX ************************************)
Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Notation format := (generic_format beta (FLX_exp prec)).
Notation round_flx :=(round beta (FLX_exp prec) ZnearestE).

Hypothesis pGt1: (1 < prec)%Z.

(** Next two assumptions are proved below in radix 2 (with 7 bits) and radix 10 (with 3 digits) *)
Hypothesis prec_suff: (/2*bpow (1-prec) <= /100).
Hypothesis fourth_format: format (/4).

Hypothesis cPos: 0 <= c.
Hypothesis cLeb: c <= b.
Hypothesis bLea: b <= a.

Hypothesis isaTriangle1: a <= b+c.

Hypothesis Fa: format a.
Hypothesis Fb: format b.
Hypothesis Fc: format c.

Let t1:=round_flx (a+round_flx (b+c)).
Let t4:=round_flx (c-round_flx (a-b)).
Let t3:=round_flx (c+round_flx (a-b)).
Let t2:=round_flx (a+round_flx (b-c)).

Let M := round_flx (round_flx (round_flx (t1*t2)*t3) *t4).
Let E_M := (a+(b+c))*(a+(b-c))*(c+(a-b))*(c-(a-b)).

Let Delta := round_flx ( round_flx (/4) * round_flx (sqrt M)).
Let E_Delta :=  /4*sqrt ((a+(b+c))*(a+(b-c))*(c+(a-b))*(c-(a-b))).

Lemma FLX_pos_is_pos: forall x, 0 <= x -> 0 <= round_flx x.
Proof with auto with typeclass_instances.
intros x Hx.
apply round_pred_ge_0 with (Rnd_NE_pt beta (FLX_exp prec)) x; auto.
apply Rnd_NE_pt_monotone; auto...
apply Rnd_NG_pt_refl.
apply generic_format_0.
apply round_NE_pt...
Qed.

Lemma FLXN_le_exp: forall f1 f2:float beta,
((Zpower beta (prec - 1) <= Z.abs (Fnum f1) < Zpower beta prec)%Z) ->
((Zpower beta (prec - 1) <= Z.abs (Fnum f2) < Zpower beta prec))%Z ->
0 <= F2R f1 -> F2R f1 <= F2R f2 ->  (Fexp f1 <= Fexp f2)%Z.
Proof.
intros f1 f2 H1 H2 H3 H4.
case (Zle_or_lt (Fexp f1) (Fexp f2)).
trivial.
assert (F2R f1 <= F2R f2) by assumption.
intros H5; contradict H.
apply Rlt_not_le.
unfold F2R.
apply Rlt_le_trans with (IZR(Zpower beta  prec)*bpow (Fexp f2))%R.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply IZR_lt.
apply Z.le_lt_trans with (2:=proj2 H2).
rewrite Z.abs_eq.
auto with zarith.
apply le_IZR.
apply Rmult_le_reg_r with (bpow (Fexp f2)).
apply bpow_gt_0.
rewrite Rmult_0_l.
apply Rle_trans with (1:=H3).
apply H4.
rewrite IZR_Zpower, <-bpow_plus.
apply Rle_trans with (bpow ((prec-1)+Fexp f1)).
apply bpow_le.
lia.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
rewrite <- IZR_Zpower.
apply IZR_le.
apply Z.le_trans with (1:=proj1 H1).
rewrite Z.abs_eq.
auto with zarith.
apply le_IZR.
apply Rmult_le_reg_r with (bpow (Fexp f1)).
apply bpow_gt_0.
rewrite Rmult_0_l.
exact H3.
lia.
lia.
Qed.

Lemma t1pos: 0 <= t1.
Proof with auto with typeclass_instances.
apply FLX_pos_is_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); exact bLea.
apply FLX_pos_is_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); exact cLeb.
exact cPos.
Qed.

Lemma t2pos: 0 <= t2.
Proof with auto with typeclass_instances.
apply FLX_pos_is_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); exact bLea.
apply FLX_pos_is_pos.
apply Rle_0_minus.
exact cLeb.
Qed.

Lemma t3pos: 0 <= t3.
Proof with auto with typeclass_instances.
apply FLX_pos_is_pos.
apply Rplus_le_le_0_compat.
exact cPos.
apply FLX_pos_is_pos.
apply Rle_0_minus.
exact bLea.
Qed.

Lemma t4pos: 0 <= t4.
Proof with auto with typeclass_instances.
apply FLX_pos_is_pos.
apply Rle_0_minus.
apply round_le_generic...
apply Rplus_le_reg_l with b; ring_simplify.
exact isaTriangle1.
Qed.

Lemma Mpos: 0 <= M.
Proof with auto with typeclass_instances.
apply FLX_pos_is_pos.
apply Rmult_le_pos;[idtac|exact t4pos].
apply FLX_pos_is_pos.
apply Rmult_le_pos;[idtac|exact t3pos].
apply FLX_pos_is_pos.
apply Rmult_le_pos;[exact t1pos|exact t2pos].
Qed.

Lemma ab_exact: round_flx (a-b)=a-b.
Proof with auto with typeclass_instances.
apply round_generic...
apply sterbenz_aux...
lra.
Qed.

Lemma t4_exact_aux: forall (f:float beta) g,
  (Z.abs (Fnum f) < Zpower beta prec)%Z
   -> (0 <= g <= F2R f)%R
   -> (exists n:Z, (g=IZR n*bpow (Fexp f))%R)
   -> format g.
Proof with auto with typeclass_instances.
intros f g Hf (Hg1,Hg2) (n,Hg3).
apply generic_format_FLX.
exists (Float beta n (Fexp f)).
exact Hg3.
apply lt_IZR.
rewrite IZR_Zpower.
2: lia.
apply Rmult_lt_reg_r with (bpow (Fexp f)).
apply bpow_gt_0.
apply Rle_lt_trans with (F2R f).
apply Rle_trans with (2:=Hg2).
apply Rle_trans with (Rabs (F2R (Float beta n (Fexp f)))).
rewrite <- F2R_Zabs.
right; reflexivity.
unfold F2R; simpl.
rewrite <- Hg3.
right; apply Rabs_right.
now apply Rle_ge.
rewrite <- (Rabs_right (F2R f)).
replace (F2R f) with (F2R (Float beta (Fnum f) (Fexp f))) by reflexivity.
rewrite <- F2R_Zabs.
unfold F2R; apply Rmult_lt_compat_r.
apply bpow_gt_0.
rewrite <- IZR_Zpower.
2: lia.
apply IZR_lt.
now simpl.
apply Rle_ge; apply Rle_trans with (1:=Hg1); assumption.
Qed.

Lemma t4_exact: t4=c-(a-b).
Proof with auto with typeclass_instances.
unfold t4; rewrite ab_exact.
case cPos; intros K.
apply round_generic...
apply FLXN_format_generic in Fc...
destruct Fc as [fc Hfc1 Hfc2].
apply t4_exact_aux with fc.
apply Hfc2.
now apply Rgt_not_eq.
split.
apply Rle_0_minus.
apply Rplus_le_reg_l with b; ring_simplify.
exact isaTriangle1.
rewrite <-Hfc1.
apply Rplus_le_reg_l with (-c+a); ring_simplify.
exact bLea.
apply FLXN_format_generic in Fa...
destruct Fa as [fa Hfa1 Hfa2].
apply FLXN_format_generic in Fb...
destruct Fb as [fb Hfb1 Hfb2].
exists (Fnum fc -(Fnum fa*Zpower beta (Fexp fa-Fexp fc)
-Fnum fb*Zpower beta (Fexp fb-Fexp fc)))%Z.
rewrite Hfa1, Hfb1, Hfc1; unfold F2R; simpl.
rewrite 2!minus_IZR.
rewrite 2!mult_IZR.
rewrite 2!IZR_Zpower.
unfold Zminus; rewrite 2!bpow_plus.
rewrite bpow_opp.
field.
apply Rgt_not_eq.
apply bpow_gt_0.
assert (Fexp fc <= Fexp fb)%Z.
2: lia.
apply FLXN_le_exp.
apply Hfc2.
now apply Rgt_not_eq.
apply Hfb2.
apply Rgt_not_eq.
apply Rlt_le_trans with c; assumption.
rewrite <- Hfc1; assumption.
rewrite <- Hfc1, <-Hfb1; assumption.
assert (Fexp fc <= Fexp fa)%Z.
apply FLXN_le_exp.
apply Hfc2.
now apply Rgt_not_eq.
apply Hfa2.
apply Rgt_not_eq.
apply Rlt_le_trans with c; try assumption.
apply Rle_trans with b; assumption.
rewrite <- Hfc1; assumption.
rewrite <- Hfc1, <-Hfa1.
apply Rle_trans with b; assumption.
lia.
unfold Rminus; rewrite <-K, Rplus_0_l.
rewrite round_NE_opp.
apply f_equal.
apply ab_exact.
Qed.

Notation err x y e := (Rabs (x - y) <= e * Rabs y).
Notation eps :=(/2*bpow (1-prec)).

Lemma epsPos: 0 <= eps.
Proof.
apply Rmult_le_pos.
auto with real.
apply bpow_ge_0.
Qed.

Lemma err_aux: forall x y e1 e2, err x y e1 -> e1 <= e2 -> err x y e2.
Proof.
intros x y e1 e2 H1 H2.
apply Rle_trans with (e1*Rabs y).
exact H1.
apply Rmult_le_compat_r.
apply Rabs_pos.
exact H2.
Qed.

Lemma err_0: forall x, err x x 0.
Proof.
intros x.
replace (x-x) with 0%R by ring.
rewrite Rabs_R0; right; ring.
Qed.

Lemma err_opp: forall x y e, err x y e -> err (-x) (-y) e.
Proof.
intros x y e H.
replace (-x - (-y)) with (-(x-y)) by ring.
now rewrite 2!Rabs_Ropp.
Qed.

Lemma err_init: forall x, err (round_flx x) x eps.
Proof with auto with typeclass_instances.
intros x.
apply Rle_trans with  (/ 2 * bpow (- prec + 1) * Rabs x).
apply relative_error_N_FLX...
right; apply f_equal2; auto.
apply f_equal, f_equal; ring.
Qed.

Lemma err_add: forall x1 y1 e1 x2 y2 e2, err x1 y1 e1 -> err x2 y2 e2 -> 0 <= y1 -> 0 <= y2
  -> err (round_flx (x1+x2)) (y1+y2) (eps + (1+eps)*(Rmax e1 e2)).
Proof with auto with typeclass_instances.
intros x1 y1 e1 x2 y2 e2 H1 H2 Hy1 Hy2.
replace (round_flx (x1+x2) - (y1+y2)) with ((round_flx (x1+x2)-(x1+x2))+(x1+x2 - (y1+y2))) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (eps*Rabs (x1+x2) + Rabs (x1 + x2 - (y1 + y2))).
apply Rplus_le_compat_r.
apply err_init.
rewrite Rmult_plus_distr_r.
pattern (x1+x2) at 1; replace (x1+x2) with ((x1 + x2 - (y1 + y2))+(y1+y2)) by ring.
apply Rle_trans with (eps * Rabs (y1 + y2) + (1 + eps) * (Rabs (x1 + x2 - (y1 + y2)))).
apply Rle_trans with (eps * Rabs (x1 + x2 - (y1 + y2)) + eps *Rabs (y1 + y2) + Rabs (x1 + x2 - (y1 + y2))).
apply Rplus_le_compat_r.
rewrite <- Rmult_plus_distr_l.
apply Rmult_le_compat_l.
apply epsPos.
apply Rabs_triang.
right; ring.
apply Rplus_le_compat_l.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Fourier_util.Rle_zero_pos_plus1, epsPos.
replace (x1 + x2 - (y1 + y2)) with ((x1-y1)+(x2-y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (e1*Rabs y1 + e2* Rabs y2).
now apply Rplus_le_compat.
apply Rle_trans with (Rmax e1 e2*Rabs y1 + Rmax e1 e2 * Rabs y2).
apply Rplus_le_compat; apply Rmult_le_compat_r; try apply Rabs_pos.
apply Rmax_l.
apply Rmax_r.
rewrite <- Rmult_plus_distr_l.
right; apply f_equal.
repeat rewrite Rabs_right; try reflexivity; apply Rle_ge; try assumption.
now apply Rplus_le_le_0_compat.
Qed.

Lemma err_add2: forall x x2 y2 e2, err x2 y2 e2
  -> 0 <= e2 -> 0 <= y2 <= x
  -> err (round_flx (x+x2)) (x+y2) (eps*(1+e2)+e2/2).
Proof with auto with typeclass_instances.
intros x x2 y2 e2 H2 H (Y1,Y2).
replace (round_flx (x+x2) - (x+y2)) with ((round_flx (x+x2)-(x+x2))+(x2 - y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
rewrite Rmult_plus_distr_r.
apply Rplus_le_compat.
apply Rle_trans with (eps*Rabs (x+x2)).
apply err_init.
rewrite Rmult_assoc with (r3:=Rabs (x + y2)).
apply Rmult_le_compat_l.
apply epsPos.
replace (x+x2) with ((x + y2) +(x2-y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
rewrite Rmult_plus_distr_r.
rewrite Rmult_1_l.
apply Rplus_le_compat_l.
apply Rle_trans with (1:=H2).
apply Rmult_le_compat_l.
apply H.
rewrite 2!Rabs_right.
rewrite <- (Rplus_0_l y2).
apply Rplus_le_compat; auto with real.
apply Rle_trans with y2; assumption.
apply Rle_ge, Rplus_le_le_0_compat.
apply Rle_trans with y2; assumption.
assumption.
apply Rle_ge; assumption.
apply Rle_trans with (1:=H2).
unfold Rdiv; rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply H.
apply Rmult_le_reg_l with 2; auto with real.
rewrite <- Rmult_assoc, Rinv_r.
2:apply Rgt_not_eq, Rlt_gt; auto with real.
rewrite 2!Rabs_pos_eq.
lra.
lra.
easy.
Qed.

Lemma err_mult: forall x1 y1 e1 x2 y2 e2, err x1 y1 e1 -> err x2 y2 e2
  -> err (round_flx (x1*x2)) (y1*y2) (eps+(1+eps)*(e1+e2+e1*e2)).
Proof with auto with typeclass_instances.
intros x1 y1 e1 x2 y2 e2 H1 H2.
replace (round_flx (x1 * x2) - y1*y2) with ((round_flx (x1 * x2) - x1*x2)+(x1*x2-y1*y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (eps*Rabs (x1*x2)+Rabs (x1 * x2 - y1 * y2)).
apply Rplus_le_compat_r.
apply err_init.
rewrite Rmult_plus_distr_r.
apply Rle_trans with (eps*Rabs (y1 * y2) + (1+eps)*Rabs (x1 * x2 - y1 * y2)).
pattern (x1*x2) at 1; replace (x1*x2) with ((x1 * x2 - (y1 * y2))+(y1*y2)) by ring.
apply Rle_trans with (eps * Rabs (x1 * x2 - y1 * y2) + eps*Rabs (y1 * y2) + Rabs (x1 * x2 - y1 * y2)).
apply Rplus_le_compat_r.
rewrite <- Rmult_plus_distr_l.
apply Rmult_le_compat_l.
apply epsPos.
apply Rabs_triang.
right; ring.
apply Rplus_le_compat_l.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Fourier_util.Rle_zero_pos_plus1, epsPos.
rewrite 2!Rmult_plus_distr_r.
replace (x1*x2-y1*y2) with ((x1-y1)*y2+(x2-y2)*y1+(x1-y1)*(x2-y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rplus_le_compat.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rplus_le_compat.
rewrite 2!Rabs_mult.
rewrite <- Rmult_assoc.
apply Rmult_le_compat_r.
apply Rabs_pos.
exact H1.
rewrite 2!Rabs_mult.
rewrite (Rmult_comm _ (Rabs y2)).
rewrite <- Rmult_assoc.
apply Rmult_le_compat_r.
apply Rabs_pos.
exact H2.
apply Rle_trans with ((e1*Rabs y1)*(e2*Rabs y2)).
rewrite Rabs_mult.
apply Rmult_le_compat; try assumption; apply Rabs_pos.
rewrite Rabs_mult; right; ring.
Qed.

Lemma err_mult_exact: forall x y e r, 0 < r -> err x y e -> err (/r*x) (/r*y) e.
Proof.
intros x y e r Hr H.
assert (r <> 0).
now apply Rgt_not_eq.
apply Rmult_le_reg_l with r.
exact Hr.
rewrite <- (Rabs_right r) at 1 4.
rewrite <- Rabs_mult.
replace (r * (/ r * x - / r * y)) with (x-y) by now field.
apply Rle_trans with (1:=H).
rewrite (Rmult_comm (Rabs r) _), Rmult_assoc.
rewrite <- Rabs_mult.
replace (/r * y *r) with y by now field.
apply Rle_refl.
apply Rle_ge; now left.
Qed.

Lemma sqrt_var_maj_2: forall h : R, Rabs h <= /2 ->
  Rabs (sqrt (1 + h) - 1) <= Rabs h / 2 + (Rabs h) * (Rabs h) / 4.
Proof.
intros h H1.
case (Rle_or_lt 0 h); intros Sh.
assert (0 <= h <= 1).
apply Rabs_le_inv in H1.
lra.
rewrite 2!Rabs_pos_eq.
apply Rminus_le.
interval with (i_autodiff h, i_prec 30).
apply Sh.
interval with (i_prec 30).
assert (-1/2 <= h <= 0).
apply Rabs_le_inv in H1.
lra.
rewrite 2!Rabs_left.
apply Rplus_le_reg_l with (h / 2 - h * h / 4).
replace (h / 2 - h * h / 4 + - (sqrt (1 + h) - 1)) with ((-h/2) * (-1 + h / 2 + 2 / (sqrt(1 + h) + 1))).
apply Rle_trans with (-h/2 * 0%R).
2: right ; field.
apply Rmult_le_compat_l.
lra.
interval with (i_autodiff h, i_prec 30).
assert (0 < (sqrt (1 + h) + 1)).
interval.
replace (sqrt (1 + h) - 1) with (h / (sqrt (1 + h) + 1)).
field.
interval.
apply Rmult_eq_reg_l with (sqrt (1 + h) + 1).
2:apply Rgt_not_eq; assumption.
apply trans_eq with h.
field.
apply Rgt_not_eq; assumption.
apply trans_eq with (Rsqr (sqrt (1 + h)) -1).
rewrite Rsqr_sqrt.
ring.
lra.
unfold Rsqr; ring.
exact Sh.
apply Rlt_minus.
rewrite <- sqrt_1 at 2.
apply sqrt_lt_1_alt.
lra.
Qed.

Lemma err_sqrt: forall x y e, 0 <= y -> e <= /2 -> err x y e
  -> err (round_flx (sqrt x)) (sqrt y) (eps+(1+eps)*(/2*e+/4*e*e)).
Proof with auto with typeclass_instances.
intros x y e Hy He H.
replace (round_flx (sqrt x) - sqrt y) with ((round_flx (sqrt x) - sqrt x)+(sqrt x - sqrt y)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (eps*Rabs (sqrt x)+Rabs (sqrt x - sqrt y)).
apply Rplus_le_compat_r.
apply err_init.
rewrite Rmult_plus_distr_r.
apply Rle_trans with (eps*Rabs (sqrt y) + (1+eps)*Rabs (sqrt x - sqrt y)).
pattern (sqrt x) at 1; replace (sqrt x) with ((sqrt x-sqrt y)+sqrt y) by ring.
apply Rle_trans with (eps * Rabs (sqrt x - sqrt y) + eps*Rabs (sqrt y) + Rabs (sqrt x - sqrt y)).
apply Rplus_le_compat_r.
rewrite <- Rmult_plus_distr_l.
apply Rmult_le_compat_l.
apply epsPos.
apply Rabs_triang.
right; ring.
apply Rplus_le_compat_l.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Fourier_util.Rle_zero_pos_plus1, epsPos.
case (Req_dec y 0); intros Hy'.
(* . *)
replace x with 0.
rewrite Hy', sqrt_0, Rminus_0_r, Rabs_R0, Rmult_0_r.
now apply Req_le.
case (Req_dec x 0).
easy.
intros H1.
absurd (Rabs x = 0).
now apply Rabs_no_R0.
assert (Rabs x <= 0).
replace x with (x-y).
replace 0 with (e*Rabs y).
exact H.
rewrite Hy', Rabs_R0; ring.
rewrite Hy'; ring.
case H0; try easy.
intros K; contradict K.
apply Rle_not_lt, Rabs_pos.
(* . *)
replace (sqrt x - sqrt y) with (sqrt y*(sqrt (1+(x-y)/y) - 1)).
rewrite Rabs_mult, Rmult_comm.
apply Rmult_le_compat_r.
apply Rabs_pos.
assert ((Rabs ((x - y) / y) <= e)).
apply Rmult_le_reg_r with (Rabs y).
case (Rabs_pos y); [easy|intros H'; contradict H'; apply sym_not_eq; now apply Rabs_no_R0].
apply Rle_trans with (2:=H).
rewrite <- Rabs_mult; right.
apply f_equal; now field.
apply Rle_trans with (Rabs ((x - y) / y) /2 + Rabs ((x - y) / y)*Rabs ((x - y) / y)/4).
apply sqrt_var_maj_2.
apply Rle_trans with (2:=He); assumption.
apply Rplus_le_compat.
unfold Rdiv; rewrite Rmult_comm.
apply Rmult_le_compat_l; try assumption.
auto with real.
unfold Rdiv; rewrite Rmult_comm.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; auto with real.
apply Rmult_le_compat; try apply Rabs_pos; try apply H0.
rewrite Rmult_minus_distr_l, Rmult_1_r.
apply f_equal2;[idtac|reflexivity].
rewrite <- sqrt_mult.
apply f_equal.
now field.
exact Hy.
apply Rmult_le_reg_l with y.
case Hy; [easy|intros H'; contradict H'; now apply sym_not_eq].
apply Rplus_le_reg_l with (-(x-y)).
apply Rle_trans with (-(x-y)).
right; ring.
apply Rle_trans with (1:=RRle_abs _).
rewrite Rabs_Ropp.
apply Rle_trans with (1:=H).
apply Rle_trans with (1*Rabs y).
apply Rmult_le_compat_r.
apply Rabs_pos.
lra.
rewrite Rabs_pos_eq by easy.
right; now field.
Qed.

(* Ugly *)

Lemma M_correct_aux: forall r, 0 <= r <= /100 ->
  2 * r ^ 8 + 15 * r ^ 7 + 50 * r ^ 6 + 97 * r ^ 5 + 120 * r ^ 4 +
   97 * r ^ 3 + 50 * r ^ 2 + 15 * r <= 52 * r ^ 2 + 15 * r.
Proof.
intros r (H1,H2).
case H1; intros K.
apply Rplus_le_reg_l with (-15*r - 51*r*r); ring_simplify.
apply Rmult_le_reg_l with (/(r*r)).
apply Rinv_0_lt_compat.
now apply Rmult_lt_0_compat.
apply Rle_trans with (2*r ^ 6 + 15 * r ^ 5 + 50 * r ^ 4 + 97 * r ^ 3 + 120 * r ^ 2 + 97 * r -1 ).
right; field.
now apply Rgt_not_eq.
apply Rle_trans with 1.
2: right; field.
unfold pow; rewrite Rmult_1_r.
interval_intro (/100) upper.
assert (J := conj H1 (Rle_trans _ _ _ H2 H)).
clear -J.
interval.
now apply Rgt_not_eq.
rewrite <-K.
right; ring.
Qed.

(* Note: order of multiplications does not matter *)

Lemma M_correct: err M E_M (15/2*eps+26*eps*eps).
Proof.
eapply err_aux.
apply err_mult.
apply err_mult.
apply err_mult.
(* t1 *)
eapply err_aux.
apply err_add.
apply err_0.
apply err_init.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); exact bLea.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); exact cLeb.
exact cPos.
apply Rle_trans with (2*eps+eps*eps).
rewrite Rmax_right.
right; ring.
apply epsPos.
now right.
(* t2 *)
eapply err_aux.
apply err_add2.
apply err_init.
apply epsPos.
split.
now apply Rle_0_minus.
apply Rle_trans with (2:=bLea).
apply Rle_trans with (b-0); auto with real.
apply Rplus_le_compat_l; auto with real.
apply Rle_trans with (3/2*eps+eps*eps).
right; field.
now right.
(* t3 *)
unfold t3; rewrite ab_exact.
apply err_init.
(* t4 *)
rewrite t4_exact.
apply err_0.
assert (0 <= eps).
left; apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply bpow_gt_0.
generalize H prec_suff; generalize eps.
clear; intros.
field_simplify.
unfold Rdiv; apply Rmult_le_compat_r.
auto with real.
apply M_correct_aux.
split; assumption.
Qed.

(* argh, would be simpler in radix 2  Delta = /4 * round_flx (sqrt M) *)

Lemma Delta_correct : (Rabs (Delta - E_Delta) <= (23/4*eps+38*eps*eps) * E_Delta).
Proof with auto with typeclass_instances.
pattern E_Delta at 2; replace E_Delta with (Rabs E_Delta).
eapply err_aux.
apply err_mult.
replace (round_flx (/ 4)) with (/4).
apply err_0.
apply sym_eq, round_generic...
apply err_sqrt.
repeat apply Rmult_le_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); assumption.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); assumption.
assumption.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); assumption.
now apply Rle_0_minus.
apply Rplus_le_le_0_compat.
assumption.
now apply Rle_0_minus.
apply Rplus_le_reg_l with a; ring_simplify.
rewrite Rplus_comm; assumption.
2: apply M_correct.
apply Rle_trans with (15/2*/100+26*/100).
apply Rplus_le_compat.
apply Rmult_le_compat_l.
unfold Rdiv; apply Rmult_le_pos.
apply IZR_le; auto with zarith.
auto with real.
assumption.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply IZR_le; auto with zarith.
rewrite <- (Rmult_1_l (/100)).
apply Rmult_le_compat.
apply epsPos.
apply epsPos.
apply Rle_trans with (1:=prec_suff).
apply Rmult_le_reg_l with 100%R.
apply IZR_lt; auto with zarith.
rewrite Rinv_r.
rewrite Rmult_1_r.
apply IZR_le; auto with zarith.
apply Rgt_not_eq, Rlt_gt.
apply IZR_lt; auto with zarith.
assumption.
rewrite <- Rmult_plus_distr_r.
clear; interval.
generalize prec_suff epsPos.
cut (0 < eps).
generalize eps; clear.
intros r H0 H1 H2.
field_simplify.
apply Rmult_le_reg_r with 16.
repeat apply Rmult_lt_0_compat; auto with real.
unfold Rdiv; rewrite Rmult_assoc.
replace (/64*16) with (/4) by field.
field_simplify.
unfold Rdiv; apply Rmult_le_compat_r.
interval.
apply Rplus_le_reg_l with (-368*r - 2431*r*r); ring_simplify.
apply Rmult_le_reg_l with (/(r*r)).
apply Rinv_0_lt_compat.
now apply Rmult_lt_0_compat.
apply Rle_trans with  (10816 * r ^ 4  + 27872 * r ^ 3 + 25028 * r ^ 2  +
    9944 * r  -155).
right; field.
now apply Rgt_not_eq.
apply Rle_trans with 1.
2: right; field.
unfold pow; rewrite Rmult_1_r.
interval_intro (/100) upper.
assert (J := conj H2 (Rle_trans _ _ _ H1 H)).
clear -J.
interval.
now apply Rgt_not_eq.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply bpow_gt_0.
apply Rabs_right.
apply Rle_ge; apply Rmult_le_pos.
left; apply Rinv_0_lt_compat, Rmult_lt_0_compat; apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply sqrt_pos.
Qed.

Lemma Delta_correct_2 : radix_val beta=2%Z ->
    (Rabs (Delta - E_Delta) <= (19/4*eps+33*eps*eps) * E_Delta).
Proof with auto with typeclass_instances.
intros Hradix.
replace Delta with (/ 4 * round_flx (sqrt M)).
pattern E_Delta at 2; replace E_Delta with (Rabs E_Delta).
apply err_mult_exact.
apply Rmult_lt_0_compat; auto with real.
eapply err_aux.
apply err_sqrt.
repeat apply Rmult_le_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); assumption.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); assumption.
assumption.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); assumption.
now apply Rle_0_minus.
apply Rplus_le_le_0_compat.
assumption.
now apply Rle_0_minus.
apply Rplus_le_reg_l with a; ring_simplify.
rewrite Rplus_comm; assumption.
2: apply M_correct.
apply Rle_trans with (15/2*/100+26*/100).
apply Rplus_le_compat.
apply Rmult_le_compat_l.
unfold Rdiv; apply Rmult_le_pos.
apply IZR_le; auto with zarith.
auto with real.
assumption.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply IZR_le; auto with zarith.
rewrite <- (Rmult_1_l (/100)).
apply Rmult_le_compat.
apply epsPos.
apply epsPos.
apply Rle_trans with (1:=prec_suff).
apply Rmult_le_reg_l with 100%R.
apply IZR_lt; auto with zarith.
rewrite Rinv_r.
rewrite Rmult_1_r.
apply IZR_le; auto with zarith.
apply Rgt_not_eq, Rlt_gt.
apply IZR_lt; auto with zarith.
assumption.
interval.
generalize prec_suff epsPos.
cut (0 < eps).
generalize eps; clear.
intros r H0 H1 H2.
field_simplify.
apply Rmult_le_reg_r with 16.
repeat apply Rmult_lt_0_compat; auto with real.
unfold Rdiv; rewrite Rmult_assoc.
replace (/64*16) with (/4) by field.
field_simplify.
unfold Rdiv; apply Rmult_le_compat_r.
interval.
apply Rplus_le_reg_l with (-304*r - 2111*r*r); ring_simplify.
apply Rmult_le_reg_l with (/(r*r)).
apply Rinv_0_lt_compat.
now apply Rmult_lt_0_compat.
apply Rle_trans with (10816 * r ^ 3 + 17056 * r ^ 2 + 7972 * r -139).
right; field.
now apply Rgt_not_eq.
apply Rle_trans with 1.
2: right; field.
unfold pow; rewrite Rmult_1_r.
interval_intro (/100) upper.
assert (J := conj H2 (Rle_trans _ _ _ H1 H)).
clear -J.
interval.
now apply Rgt_not_eq.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply bpow_gt_0.
apply Rabs_right.
apply Rle_ge; apply Rmult_le_pos.
left; apply Rinv_0_lt_compat, Rmult_lt_0_compat; apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply sqrt_pos.
apply trans_eq with (round_flx (/ 4 * round_flx (sqrt M))).
apply sym_eq, round_generic...
apply generic_format_FLX.
assert (format (round_flx (sqrt M))).
apply generic_format_round...
apply FLX_format_generic in H...
destruct H as [f Hf1 Hf2].
exists (Float beta (Fnum f) (Fexp f -2)).
rewrite Hf1; unfold F2R; simpl.
unfold Zminus;rewrite bpow_plus.
replace (bpow (-(2))) with (/4).
ring.
simpl; unfold Zpower_pos;simpl.
rewrite Hradix; apply f_equal.
simpl; ring.
now simpl.
apply f_equal.
apply f_equal2.
apply sym_eq, round_generic...
reflexivity.
Qed.

End Delta_FLX.

Section Hyp_ok.

Definition radix10 := Build_radix 10 (refl_equal true).

Lemma prec_suff_2: forall prec:Z, (7 <= prec)%Z -> (/2*bpow radix2 (1-prec) <= /100)%R.
Proof.
intros p Hp.
apply Rle_trans with (/2* bpow radix2 (-6))%R.
apply Rmult_le_compat_l.
lra.
apply bpow_le.
lia.
rewrite <- (Rmult_1_l (bpow _ _)).
interval.
Qed.

Lemma prec_suff_10: forall prec:Z, (3 <= prec)%Z -> (/2*bpow radix10 (1-prec) <= /100)%R.
Proof.
intros p Hp.
apply Rle_trans with (/2* bpow radix10 (-2))%R.
apply Rmult_le_compat_l.
lra.
apply bpow_le.
lia.
rewrite bpow_exp.
change (IZR radix10) with 10%R.
interval.
Qed.

Lemma fourth_format_2: forall prec:Z, (0 < prec)%Z -> generic_format radix2 (FLX_exp prec) (/4).
Proof with auto with typeclass_instances.
intros prec Hprec.
change (/4)%R with (bpow radix2 (-2)).
apply generic_format_bpow'...
unfold FLX_exp.
lia.
Qed.

Lemma fourth_format_10: forall prec:Z, (2 <= prec)%Z -> generic_format radix10 (FLX_exp prec) (/4).
Proof with auto with typeclass_instances.
intros prec Hprec.
apply generic_format_FLX.
exists (Float radix10 25 (-2)).
change (F2R (Float radix10 25 (-2))) with (25 / 100)%R.
field.
simpl.
apply Z.lt_le_trans with (10^2)%Z.
unfold Zpower, Zpower_pos; simpl; lia.
change 10%Z with (radix_val radix10).
now apply Zpower_le.
Qed.

End Hyp_ok.

Section Delta_FLT.
Open Scope R_scope.

Variables a b c:R.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable prec emin : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

(***********************  FLT ************************************)
Notation format := (generic_format beta (FLT_exp emin prec)).
Notation round_flt :=(round beta (FLT_exp emin prec) ZnearestE ).

Hypothesis pGt1: (1 < prec)%Z.
Hypothesis OneisNormal: (emin <= -3-prec)%Z.

(** Next two assumptions are proved below in radix 2 (with 7 bits) and radix 10 (with 3 digits) *)
Hypothesis prec_suff: (/2*bpow (1-prec) <= /100).
Hypothesis fourth_format_gen: forall e, (emin +2 <= e)%Z -> format (/4* bpow e).

Lemma fourth_format: format (/4).
Proof.
replace (/4) with (/4*bpow 0).
apply fourth_format_gen.
lia.
simpl; ring.
Qed.

Hypothesis cPos: 0 <= c.
Hypothesis cLeb: c <= b.
Hypothesis bLea: b <= a.

Hypothesis isaTriangle1: a <= b+c.

Hypothesis Fa: format a.
Hypothesis Fb: format b.
Hypothesis Fc: format c.

Let t1:=round_flt (a+round_flt (b+c)).
Let t4:=round_flt (c-round_flt (a-b)).
Let t3:=round_flt (c+round_flt (a-b)).
Let t2:=round_flt (a+round_flt (b-c)).

Let M := round_flt (round_flt (round_flt (t1*t2)*t3) *t4).
Let E_M := (a+(b+c))*(a+(b-c))*(c+(a-b))*(c-(a-b)).

Let Delta := round_flt ( round_flt (/4) * round_flt (sqrt M)).
Let E_Delta :=  /4*sqrt ((a+(b+c))*(a+(b-c))*(c+(a-b))*(c-(a-b))).

Lemma FLT_pos_is_pos: forall x, 0 <= x -> 0 <= round_flt x.
Proof with auto with typeclass_instances.
intros x Hx.
apply round_pred_ge_0 with (Rnd_NE_pt beta (FLT_exp emin prec)) x; auto.
apply Rnd_NE_pt_monotone; auto...
apply Rnd_NG_pt_refl.
apply generic_format_0.
apply round_NE_pt...
Qed.

Lemma t1pos_: 0 <= t1.
Proof with auto with typeclass_instances.
apply FLT_pos_is_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); exact bLea.
apply FLT_pos_is_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); exact cLeb.
exact cPos.
Qed.

Lemma t2pos_: 0 <= t2.
Proof with auto with typeclass_instances.
apply FLT_pos_is_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); exact bLea.
apply FLT_pos_is_pos.
apply Rle_0_minus.
exact cLeb.
Qed.

Lemma t3pos_: 0 <= t3.
Proof with auto with typeclass_instances.
apply FLT_pos_is_pos.
apply Rplus_le_le_0_compat.
exact cPos.
apply FLT_pos_is_pos.
apply Rle_0_minus.
exact bLea.
Qed.

Lemma t4pos_: 0 <= t4.
Proof with auto with typeclass_instances.
apply FLT_pos_is_pos.
apply Rle_0_minus.
apply round_le_generic...
apply Rplus_le_reg_l with b; ring_simplify.
exact isaTriangle1.
Qed.

Lemma Mpos_: 0 <= M.
Proof with auto with typeclass_instances.
apply FLT_pos_is_pos.
apply Rmult_le_pos;[idtac|exact t4pos_].
apply FLT_pos_is_pos.
apply Rmult_le_pos;[idtac|exact t3pos_].
apply FLT_pos_is_pos.
apply Rmult_le_pos;[exact t1pos_|exact t2pos_].
Qed.

Lemma ab_exact_: round_flt (a-b)=a-b.
Proof with auto with typeclass_instances.
apply round_generic...
apply sterbenz_aux...
lra.
Qed.

Lemma t4_exact_aux_: forall (f:float beta) g,
  (Z.abs (Fnum f) < Zpower beta prec)%Z
   -> (0 <= g <= F2R f)%R
   -> (exists n:Z, (g=IZR n*bpow (Fexp f))%R)
   -> (emin <= Fexp f)%Z
   -> format g.
Proof with auto with typeclass_instances.
intros f g Hf (Hg1,Hg2) (n,Hg3) Y.
apply generic_format_FLT.
exists (Float beta n (Fexp f)).
exact Hg3.
apply lt_IZR.
rewrite IZR_Zpower.
2: lia.
apply Rmult_lt_reg_r with (bpow (Fexp f)).
apply bpow_gt_0.
apply Rle_lt_trans with (F2R f).
apply Rle_trans with (2:=Hg2).
apply Rle_trans with (Rabs (F2R (Float beta n (Fexp f)))).
rewrite <- F2R_Zabs.
right; reflexivity.
unfold F2R; simpl.
rewrite <- Hg3.
right; apply Rabs_right.
now apply Rle_ge.
rewrite <- (Rabs_right (F2R f)).
replace (F2R f) with (F2R (Float beta (Fnum f) (Fexp f))) by reflexivity.
rewrite <- F2R_Zabs.
unfold F2R; apply Rmult_lt_compat_r.
apply bpow_gt_0.
rewrite <- IZR_Zpower.
2: lia.
apply IZR_lt.
now simpl.
apply Rle_ge; apply Rle_trans with (1:=Hg1); assumption.
assumption.
Qed.

Lemma t4_exact_: t4=c-(a-b).
Proof with auto with typeclass_instances.
unfold t4; rewrite ab_exact_.
case cPos; intros K.
apply round_generic...
assert (H:(generic_format beta (FLX_exp prec) c)).
now apply generic_format_FLX_FLT with emin.
apply FLXN_format_generic in H...
destruct H as [fc Hfc1 Hfc2].
case (Zle_or_lt emin (Fexp fc)); intros Y.
(* normal *)
apply t4_exact_aux_ with fc.
apply Hfc2.
now apply Rgt_not_eq.
split.
apply Rle_0_minus.
apply Rplus_le_reg_l with b; ring_simplify.
exact isaTriangle1.
rewrite <-Hfc1.
apply Rplus_le_reg_l with (-c+a); ring_simplify.
exact bLea.
apply generic_format_FLX_FLT in Fa.
apply FLXN_format_generic in Fa...
destruct Fa as [fa Hfa1 Hfa2].
apply generic_format_FLX_FLT in Fb.
apply FLXN_format_generic in Fb...
destruct Fb as [fb Hfb1 Hfb2].
exists (Fnum fc -(Fnum fa*Zpower beta (Fexp fa-Fexp fc)
-Fnum fb*Zpower beta (Fexp fb-Fexp fc)))%Z.
rewrite Hfa1, Hfb1, Hfc1; unfold F2R; simpl.
rewrite 2!minus_IZR.
rewrite 2!mult_IZR.
rewrite 2!IZR_Zpower.
unfold Zminus; rewrite 2!bpow_plus.
rewrite bpow_opp.
field.
apply Rgt_not_eq.
apply bpow_gt_0.
assert (Fexp fc <= Fexp fb)%Z.
2: lia.
apply FLXN_le_exp with prec...
apply Hfc2.
now apply Rgt_not_eq.
apply Hfb2.
apply Rgt_not_eq.
apply Rlt_le_trans with c; assumption.
rewrite <- Hfc1; assumption.
rewrite <- Hfc1, <-Hfb1; assumption.
assert (Fexp fc <= Fexp fa)%Z.
apply FLXN_le_exp with prec...
apply Hfc2.
now apply Rgt_not_eq.
apply Hfa2.
apply Rgt_not_eq.
apply Rlt_le_trans with c; try assumption.
apply Rle_trans with b; assumption.
rewrite <- Hfc1; assumption.
rewrite <- Hfc1, <-Hfa1.
apply Rle_trans with b; assumption.
lia.
assumption.
(* subnormal *)
assert (exists f:float beta, c = F2R f /\ Fexp f = emin /\ (Z.abs (Fnum f) < beta ^ prec)%Z).
apply FLT_format_generic in Fc...
destruct Fc as [ffc Hffc1 Hffc2 Hffc3].
exists (Float beta (Fnum ffc*Zpower beta (Fexp ffc-emin)) emin).
split.
rewrite Hffc1; unfold F2R; simpl.
rewrite mult_IZR, IZR_Zpower.
unfold Zminus; rewrite bpow_plus, bpow_opp.
field.
apply Rgt_not_eq.
apply bpow_gt_0.
lia.
split.
reflexivity.
simpl.
apply lt_IZR.
rewrite abs_IZR, mult_IZR, IZR_Zpower.
2: lia.
unfold Zminus; rewrite bpow_plus, <- Rmult_assoc.
replace (IZR (Fnum ffc) * bpow (Fexp ffc)) with (F2R ffc) by reflexivity.
rewrite <- Hffc1.
rewrite Hfc1; unfold F2R; rewrite Rmult_assoc, <- bpow_plus.
rewrite Rabs_mult.
apply Rle_lt_trans with (Rabs (IZR (Fnum fc)) *1).
apply Rmult_le_compat_l.
apply Rabs_pos.
rewrite Rabs_right.
2: apply Rle_ge, bpow_ge_0.
replace 1 with (bpow 0) by reflexivity.
apply bpow_le.
lia.
rewrite Rmult_1_r.
rewrite <- abs_IZR.
apply IZR_lt.
apply Hfc2.
now apply Rgt_not_eq.
destruct H as (gc,(Hgc1,(Hgc2,Hgc3))).
apply t4_exact_aux_ with gc.
assumption.
split.
apply Rle_0_minus.
apply Rplus_le_reg_l with b; ring_simplify.
exact isaTriangle1.
rewrite <-Hgc1.
apply Rplus_le_reg_l with (-c+a); ring_simplify.
exact bLea.
apply FLT_format_generic in Fa...
destruct Fa as [fa Hfa1 Hfa2 Hfa3].
apply FLT_format_generic in Fb...
destruct Fb as [fb Hfb1 Hfb2 Hfb3].
rewrite Hgc2.
exists (Fnum gc -(Fnum fa*Zpower beta (Fexp fa-emin)
-Fnum fb*Zpower beta (Fexp fb -emin)))%Z.
rewrite Hfa1, Hfb1, Hgc1; unfold F2R; simpl.
rewrite Hgc2, 2!minus_IZR.
rewrite 2!mult_IZR.
rewrite 2!IZR_Zpower.
unfold Zminus; rewrite 2!bpow_plus.
rewrite bpow_opp.
field.
apply Rgt_not_eq.
apply bpow_gt_0.
lia.
lia.
lia.
(* *)
unfold Rminus; rewrite <-K, Rplus_0_l.
rewrite round_NE_opp.
apply f_equal.
apply ab_exact_.
Qed.

Lemma t4Let3: t4 <= t3.
Proof with auto with typeclass_instances.
apply round_le...
apply Rplus_le_compat_l.
assert (0 <= round_flt (a - b)).
rewrite ab_exact_.
now apply Rle_0_minus.
apply Rle_trans with (2:=H).
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
Qed.

Lemma t3Let2: t3 <= t2.
Proof with auto with typeclass_instances.
apply round_le...
rewrite ab_exact_.
apply Rle_trans with (a+(c-b));[right; ring|idtac].
apply Rplus_le_compat_l.
apply Rle_trans with 0%R.
now apply Rle_minus.
apply FLT_pos_is_pos.
now apply Rle_0_minus.
Qed.

Lemma t2Let1: t2 <= t1.
Proof with auto with typeclass_instances.
apply round_le...
apply Rplus_le_compat_l.
apply round_le...
apply Rplus_le_compat_l.
apply Rle_trans with (2:=cPos).
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
Qed.

Notation err x y e := (Rabs (x - y) <= e * Rabs y).
Notation eps :=(/2*bpow (1-prec)).

Lemma err_add_no_err: forall x1 x2,
    format x1 -> format x2
  -> err (round_flt (x1+x2)) (x1+x2) eps.
Proof with auto with typeclass_instances.
intros x1 x2 Fx1 Fx2.
case (Rle_or_lt (bpow (emin+prec-1)) (Rabs (x1+x2))); intros Y.
(* . *)
replace eps with (/ 2 * Raux.bpow beta (- prec + 1)).
apply relative_error_N_FLT...
apply f_equal; apply f_equal; ring.
(* . *)
replace (round_flt (x1 + x2)) with (x1+x2).
apply err_aux with 0.
apply err_0.
apply epsPos.
apply sym_eq, round_generic...
apply generic_format_FLT.
apply FLT_format_generic in Fx1; apply FLT_format_generic in Fx2...
destruct Fx1 as [f Hf1 Hf2 Hf3].
destruct Fx2 as [g Hg1 Hg2 Hg3].
exists (Fplus f g).
now rewrite F2R_plus, Hf1, Hg1.
apply lt_IZR.
rewrite abs_IZR.
rewrite IZR_Zpower.
2: auto with zarith.
apply Rmult_lt_reg_r with (bpow (Fexp (Fplus f g))).
apply bpow_gt_0.
apply Rle_lt_trans with (Rabs (F2R (Fplus f g))).
right; unfold F2R; rewrite Rabs_mult.
apply f_equal.
apply sym_eq, Rabs_right.
apply Rle_ge, bpow_ge_0.
rewrite F2R_plus, <- Hf1, <- Hg1.
apply Rlt_le_trans with (1:=Y).
rewrite <- bpow_plus.
apply bpow_le.
assert (emin <= Fexp (Fplus f g))%Z.
rewrite Fexp_Fplus.
now apply Z.min_case.
lia.
rewrite Fexp_Fplus.
now apply Z.min_case.
Qed.

Lemma err_add_: forall x1 y1 e1 x2 y2 e2, err x1 y1 e1 -> err x2 y2 e2 -> 0 <= y1 -> 0 <= y2
  -> format x1 -> format x2
  -> err (round_flt (x1+x2)) (y1+y2) (eps + (1+eps)*(Rmax e1 e2)).
Proof with auto with typeclass_instances.
intros x1 y1 e1 x2 y2 e2 H1 H2 Hy1 Hy2 Fx1 Fx2.
replace (round_flt (x1+x2) - (y1+y2)) with ((round_flt (x1+x2)-(x1+x2))+(x1+x2 - (y1+y2))) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (eps*Rabs (x1+x2) + Rabs (x1 + x2 - (y1 + y2))).
apply Rplus_le_compat_r.
now apply err_add_no_err.
(* *)
rewrite Rmult_plus_distr_r.
pattern (x1+x2) at 1; replace (x1+x2) with ((x1 + x2 - (y1 + y2))+(y1+y2)) by ring.
apply Rle_trans with (eps * Rabs (y1 + y2) + (1 + eps) * (Rabs (x1 + x2 - (y1 + y2)))).
apply Rle_trans with (eps * Rabs (x1 + x2 - (y1 + y2)) + eps *Rabs (y1 + y2) + Rabs (x1 + x2 - (y1 + y2))).
apply Rplus_le_compat_r.
rewrite <- Rmult_plus_distr_l.
apply Rmult_le_compat_l.
apply epsPos.
apply Rabs_triang.
right; ring.
apply Rplus_le_compat_l.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Fourier_util.Rle_zero_pos_plus1, epsPos.
replace (x1 + x2 - (y1 + y2)) with ((x1-y1)+(x2-y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (e1*Rabs y1 + e2* Rabs y2).
now apply Rplus_le_compat.
apply Rle_trans with (Rmax e1 e2*Rabs y1 + Rmax e1 e2 * Rabs y2).
apply Rplus_le_compat; apply Rmult_le_compat_r; try apply Rabs_pos.
apply Rmax_l.
apply Rmax_r.
rewrite <- Rmult_plus_distr_l.
right; apply f_equal.
repeat rewrite Rabs_right; try reflexivity; apply Rle_ge; try assumption.
now apply Rplus_le_le_0_compat.
Qed.

Lemma err_add2_: forall x x2 y2 e2, err x2 y2 e2
  -> format x -> format x2
  -> 0 <= e2 -> 0 <= y2 <= x
  -> err (round_flt (x+x2)) (x+y2) (eps*(1+e2)+e2/2).
Proof with auto with typeclass_instances.
intros x x2 y2 e2 H2 Z1 Z2 H (Y1,Y2).
replace (round_flt (x+x2) - (x+y2)) with ((round_flt (x+x2)-(x+x2))+(x2 - y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
rewrite Rmult_plus_distr_r.
apply Rplus_le_compat.
apply Rle_trans with (eps*Rabs (x+x2)).
now apply err_add_no_err.
rewrite Rmult_assoc with (r3:=Rabs (x + y2)).
apply Rmult_le_compat_l.
apply epsPos.
replace (x+x2) with ((x + y2) +(x2-y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
rewrite Rmult_plus_distr_r.
rewrite Rmult_1_l.
apply Rplus_le_compat_l.
apply Rle_trans with (1:=H2).
apply Rmult_le_compat_l.
apply H.
rewrite 2!Rabs_right.
rewrite <- (Rplus_0_l y2).
apply Rplus_le_compat; auto with real.
apply Rle_trans with y2; assumption.
apply Rle_ge, Rplus_le_le_0_compat.
apply Rle_trans with y2; assumption.
assumption.
apply Rle_ge; assumption.
apply Rle_trans with (1:=H2).
unfold Rdiv; rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply H.
apply Rmult_le_reg_l with 2; auto with real.
rewrite <- Rmult_assoc, Rinv_r.
2: now apply IZR_neq.
rewrite 2!Rabs_pos_eq ; lra.
Qed.

Lemma err_mult_aux: forall x1 y1 e1 x2 y2 e2, format x1 -> format x2 -> err x1 y1 e1 -> err x2 y2 e2
  -> err (round_flt (x1*x2)) (y1*y2) (eps+(1+eps)*(e1+e2+e1*e2))
       \/ (Rabs (round_flt (x1*x2)) <= bpow (emin+prec-1)).
Proof with auto with typeclass_instances.
intros x1 y1 e1 x2 y2 e2 Hx1 Hx2 H1 H2.
case (Rle_or_lt (Rabs (x1 * x2)) (bpow (emin + prec-1))); intros Y.
right.
rewrite <- round_NE_abs...
eapply Rnd_NE_pt_monotone with (beta:=beta) (fexp:=(FLT_exp emin prec))...
apply round_NE_pt...
replace (bpow (emin + prec - 1)) with (round_flt ((bpow (emin + prec - 1)))).
apply round_NE_pt...
apply round_generic...
apply generic_format_bpow'...
unfold FLT_exp; apply Z.max_case; lia.
exact Y.
left.
replace (round_flt (x1 * x2) - y1*y2) with ((round_flt (x1 * x2) - x1*x2)+(x1*x2-y1*y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (eps*Rabs (x1*x2)+Rabs (x1 * x2 - y1 * y2)).
apply Rplus_le_compat_r.
replace eps with (/ 2 * Raux.bpow beta (- prec + 1)).
apply relative_error_N_FLT...
left; exact Y.
apply f_equal; apply f_equal; ring.
rewrite Rmult_plus_distr_r.
apply Rle_trans with (eps*Rabs (y1 * y2) + (1+eps)*Rabs (x1 * x2 - y1 * y2)).
pattern (x1*x2) at 1; replace (x1*x2) with ((x1 * x2 - (y1 * y2))+(y1*y2)) by ring.
apply Rle_trans with (eps * Rabs (x1 * x2 - y1 * y2) + eps*Rabs (y1 * y2) + Rabs (x1 * x2 - y1 * y2)).
apply Rplus_le_compat_r.
rewrite <- Rmult_plus_distr_l.
apply Rmult_le_compat_l.
apply epsPos.
apply Rabs_triang.
right; ring.
apply Rplus_le_compat_l.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Fourier_util.Rle_zero_pos_plus1, epsPos.
rewrite 2!Rmult_plus_distr_r.
replace (x1*x2-y1*y2) with ((x1-y1)*y2+(x2-y2)*y1+(x1-y1)*(x2-y2)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rplus_le_compat.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rplus_le_compat.
rewrite 2!Rabs_mult.
rewrite <- Rmult_assoc.
apply Rmult_le_compat_r.
apply Rabs_pos.
exact H1.
rewrite 2!Rabs_mult.
rewrite (Rmult_comm _ (Rabs y2)).
rewrite <- Rmult_assoc.
apply Rmult_le_compat_r.
apply Rabs_pos.
exact H2.
apply Rle_trans with ((e1*Rabs y1)*(e2*Rabs y2)).
rewrite Rabs_mult.
apply Rmult_le_compat; try assumption; apply Rabs_pos.
rewrite Rabs_mult; right; ring.
Qed.

Lemma err_mult_: forall x1 y1 e1 x2 y2 e2, format x1 -> format x2 -> err x1 y1 e1 -> err x2 y2 e2
  -> (bpow (emin+prec-1) < Rabs (round_flt (x1*x2)))
  -> err (round_flt (x1*x2)) (y1*y2) (eps+(1+eps)*(e1+e2+e1*e2)).
Proof.
intros.
case (err_mult_aux x1  y1 e1 x2 y2 e2); try assumption.
easy.
intros Y; contradict Y.
now apply Rlt_not_le.
Qed.

Lemma err_sqrt_aux: forall x, bpow (Zceil ((IZR (emin+prec-1))/2)) < round_flt (sqrt x) -> bpow (emin+prec-1) < x.
Proof with auto with typeclass_instances.
intros x H.
case (Rle_or_lt x (bpow (emin + prec - 1))); intros H1;[idtac|easy].
contradict H.
apply Rle_not_lt.
apply round_le_generic...
apply generic_format_bpow.
unfold FLT_exp.
rewrite Z.max_l.
lia.
cut (emin + prec-1 <= Zceil (IZR (emin + prec - 1) / 2))%Z. lia.
rewrite <- (Zceil_IZR (emin+prec-1)) at 1.
apply Zceil_le.
apply Rmult_le_reg_l with 2%R.
intuition.
apply Rplus_le_reg_l with (-IZR (emin+prec-1)).
apply Rle_trans with (IZR (emin + prec - 1));[right; ring|idtac].
apply Rle_trans with 0%R;[idtac|right;simpl;field].
apply IZR_le.
lia.
apply Rle_trans with (sqrt (bpow (emin + prec - 1))).
now apply sqrt_le_1_alt.
apply Rle_trans with (sqrt (bpow (2*Zceil (IZR (emin + prec - 1) / 2)))).
apply sqrt_le_1_alt.
apply bpow_le.
apply le_IZR.
rewrite mult_IZR.
apply Rle_trans with ( 2 * ((IZR (emin + prec - 1) / 2))).
right; field.
apply Rmult_le_compat_l.
intuition.
apply Zceil_ub.
right; apply sqrt_lem_1.
apply bpow_ge_0.
apply bpow_ge_0.
rewrite <- bpow_plus.
apply f_equal.
ring.
Qed.

Lemma err_sqrt_: forall x y e, 0 <= y -> e <= /2 -> err x y e ->
     bpow (emin+prec-1) < round_flt (sqrt x)
  -> err (round_flt (sqrt x)) (sqrt y) (eps+(1+eps)*(/2*e+/4*e*e)).
Proof with auto with typeclass_instances.
intros x y e Hy He H Y.
replace (round_flt (sqrt x) - sqrt y) with ((round_flt (sqrt x) - sqrt x)+(sqrt x - sqrt y)) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (eps*Rabs (sqrt x)+Rabs (sqrt x - sqrt y)).
apply Rplus_le_compat_r.
replace eps with (/ 2 * Raux.bpow beta (- prec + 1)).
apply relative_error_N_FLT...
rewrite Rabs_right.
2: apply Rle_ge, sqrt_pos.
case (Rle_or_lt (bpow (emin + prec - 1)) (sqrt x)); intros Y1.
assumption.
contradict Y; apply Rle_not_lt.
apply round_le_generic...
apply generic_format_bpow.
unfold FLT_exp.
replace (emin + prec - 1 + 1 - prec)%Z with emin by ring.
rewrite Z.max_l; lia.
now left.
apply f_equal; apply f_equal; ring.
rewrite Rmult_plus_distr_r.
apply Rle_trans with (eps*Rabs (sqrt y) + (1+eps)*Rabs (sqrt x - sqrt y)).
pattern (sqrt x) at 1; replace (sqrt x) with ((sqrt x-sqrt y)+sqrt y) by ring.
apply Rle_trans with (eps * Rabs (sqrt x - sqrt y) + eps*Rabs (sqrt y) + Rabs (sqrt x - sqrt y)).
apply Rplus_le_compat_r.
rewrite <- Rmult_plus_distr_l.
apply Rmult_le_compat_l.
apply epsPos.
apply Rabs_triang.
right; ring.
apply Rplus_le_compat_l.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Fourier_util.Rle_zero_pos_plus1, epsPos.
case (Req_dec y 0); intros Hy'.
(* . *)
replace x with 0.
rewrite Hy', sqrt_0, Rminus_0_r, Rabs_R0, Rmult_0_r.
now apply Req_le.
case (Req_dec x 0).
easy.
intros H1.
absurd (Rabs x = 0).
now apply Rabs_no_R0.
assert (Rabs x <= 0).
replace x with (x-y).
replace 0 with (e*Rabs y).
exact H.
rewrite Hy', Rabs_R0; ring.
rewrite Hy'; ring.
case H0; try easy.
intros K; contradict K.
apply Rle_not_lt, Rabs_pos.
(* . *)
replace (sqrt x - sqrt y) with (sqrt y*(sqrt (1+(x-y)/y) - 1)).
rewrite Rabs_mult, Rmult_comm.
apply Rmult_le_compat_r.
apply Rabs_pos.
assert ((Rabs ((x - y) / y) <= e)).
apply Rmult_le_reg_r with (Rabs y).
case (Rabs_pos y); [easy|intros H'; contradict H'; apply sym_not_eq; now apply Rabs_no_R0].
apply Rle_trans with (2:=H).
rewrite <- Rabs_mult; right.
apply f_equal; now field.
apply Rle_trans with (Rabs ((x - y) / y) /2 + Rabs ((x - y) / y)*Rabs ((x - y) / y)/4).
apply sqrt_var_maj_2.
apply Rle_trans with (2:=He); assumption.
apply Rplus_le_compat.
unfold Rdiv; rewrite Rmult_comm.
apply Rmult_le_compat_l; try assumption.
auto with real.
unfold Rdiv; rewrite Rmult_comm.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; auto with real.
apply Rmult_le_compat; try apply Rabs_pos; try apply H0.
rewrite Rmult_minus_distr_l, Rmult_1_r.
apply f_equal2;[idtac|reflexivity].
rewrite <- sqrt_mult.
apply f_equal.
now field.
exact Hy.
apply Rmult_le_reg_l with y.
case Hy; [easy|intros H'; contradict H'; now apply sym_not_eq].
apply Rplus_le_reg_l with (-(x-y)).
apply Rle_trans with (-(x-y)).
right; ring.
apply Rle_trans with (1:=RRle_abs _).
rewrite Rabs_Ropp.
apply Rle_trans with (1:=H).
apply Rle_trans with (1*Rabs y).
apply Rmult_le_compat_r.
apply Rabs_pos.
lra.
rewrite Rabs_pos_eq by easy.
right; now field.
Qed.

Lemma subnormal_aux: forall x y, format x -> (Rabs x <= 1 -> Rabs y <= 1) -> bpow (emin+prec-1) < Rabs (round_flt (x*y))
   -> bpow (emin+prec-1) < Rabs x.
Proof with auto with typeclass_instances.
intros x y Fx H1 H2.
case (Rle_or_lt (Rabs x) (bpow (emin + prec - 1))); intros H3;[idtac|assumption].
contradict H2.
apply Rle_not_lt.
apply Rle_trans with (2:=H3).
assert (H4: format (round_flt (x * y))).
apply generic_format_round...
rewrite <- round_NE_abs...
apply round_le_generic...
now apply generic_format_abs.
rewrite <- (Rmult_1_r (Rabs x)), Rabs_mult.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply H1.
apply Rle_trans with (1:=H3).
apply Rle_trans with (bpow 0).
apply bpow_le.
lia.
now apply Rle_refl.
Qed.

Lemma subnormal_aux_aux: (round_flt (t1 * t2)) <= 1 -> t3 <= 1.
Proof with auto with typeclass_instances.
intros Y.
case (Rle_or_lt t1 1); intros Y1.
apply Rle_trans with (2:=Y1).
apply Rle_trans with (1:=t3Let2).
apply t2Let1.
case (Rle_or_lt t2 1); intros Y2.
apply Rle_trans with (2:=Y2).
apply t3Let2.
contradict Y.
apply Rlt_not_le.
apply Rlt_le_trans with (1:=Y1).
apply round_ge_generic...
apply generic_format_round...
rewrite <- (Rmult_1_r t1) at 1.
apply Rmult_le_compat_l.
apply t1pos_.
now left.
Qed.

Lemma subnormal_1: bpow (emin+prec-1) < M -> bpow (emin+prec-1) < Rabs (round_flt (round_flt (t1*t2)*t3)).
Proof with auto with typeclass_instances.
intros H.
apply subnormal_aux with t4.
apply generic_format_round...
rewrite 2!Rabs_right.
intros Y.
case (Rle_or_lt (round_flt (t1 * t2)) 1); intros Y1.
apply subnormal_aux_aux in Y1.
apply Rle_trans with (2:=Y1).
apply t4Let3.
case (Rle_or_lt t3 1); intros Y2.
apply Rle_trans with (2:=Y2).
apply t4Let3.
contradict Y.
apply Rlt_not_le.
apply Rlt_le_trans with (1:=Y1).
apply round_ge_generic...
apply generic_format_round...
rewrite <- (Rmult_1_r (round_flt (t1 * t2))) at 1.
apply Rmult_le_compat_l.
apply FLT_pos_is_pos.
apply Rmult_le_pos.
apply t1pos_.
apply t2pos_.
now left.
apply Rle_ge, t4pos_.
apply Rle_ge, FLT_pos_is_pos.
apply Rmult_le_pos.
apply FLT_pos_is_pos.
apply Rmult_le_pos.
apply t1pos_.
apply t2pos_.
apply t3pos_.
rewrite Rabs_right.
exact H.
apply Rle_ge, Mpos_.
Qed.

Lemma subnormal_2: bpow (emin+prec-1) < M -> bpow (emin+prec-1) < Rabs (round_flt (t1*t2)).
Proof with auto with typeclass_instances.
intros H.
apply subnormal_aux with t3.
apply generic_format_round...
rewrite 2!Rabs_right.
apply subnormal_aux_aux.
apply Rle_ge, t3pos_.
apply Rle_ge, FLT_pos_is_pos.
apply Rmult_le_pos.
apply t1pos_.
apply t2pos_.
apply subnormal_1.
exact H.
Qed.

Lemma M_correct_: bpow (emin+prec-1) < M -> err M E_M (15/2*eps+26*eps*eps).
Proof with auto with typeclass_instances.
intros Y1.
eapply err_aux.
apply err_mult_.
apply generic_format_round...
apply generic_format_round...
apply err_mult_.
apply generic_format_round...
apply generic_format_round...
apply err_mult_.
apply generic_format_round...
apply generic_format_round...
(* t1 *)
apply err_add_; try assumption.
apply err_0.
apply err_add_no_err; try assumption.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); exact bLea.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); exact cLeb.
exact cPos.
apply generic_format_round...
(* t2 *)
apply err_add2_; try assumption.
apply err_add_no_err; try assumption.
now apply generic_format_opp...
apply generic_format_round...
apply epsPos.
split.
now apply Rle_0_minus.
apply Rle_trans with (2:=bLea).
apply Rle_trans with (b-0); auto with real.
apply Rplus_le_compat_l; auto with real.
now apply subnormal_2.
(* t3 *)
unfold t3; rewrite ab_exact_.
apply err_add_no_err; try assumption.
rewrite <- ab_exact_.
apply generic_format_round...
now apply subnormal_1.
(* t4 *)
rewrite t4_exact_.
apply err_0.
rewrite Rabs_right.
exact Y1.
apply Rle_ge, Mpos_.
(* Ugly... *)
generalize prec_suff (epsPos beta prec).
cut (0 < eps).
generalize eps; clear.
intros r H0 H1 H2.
rewrite Rmax_right;[idtac|assumption].
field_simplify.
unfold Rdiv; apply Rmult_le_compat_r.
auto with real.
apply Rplus_le_reg_l with (-15*r - 51*r*r); ring_simplify.
apply Rmult_le_reg_l with (/(r*r)).
apply Rinv_0_lt_compat.
now apply Rmult_lt_0_compat.
apply Rle_trans with (2*r ^ 6 + 15 * r ^ 5 + 50 * r ^ 4 + 97 * r ^ 3 + 120 * r ^ 2 + 97 * r -1 ).
right; field.
now apply Rgt_not_eq.
apply Rle_trans with 1.
2: right; field.
unfold pow; rewrite Rmult_1_r.
interval_intro (/100) upper.
assert (J := conj H2 (Rle_trans _ _ _ H1 H)).
clear -J.
interval.
now apply Rgt_not_eq.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply bpow_gt_0.
Qed.

(* argh, would be simpler in radix 2  Delta = /4 * round_flx (sqrt M) *)

Lemma Delta_correct_ :
  /4 * bpow (Zceil ((IZR (emin+prec-1))/2)) < Delta  ->
   (Rabs (Delta - E_Delta) <= (23/4*eps+38*eps*eps) * E_Delta).
Proof with auto with typeclass_instances.
intros Y.
assert (bpow (Zceil (IZR (emin + prec - 1) / 2)) < round_flt (sqrt M)).
case (Rle_or_lt (round_flt (sqrt M)) (bpow (Zceil (IZR (emin + prec - 1) / 2)))); intros Y1.
2: easy.
contradict Y; apply Rle_not_lt.
apply round_le_generic...
apply fourth_format_gen.
apply le_IZR.
apply Rle_trans with (2:=Zceil_ub _).
apply Rmult_le_reg_r with 2%R.
intuition.
unfold Rdiv; rewrite Rmult_assoc.
rewrite Rinv_l.
rewrite Rmult_1_r.
rewrite <- mult_IZR.
apply IZR_le.
lia.
apply Rgt_not_eq; intuition.
replace (round_flt (/ 4)) with (/4).
apply Rmult_le_compat_l.
left; apply Rinv_0_lt_compat, Rmult_lt_0_compat; intuition.
exact Y1.
apply sym_eq, round_generic...
apply fourth_format.
pattern E_Delta at 2; replace E_Delta with (Rabs E_Delta).
eapply err_aux.
apply err_mult_.
apply generic_format_round...
apply generic_format_round...
replace (round_flt (/ 4)) with (/4).
apply err_0.
apply sym_eq, round_generic...
apply fourth_format.
apply err_sqrt_.
repeat apply Rmult_le_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); assumption.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); assumption.
assumption.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); assumption.
now apply Rle_0_minus.
apply Rplus_le_le_0_compat.
assumption.
now apply Rle_0_minus.
apply Rplus_le_reg_l with a; ring_simplify.
rewrite Rplus_comm; assumption.
instantiate (1:=(15/2*eps+26*eps*eps)).
generalize prec_suff (epsPos beta prec).
generalize eps; clear.
intros r H1 H2; interval_intro (/100) upper.
assert (J := conj H2 (Rle_trans _ _ _ H1 H)).
interval.
apply M_correct_.
apply err_sqrt_aux.
exact H.
apply Rle_lt_trans with (2:=H).
apply bpow_le.
rewrite <- (Zceil_IZR (emin+prec-1)) at 1.
apply Zceil_le.
apply Rmult_le_reg_l with 2%R.
intuition.
apply Rplus_le_reg_l with (-IZR (emin+prec-1)).
apply Rle_trans with (IZR (emin + prec - 1));[right; ring|idtac].
apply Rle_trans with 0%R;[idtac|right;simpl;field].
apply IZR_le.
lia.
rewrite Rabs_right.
apply Rle_lt_trans with (2:=Y).
apply Rmult_le_reg_l with 4.
apply Rmult_lt_0_compat; intuition.
rewrite <- Rmult_assoc, Rinv_r.
rewrite Rmult_1_l.
apply Rle_trans with (bpow (2+(emin + prec - 1))).
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rle_trans with (IZR (radix_val beta)*IZR (radix_val beta)).
apply (Rmult_le_compat 2 _ 2); try apply IZR_le; try easy; clear.
apply Zle_bool_imp_le; now destruct beta.
apply Zle_bool_imp_le; now destruct beta.
right; simpl.
unfold Zpower_pos; simpl.
now rewrite mult_IZR, Zmult_1_r.
apply bpow_le.
apply le_IZR.
apply Rle_trans with (2:=Zceil_ub _).
apply Rmult_le_reg_r with 2%R.
intuition.
unfold Rdiv; rewrite Rmult_assoc.
rewrite Rinv_l.
rewrite Rmult_1_r.
rewrite <- mult_IZR.
apply IZR_le.
lia.
apply Rgt_not_eq.
intuition.
apply Rgt_not_eq.
apply Rmult_lt_0_compat; intuition.
apply Rle_ge; apply FLT_pos_is_pos.
apply Rmult_le_pos.
apply FLT_pos_is_pos.
left; apply Rinv_0_lt_compat, Rmult_lt_0_compat; apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply FLT_pos_is_pos.
apply sqrt_pos.
(* *)
generalize prec_suff (epsPos beta prec).
cut (0 < eps).
generalize eps; clear.
intros r H0 H1 H2.
field_simplify.
apply Rmult_le_reg_r with 16.
repeat apply Rmult_lt_0_compat; auto with real.
unfold Rdiv; rewrite Rmult_assoc.
replace (/64*16) with (/4) by field.
field_simplify.
unfold Rdiv; apply Rmult_le_compat_r.
interval.
apply Rplus_le_reg_l with (-368*r - 2431*r*r); ring_simplify.
apply Rmult_le_reg_l with (/(r*r)).
apply Rinv_0_lt_compat.
now apply Rmult_lt_0_compat.
apply Rle_trans with  (10816 * r ^ 4  + 27872 * r ^ 3 + 25028 * r ^ 2  +
    9944 * r  -155).
right; field.
now apply Rgt_not_eq.
apply Rle_trans with 1.
2: right; field.
unfold pow; rewrite Rmult_1_r.
interval_intro (/100) upper.
assert (J := conj H2 (Rle_trans _ _ _ H1 H)).
clear -J.
interval.
now apply Rgt_not_eq.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply bpow_gt_0.
apply Rabs_right.
apply Rle_ge; apply Rmult_le_pos.
left; apply Rinv_0_lt_compat, Rmult_lt_0_compat; apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply sqrt_pos.
Qed.

Lemma Delta_correct_2_ : radix_val beta=2%Z ->
  bpow (Zceil ((IZR (emin+prec-1))/2) -2) < Delta  ->
  (Rabs (Delta - E_Delta) <= (19/4*eps+33*eps*eps) * E_Delta).
Proof with auto with typeclass_instances.
intros Hradix Y.
assert (bpow (Zceil (IZR (emin + prec - 1) / 2)) < round_flt (sqrt M)).
case (Rle_or_lt (round_flt (sqrt M)) (bpow (Zceil (IZR (emin + prec - 1) / 2)))); intros Y1.
2: easy.
contradict Y; apply Rle_not_lt.
apply round_le_generic...
apply generic_format_bpow.
unfold FLT_exp.
rewrite Z.max_l.
lia.
cut (emin+prec+1 <= Zceil (IZR (emin + prec - 1) / 2))%Z. lia.
apply le_IZR.
apply Rle_trans with (2:=Zceil_ub _).
apply Rmult_le_reg_r with 2%R.
intuition.
unfold Rdiv; rewrite Rmult_assoc.
rewrite Rinv_l.
rewrite Rmult_1_r.
rewrite <- mult_IZR.
apply IZR_le.
lia.
apply Rgt_not_eq; intuition.
replace (round_flt (/ 4)) with (/4).
unfold Zminus; rewrite Rmult_comm, bpow_plus.
replace (bpow (-(2))) with (/4).
apply Rmult_le_compat_r.
left; apply Rinv_0_lt_compat, Rmult_lt_0_compat; intuition.
exact Y1.
simpl; apply f_equal; unfold Zpower_pos; simpl.
rewrite Hradix; simpl; ring.
apply sym_eq, round_generic...
apply fourth_format.
replace Delta with (/ 4 * round_flt (sqrt M)).
pattern E_Delta at 2; replace E_Delta with (Rabs E_Delta).
apply err_mult_exact.
apply Rmult_lt_0_compat; auto with real.
eapply err_aux.
apply err_sqrt_.
repeat apply Rmult_le_pos.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); assumption.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); assumption.
assumption.
apply Rplus_le_le_0_compat.
apply Rle_trans with (1:=cPos); apply Rle_trans with (1:=cLeb); assumption.
now apply Rle_0_minus.
apply Rplus_le_le_0_compat.
assumption.
now apply Rle_0_minus.
apply Rplus_le_reg_l with a; ring_simplify.
rewrite Rplus_comm; assumption.
2: apply M_correct_.
generalize prec_suff (epsPos beta prec).
generalize eps; clear.
intros r H1 H2; interval_intro (/100) upper.
assert (J := conj H2 (Rle_trans _ _ _ H1 H)).
interval.
apply err_sqrt_aux.
exact H.
apply Rle_lt_trans with (2:=H).
apply bpow_le.
rewrite <- (Zceil_IZR (emin+prec-1)) at 1.
apply Zceil_le.
apply Rmult_le_reg_l with 2%R.
intuition.
apply Rplus_le_reg_l with (-IZR (emin+prec-1)).
apply Rle_trans with (IZR (emin + prec - 1));[right; ring|idtac].
apply Rle_trans with 0%R;[idtac|right;simpl;field].
apply IZR_le.
lia.
(* *)
generalize prec_suff (epsPos beta prec).
cut (0 < eps).
generalize eps; clear.
intros r H0 H1 H2.
field_simplify.
apply Rmult_le_reg_r with 16.
repeat apply Rmult_lt_0_compat; auto with real.
unfold Rdiv; rewrite Rmult_assoc.
replace (/64*16) with (/4) by field.
field_simplify.
unfold Rdiv; apply Rmult_le_compat_r.
interval.
apply Rplus_le_reg_l with (-304*r - 2111*r*r); ring_simplify.
apply Rmult_le_reg_l with (/(r*r)).
apply Rinv_0_lt_compat.
now apply Rmult_lt_0_compat.
apply Rle_trans with (10816 * r ^ 3 + 17056 * r ^ 2 + 7972 * r -139).
right; field.
now apply Rgt_not_eq.
apply Rle_trans with 1.
2: right; field.
unfold pow; rewrite Rmult_1_r.
interval_intro (/100) upper.
assert (J := conj H2 (Rle_trans _ _ _ H1 H)).
clear -J.
interval.
now apply Rgt_not_eq.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply bpow_gt_0.
apply Rabs_right.
apply Rle_ge; apply Rmult_le_pos.
left; apply Rinv_0_lt_compat, Rmult_lt_0_compat; apply Rle_lt_0_plus_1; apply Rlt_le; exact Rlt_0_1.
apply sqrt_pos.
apply trans_eq with (round_flt (/ 4 * round_flt (sqrt M))).
apply sym_eq, round_generic...
apply generic_format_FLT.
assert (format (round_flt (sqrt M))).
apply generic_format_round...
apply FLT_format_generic in H0...
destruct H0 as [f Hf1 Hf2 Hf3].
exists (Float beta (Fnum f) (Fexp f -2)).
rewrite Hf1; unfold F2R; simpl.
unfold Zminus;rewrite bpow_plus.
replace (bpow (-(2))) with (/4).
ring.
simpl; unfold Zpower_pos;simpl.
rewrite Hradix; apply f_equal.
simpl; ring.
now simpl.
simpl.
assert (emin+1+prec < prec+Fexp f)%Z;[idtac|lia].
apply lt_bpow with beta.
apply Rle_lt_trans with  (bpow (Zceil (IZR (emin + prec - 1) / 2))).
apply bpow_le.
apply le_IZR.
apply Rle_trans with (2:=Zceil_ub _).
apply Rmult_le_reg_r with 2%R.
intuition.
unfold Rdiv; rewrite Rmult_assoc.
rewrite Rinv_l.
rewrite Rmult_1_r.
rewrite <- mult_IZR.
apply IZR_le.
lia.
apply Rgt_not_eq; intuition.
apply Rlt_le_trans with (1:=H).
rewrite Hf1.
apply Rle_trans with (1:=RRle_abs _).
rewrite <- F2R_abs.
unfold F2R; rewrite bpow_plus.
replace (Fexp (Fabs f)) with (Fexp f).
apply Rmult_le_compat_r.
apply bpow_ge_0.
rewrite <- IZR_Zpower.
left; apply IZR_lt.
replace (Fnum (Fabs f)) with (Z.abs (Fnum f)).
assumption.
destruct f; unfold Fabs; reflexivity.
lia.
destruct f; unfold Fabs; reflexivity.
apply f_equal.
apply f_equal2.
apply sym_eq, round_generic...
apply fourth_format.
reflexivity.
Qed.

End Delta_FLT.

Section Hyp_ok_.

Lemma fourth_format_gen_2: forall prec emin e:Z, (0 < prec)%Z -> (emin +2 <= e)%Z
  -> generic_format radix2 (FLT_exp emin prec) (/4*bpow radix2 e).
Proof with auto with typeclass_instances.
intros prec emin e Hprec H.
change (/4)%R with (bpow radix2 (-2)).
rewrite <- bpow_plus.
apply generic_format_bpow...
unfold FLT_exp.
lia.
Qed.

Lemma fourth_format_gen_10: forall prec emin e:Z, (2 <= prec)%Z -> (emin +2 <= e)%Z
   -> generic_format radix10 (FLT_exp emin prec) (/4*bpow radix10 e).
Proof with auto with typeclass_instances.
intros prec emin e Hprec H.
apply generic_format_FLT.
exists (Float radix10 25 (e-2)).
unfold F2R; simpl.
unfold Zminus; rewrite bpow_plus.
change (bpow radix10 (-(2))) with (/100)%R.
field.
simpl.
apply Z.lt_le_trans with (10^2)%Z.
unfold Zpower, Zpower_pos; simpl; lia.
change 10%Z with (radix_val radix10).
now apply Zpower_le.
simpl.
lia.
Qed.

End Hyp_ok_.


From FOL Require Import FullSyntax Arithmetics Theories.
From Undecidability.Shared Require Import ListAutomation.
From FOL.Tennenbaum Require Import MoreDecidabilityFacts Church Coding NumberUtils Formulas SyntheticInType Peano CantorPairing.

(* Require Import FOL Peano Tarski Deduction CantorPairing NumberTheory Synthetic DecidabilityFacts Formulas Coding Church. *)
Require Import Lia.
Import Vector.VectorNotations.

Notation "x 'el' A" := (List.In x A) (at level 70).
Notation "A '<<=' B" := (List.incl A B) (at level 70).
Notation "x ∣ y" := (exists k, x * k = y) (at level 50).

Section Model.

  Context {Δ1 : Delta1}.

  Variable D : Type.
  Variable I : interp D.
  Local Definition I' : interp D := extensional_model I.
  Existing Instance I | 100.
  Existing Instance I' | 0.
  Notation "⊨ phi" := (forall rho, rho ⊨ phi) (at level 21).
  Variable axioms : forall ax, PA ax -> ⊨ ax.

  Notation "N⊨ phi" := (forall rho, @sat _ _ nat interp_nat _ rho phi) (at level 40).
  Notation "x 'i=' y"  := (@i_atom PA_funcs_signature PA_preds_signature D I Eq ([x ; y])) (at level 40).
  Notation "'iσ' x" := (@i_func PA_funcs_signature PA_preds_signature D I Succ ([x])) (at level 37).
  Notation "x 'i⊕' y" := (@i_func PA_funcs_signature PA_preds_signature D I Plus ([x ; y])) (at level 39).
  Notation "x 'i⊗' y" := (@i_func PA_funcs_signature PA_preds_signature D I Mult ([x ; y])) (at level 38).
  Notation "'i0'" := (i_func (Σ_funcs:=PA_funcs_signature) (f:=Zero) []) (at level 2) : PA_Notation.
  Notation "x 'i⧀' y" := (exists d : D, y = iσ (x i⊕ d) ) (at level 40).

  (* We also assume the existence of a formula which represents the prime number function *)
  Variable ψ : form.
  Variable Hψ : bounded 2 ψ /\ (forall x, Q ⊢I ∀ ψ[up (num x)..] ↔ $0 == num (Irred x) ).

  Definition div e d := exists k : D, e i⊗ k = d.
  Definition div_num n (d : D) := exists e, inu n i⊗ e = d.
  Definition Div_nat (d : D) := fun n => div_num n d.
  Definition div_pi n a :=  (inu n .: (fun _ => a)) ⊨ (∃ (ψ ∧ ∃ $1 ⊗ $0 == $3)).

  Variable surj_form_ : { Φ : nat -> form & surj Φ }.
  Variable enumerable_Q_prv : forall Φ : nat -> form, enumerable (fun n => Q ⊢I (Φ n)).

  Definition Φ := projT1 surj_form_.
  Definition surj_form := projT2 (surj_form_).
  Definition A n := Q ⊢I ¬(Φ n)[(num n)..].
  Definition B n := Q ⊢I (Φ n)[(num n)..].

  Lemma Disjoint_AB : forall n, ~(A n /\ B n).
  Proof.
    unfold A, B. intros n [A_n B_n].
    apply Q_consistent.
    eapply IE; eauto.
  Qed.

  (** Recursively inseparable predicates.  *)

  Definition Insep' :=
    exists A B : nat -> Prop,
      enumerable A /\ enumerable B /\
      (forall n, ~ (A n /\ B n)) /\
      (forall D, Dec D ->
        (forall n, A n -> D n) ->
        (forall n, ~ (B n /\ D n)) ->
        False).

  Definition Insep :=
    exists α β,
      bounded 3 α /\ inhabited(delta1 α) /\ bounded 3 β /\ inhabited(delta1 β) /\
      (forall n, ~ Q ⊢I ((∃∃α) ∧ (∃∃β))[(num n)..] ) /\
      (forall G, Dec G -> (forall n, Q ⊢I (∃∃α)[(num n)..] -> G n) ->
        (forall n, ~ (Q ⊢I (∃∃β)[(num n)..] /\ G n)) -> False).

  Lemma Insep_ :
    RT_strong -> Insep'.
  Proof.
    intros rt.
    exists A, B. repeat split; auto.
    1,2 : apply enumerable_Q_prv.
    { apply Disjoint_AB. }
    intros G Dec_G.
    destruct (rt G Dec_G) as [γ [? [? []]]],
      (surj_form (∃ γ)) as [c Hc].
    rewrite <-Hc in *.
    unfold A, B in *; fold Φ in *.
    intros ? ?%(fun h => h c).
    enough (~ G c); auto.
  Qed.

  Lemma CT_Inseparable :
    CT_Q -> Insep.
  Proof.
    intros ct.
    destruct (Insep_ (CT_RTs ct)) as (A & B & HA & HB & disj & H).
    destruct ((CT_RTw ct) A HA) as [α (Ha0 & [Ha1] & Hα)],
            ((CT_RTw ct) B HB) as [β (Hb0 & [Hb1] & Hβ)].
    exists α, β. do 4 (split; auto).
    repeat split; auto; unfold weak_repr in *.
    - intros n h%soundness. apply (disj n).
      rewrite Hα, Hβ.
      split; apply sigma1_ternary_complete; auto.
      all: intros rho; specialize (h _ interp_nat rho);
            apply h; apply Q_std_axioms.
    - setoid_rewrite <-Hα.
      setoid_rewrite <-Hβ.
      apply H.
  Qed.

  Lemma WInsep_ :
    WRT_strong -> Insep'.
  Proof.
    intros wrt.
    exists A, B. repeat split; auto.
    1,2 : apply enumerable_Q_prv.
    { apply Disjoint_AB. }
    intros G Dec_G.
    intros H.
    apply (DN_remove (wrt G Dec_G)).
    intros [γ [? [? []]]].
    destruct (surj_form (∃ γ)) as [c Hc].
    rewrite <-Hc in *.
    unfold A, B in *; fold Φ in *.
    intros ?%(fun h => h c).
    enough (~ G c); auto.
  Qed.

  Lemma WCT_Inseparable :
    WCT_Q -> ~~ Insep.
  Proof.
    intros wct.
    destruct (WInsep_ (WCT_WRTs wct)) as (A & B & HA & HB & disj & H).
    apply (DN_chaining ((WCT_WRTw wct) B HB)), (DN_chaining ((WCT_WRTw wct) A HA)), DN.
    intros [α (Ha0 & [Ha1] & Hα)] [β (Hb0 & [Hb1] & Hβ)].
    exists α, β. do 4 (split; auto).
    repeat split; unfold weak_repr in *.
    - intros n h%soundness. apply (disj n).
      rewrite Hα, Hβ.
      split; apply sigma1_ternary_complete; auto.
      all: intros rho; specialize (h _ interp_nat rho);
            apply h; apply Q_std_axioms.
    - setoid_rewrite <-Hα.
      setoid_rewrite <-Hβ.
      apply H.
  Qed.

  Lemma delta1_ternary_definite phi :
    delta1 phi -> bounded 3 phi -> ⊨ ∀∀∀ phi ∨ ¬ phi.
  Proof.
    intros d0 b3.
    intros rho. cbn. intros ???.
    specialize (delta1_HA d0) as d0'.
    unshelve refine (let H := tsoundness d0' _  in _).
    3: apply H. intros ??.
    now apply axioms.
  Qed.

  Lemma LEM_bounded_exist_ternary' phi :
    (⊨ ∀∀∀ phi ∨ ¬ phi) -> bounded 3 phi -> ⊨ ∀∀∀ (∃ $0 ⧀ $3 ∧ phi) ∨ ¬ (∃ $0 ⧀ $3 ∧ phi).
  Proof.
    intros def b3.
    pose (Phi := ∀∀ (∃ $0 ⧀ $3 ∧ phi) ∨ ¬ (∃ $0 ⧀ $3 ∧ phi)).
    assert (H : forall d rho, (d.:rho) ⊨ Phi).
    apply induction.
    - apply axioms.
    - repeat solve_bounds;
      eapply bounded_up; apply b3 + lia.
    - intros rho y. cbn. right.
      now intros (? & ?%nolessthen_zero & ?).
    - intros n IHN rho y x. cbn. cbn in IHN.
      destruct (IHN rho y x) as [IH|IH]; fold sat in *; cbn in IH.
      + left. destruct IH as [d Hd]. exists d. split.
        ++ destruct Hd as [[k ->] _]. exists (iσ k).
          now rewrite add_rec_r.
        ++ eapply bound_ext. apply b3.
          2 : apply Hd.
          intros [|[|[]]] ?; (eauto + solve_bounds); lia.
      + destruct (def (fun _ => i0) y x n) as [HN|HN]; fold sat in *.
        ++ left. exists n. split.
          exists i0. now rewrite add_zero_r.
          eapply bound_ext. apply b3.
          2 : apply HN.
          intros [|[|[]]] ?; (eauto + solve_bounds); lia.
        ++ right. intros H. apply IH.
          destruct H as (k & Hk1%lt_S & Hk2 ).
          exists k. split.
          destruct Hk1 as [| ->]. assumption.
          exfalso. apply HN.
          eapply bound_ext. apply b3.
          2 : apply Hk2.
          intros [|[|[]]] ?; (eauto + solve_bounds); lia.
          eapply bound_ext. apply b3.
          2 : apply Hk2.
          intros [|[|[]]] ?; (eauto + solve_bounds); lia.
          apply axioms.
      - intros rho y. apply H.
  Qed.

  Lemma LEM_bounded_exist_ternary {phi} sigma :
    delta1 phi -> bounded 3 phi -> forall b x, (x .: b .: sigma) ⊨ (∃∃ $0 ⧀ $3 ∧ $1 ⧀ $3 ∧ phi) \/ ~ (x .: b .: sigma) ⊨ (∃∃ $0 ⧀ $3 ∧ $1 ⧀ $3 ∧ phi).
  Proof.
    intros d0 b3 b y.
    unshelve refine (let D' := @LEM_bounded_exist_ternary' (∃ $0 ⧀ $3 ∧ phi) _ _ in _); auto.
    - apply LEM_bounded_exist_ternary'; auto.
      now apply delta1_ternary_definite.
    - repeat solve_bounds. eapply bounded_up; eauto.
    - specialize (D' sigma b b y); fold sat in *.
      destruct D' as [H|nH].
      + left. cbn in H. destruct H as [x1 [H1 [x2 [H2 H]]]].
        exists x1, x2. cbn. repeat split; try tauto.
        eapply bound_ext. 3 : apply H. eauto.
        intros [|[|[]]] ?; (eauto + solve_bounds); lia.
      + right; cbn. intros (x1 & x2 & H). apply nH; fold sat; cbn.
        exists x1. split; try tauto.
        exists x2. split; try tauto.
        eapply bound_ext. 3 : apply H. eauto.
        intros [|[|[]]] ?; (eauto + solve_bounds); lia.
  Qed.

  (** Potential existence of undecidable predicates. *)
  Lemma nonDecDiv :
    Insep -> Stable std -> nonStd D -> ~ ~ exists d : D, ~ Dec (fun n => div_pi n d).
  Proof.
    intros (α & β & Ha1 & [Ha0] & Hb1 & [Hb0] & Disj & Insepa) Stab [d Hd].
    pose (phi := (∀ $0 ⧀ $1 → ∀ $0 ⧀ $2 → ∀ $0 ⧀ $3 → ∀ $0 ⧀ $4 → ∀ $0 ⧀ $5 → ¬ (α[$3..][$1..] ∧ β[$5..][$3..]) ) ).
    enough (forall n rho, ((inu n).:rho) ⊨ phi ) as Hx.
    unshelve epose proof (Overspill_DN _ _ _ _ Hx) as H. all: eauto.
    - unfold Coding.unary. repeat solve_bounds.
      eapply subst_bound with (N:=4).
      eapply subst_bound with (N:=4). eapply bounded_up; eauto.
      intros [|[|[|[|[]]]]] ?; cbn; lia + solve_bounds.
      intros [|[|[|[|[]]]]] ?; cbn; lia + solve_bounds.
      eapply subst_bound with (N:=6).
      eapply subst_bound with (N:=6). eapply bounded_up; eauto.
      intros [|[|[|[|[|[]]]]]] ?; cbn; lia + solve_bounds.
      intros [|[|[|[|[|[]]]]]] ?; cbn; lia + solve_bounds.
    - apply nonStd_notStd. now exists d.
    - refine (DN_chaining (@Coding_nonstd_binary_Definite _ _ _ _ _ _ _ (∃∃ $0 ⧀ $3 ∧ $1 ⧀ $3 ∧ α) _ _) _); eauto.
    {apply nonStd_notStd. now exists d. }
    { unfold Coding.binary. repeat solve_bounds.
      eapply bounded_up; eauto; lia. }
    { intros b u.
      specialize (LEM_bounded_exist_ternary (fun _ => i0) Ha0 Ha1 b (inu u)) as [h|h].
      - left. intros ?. eapply bound_ext with (N := 2).
        3 : apply h.
        repeat solve_bounds. eapply bounded_up; eauto.
        intros [|[]]; try reflexivity; lia.
      - right. intros nh. apply h.
        eapply bound_ext with (N := 2).
        3 : apply nh.
        repeat solve_bounds. eapply bounded_up; eauto.
        intros [|[]]; try reflexivity; lia.
    }
    apply (DN_chaining H).
    apply DN. clear H.
    intros [e [? He]] [c Hc]%(fun h => h e).
    exists c. intros Dec_div_c.
    eapply (Insepa _ Dec_div_c).
    + intros n A_n. unfold Div_nat.
      specialize (Hc n (fun _ => e)) as [Hc _].
      cbn in Hc. destruct Hc as [ d' [H1 H2] ].
      * assert (N⊨ (∃∃α)[(num n)..]) as A_n'.
        { intros rho. eapply soundness.
          - apply A_n.
          - apply Q_std_axioms.
        }
        apply sigma1_ternary_complete' in A_n'; auto.
        destruct A_n' as (a & b & Hab).
        exists (inu a), (inu b). repeat split; unfold I'; rewrite <- inu_I; [apply num_lt_nonStd; auto|apply num_lt_nonStd; auto| ].
        apply soundness in Hab.
        specialize (Hab D I' (fun _ => i0)). rewrite !sat_comp in Hab.
        eapply bound_ext. apply Ha1. 2: apply Hab.
        intros [|[|[]]] ?; cbn; try setoid_rewrite num_subst; try setoid_rewrite eval_num; try easy; try lia.
        1: try setoid_rewrite num_subst; try setoid_rewrite eval_num; easy.
        intros ??. apply axioms. now apply PA_compatible_Qeq_PAeq.
      * exists d'. split.
        eapply bound_ext. apply Hψ. 2: apply H1.
        intros [|[]]; try reflexivity; try lia.
        cbn. apply H2.
    + intros n [B_n C_n].
      assert (N⊨ (∃∃β)[(num n)..]) as B_n'.
      { intros rho. eapply soundness.
        - apply B_n.
        - apply Q_std_axioms.
      }
      apply sigma1_ternary_complete' in B_n'; auto.
      destruct B_n' as (a & b & Hab).
      apply soundness in Hab.
      assert ((fun _ => e) ⊨ (∃∃ $0 ⧀ $2 ∧ $1 ⧀ $2 ∧ β[up (up (num n)..)] )) as Heβ.
      { cbn. exists (inu a), (inu b). repeat split; unfold I'; rewrite <- inu_I; [apply num_lt_nonStd; auto|apply num_lt_nonStd; auto| ].
        specialize (Hab D I' (fun _ => i0)). rewrite !sat_comp in Hab.
        rewrite sat_comp.
        eapply bound_ext. apply Hb1. 2: apply Hab.
        intros [|[|[]]] ?; cbn; try setoid_rewrite num_subst; try setoid_rewrite eval_num; try easy; try lia.
        1: try setoid_rewrite num_subst; try setoid_rewrite eval_num; easy.
        intros ??. apply axioms. now apply PA_compatible_Qeq_PAeq. }
      specialize (Hc n (fun _ => e)) as [_ Hc]. cbn in Hc.
      destruct Hc as (k1 & k2 & [Hk2 Hk1] & Hk12); fold sat in *.
      * destruct C_n as [d' Hd']. exists d'. split.
        eapply bound_ext. apply Hψ. 2 : apply Hd'.
        intros [|[]] ?; cbn; eauto + solve_bounds; lia.
        apply Hd'.
      * cbn in Heβ, Hk12, Hk1, Hk2. cbn in Heβ. destruct Heβ as (k3 & k4 & [Hk4 Hk3] & Hk34).
        rewrite sat_comp in Hk34. cbn in He.
        eapply He; fold sat; cbn.
        apply Hk4.
        apply Hk3.
        apply Hk2.
        apply Hk1.
        apply num_lt_nonStd with (n:=n); auto.
        rewrite !sat_comp.
        split.
        **  eapply bound_ext.
            apply Ha1. 2: apply Hk12.
            intros [|[|[]]] ?; try reflexivity; try lia.
        **  eapply bound_ext.
            apply Hb1. 2: apply Hk34.
            intros [|[|[]]] ?; cbn; try reflexivity; try lia.
            try setoid_rewrite num_subst; try setoid_rewrite eval_num; try easy; try lia.
            try setoid_rewrite num_subst; try setoid_rewrite eval_num; try easy; try lia.
        Unshelve. exact (fun _ => i0).
    - intros n rho. cbn.
      intros d4 H4 d3 H3 d2 H2 d1 H1 d0 H0 [H31 H53].
      epose proof (lessthen_num H4) as H4'; auto.
      epose proof (lessthen_num H3) as H3'; auto.
      epose proof (lessthen_num H2) as H2'; auto.
      epose proof (lessthen_num H1) as H1'; auto.
      epose proof (lessthen_num H0) as H0'; auto.
      clear H4 H3 H2 H1 H0.
      destruct H4' as (k4 & H4 & ->).
      destruct H3' as (k3 & H3 & ->).
      destruct H2' as (k2 & H2 & ->).
      destruct H1' as (k1 & H1 & ->).
      destruct H0' as (k0 & H0 & ->).
      apply (Disj k0).
      change (Q ⊢I ((∃∃ α)[(num k0)..] ∧ (∃∃ β)[(num k0)..])).
      apply CI.
      + apply sigma1_ternary_complete; auto.
        intros sigma. unfold I' in H31. rewrite <- !inu_I in H31. rewrite <-switch_num in H31.
        exists k1, k2.
        assert ((inu k1 .: inu k2 .: inu k3 .: inu k4 .: inu n .: rho) ⊨ α[up (up (num k0)..)][(num k2)..][(num k1)..]).
        eapply bound_ext with (N:=0).
        eapply subst_bound with (N:=1).
        eapply subst_bound with (N:=2).
        eapply subst_bound with (N:=3); auto.
        intros [|[|[|[]]]] ?; cbn; lia + solve_bounds.
        rewrite ?num_subst. apply closed_num.
        intros [|[|[]]] ?; cbn; lia + solve_bounds.
        apply closed_num.
        intros [|[]] ?; cbn; lia + solve_bounds.
        apply closed_num.
        lia.
        rewrite !sat_comp. rewrite !sat_comp in H31.
        eapply bound_ext. apply Ha1. 2 : apply H31.
        intros [|[|[]]] ?; cbn; try setoid_rewrite num_subst; try setoid_rewrite eval_num; try easy; try lia.
        1: try setoid_rewrite num_subst; try setoid_rewrite eval_num; easy.
        eapply delta1_absolutness' in H.
        rewrite !switch_nat_num in H.
        apply H.
        * eapply subst_bound with (N:=1).
          eapply subst_bound with (N:=2).
          eapply subst_bound; eauto.
          intros[|[|[]]] ?; cbn; lia + solve_bounds.
          rewrite !num_subst. apply closed_num.
          intros[|[]] ?; cbn; lia + solve_bounds. apply closed_num.
          intros[] ?; cbn; lia + solve_bounds. apply closed_num.
        * rewrite !subst_comp. now apply delta1_subst.
        * apply axioms.
        * intros ??. now apply PA_std_axioms.
      + apply sigma1_ternary_complete; auto.
        intros sigma. unfold I' in H53. rewrite <- !inu_I in H53. rewrite <-switch_num in H53.
        exists k3, k4.
        assert ((inu k1 .: inu k2 .: inu k3 .: inu k4 .: inu n .: rho) ⊨ β[up (up (num k0)..)][(num k4)..][(num k3)..]).
        eapply bound_ext with (N:=0).
        eapply subst_bound with (N:=1).
        eapply subst_bound with (N:=2).
        eapply subst_bound with (N:=3); auto.
        intros [|[|[|[]]]] ?; cbn; lia + solve_bounds.
        rewrite ?num_subst. apply closed_num.
        intros [|[|[]]] ?; cbn; lia + solve_bounds.
        apply closed_num.
        intros [|[]] ?; cbn; lia + solve_bounds.
        apply closed_num.
        lia.
        rewrite !sat_comp. rewrite !sat_comp in H53.
        eapply bound_ext. apply Hb1. 2 : apply H53.
        intros [|[|[]]] ?; cbn; lia + rewrite ?num_subst, ?eval_num; try reflexivity; try lia.
        1-3: try setoid_rewrite num_subst; try setoid_rewrite eval_num; easy.
        eapply delta1_absolutness' in H.
        rewrite !switch_nat_num in H.
        apply H.
        * eapply subst_bound with (N:=1).
          eapply subst_bound with (N:=2).
          eapply subst_bound; eauto.
          intros[|[|[]]] ?; cbn; lia + solve_bounds.
          rewrite !num_subst. apply closed_num.
          intros[|[]] ?; cbn; lia + solve_bounds. apply closed_num.
          intros[] ?; cbn; lia + solve_bounds. apply closed_num.
        * rewrite !subst_comp. now apply delta1_subst.
        * apply axioms.
        * intros ??. now apply PA_std_axioms.
    Unshelve. all: auto.
  Qed.

End Model.


Require Export List.
Require Export Basics.
Require Import Tactics.

Infix "∘" := compose (at level 40, left associativity).

Import ListNotations.

Fixpoint zipWith {A B C} (f : A -> B -> C) (xs : list A) (ys : list B) : list C :=
match xs, ys with
    | (x::xs'), (y::ys') => f x y :: zipWith f xs' ys'
    | _, _ => []
end.

Inductive all {A} (P : A -> Prop) : list A -> Prop :=
| forall_nil : all P nil
| forall_cons {x xs} : P x -> all P xs -> all P (x :: xs).

Lemma all_apply'' {A} (P: A -> Prop) (x: A) (xs: list A) :
  all P (x::xs) -> P x /\ (all P xs).
Proof. intros. inversion H. split.
       - apply H2.
       - apply H3.
Qed.

Hint Constructors all.

Inductive all2 {A B} (R : A -> B -> Prop) : list A -> list B -> Prop :=
| all2_nil : all2 R [] []
| all2_cons {x y xs ys} : R x y -> all2 R xs ys -> all2 R (x::xs) (y::ys).

Hint Constructors all2.

Inductive all3 {A B C} (R : A -> B -> C -> Prop) : list A -> list B -> list C -> Prop :=
| all3_nil : all3 R [] [] []
| all3_cons {x y z xs ys zs} : R x y z -> all3 R xs ys zs -> all3 R (x::xs) (y::ys) (z::zs).

Hint Constructors all3.

Lemma all2_impl {A B} (R1 R2 : A -> B -> Prop) xs ys :
  (forall x y, R1 x y -> R2 x y) -> all2 R1 xs ys -> all2 R2 xs ys.
Proof.
  intros f l. induction l; auto.
Qed.

Lemma all2_apply {A B} (P : Type) (p : P) (R : A -> B -> P -> Prop) xs ys :
  all2 (fun x y => forall (p:P), R x y p) xs ys -> all2 (fun x y => R x y p) xs ys.
Proof.
  intros F. induction F; auto.
Qed.

Lemma all2_and {A B} (R1 R2 : A -> B -> Prop) xs ys :
  all2 R1 xs ys -> all2 R2 xs ys -> all2 (fun x y => R1 x y /\ R2 x y) xs ys.
Proof.
  intros A1 A2. induction A1; inversion A2; auto.
Qed.

Lemma all2_map {A B} (P : A -> B -> Prop) (f: A -> A) (g : B -> B) xs ys :
  (forall x y, P x y -> P (f x) (g y)) ->
  all2 P xs ys -> all2 P (map f xs) (map g ys).
Proof.
  intros I Z. induction Z;constructor; auto.
Qed.

Lemma all2_map' {A1 A2 B1 B2} P (f : A1 -> B1) (g : A2 -> B2) xs ys :
  all2 (fun x y => P (f x) (g y)) xs ys -> all2 P (map f xs) (map g ys).
Proof.
  intro L. induction L; constructor;auto.
Qed.

Class Partial t := {
  lep : t -> t -> Prop
                  }.

Infix "⊆" := lep (at level 60).

Definition default {A} (d : A) (x : option A) : A :=
  match x with
    | Some y => y
    | None => d
  end.

Instance none_Partial A : Partial (option A) := {
  lep t1 t2  := forall z , t1 = Some z -> t2 = Some z
  }.

(* Lifts binary functions into [option] types. *)

Definition bind {A B} (x : option A) (f : A -> option B) : option B :=
  match x with
    | None => None
    | Some x' => f x'
  end.

Definition pure {A} : A -> option A := fun x => Some x.

Instance list_Partial {A} : Partial (list (option A)) := {
  lep t1 t2  := all2 lep t1 t2
                                                        }.

Lemma all_apply {A} (P : Type) (p : P) (R : A -> P -> Prop) xs :
  all (fun x => forall (p:P), R x p) xs -> all (fun x => R x p) xs.
Proof.
  intros F. induction F; auto.
Qed.

Lemma all_map {A B} P (f : A -> B) xs : all (fun x => P (f x)) xs -> all P (map f xs).
Proof.
  intro L. induction L; constructor;auto.
Qed.

Lemma all_map_forall {A B} (P : B -> Prop) (f : A -> B) xs : (forall x, P (f x)) ->  all P (map f xs).
Proof.
  intro L. induction xs; constructor;auto.
Qed.

Lemma all_zip T T' (P : T -> T' -> Prop) l l' f :
  all (fun x => forall t, P x t -> P (f x) t) l -> all2 P l l' -> all2 P (map f l) l'.
Proof.
  generalize dependent l'. induction l; intros.
  + simpl. assumption.
  + simpl. inversion H. inversion H0. subst. constructor. auto. apply IHl; auto.
Qed.

Lemma all_apply' {A} (P Q : Type) (q : Q) (R : A -> P -> Q -> Prop) xs :
  all (fun x => forall (p:P) (q:Q), R x p q) xs -> all (fun x => forall (p:P), R x p q) xs.
Proof.
  intros F. induction F; auto.
Qed.

Lemma all_mp {A} (P Q : A -> Prop) xs : all P xs -> all (fun x => P x -> Q x) xs -> all Q xs.
Proof.
  intro All. induction All;constructor;inversion H0; auto.
Qed.

Lemma all2_map_all2 {A' A B B'} xs ys P (f : A -> A') (g : B -> B') :
  all2 (fun x y => P (f x) (g y)) xs ys -> all2 P (map f xs) (map g ys).
Proof.
  intro Ps. induction Ps;simpl;constructor;auto.
Qed.

Lemma all2_all {A B} P (xs : list A) (ys : list B) : all2 (fun x y => P x) xs ys -> all P xs.
Proof.
  intros T. induction T;constructor;auto.
Qed.

Require Import Reals.

Definition Rleb (x y : R) : bool :=
  match Rle_dec x y with
    | left _ => true
    | right _ => false
  end.

Definition Rltb (s1 s2 : R) : bool :=
  match Rlt_dec s1 s2 with
      | left  _ => true
      | right _ => false
  end.

Open Scope bool.
Definition Reqb (x y : R) : bool := Rleb x y && Rleb y x.

Open Scope R.

Lemma Rleb_iff x y : Rleb x y = true <-> x <= y.
Proof.
  unfold Rleb. split; intro; destruct (Rle_dec x y) ;auto; discriminate.
Qed.

Lemma Rltb_iff x y : Rltb x y = true <-> x < y.
Proof.
  unfold Rltb. split; intro; destruct (Rlt_dec x y);auto; discriminate.
Qed.


Require Import NoQ.Eqv.
Require Import NoQ.Universe.
Require Import NoQ.Relation.
Require Import NoQ.Symmetric.
Require Import NoQ.Transitive.
Require Import NoQ.Equivalence.
Require Import NoQ.Reflexive.
Require Import NoQ.LibReflexive.
Require Import NoQ.Antisymmetric.
Require Import NoQ.PartialOrder.
Require Import NoQ.PreOrder.
Require Import NoQ.Universe.
Require Import NoQ.Arrow.

Class ProperArrow U `{! Universe U } :=
  { proper_arrow : U -> U -> U }.
Infix "⇒" := proper_arrow (at level 90, right associativity).

Inductive PFun (A B:UPO) :=
  { pfun : dom A -> dom B
  ; pfun_proper : proper (eqv ⇉ eqv) pfun
  }.
Arguments Build_PFun {A B} _ _.
Arguments pfun {A B} _ _.
Arguments pfun_proper {A B} _ _ _ _.

Local Instance PFun_Eqv (A B:UPO) : Eqv (PFun A B) :=
  { eqv f g := (eqv ⇉ eqv) (pfun f) (pfun g) }.
Proof.
  constructor ; constructor ; intros ; unfold "⇉" ; intros.
  - apply (pfun_proper x) ; auto.
  - apply symmetry.
    apply H.
    apply symmetry ; auto.
  - apply (transitivity (pfun y x0)).
    + apply H ; apply lib_reflexivity.
    + apply H0 ; auto.
Defined.

Local Instance PFun_PreOrder (A B:UPO)
: PreOrder (PFun A B) :=
  { lte f g := (eqv ⇉ lte) (pfun f) (pfun g) }.
Proof.
  - unfold proper,"⇉" ; simpl ; intros.
    apply (lte_change_eqv (pfun x x1) (pfun x0 y1)).
    { apply symmetry ; apply H ; apply lib_reflexivity. }
    { apply symmetry ; apply H0 ; apply lib_reflexivity. }
    apply H1 ; auto.
  - constructor ; unfold "⇉" ; intros.
    apply reflexivity.
    apply H ; auto.
  - constructor ; unfold "⇉" ; intros.
    apply (transitivity (pfun y x0)).
    + apply H ; apply lib_reflexivity.
    + apply H0 ; auto.
Defined.

Local Instance PArrow_PartialOrder (A B:UPO) `{! PartialOrder (dom B) }
: PartialOrder (PFun A B) := {}.
Proof.
  constructor ; intros.
  unfold "≃" ; simpl.
  unfold "⇉" ; intros.
  apply antisymmetry ; [ apply H | apply H0 ] ; auto || (apply symmetry ; auto).
Defined.

Definition PArrow_UPreOrder (A B:UPO) : UPO :=
  {| UPreOrder_dom := PFun A B |}.
Instance UPreOrder_ProperArrow : ProperArrow UPO :=
  { proper_arrow := PArrow_UPreOrder }.
Definition PArrow_UPreOrder_apply {A B:UPO} (f:dom (A ⇒ B)) (x:dom A) := pfun f x.
Definition PArrow_UPreOrder_id {A:UPO} : dom (A ⇒ A).
refine {| pfun x := x |}.
  unfold proper,"⇉" ; auto.
Defined.
Definition PArrow_UPreOrder_compose {A B C:UPO} : dom ((B ⇒ C) ⇒ (A ⇒ B) ⇒ (A ⇒ C)).
refine {| pfun := fun (g:dom (B ⇒ C)) =>
          {| pfun := fun (f:dom (A ⇒ B)) =>
             {| pfun := fun (x:dom A) => pfun g (pfun f x) |} : dom (A ⇒ C)
          |}  : dom ((A ⇒ B) ⇒ (A ⇒ C))
       |}.
Proof.
  unfold proper,"⇉" ; intros.
  unfold "≃" ; simpl.
  unfold "⇉" ; intros.
  unfold "≃" ; simpl.
  unfold "⇉" ; intros.
  apply H.
  apply H0.
  auto.
Grab Existential Variables.
  - unfold proper,"⇉" ; intros.
    unfold "≃" ; simpl.
    unfold "⇉" ; intros.
    apply (pfun_proper g).
    apply H.
    auto.
  - unfold proper,"⇉" ; intros.
    apply (pfun_proper g).
    apply (pfun_proper f).
    auto.
Defined.

Instance PArrow_UPreOrder_Arrow : Arrow PArrow_UPreOrder :=
  { lambda_p A B f := proper (eqv ⇉ eqv) f
  ; lambda A B f p := {| pfun := f ; pfun_proper := p |}
  ; apply := @PArrow_UPreOrder_apply
  ; id := @PArrow_UPreOrder_id
  ; compose := @PArrow_UPreOrder_compose
  }.
Proof.
  - intros ; apply lib_reflexivity.
  - intros ; apply lib_reflexivity.
  - intros ; simpl.
    unfold "≃" ; simpl.
    unfold "⇉" ; intros.
    apply (pfun_proper f) ; auto.
  - intros ; simpl.
    unfold "≃" ; simpl.
    unfold "⇉" ; intros.
    apply (pfun_proper f) ; auto.
  - intros ; simpl.
    unfold "≃" ; simpl.
    unfold "⇉" ; intros.
    apply (pfun_proper h).
    apply (pfun_proper g).
    apply (pfun_proper f) ; auto.
Defined.

Instance PArrow_UPreOrder_Logical : Logical PArrow_UPreOrder :=
  { logical_intro A B f g p := p
  ; logical_elim A B f g p := p
  }.


(** * Macros for the definition of HILECOP Place and Transition designs. *)

Require Import NArith.
Require Import AbstractSyntax.
Require Import GlobalTypes.
Require Import HVhdlTypes.

(** /!\ We must ensure that the identifiers generated by the SITPN to
    VHDL transformation does override the set of reserved
    identifiers. Therefore, the first generated identifier must begin
    at the last reserved identifier + 1. *)

(** Defines the clock input port reserved identifier. Every design in
    H-VHDL is equipped with an clock input port.  *)

Definition clk : ident := 0.

(** Defines reserved identifiers for the place, and the transition
    designs.  *)

Definition place_id : ident := 1.
Definition place_archid : ident := 2.
Definition trans_id : ident := 3.
Definition transition_archid : ident := 4.

(** Reserved identifiers for the action activation and function
    execution generated processes. *)

Definition actions_ps_id : ident := 5.
Definition functions_ps_id : ident := 6.

(** Defines the first fresh identifier.
    Starts the available identifier range. *)

Definition ffid : ident := 10.

(** Defines multiple macros that are convenient to build
    the Place and Transition designs in H-VHDL abstract syntax.

    Constants, types and subtypes defined in the "petri.vhd" of HILECOP
    find here their equivalent definition in Coq.
 *)

(** Global constant macros. *)

Definition MAXIMAL_GLOBAL_MARKING : N := 255.

(** Type and subtype macros. *)

Definition arc_t           : tind := tind_natural 0%N 2%N.
Definition transition_t    : tind := tind_natural 0%N 3%N.

Definition weight_t        : tind := tind_natural 0%N MAXIMAL_GLOBAL_MARKING.
Definition weight_vector_t : expr -> expr -> tind := tind_array weight_t.
Definition arc_vector_t    : expr -> expr -> tind := tind_array arc_t.
Definition bool_vector_t   : expr -> expr -> tind := tind_array tind_boolean.


Require Import Iron.Language.SystemF2Cap.Value.Relation.TyJudge.

(* Weakening Type Env in Type Judgement.
   We can insert a new type into the type environment, provided we
   lift existing references to types higher in the stack across
   the new one. *)
Lemma type_tyenv_insert
 :  forall ke te se sp ix x t1 e1 t2
 ,  TypeX  ke te se sp x t1 e1
 -> TypeX  ke (insert ix t2 te) se sp (liftXX 1 ix x) t1 e1.
Proof.
 intros. gen ix ke se sp te t1 e1 t2.
 induction x using exp_mutind with
  (PV := fun v => forall ix ke se sp te t1 t2
      ,  TypeV ke te se sp v t1
      -> TypeV ke (insert ix t2 te) se sp (liftXV 1 ix v) t1)
  ; intros; inverts_type; simpl; eauto.

 - Case "VVar".
   nnat; lift_cases; burn.

 - Case "VLam".
   apply TvLam; eauto.
   rewrite insert_rewind. auto.

 - Case "VLAM".
   apply TvLAM.
   have ( liftTE 0 (insert ix t2 te)
        = insert ix (liftTT 1 0 t2) (liftTE 0 te))
    by (unfold liftTE; rewrite map_insert; auto).
   rewritess. eauto.

 - Case "XLet".
   apply TxLet; eauto.
   rewrite insert_rewind. eauto.

 - Case "XPrivate".
   eapply TxPrivate with (t := t) (e := e); eauto.
   have ( liftTE 0 (insert ix t2 te)
        = insert ix (liftTT 1 0 t2) (liftTE 0 te))
    by (unfold liftTE; rewrite map_insert; auto).
   rewritess.
   rewrite insert_app.
   eapply IHx.
   auto.

 - Case "XExtend".
   eapply TxExtend; eauto.
   have ( liftTE 0 (insert ix t2 te)
        = insert ix (liftTT 1 0 t2) (liftTE 0 te))
    by (unfold liftTE; rewrite map_insert; auto).
   rewritess. eauto.
Qed.

(* We can push a new type onto the environment stack provided
   we lift references to existing types across the new one. *)
Lemma type_tyenv_weaken1
 :  forall ke te se sp x t1 e1 t2
 ,  TypeX  ke te se sp x t1 e1
 -> TypeX  ke (te :> t2) se sp (liftXX 1 0 x) t1 e1.
Proof.
 intros.
 rrwrite (te :> t2 = insert 0 t2 te).
 burn using type_tyenv_insert.
Qed.

(* We can push a new type into the enviroment of a type-of-value
   judgement provided we lift references to existing types across
   the new one *)
Lemma typev_tyenv_weaken1
 :  forall ke te se sp v t1 t2
 ,  TypeV  ke te se sp v t1
 -> TypeV  ke (te :> t2) se sp (liftXV 1 0 v) t1.
Proof.
 intros.
 have HX: (TypeX ke te se sp (XVal v) t1 (TBot KEffect)).
 eapply type_tyenv_weaken1 in HX.
 simpl in HX. inverts HX. eauto.
Qed.

(* We can several new types onto the environment stack provided
   we lift referenes to existing types across the new one. *)
Lemma typev_tyenv_weaken_append
 :  forall ke te se sp te' v t1
 ,  TypeV  ke te se sp v t1
 -> TypeV  ke (te >< te') se sp (liftXV (length te') 0 v) t1.
Proof.
 intros.
 induction te'; simpl.
 - burn.

 - rrwrite (S (length te') = length te' + 1).
   rrwrite (length te' + 1 = 1 + length te').
   rewrite <- liftXV_plus.
   eapply typev_tyenv_weaken1.
   auto.
Qed.

(* We can several new types onto the environment stack provided
   we lift referenes to existing types across the new one. *)
Lemma type_tyenv_weaken_append
 :  forall ke te se sp te' x t1 e1
 ,  TypeX  ke te se sp x t1 e1
 -> TypeX  ke (te >< te') se sp (liftXX (length te') 0 x) t1 e1.
Proof.
 intros.
 induction te'; simpl.
  - burn.

  - rrwrite (S (length te') = length te' + 1).
    rrwrite (length te' + 1 = 1 + length te').
    rewrite <- liftXX_plus.
    eapply type_tyenv_weaken1.
    auto.
Qed.