(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Reals Psatz.
From Flocq Require Import Raux Digits.

Require Import Stdlib.
Require Import Xreal.
Require Import Basic.
Require Import Sig.
Require Import Interval.
Require Import Float.

Module TranscendentalFloatFast (F : FloatOps with Definition sensible_format := true).

Module I := FloatInterval F.
Module J := IntervalBasicExt I.
Module F' := FloatExt F.

CoInductive hidden_constant : Type :=
  | HConst : I.type -> hidden_constant.

CoInductive constants : Type :=
  | Consts: hidden_constant -> constants -> constants.

Fixpoint constant_getter_aux n cst :=
  match n, cst with
  | O, Consts (HConst xi) _ => xi
  | S p, Consts _ c => constant_getter_aux p c
  end.

Definition constant_getter cst prec :=
  let nb := Z.abs_nat (Z.pred (fst (Zdiv.Zdiv_eucl_POS (F.prec prec + 30)%positive 31%Z))) in
  constant_getter_aux nb cst.

CoFixpoint hidden_constant_generator gen n :=
  HConst (gen (F.PtoP (n * 31)%positive)).

CoFixpoint constant_generator_aux gen n :=
  Consts (hidden_constant_generator gen n) (constant_generator_aux gen (Pos.succ n)).

Definition constant_generator gen :=
  constant_generator_aux gen 1.

Definition Z2nat x :=
  match x with
  | Zpos p => nat_of_P p
  | _ => O
  end.

Definition Z2P x :=
  match x with
  | Zpos p => p
  | _ => xH
  end.

Definition c1 := F.one.
Definition c2 := F.fromZ 2.
Definition c3 := F.fromZ 3.
Definition cm1 := F.neg F.one.
Definition i1 := I.fromZ_small 1.
Definition i2 := I.fromZ_small 2.
Definition i3 := I.fromZ_small 3.
Definition i4 := I.fromZ_small 4.
Definition i5 := I.fromZ_small 5.
Definition i6 := I.fromZ_small 6.
Definition i239 := I.fromZ_small 239.
Definition c1_2 := F.div2 c1.
Definition c1_8 := iter_pos F.div2 8 c1.  (* TODO: eval *compute in ? *)
Definition c1_p_c1_8 := F.add_DN (F.PtoP 52) c1 c1_8.  (* TODO: eval *compute in ? *)

Lemma c1_n_correct :
  forall x n,
  (/ 256 * 2^Pos.to_nat n <= Rabs (F.toR x))%R ->
  F.toX (iter_pos F.div2 n x) = Xmul (F.toX x) (Xreal ((/2)^Pos.to_nat n)).
Proof.
intros x n Hx.
rewrite iter_pos_nat.
revert x Hx.
elim (Pos.to_nat n); clear n; [|intros n IHn]; intros x Hx.
{ now simpl; case F.toX; [|intro r; simpl; rewrite Rmult_1_r]. }
simpl.
rewrite IHn.
{ rewrite F.div2_correct; [|easy|].
  { rewrite Xdiv_split.
    case F.toX; [easy|]; intro rx.
    simpl; unfold Xinv'; rewrite is_zero_false; [|easy].
    now simpl; rewrite Rmult_assoc. }
  revert Hx; apply Rle_trans.
  unfold Rdiv; rewrite Rmult_1_l.
  rewrite <-(Rmult_1_r (/ 256)) at 1.
  apply Rmult_le_compat_l; [|apply pow_R1_Rle]; lra. }
unfold F.toR; rewrite F.div2_correct; [|easy|].
{ revert Hx; unfold F.toR; case F.toX; [|intro rx].
  { simpl; change R0 with 0%R; rewrite Rabs_R0.
    intro H; exfalso; apply (Rlt_irrefl 0); revert H; apply Rlt_le_trans.
    do 2 (apply Rmult_lt_0_compat; [lra|]).
    apply pow_lt; lra. }
  rewrite Xdiv_split; unfold Xinv'.
  simpl.
  intro Hx.
  rewrite is_zero_false; [|easy].
  simpl.
  rewrite Rabs_mult, (Rabs_pos_eq (/ 2)); lra. }
revert Hx; apply Rle_trans.
unfold Rdiv; rewrite Rmult_1_l.
rewrite <-(Rmult_1_r (/ 256)) at 1.
apply Rmult_le_compat_l; [|apply pow_R1_Rle]; lra.
Qed.

Lemma c1_2_correct : F.toX c1_2 = Xreal (/ 2).
Proof.
change c1_2 with (iter_pos F.div2 1 c1); rewrite c1_n_correct.
{ unfold c1; rewrite F.one_correct; simpl; apply f_equal; lra. }
unfold F.toR, c1; rewrite F.one_correct; simpl; rewrite Rabs_R1; lra.
Qed.

Lemma c1_8_correct : F.toX c1_8 = Xreal (/ 256).
Proof.
change c1_8 with (iter_pos F.div2 8 c1); rewrite c1_n_correct.
{ unfold c1; rewrite F.one_correct; simpl; apply f_equal; lra. }
unfold F.toR, c1; rewrite F.one_correct; simpl; rewrite Rabs_R1; lra.
Qed.

Lemma i1_correct : contains (I.convert i1) (Xreal 1).
Proof.
simpl; unfold c1.
rewrite F'.valid_lb_real; [|now rewrite F.real_correct, F.fromZ_correct].
rewrite F'.valid_ub_real; [|now rewrite F.real_correct, F.fromZ_correct].
simpl.
rewrite F.fromZ_correct; [lra|lia].
Qed.

Ltac bound_tac :=
  unfold Xround, Xbind ;
  match goal with
  | |- (round ?r_DN ?p ?v <= ?v)%R =>
    apply (proj1 (proj2 (Generic_fmt.round_DN_pt F.radix (FLX.FLX_exp (Zpos p)) v)))
  | |- (?v <= round ?r rnd_UP ?p ?v)%R =>
    apply (proj1 (proj2 (Generic_fmt.round_UP_pt F.radix (FLX.FLX_exp (Zpos p)) v)))
  | |- (round ?r_DN ?p ?v <= ?w)%R =>
    apply Rle_trans with (1 := proj1 (proj2 (Generic_fmt.round_DN_pt F.radix (FLX.FLX_exp (Zpos p)) v)))
  | |- (?w <= round ?r rnd_UP ?p ?v)%R =>
    apply Rle_trans with (2 := proj1 (proj2 (Generic_fmt.round_UP_pt F.radix (FLX.FLX_exp (Zpos p)) v)))
  end.

Notation toR := F.toR (only parsing).

(* 0 <= inputs *)
Fixpoint atan_fast0_aux prec thre powi sqri divi (nb : nat) { struct nb } :=
  let npwi := I.mul prec powi sqri in
  let vali := I.div prec npwi divi in
  match F.cmp (I.upper vali) thre, nb with
  | Xlt, _
  | _, O => I.bnd F.zero (I.upper vali)
  | _, S n =>
    I.sub prec vali
      (atan_fast0_aux prec thre npwi sqri (I.add prec divi i2) n)
  end.

(* -1/2 <= input <= 1/2 *)
Definition atan_fast0 prec xi :=
  let x2i := I.sqr prec xi in
  let p := F.prec prec in
  let thre := F.scale c1 (F.ZtoS (Zneg p)) in
  let rem := atan_fast0_aux prec thre i1 x2i i3 (nat_of_P p) in
  I.mul prec (I.sub prec i1 rem) xi.

Definition pi4_gen prec :=
  I.sub prec
   (I.mul2 prec (I.mul2 prec (atan_fast0 prec (I.inv prec i5))))
   (atan_fast0 prec (I.inv prec i239)).

Definition pi4_seq := constant_generator pi4_gen.
Definition pi4 := constant_getter pi4_seq.

Definition atan_fastP prec x :=
  let xi := I.bnd x x in
  if F'.lt c1_2 x then
    let prec := F.incr_prec prec 2 in
    let pi4i := pi4 prec in
    if F'.lt c2 x then
      I.sub prec
       (I.mul2 prec pi4i)
       (atan_fast0 prec (I.div prec i1 xi))
    else
      let xm1i := I.sub prec xi i1 in
      let xp1i := I.add prec xi i1 in
      I.add prec pi4i
       (atan_fast0 prec (I.div prec xm1i xp1i))
  else
    atan_fast0 (F.incr_prec prec 1) xi.

Definition atan_fast prec x :=
  match F'.cmp x F.zero with
  | Xeq => I.zero
  | Xlt => I.neg (atan_fastP prec (F.neg x))
  | Xgt => atan_fastP prec x
  | Xund => I.nai
  end.

Lemma atan_fast0_correct :
  forall prec xi x,
  (Rabs x <= /2)%R ->
  contains (I.convert xi) (Xreal x) ->
  contains (I.convert (atan_fast0 prec xi)) (Xreal (atan x)).
Proof.
intros prec xi x Bx Ix.
unfold atan_fast0.
rewrite atan_atanc, Rmult_comm.
apply J.mul_correct with (2 := Ix).
replace (atanc x) with (1 - (1 - atanc x))%R by ring.
apply J.sub_correct.
  now apply I.fromZ_small_correct.
pose (Ai := fun x => sum_f_R0 (fun n : nat => ((-1) ^ n / INR (2 * n + 1) * x ^ (2 * n))%R)).
assert (Hexit : forall k powi divi,
    contains (I.convert powi) (Xreal (x ^ (2 * k))) ->
    contains (I.convert divi) (Xreal (INR (2 * (k + 1) + 1))) ->
    contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi (I.sqr prec xi)) divi))))
      (Xreal ((-1) ^ (k + 1) * (atanc x - Ai x k)))).
{ intros k powi divi Hpow Hdiv.
  assert (A: (0 <= (-1) ^ (k + 1) * (atanc x - Ai x k) <= x ^ (2 * (k + 1)) / INR (2 * (k + 1) + 1))%R).
  { replace (Ai x k) with (sum_f_R0 (tg_alt (fun n => / INR (2 * n + 1) * x ^ (2 * n))%R) k).
    { unfold Rdiv.
      rewrite (Rmult_comm (x ^ _)).
      replace (k + 1) with (S k) by ring.
      apply alternated_series_ineq'.
      { apply Un_decreasing_atanc.
        lra. }
      { apply Un_cv_atanc.
        lra. }
      unfold atanc.
      case Ratan.in_int ; intros Hx.
      { case atanc_exists ; simpl projT1 ; intros l C.
        exact C. }
      elim Hx.
      apply Rabs_le_inv.
      lra. }
    apply sum_eq.
    intros n _.
    unfold tg_alt.
    apply sym_eq, Rmult_assoc. }
  assert (Hne : not_empty
    (I.convert (I.div prec (I.mul prec powi (I.sqr prec xi)) divi))).
  { exists ((x ^ (2 * k) * (x * x)) / INR (2 * (k + 1) + 1))%R.
    now apply J.div_correct; [apply J.mul_correct; [|apply J.sqr_correct]|]. }
  rewrite I.bnd_correct.
  2: { now apply I.valid_lb_real; rewrite F.zero_correct. }
  2: { now apply I.valid_ub_upper. }
  rewrite F.zero_correct, (I.upper_correct _ Hne).
  apply (conj (proj1 A)).
  assert (Hx2 := J.sqr_correct prec _ _ Ix).
  assert (H1 := J.mul_correct prec _ _ _ _ Hpow Hx2).
  assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv).
  destruct (I.convert (I.div _ _ _)) as [|l [|u]] ; try easy.
  simpl.
  apply Rle_trans with (1 := proj2 A).
  apply Rle_trans with (2 := proj2 H2).
  apply Req_le.
  apply Rmult_eq_compat_r.
  replace (2 * (k + 1)) with (2 * k + 2) by ring.
  now rewrite pow_add, <- Rsqr_pow2. }
generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)).
intros thre n.
replace 1%R with (Ai x 0) by (unfold Ai ; simpl ; field).
assert (H3le256 : (Z.abs 3 <= 256)%Z); [now compute|].
generalize i1_correct (I.fromZ_small_correct 3 H3le256).
fold i1 i3.
generalize i1 i3.
intros powi divi.
change 1%R with (pow x (2 * 0)).
change 3%Z with (Z.of_nat (2 * (0 + 1) + 1)).
rewrite <- INR_IZR_INZ.
replace (Ai x 0%nat - atanc x)%R with ((-1) * 1 * (atanc x - Ai x 0%nat))%R by ring.
change (-1 * 1)%R with (pow (-1) (0 + 1)).
rewrite <- (minus_diag n) at 2 4 7 9.
generalize (le_refl n).
generalize n at 1 4 6 7 9 11.
intros m.
revert powi divi.
induction m as [|m IHm] ; intros powi divi Hm Hpow Hdiv.
{ simpl atan_fast0_aux.
  specialize (Hexit (n - 0) _ _ Hpow Hdiv).
  now case F.cmp. }
simpl atan_fast0_aux.
set (powi' := I.mul prec powi (I.sqr prec xi)).
set (divi' := I.add prec divi i2).
specialize (IHm powi' divi').
specialize (Hexit (n - S m) _ _ Hpow Hdiv).
assert (H: forall p, n - S m + S p = n - m + p).
{ intros p.
  clear -Hm ; lia. }
cut (contains (I.convert (I.sub prec (I.div prec powi' divi)
        (atan_fast0_aux prec thre powi' (I.sqr prec xi) divi' m)))
      (Xreal ((-1) ^ (n - S m + 1) * (atanc x - Ai x (n - S m))))).
{ now case F.cmp. }
replace ((-1) ^ (n - S m + 1) * (atanc x - Ai x (n - S m)%nat))%R
  with ((-1) ^ (n - S m + 1) * (-1) ^ S (n - S m) * x ^ (2 * S (n - S m)) * / INR (2 * S (n - S m) + 1) - (((-1) * (-1) ^ (n - S m + 1)) * (atanc x - (Ai x (n - S m)%nat + ((-1) ^ S (n - S m) * / INR (2 * S (n - S m) + 1) * x ^ (2 * S (n - S m)))))))%R by ring.
assert (Hpow': contains (I.convert powi') (Xreal (x ^ (2 * (n - S m + 1))))).
{ replace (2 * (n - S m + 1)) with (2 * (n - S m) + 2) by ring.
  rewrite pow_add, <- Rsqr_pow2.
  apply J.mul_correct with (1 := Hpow).
  now apply J.sqr_correct. }
apply J.sub_correct.
{ rewrite <- pow_add.
  replace (n - S m + 1 + S (n - S m)) with (2 * (n - S m + 1)) by (clear -Hm ; omega).
  rewrite pow_1_even, Rmult_1_l.
  replace (S (n - S m)) with (n - S m + 1) by now rewrite plus_comm.
  apply J.div_correct.
  { exact Hpow'. }
  exact Hdiv. }
evar_last.
apply IHm.
now apply le_Sn_le.
rewrite <- (plus_0_r (n - m)), <- H.
exact Hpow'.
rewrite H, plus_0_r in Hdiv.
replace (2 * (n - m + 1) + 1) with (2 * (n - m) + 1 + 2) by ring.
rewrite plus_INR.
apply J.add_correct with (1 := Hdiv).
now apply I.fromZ_small_correct; compute.
change (Ai x (n - S m)%nat + (-1) ^ S (n - S m) * / INR (2 * S (n - S m) + 1) * x ^ (2 * S (n - S m)))%R
  with (Ai x (S (n - S m))).
change (-1 * (-1) ^ (n - S m + 1))%R with ((-1) ^ (S (n - S m + 1)))%R.
rewrite <- plus_Sn_m.
now rewrite -> minus_Sn_m.
Qed.

Lemma pi4_correct :
  forall prec, contains (I.convert (pi4 prec)) (Xreal (PI/4)).
Proof.
intros prec.
rewrite Machin_4_5_239.
unfold pi4, constant_getter.
set (n := Z.abs_nat _).
unfold pi4_seq, constant_generator.
generalize xH at 1.
induction n as [|n].
2: intros p ; apply IHn.
simpl.
intros p.
generalize (F.PtoP (p * 31)).
clear prec p.
intros prec.
assert (H: forall p, (2 <= p <= 256)%Z ->
    contains (I.convert (atan_fast0 prec (I.inv prec (I.fromZ_small p)))) (Xreal (atan (/ IZR p)))).
  intros p Hp.
  apply atan_fast0_correct.
  rewrite Rabs_pos_eq.
  apply Rle_Rinv_pos.
  apply Rlt_0_2.
  now apply IZR_le.
  apply Rlt_le, Rinv_0_lt_compat.
  apply IZR_lt.
  now apply Z.lt_le_trans with 2%Z.
  replace (Xreal (/ IZR p)) with (Xinv (Xreal (IZR p))).
  apply I.inv_correct.
  apply I.fromZ_small_correct.
    rewrite Z.abs_eq.
    apply Hp.
    now apply Z.le_trans with 2%Z.
  unfold Xinv'.
  simpl.
  case is_zero_spec ; try easy.
  intros H.
  apply (eq_IZR p 0) in H.
  elim Hp.
  now rewrite H.
unfold pi4_gen.
apply (I.sub_correct _ _ _ (Xreal _) (Xreal _)).
rewrite Rmult_comm.
replace (Xreal (atan (/ 5) * 4))
  with (Xreal (atan (/ 5)) * Xreal 2 * Xreal 2)%XR;
  [|simpl; apply f_equal; ring].
do 2 apply I.mul2_correct.
now apply (H 5%Z).
now apply (H 239%Z).
Qed.

Lemma atan_fastP_correct :
  forall prec x,
  F.toX x = Xreal (toR x) ->
  (0 <= toR x)%R ->
  contains (I.convert (atan_fastP prec x)) (Xreal (atan (toR x))).
Proof.
intros prec x Rx Bx.
unfold atan_fastP, c1_2, c1, c2.
rewrite F'.lt_correct with (2 := Rx).
2: {
  unfold F.toR.
  now fold c1; fold c1_2; rewrite c1_2_correct. }
unfold F.toR at 1.
fold c1; fold c1_2; rewrite c1_2_correct.
simpl Rlt_bool.
assert (Ix: contains (I.convert (I.bnd x x)) (Xreal (toR x))).
{ rewrite I.bnd_correct; [|apply I.valid_lb_real|apply I.valid_ub_real];
    rewrite Rx; [|easy..].
  split ; apply Rle_refl. }
case Rlt_bool_spec ; intros Bx'.
2: {
  apply atan_fast0_correct with (2 := Ix).
  now rewrite Rabs_pos_eq. }
rewrite F'.lt_correct with (2 := Rx);
  [|now unfold F.toR; rewrite F.fromZ_correct; [..|lia]].
unfold F.toR at 1.
rewrite F.fromZ_correct; [|lia].
simpl Rlt_bool.
case Rlt_bool_spec ; intros Bx'' ; cycle 1.
{ replace (Xreal (atan (toR x))) with (Xadd (Xreal (PI / 4)) (Xatan (Xreal ((toR x - 1) / (toR x + 1))))).
  { apply I.add_correct.
    { apply pi4_correct. }
    apply atan_fast0_correct.
    { apply Rabs_le.
      assert (Bx1: (0 < toR x + 1)%R) by (clear -Bx ; lra).
      split.
      { apply Rmult_le_reg_r with (1 := Bx1).
        unfold Rdiv.
        rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
        { apply Rminus_le.
          replace (- / 2 * (toR x + 1) - (toR x - 1))%R with (-3/2 * toR x + /2)%R by field.
          clear -Bx' ; lra. }
        now apply Rgt_not_eq. }
      apply Rmult_le_reg_r with (1 := Bx1).
      unfold Rdiv.
      rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
      { apply Rminus_le.
        replace (toR x - 1 - / 2 * (toR x + 1))%R with (/2 * toR x - 3/2)%R by field.
        lra. }
      now apply Rgt_not_eq. }
    apply J.div_correct.
    { apply J.sub_correct with (1 := Ix).
      apply i1_correct. }
    apply J.add_correct with (1 := Ix).
    apply i1_correct. }
  simpl.
  apply (f_equal Xreal).
  rewrite Rplus_comm.
  apply atan_plus_PI4.
  lra. }
replace (Xreal (atan (toR x))) with (Xsub (Xmul (Xreal (PI/4)) (Xreal 2)) (Xatan (Xreal (/ toR x)))).
{ apply I.sub_correct.
  { apply I.mul2_correct.
    apply pi4_correct. }
  apply atan_fast0_correct.
  { rewrite Rabs_pos_eq.
    { apply Rle_Rinv_pos.
      { apply Rlt_0_2. }
      now apply Rlt_le. }
    apply Rlt_le, Rinv_0_lt_compat.
    lra. }
  rewrite <- (Rmult_1_l (/ toR x)).
  apply J.div_correct with (2 := Ix).
  apply i1_correct. }
simpl.
apply f_equal.
rewrite atan_inv; lra.
Qed.

Lemma atan_fast_correct :
  forall prec x,
  contains (I.convert (atan_fast prec x)) (Xatan (F.toX x)).
Proof.
intros prec x.
unfold atan_fast.
rewrite F'.cmp_correct, F.zero_correct.
case_eq (F.toX x) ; simpl.
{ easy. }
intros r Hr.
case Rcompare_spec ; intros H.
{ (* neg *)
  rewrite <- (Ropp_involutive r).
  replace (Ropp r) with (toR (F.neg x)).
  { rewrite atan_opp.
    apply (I.neg_correct _ (Xreal _)).
    apply atan_fastP_correct.
    { unfold toR.
      now rewrite F'.neg_correct, Hr. }
    unfold toR.
    rewrite F'.neg_correct, Hr.
    simpl.
    rewrite <- Ropp_0.
    now apply Ropp_le_contravar, Rlt_le. }
  unfold toR.
  now rewrite F'.neg_correct, Hr. }
{ (* zero *)
  rewrite H, atan_0.
  simpl.
  rewrite F.zero_correct, F'.valid_lb_zero, F'.valid_ub_zero.
  split ; apply Rle_refl. }
(* pos *)
replace r with (toR x).
{ apply atan_fastP_correct.
  { unfold toR.
    now rewrite Hr. }
  unfold toR.
  rewrite Hr.
  now apply Rlt_le. }
unfold toR.
now rewrite Hr.
Qed.

(* 0 <= inputs *)
Fixpoint ln1p_fast0_aux prec thre powi xi divi (nb : nat) { struct nb } :=
  let npwi := I.mul prec powi xi in
  let vali := I.div prec npwi divi in
  match F'.cmp (I.upper vali) thre, nb with
  | Xlt, _
  | _, O => I.bnd F.zero (I.upper vali)
  | _, S n =>
    I.sub prec vali (ln1p_fast0_aux prec thre npwi xi (I.add prec divi i1) n)
  end.

(* 0 <= input <= 1/2 *)
Definition ln1p_fast0 prec xi :=
  let p := F.prec prec in
  let thre := F.scale c1 (F.ZtoS (Zneg p)) in
  let rem := ln1p_fast0_aux prec thre i1 xi i2 (nat_of_P p) in
  I.mul prec (I.sub prec i1 rem) xi.

(* 1 <= input *)
Definition ln_fast1P prec xi :=
  let th := c1_p_c1_8 in
  match F'.le' (I.upper xi) th with
  | true =>
    ln1p_fast0 prec (I.sub prec xi i1)
  | false =>
    let m := Digits.Zdigits2 (F.StoZ (F.mag (I.upper xi))) in
    let prec := F.incr_prec prec 10 in
    let fix reduce xi (nb : nat) {struct nb} :=
      match F'.le' (I.upper xi) th, nb with
      | true, _ => ln1p_fast0 prec (I.sub prec xi i1)
      | _, O => I.bnd F.zero F.nan
      | _, S n => I.mul2 prec (reduce (I.sqrt prec xi) n)
      end in
    reduce xi (8 + Z2nat m)
  end.

Definition ln_fast prec x :=
  match F.cmp x F.zero with
  | Xgt =>
    let xi := I.bnd x x in
    match F.cmp x c1 with
    | Xeq => I.zero
    | Xlt =>
      let m := Z.opp (F.StoZ (F.mag (F.sub_UP prec c1 x))) in
      let prec := F.incr_prec prec (Z2P m) in
      I.neg (ln_fast1P prec (I.div prec i1 xi))
    | Xgt => if F.real x then ln_fast1P prec xi else I.nai
    | Xund => I.nai
    end
  | _ => I.nai
  end.

Lemma ln1p_fast0_correct :
  forall prec xi x,
  (0 <= x <= /2)%R ->
  contains (I.convert xi) (Xreal x) ->
  contains (I.convert (ln1p_fast0 prec xi)) (Xreal (ln (1 + x))).
Proof.
intros prec xi x Bx Ix.
unfold ln1p_fast0.
rewrite ln1p_ln1pc.
replace (ln1pc x) with (1 - (1 - ln1pc x))%R by ring.
rewrite Rmult_comm.
apply J.mul_correct with (2 := Ix).
apply J.sub_correct.
apply i1_correct.
pose (Ai := fun x => sum_f_R0 (fun n : nat => ((-1) ^ n / INR (n + 1) * x ^ n)%R)).
assert (Hexit : forall k powi divi,
    contains (I.convert powi) (Xreal (x ^ k)) ->
    contains (I.convert divi) (Xreal (INR ((k + 1) + 1))) ->
    contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi xi) divi))))
      (Xreal ((-1) ^ (k + 1) * (ln1pc x - Ai x k)))).
{ intros k powi divi Hpow Hdiv.
  rewrite I.bnd_correct.
  2: { now apply I.valid_lb_real; rewrite F.zero_correct. }
  2: { apply I.valid_ub_upper.
    exists (x ^ k * x / INR (k + 1 + 1))%R.
    now apply J.div_correct; [apply J.mul_correct|]. }
  rewrite F.zero_correct, I.upper_correct.
  2: { exists (x ^ k * x / INR (k + 1 + 1))%R.
    now apply J.div_correct; [apply J.mul_correct|]. }
  assert (A: (0 <= (-1) ^ (k + 1) * (ln1pc x - Ai x k) <= x ^ (k + 1) / INR ((k + 1) + 1))%R).
  { replace (Ai x k) with (sum_f_R0 (tg_alt (fun n => / INR (n + 1) * x ^ n)%R) k).
    { unfold Rdiv.
      rewrite (Rmult_comm (x ^ _)).
      replace (k + 1) with (S k) by ring.
      apply alternated_series_ineq'.
      { apply Un_decreasing_ln1pc.
        lra. }
      { apply Un_cv_ln1pc.
        rewrite Rabs_pos_eq ; lra. }
      unfold ln1pc.
      case ln1pc_in_int ; intros Hx.
      { case ln1pc_exists ; simpl projT1 ; intros l C.
        exact C. }
      elim Hx.
      lra. }
    apply sum_eq.
    intros n _.
    unfold tg_alt.
    apply sym_eq, Rmult_assoc. }
  apply (conj (proj1 A)).
  assert (H1 := J.mul_correct prec _ _ _ _ Hpow Ix).
  assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv).
  destruct (I.convert (I.div _ _ _)) as [|l [|u]] ; try easy.
  apply Rle_trans with (1 := proj2 A).
  apply Rle_trans with (2 := proj2 H2).
  apply Req_le, Rmult_eq_compat_r.
  rewrite pow_add.
  simpl.
  now rewrite Rmult_1_r. }
generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)).
intros thre n.
replace 1%R with (Ai x 0) by (unfold Ai ; simpl ; field).
assert (H2le256 : (2 <= 256)%Z); [now compute|].
generalize i1_correct (I.fromZ_small_correct 2 H2le256).
fold i1 i2.
generalize i1 i2.
intros powi divi.
change 1%R with (pow x 0).
change 2%Z with (Z_of_nat ((0 + 1) + 1)).
rewrite <- INR_IZR_INZ.
replace (Ai x 0%nat - ln1pc x)%R with ((-1) * 1 * (ln1pc x - Ai x 0%nat))%R by ring.
change (-1 * 1)%R with (pow (-1) (0 + 1)).
rewrite <- (minus_diag n) at 1 2 5 7.
generalize (le_refl n).
generalize n at 1 4 6 7 9 11.
intros m.
revert powi divi.
induction m as [|m IHm] ; intros powi divi Hm Hpow Hdiv.
{ simpl.
  cut (contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi xi) divi))))
        (Xreal ((-1) ^ (n - 0 + 1) * (ln1pc x - Ai x (n - 0))))).
  { now destruct F'.cmp. }
  now apply Hexit. }
simpl ln1p_fast0_aux.
set (powi' := I.mul prec powi xi).
set (divi' := I.add prec divi i1).
specialize (IHm powi' divi').
assert (H: forall p, n - S m + S p = n - m + p).
{ intros p.
  clear -Hm ; omega. }
cut (contains (I.convert (I.sub prec (I.div prec powi' divi) (ln1p_fast0_aux prec thre powi' xi divi' m)))
    (Xreal ((-1) ^ (n - S m + 1) * (ln1pc x - Ai x (n - S m))))).
{ case F'.cmp ; try easy.
  intros H'.
  now apply Hexit. }
replace ((-1) ^ (n - S m + 1) * (ln1pc x - Ai x (n - S m)%nat))%R
  with ((-1) ^ (n - S m + 1) * (-1) ^ S (n - S m) * x ^ (S (n - S m)) * / INR (S (n - S m) + 1) - (((-1) * (-1) ^ (n - S m + 1)) * (ln1pc x - (Ai x (n - S m)%nat + ((-1) ^ S (n - S m) * / INR (S (n - S m) + 1) * x ^ (S (n - S m)))))))%R by ring.
apply J.sub_correct.
{ rewrite <- pow_add.
  replace (n - S m + 1 + S (n - S m)) with (2 * (n - S m + 1)) by (clear -Hm ; omega).
  replace (S (n - S m)) with (n - S m + 1) by now rewrite plus_comm.
  apply J.div_correct with (2 := Hdiv).
  rewrite pow_1_even, Rmult_1_l.
  rewrite pow_add, pow_1.
  now apply J.mul_correct. }
evar_last.
apply IHm.
clear -Hm ; lia.
rewrite <- (plus_0_r (n - m)), <- H.
rewrite pow_add, pow_1.
now apply J.mul_correct.
rewrite <- H.
replace (_ + 2 + 1) with (n - S m + 1 + 1 + 1) by ring.
rewrite plus_INR.
apply J.add_correct with (1 := Hdiv).
apply i1_correct.
change (Ai x (n - S m)%nat + (-1) ^ S (n - S m) * / INR (S (n - S m) + 1) * x ^ (S (n - S m)))%R
  with (Ai x (S (n - S m))).
change (-1 * (-1) ^ (n - S m + 1))%R with ((-1) ^ (S (n - S m + 1)))%R.
rewrite <- plus_Sn_m.
now rewrite -> minus_Sn_m.
Qed.

Lemma ln_fast1P_correct :
  forall prec xi x,
  (1 <= x)%R ->
  contains (I.convert xi) (Xreal x) ->
  contains (I.convert (ln_fast1P prec xi)) (Xreal (ln x)).
Proof.
set (thre := c1_p_c1_8).
assert (H: forall prec xi x,
    (1 <= x)%R ->
    (F'.le' (I.upper xi) thre = true) ->
    contains (I.convert xi) (Xreal x) ->
    contains (I.convert (ln1p_fast0 prec (I.sub prec xi i1))) (Xreal (ln x))).
{ intros prec xi x Hx Hxu Ix.
  replace x with (1 + (x - 1))%R by ring.
  apply ln1p_fast0_correct.
  { split. lra.
    apply F'.le'_correct in Hxu.
    rewrite I.upper_correct in Hxu; [|now exists x].
    destruct (I.convert xi) as [|l [|u]] ; try easy.
    revert Hxu.
    simpl.
    unfold thre, c1_p_c1_8, c1.
    elim (F.add_DN_correct (F.PtoP 52) F.one c1_8).
    2: now rewrite F'.valid_lb_one.
    2: now rewrite F'.valid_lb_real; [|rewrite F.real_correct, c1_8_correct].
    intros Va.
    case (F.toX _); [easy|intro r].
    rewrite c1_8_correct, F.one_correct.
    simpl.
    intro Hr.
    apply Ropp_le_cancel in Hr.
    intro H.
    assert (H' : (u <= 1 + / 256)%R).
    { now apply (Rle_trans _ _ _ H). }
    generalize (proj2 Ix).
    lra. }
  apply J.sub_correct with (1 := Ix).
  apply i1_correct. }
intros prec xi x Hx Ix.
unfold ln_fast1P.
fold thre.
case_eq (F'.le' (I.upper xi) thre) ; intros Hxu.
{ now apply H. }
clear Hxu.
set (m := Zdigits2 (F.StoZ (F.mag (I.upper xi)))).
clearbody m.
generalize (F.incr_prec prec 10).
clear prec; intro prec.
generalize (8 + Z2nat m).
intro nb.
revert xi x Hx Ix.
induction nb as [|nb] ; intros xi x Hx Ix.
{ (* nb = 0 *)
  simpl.
  case_eq (F'.le' (I.upper xi) thre) ; intros Hxu.
  { now apply H. }
  simpl.
  rewrite F.zero_correct, F'.nan_correct.
  rewrite F'.valid_lb_zero, F'.valid_ub_nan.
  refine (conj _ I).
  destruct (Rlt_dec 1 x) as [Hx'|Hx'].
  { rewrite <- ln_1.
    apply Rlt_le, ln_increasing.
    { exact Rlt_0_1. }
    exact Hx'. }
  replace x with 1%R by lra.
  rewrite ln_1.
  apply Rle_refl. }
(* nb > 0 *)
case_eq (F'.le' (I.upper xi) thre) ; intros Hxu.
{ now apply H. }
clear H Hxu.
replace (ln x) with (ln (sqrt x) * 2)%R.
{ change (Xreal (ln (sqrt x) * 2)) with (Xmul (Xreal (ln (sqrt x))) (Xreal (bpow radix2 1))).
  apply I.mul2_correct.
  apply IHnb.
  { clear IHnb.
    rewrite <- sqrt_1.
    now apply sqrt_le_1_alt. }
  now apply J.sqrt_correct. }
rewrite <- (sqrt_sqrt x) at 2 by lra.
assert (0 < sqrt x)%R.
{ apply sqrt_lt_R0.
  lra. }
rewrite ln_mult by easy.
ring.
Qed.

Theorem ln_fast_correct :
  forall prec x,
  contains (I.convert (ln_fast prec x)) (Xln (F.toX x)).
Proof.
intros prec x.
unfold ln_fast.
rewrite F.cmp_correct, F.zero_correct, F'.classify_zero.
generalize (F.classify_correct x); rewrite F.real_correct.
case_eq (F.classify x); intro Cx; [|easy..|];
  [case_eq (F.toX x); [easy|]; intros rx Hrx _
  |case_eq (F.toX x); [|easy]; intros Hx _].
{ (* x real *)
  unfold Xcmp, c1.
  case Rcompare_spec; intro Hrx0; [easy..|].
  rewrite F.cmp_correct, Cx, Hrx.
  generalize (F.classify_correct F.one).
  rewrite F.real_correct, F.one_correct.
  case F.classify; [|easy..]; intros _.
  unfold Xcmp.
  case Rcompare_spec.
  { (* x < 1 *)
    intros Hx'.
    generalize (F.incr_prec prec (Z2P (Z.opp (F.StoZ (F.mag (F.sub_UP prec (F.fromZ 1) x)))))).
    intros prec'.
    rewrite <- (Rinv_involutive rx); [|lra].
    unfold Xln, Xln'.
    rewrite ln_Rinv; [|now apply Rinv_0_lt_compat].
    rewrite is_positive_true; [|now do 2 apply Rinv_0_lt_compat].
    apply J.neg_correct.
    apply ln_fast1P_correct.
    { rewrite <- Rinv_1.
      apply Rinv_le.
      { exact Hrx0. }
      now apply Rlt_le. }
    rewrite <- (Rmult_1_l (/ _)).
    apply J.div_correct.
    { apply i1_correct. }
    rewrite I.bnd_correct, Hrx.
    { split ; apply Rle_refl. }
    { now apply I.valid_lb_real; rewrite Hrx. }
    now apply I.valid_ub_real; rewrite Hrx. }
  { (* x = 1 *)
    intros ->.
    unfold Xln, Xln'.
    rewrite is_positive_true; [|lra].
    rewrite I.zero_correct, ln_1.
    split ; apply Rle_refl. }
  (* x > 1 *)
  intros Hx'.
  unfold Xln, Xln'.
  rewrite is_positive_true; [|lra].
  apply ln_fast1P_correct.
  { now apply Rlt_le. }
  rewrite I.bnd_correct, Hrx.
  { split ; apply Rle_refl. }
  { now apply I.valid_lb_real; rewrite Hrx. }
  now apply I.valid_ub_real; rewrite Hrx. }
(* x = +oo *)
rewrite F.cmp_correct, Cx.
unfold c1.
generalize (F.classify_correct F.one).
rewrite F.real_correct, F.one_correct.
now case F.classify.
Qed.

(*
(* 0 <= inputs *)
Fixpoint umc_fast0_aux prec thre powl powu sqrl sqru fact div (nb : nat) { struct nb } :=
  let npwu := F.mul_UP prec powu sqru in
  let valu := F.div_UP prec npwu div in
  match F.cmp valu thre, nb with
  | Xlt, _
  | _, O => I.bnd F.zero valu
  | _, S n =>
    let npwl := F.mul_DN prec powl sqrl in
    let vall := F.div_DN prec npwl div in
    let one := F.fromZ 1 in
    let nfact := F.add_exact fact (F.add_exact one one) in
    let ndiv := F.mul_exact div (F.mul_exact fact (F.add_exact fact one)) in
    I.sub prec (I.bnd vall valu)
      (umc_fast0_aux prec thre npwl npwu sqrl sqru nfact ndiv n)
  end.

Definition umc_fast0 prec x :=
  let x2l := F.mul_DN prec x x in
  let x2u := F.mul_UP prec x x in
  let c1 := F.fromZ 1 in
  let p := F.prec prec in
  let thre := F.scale c1 (F.ZtoS (Zneg p)) in
  I.scale2
   (I.mul prec
     (I.bnd x2l x2u)
     (I.sub prec
       (I.bnd c1 c1)
       (umc_fast0_aux prec thre c1 c1 x2l x2u (F.fromZ 5) (F.fromZ 12) (nat_of_P p))))
   (F.ZtoS (-1)%Z).

Definition umc_reduce prec x :=
  let c1 := F.fromZ 1 in
  let th := F.scale2 c1 (F.ZtoS (-4)%Z) in
  (*let prec := F.incr_prec prec 1 in*)
  let c2 := F.fromZ 2 in
  let i2 := I.bnd c2 c2 in
  let s1 := F.ZtoS 1 in
  let sm1 := F.ZtoS (-1)%Z in
  let fix reduce x (nb : nat) {struct nb} :=
    match le x th, nb with
    | true, _ => umc_fast0 prec x
    | _, O => umc_fast0 prec x
    | _, S n =>
      (*match reduce (F.scale2 x sm1) n with
      | Ibnd yl yu => I.scale2 (Ibnd (F.mul_DN prec yl (F.sub_DN prec c2 yl)) (F.mul_UP prec yu (F.sub_UP prec c2 yu))) s1
      | Inan => Inan
      end*)
      let u := reduce (F.scale2 x sm1) n in
      I.scale2 (I.mul prec u (I.sub prec i2 u)) s1
    end in
  reduce x 10.

Definition cos_fast0 prec x :=
  let c1 := F.fromZ 1 in
  I.sub prec (I.bnd c1 c1) (umc_reduce prec x).
*)

(* 0 <= inputs *)
Fixpoint cos_fast0_aux prec thre powi sqri facti divi (nb : nat) { struct nb } :=
  let npwi := I.mul prec powi sqri in
  let vali := I.div prec npwi divi in
  match F'.cmp (I.upper vali) thre, nb with
  | Xlt, _
  | _, O => I.bnd F.zero (I.upper vali)
  | _, S n =>
    let nfacti := I.add prec facti i2 in
    let ndivi := I.mul prec divi (I.mul prec facti (I.add prec facti i1)) in
    I.sub prec vali (cos_fast0_aux prec thre npwi sqri nfacti ndivi n)
  end.

(* -1/2 <= input <= 1/2 *)
Definition cos_fast0 prec x :=
  let xi := I.bnd x x in
  let x2i := I.sqr prec xi in
  let p := F.prec prec in
  let thre := F.scale c1 (F.ZtoS (Zneg p)) in
  let rem := cos_fast0_aux prec thre i1 x2i i3 i2 (nat_of_P p) in
  I.sub prec i1 rem.

(* 0 <= input *)
Definition sin_cos_reduce prec x :=
  let th := c1_2 in
  let fix reduce x (nb : nat) {struct nb} :=
    match F'.le x th, nb with
    | true, _ => (Gt, cos_fast0 prec x)
    | _, O => (Eq, I.bnd cm1 c1)
    | _, S n =>
      match reduce (F.div2 x) n with
      | (s, c) =>
       (match s, I.sign_large c with
        | Lt, Xgt => Lt
        | Lt, Xlt => Gt
        | Lt, _ => Eq
        | Gt, Xlt => Lt
        | Gt, Xgt => Gt
        | Gt, _ => Eq
        | _, _ => s
        end,
        I.sub prec (I.mul2 prec (I.sqr prec c)) i1)
      end
    end in
  reduce x.

Lemma cos_fast0_correct :
  forall prec x,
  F.toX x = Xreal (toR x) ->
  (Rabs (toR x) <= /2)%R ->
  contains (I.convert (cos_fast0 prec x)) (Xreal (cos (toR x))).
Proof.
intros prec x Rx Bx.
unfold cos_fast0.
replace (cos (toR x)) with (1 - (1 - cos (toR x)))%R by ring.
apply J.sub_correct.
{ apply i1_correct. }
set (xi := I.bnd x x).
assert (Ix: contains (I.convert xi) (Xreal (toR x))).
{ unfold xi.
  rewrite I.bnd_correct, Rx.
  2: now apply I.valid_lb_real; rewrite Rx.
  2: now apply I.valid_ub_real; rewrite Rx.
  split ; apply Rle_refl. }
set (x2i := I.sqr prec xi).
assert (Hexit: forall k powi divi,
    contains (I.convert powi) (Xreal (toR x ^ (2 * k))) ->
    contains (I.convert divi) (Xreal (INR (fact (2 * (k + 1))))) ->
    contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi x2i) divi))))
      (Xreal ((-1) ^ (k + 1) * (cos (toR x) - A1 (toR x) k)))).
{ intros k powi facti Hpow Hdiv.
  assert (Hne : not_empty (I.convert (I.div prec (I.mul prec powi x2i) facti))).
  { exists ((F.toR x ^ (2 * k) * (F.toR x * F.toR x)) / INR (fact (2 * (k + 1))))%R.
    now apply J.div_correct; [apply J.mul_correct; [|apply J.sqr_correct]|]. }
  rewrite I.bnd_correct.
  2: now apply I.valid_lb_real; rewrite F.zero_correct.
  2: now apply I.valid_ub_upper.
  rewrite F.zero_correct, I.upper_correct; [|easy].
  assert (A: (0 <= (-1) ^ (k + 1) * (cos (toR x) - A1 (toR x) k) <= toR x ^ (2 * (k + 1)) / INR (fact (2 * (k + 1))))%R).
  { replace (A1 (toR x) k) with (sum_f_R0 (tg_alt (fun n => / INR (fact (2 * n)) * toR x ^ (2 * n))%R) k).
    { unfold Rdiv.
      rewrite (Rmult_comm (toR x ^ _)).
      replace (k + 1) with (S k) by ring.
      apply alternated_series_ineq'.
      { apply Un_decreasing_cos.
        lra. }
      { apply (Un_cv_subseq (fun n => (/ INR (fact n) * toR x ^ n)%R)).
        { clear ; intros n ; omega. }
        eapply Un_cv_ext.
        { intros n.
          apply Rmult_comm. }
        apply cv_speed_pow_fact. }
      generalize (A1_cvg (toR x)).
      apply Un_cv_ext.
      intros n.
      unfold A1, tg_alt.
      apply sum_eq.
      intros i _.
      apply Rmult_assoc. }
    unfold A1, tg_alt.
    apply sum_eq.
    intros i _.
    apply sym_eq, Rmult_assoc. }
  apply (conj (proj1 A)).
  assert (Hx2 := J.sqr_correct prec _ _ Ix).
  assert (H1 := J.mul_correct prec _ _ _ _ Hpow Hx2).
  assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv).
  destruct (I.convert (I.div _ _ _)) as [|l [|u]] ; try easy.
  apply Rle_trans with (1 := proj2 A).
  apply Rle_trans with (2 := proj2 H2).
  apply Req_le, Rmult_eq_compat_r.
  replace (2 * (k + 1)) with (2 * k + 2) by ring.
  rewrite pow_add.
  now rewrite Rsqr_pow2. }
generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)).
intros thre n.
replace 1%R with (A1 (toR x) 0) by (unfold A1 ; simpl ; field).
assert (H2le256 : (Z.abs 2 <= 256)%Z); [now compute|].
assert (H3le256 : (Z.abs 2 <= 256)%Z); [now compute|].
generalize i1_correct (I.fromZ_small_correct 2 H2le256) (I.fromZ_small_correct 3 H3le256).
fold i1 i2 i3.
generalize i1 i2 i3.
intros powi divi facti.
change 1%R with (pow (toR x) (2 * 0)).
change 3%Z with (Z_of_nat (2 * (0 + 1) + 1)).
change 2%Z with (Z_of_nat (fact (2 * (0 + 1)))).
rewrite <- 2!INR_IZR_INZ.
replace (A1 (toR x) 0 - cos (toR x))%R with ((-1) * 1 * (cos (toR x) - A1 (toR x) 0))%R by ring.
change (-1 * 1)%R with (pow (-1) (0 + 1)).
rewrite <- (minus_diag n) at 2 4 7 10 12.
generalize (le_refl n).
generalize n at 1 4 6 8 9 11 13.
intros m.
revert powi divi facti.
induction m as [|m IHm] ; intros powi divi facti Hm Hpow Hdiv Hfact.
{ simpl cos_fast0_aux.
  cut (contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi x2i) divi))))
        (Xreal ((-1) ^ (n - 0 + 1) * (cos (toR x) - A1 (toR x) (n - 0))))).
  { now destruct F'.cmp. }
  now apply Hexit. }
simpl cos_fast0_aux.
set (powi' := I.mul prec powi x2i).
set (divi' := I.mul prec divi (I.mul prec facti (I.add prec facti i1))).
set (facti' := I.add prec facti i2).
specialize (IHm powi' divi' facti').
assert (H: forall p, n - S m + S p = n - m + p).
{ intros p.
  clear -Hm ; lia. }
cut (contains (I.convert (I.sub prec (I.div prec powi' divi)
           (cos_fast0_aux prec thre powi' x2i facti' divi' m)))
    (Xreal ((-1) ^ (n - S m + 1) * (cos (toR x) - A1 (toR x) (n - S m))))).
{ case F'.cmp ; try easy.
  intros H'.
  now apply Hexit. }
replace ((-1) ^ (n - S m + 1) * (cos (toR x) - A1 (toR x) (n - S m)))%R
  with ((-1) ^ (n - S m + 1) * (-1) ^ S (n - S m) * (toR x) ^ (2 * S (n - S m)) * / INR (fact (2 * S (n - S m))) - (((-1) * (-1) ^ (n - S m + 1)) * (cos (toR x) - (A1 (toR x) (n - S m) + ((-1) ^ S (n - S m) * / INR (fact (2 * S (n - S m))) * (toR x) ^ (2 * S (n - S m)))))))%R by ring.
assert (Hpow': contains (I.convert powi') (Xreal (toR x ^ (2 * (n - S m + 1))))).
{ replace (2 * (n - S m + 1)) with (2 * (n - S m) + 2) by ring.
  rewrite pow_add, <- Rsqr_pow2.
  apply J.mul_correct with (1 := Hpow).
  now apply J.sqr_correct. }
apply J.sub_correct.
{ rewrite <- pow_add.
  replace (n - S m + 1 + S (n - S m)) with (2 * (n - S m + 1)) by (clear -Hm ; omega).
  rewrite pow_1_even, Rmult_1_l.
  replace (S (n - S m)) with (n - S m + 1) by now rewrite plus_comm.
  now apply J.div_correct. }
evar_last.
apply IHm.
clear -Hm ; lia.
now rewrite <- (plus_0_r (n - m)), <- H.
rewrite <- H.
replace (2 * (n - S m + 2)) with (S (S (2 * (n - S m + 1)))) by ring.
rewrite 2!fact_simpl.
rewrite 2!mult_INR, <- Rmult_assoc, Rmult_comm.
apply J.mul_correct with (1 := Hdiv).
rewrite Rmult_comm.
apply J.mul_correct.
now rewrite <- Nat.add_1_r.
rewrite <- 2!Nat.add_1_r.
rewrite plus_INR.
apply J.add_correct with (1 := Hfact).
apply i1_correct.
rewrite <- H.
replace (2 * (n - S m + 2) + 1) with (2 * (n - S m + 1) + 1 + 2) by ring.
rewrite plus_INR.
apply J.add_correct with (1 := Hfact).
now apply I.fromZ_small_correct; compute.
apply f_equal.
change (A1 (toR x) (n - S m) + (-1) ^ S (n - S m) * / INR (fact (2 * S (n - S m))) * toR x ^ (2 * S (n - S m)))%R
  with (A1 (toR x) (S (n - S m))).
change (-1 * (-1) ^ (n - S m + 1))%R with ((-1) ^ (S (n - S m + 1)))%R.
rewrite <- plus_Sn_m.
now rewrite -> minus_Sn_m.
Qed.

Lemma sin_cos_reduce_correct :
  forall prec nb x,
  F.toX x = Xreal (toR x) ->
  (0 <= toR x)%R ->
  match sin_cos_reduce prec x nb with
  | (ss, ci) =>
    contains (I.convert ci) (Xreal (cos (toR x))) /\
    match ss with
    | Lt => (sin (toR x) <= 0)%R
    | Gt => (0 <= sin (toR x))%R
    | _ => True
    end
  end.
Proof.
intros prec.
assert (forall x, F.toX x = Xreal (toR x) -> (0 <= toR x)%R ->
        F'.le x c1_2 = true ->
        contains (I.convert (cos_fast0 prec x)) (Xreal (cos (toR x))) /\
        (0 <= sin (toR x))%R).
{ intros x Hxr Hx0 H.
  unfold c1_2, c1 in H.
  assert (toR x <= /2)%R.
  { rewrite F'.le_correct with (1 := Hxr) in H.
    2: {
      unfold F.toR.
      now fold c1; fold c1_2; rewrite c1_2_correct. }
    revert H.
    case Rle_bool_spec ; try easy.
    unfold F.toR.
    now fold c1; fold c1_2; rewrite c1_2_correct. }
  split.
  { apply cos_fast0_correct with (1 := Hxr).
    now rewrite Rabs_right; [|apply Rle_ge]. }
  apply sin_ge_0 with (1 := Hx0).
  (*   x <= pi *)
  apply Rle_trans with (1 := H0).
  apply Rlt_le.
  apply Rmult_lt_reg_l with (/4)%R.
  { apply Rinv_0_lt_compat.
    now apply IZR_lt. }
  rewrite <- (Rmult_comm PI).
  apply Rlt_le_trans with (2 := proj1 (PI_ineq 0)).
  unfold tg_alt, PI_tg.
  simpl.
  lra. }
induction nb ; intros x Hxr Hx.
{ (* nb = 0 *)
  simpl.
  case_eq (F'.le x c1_2).
  { intros.
    exact (H x Hxr Hx H0). }
  intros _.
  simpl.
  unfold c1, cm1.
  rewrite F'.neg_correct.
  rewrite F'.valid_lb_neg.
  rewrite F'.valid_ub_one.
  rewrite F.one_correct.
  refine (conj _ I).
  simpl.
  apply COS_bound. }
(* nb > 0 *)
simpl.
case_eq (F'.le x c1_2).
{ intros.
  exact (H x Hxr Hx H0). }
rewrite F'.le_correct; try (unfold F.toR; rewrite c1_2_correct); [simpl|easy..].
intros Hxhalf.
refine (_ (IHnb (F.div2 x) _ _)).
{ destruct (sin_cos_reduce prec (F.div2 x) nb) as (ss, ci).
  fold (F.toR x).
  replace (F.toR x) with (2 * (toR (F.div2 x)))%R.
  { generalize (toR (F.div2 x)).
    revert Hxr Hxhalf; clear; intros Hxr Hxhalf.
    intros hx (Hc, Hs).
    split.
    { (* - cos *)
      replace (Xreal (cos (2 * hx))) with (Xsub (Xmul (Xsqr (Xreal (cos hx))) (Xreal 2)) (Xreal 1)).
      { apply I.sub_correct.
        { apply I.mul2_correct.
          apply I.sqr_correct.
          exact Hc. }
        apply i1_correct. }
      simpl.
      apply f_equal.
      rewrite cos_2a_cos.
      unfold Rsqr.
      ring. }
    (* - sin *)
    rewrite sin_2a.
    destruct ss.
    { exact I. }
    { change (cos hx) with (proj_val (Xreal (cos hx))).
      generalize (I.sign_large_correct ci).
      case (I.sign_large ci) ; intros ; try exact I.
      { apply Rmult_le_neg_neg.
        { apply Rmult_le_pos_neg.
          { now apply IZR_le. }
          exact Hs. }
        exact (proj2 (H _ Hc)). }
      apply Rmult_le_neg_pos.
      { apply Rmult_le_pos_neg.
        { now apply IZR_le. }
        exact Hs. }
      exact (proj2 (H _ Hc)). }
    change (cos hx) with (proj_val (Xreal (cos hx))).
    generalize (I.sign_large_correct ci).
    case (I.sign_large ci) ; intros ; try exact I.
    { apply Rmult_le_pos_neg.
      { apply Rmult_le_pos_pos.
        { now apply IZR_le. }
        exact Hs. }
      exact (proj2 (H _ Hc)). }
    apply Rmult_le_pos_pos.
    { apply Rmult_le_pos_pos.
      { now apply IZR_le. }
      exact Hs. }
    exact (proj2 (H _ Hc)). }
  unfold toR; rewrite F.div2_correct; [|easy|].
  { rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy].
    rewrite Hxr; simpl; lra. }
  rewrite (Rabs_pos_eq _ Hx).
  revert Hxhalf; case Rle_bool_spec; [easy|]; fold (F.toR x); lra. }
{ unfold toR; rewrite F.div2_correct; [|easy|].
  { rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy].
    now rewrite Hxr. }
  rewrite (Rabs_pos_eq _ Hx).
  revert Hxhalf; case Rle_bool_spec; [easy|]; fold (F.toR x); lra. }
unfold toR; rewrite F.div2_correct; [|easy|].
{ rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy].
  rewrite Hxr; simpl; lra. }
rewrite (Rabs_pos_eq _ Hx).
revert Hxhalf; case Rle_bool_spec; [easy|]; fold (F.toR x); lra.
Qed.

(* 0 <= input *)
Definition cos_fastP prec x :=
  let th := c1_2 in
  match F'.le' x th with
  | true => cos_fast0 prec x
  | _ =>
    let m := F.StoZ (F.mag x) in
    let prec := F.incr_prec prec (Z2P (m + 6)) in
    snd (sin_cos_reduce prec x (S (Z2nat m)))
  end.

Lemma cos_fastP_correct :
  forall prec x,
  F.toX x = Xreal (toR x) ->
  (0 <= toR x)%R ->
  contains (I.convert (cos_fastP prec x)) (Xreal (cos (toR x))).
Proof.
intros prec x Hxr Hx0.
unfold cos_fastP.
case_eq (F'.le' x c1_2) ; intros H.
{ apply cos_fast0_correct.
  { easy. }
  rewrite Rabs_pos_eq with (1 := Hx0).
  apply F'.le'_correct in H.
  revert H.
  now rewrite c1_2_correct, Hxr. }
generalize (S (Z2nat (F.StoZ (F.mag x)))) (F.incr_prec prec (Z2P (F.StoZ (F.mag x) + 6))).
intros nb prec'.
generalize (sin_cos_reduce_correct prec' nb x Hxr Hx0).
destruct sin_cos_reduce as [ss ci].
apply proj1.
Qed.

Definition cos_fast prec x :=
  match F'.cmp x F.zero with
  | Xeq => i1
  | Xlt => cos_fastP prec (F.neg x)
  | Xgt => cos_fastP prec x
  | Xund => I.nai
  end.

Theorem cos_fast_correct :
  forall prec x,
  contains (I.convert (cos_fast prec x)) (Xcos (F.toX x)).
Proof.
intros prec x.
unfold cos_fast.
rewrite F'.cmp_correct, F.zero_correct.
case_eq (F.toX x).
{ easy. }
intros r Hr.
simpl.
case Rcompare_spec ; intros H.
{ (* neg *)
  replace r with (- toR (F.neg x))%R.
  { rewrite cos_neg.
    apply cos_fastP_correct.
    { unfold toR.
      now rewrite F'.neg_correct, Hr. }
    unfold toR.
    rewrite F'.neg_correct, Hr.
    rewrite <- Ropp_0.
    apply Ropp_le_contravar.
    now apply Rlt_le. }
  unfold toR.
  rewrite F'.neg_correct, Hr.
  apply Ropp_involutive. }
{ (* zero *)
  rewrite H, cos_0.
  apply i1_correct. }
(* pos *)
replace r with (toR x).
{ apply cos_fastP_correct.
  { unfold toR.
    now rewrite Hr. }
  unfold toR.
  rewrite Hr.
  now apply Rlt_le. }
unfold toR.
now rewrite Hr.
Qed.

(* -1/2 <= input <= 1/2 *)
Definition sin_fast0 prec x :=
  let xi := I.bnd x x in
  let x2i := I.sqr prec xi in
  let p := F.prec prec in
  let thre := F.scale c1 (F.ZtoS (Zneg p)) in
  let rem := cos_fast0_aux prec thre i1 x2i i4 i6 (nat_of_P p) in
  I.mul prec (I.sub prec i1 rem) xi.

Lemma sin_fast0_correct :
  forall prec x,
  F.toX x = Xreal (toR x) ->
  (Rabs (toR x) <= /2)%R ->
  contains (I.convert (sin_fast0 prec x)) (Xreal (sin (toR x))).
Proof.
intros prec x Rx Bx.
unfold sin_fast0.
rewrite sin_sinc.
replace (sinc (toR x)) with (1 - (1 - sinc (toR x)))%R by ring.
rewrite Rmult_comm.
set (xi := I.bnd x x).
assert (Ix: contains (I.convert xi) (Xreal (toR x))).
{ unfold xi.
  rewrite I.bnd_correct, Rx.
  2: now apply I.valid_lb_real; rewrite Rx.
  2: now apply I.valid_ub_real; rewrite Rx.
  split ; apply Rle_refl. }
apply J.mul_correct.
{ apply J.sub_correct.
  { apply i1_correct. }
  set (x2i := I.sqr prec xi).
  pose (Si := fun x => sum_f_R0 (fun n : nat => ((-1) ^ n / INR (fact (2 * n + 1)) * x ^ (2 * n))%R)).
  assert (Hexit : forall k powi divi,
    contains (I.convert powi) (Xreal (toR x ^ (2 * k))) ->
    contains (I.convert divi) (Xreal (INR (fact (2 * (k + 1) + 1)))) ->
    contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi x2i) divi))))
      (Xreal ((-1) ^ (k + 1) * (sinc (toR x) - Si (toR x) k)))).
  { intros k powi divi Hpow Hdiv.
    assert (Hne : not_empty (I.convert (I.div prec (I.mul prec powi x2i) divi))).
    { exists ((F.toR x ^ (2 * k) * (F.toR x * F.toR x)) / INR (fact (2 * (k + 1) + 1)))%R.
      now apply J.div_correct; [apply J.mul_correct; [|apply J.sqr_correct]|]. }
    rewrite I.bnd_correct.
    2: now apply I.valid_lb_real; rewrite F.zero_correct.
    2: now apply I.valid_ub_upper.
    rewrite F.zero_correct, I.upper_correct; [|easy].
    assert (A: (0 <= (-1) ^ (k + 1) * (sinc (toR x) - Si (toR x) k) <= toR x ^ (2 * (k + 1)) / INR (fact (2 * (k + 1) + 1)))%R).
    { replace (Si (toR x) k) with (sum_f_R0 (tg_alt (fun n => / INR (fact (2 * n + 1)) * toR x ^ (2 * n))%R) k).
      { unfold Rdiv.
        rewrite (Rmult_comm (toR x ^ _)).
        replace (k + 1) with (S k) by ring.
        apply alternated_series_ineq'.
        { apply Un_decreasing_sinc.
          lra. }
        { destruct (Req_dec (toR x) 0) as [Zx|Zx].
          { rewrite Zx.
            intros eps Heps.
            exists 1%nat.
            intros n Hn.
            rewrite pow_ne_zero by (clear -Hn ; omega).
            unfold R_dist, Rminus.
            now rewrite Rmult_0_r, Rplus_opp_r, Rabs_R0. }
          rewrite <- (Rmult_0_l (/toR x)).
          apply Un_cv_ext with (fun n : nat => (/ INR (fact (2 * n + 1)) * toR x ^ (2 * n + 1) * / toR x)%R).
          { intros n.
            rewrite pow_add.
            field.
            split.
            { apply Rgt_not_eq.
              apply INR_fact_lt_0. }
            exact Zx. }
          apply CV_mult.
          { apply (Un_cv_subseq (fun n => (/ INR (fact n) * toR x ^ n)%R)).
            { clear ; intros n ; omega. }
            eapply Un_cv_ext.
            { intros n.
              apply Rmult_comm. }
            apply cv_speed_pow_fact. }
          intros eps Heps.
          exists 0.
          intros _ _.
          unfold R_dist, Rminus.
          now rewrite Rplus_opp_r, Rabs_R0. }
        unfold sinc.
        case exist_sin.
        intro l.
        change (projT1 _) with l.
        apply Un_cv_ext.
        intros n.
        apply sum_eq.
        intros i _.
        unfold sin_n, tg_alt.
        rewrite pow_Rsqr.
        apply Rmult_assoc. }
      unfold Si, tg_alt.
      apply sum_eq.
      intros i _.
      apply sym_eq, Rmult_assoc. }
    apply (conj (proj1 A)).
    assert (Hx2 := J.sqr_correct prec _ _ Ix).
    assert (H1 := J.mul_correct prec _ _ _ _ Hpow Hx2).
    assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv).
    destruct (I.convert (I.div prec _ _)) as [|l [|u]] ; try easy.
    apply Rle_trans with (1 := proj2 A).
    apply Rle_trans with (2 := proj2 H2).
    apply Req_le, Rmult_eq_compat_r.
    replace (2 * (k + 1)) with (2 * k + 2) by ring.
    now rewrite pow_add, Rsqr_pow2. }
  generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)).
  intros thre n.
  replace 1%R with (Si (toR x) 0) by (unfold Si ; simpl ; field).
  assert (H6le256 : (Z.abs 6 <= 256)%Z); [now compute|].
  assert (H4le256 : (Z.abs 4 <= 256)%Z); [now compute|].
  generalize i1_correct (I.fromZ_small_correct 6 H6le256) (I.fromZ_small_correct 4 H4le256).
  fold i1 i6 i4.
  generalize i1 i6 i4.
  intros powi divi facti.
  change 1%R with (pow (toR x) (2 * 0)).
  change 4%Z with (Z_of_nat (2 * (0 + 1) + 2)).
  change 6%Z with (Z_of_nat (fact (2 * (0 + 1) + 1))).
  rewrite <- 2!INR_IZR_INZ.
  replace (Si (toR x) 0%nat - sinc (toR x))%R with ((-1) * 1 * (sinc (toR x) - Si (toR x) 0%nat))%R by ring.
  change (-1 * 1)%R with (pow (-1) (0 + 1)).
  rewrite <- (minus_diag n) at 2 4 8 11 13.
  generalize (le_refl n).
  generalize n at 1 4 6 8 9 11 13.
  intros m.
  revert powi divi facti.
  induction m as [|m IHm] ; intros powi divi facti Hm Hpow Hdiv Hfact.
  { simpl cos_fast0_aux.
    cut (contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi x2i) divi))))
    (Xreal ((-1) ^ (n - 0 + 1) * (sinc (toR x) - Si (toR x) (n - 0))))).
    { now destruct F'.cmp. }
    now apply Hexit. }
  simpl cos_fast0_aux.
  set (powi' := I.mul prec powi x2i).
  set (divi' := I.mul prec divi (I.mul prec facti (I.add prec facti i1))).
  set (facti' := I.add prec facti i2).
  specialize (IHm powi' divi' facti').
  assert (H: forall p, n - S m + S p = n - m + p).
  { intros p.
    clear -Hm ; omega. }
  cut (contains (I.convert (I.sub prec (I.div prec powi' divi) (cos_fast0_aux prec thre powi' x2i facti' divi' m)))
    (Xreal ((-1) ^ (n - S m + 1) * (sinc (toR x) - Si (toR x) (n - S m))))).
  { case F'.cmp ; try easy.
    intros H'.
    now apply Hexit. }
  replace ((-1) ^ (n - S m + 1) * (sinc (toR x) - Si (toR x) (n - S m)%nat))%R
  with ((-1) ^ (n - S m + 1) * (-1) ^ S (n - S m) * (toR x) ^ (2 * S (n - S m)) * / INR (fact (2 * S (n - S m) + 1)) - (((-1) * (-1) ^ (n - S m + 1)) * (sinc (toR x) - (Si (toR x) (n - S m)%nat + ((-1) ^ S (n - S m) * / INR (fact (2 * S (n - S m) + 1)) * (toR x) ^ (2 * S (n - S m)))))))%R by ring.
  assert (Hpow': contains (I.convert powi') (Xreal (toR x ^ (2 * (n - S m + 1))))).
  { replace (2 * (n - S m + 1)) with (2 * (n - S m) + 2) by ring.
    rewrite pow_add, <- Rsqr_pow2.
    apply J.mul_correct with (1 := Hpow).
    now apply J.sqr_correct. }
  apply J.sub_correct.
  { rewrite <- pow_add.
    replace (n - S m + 1 + S (n - S m)) with (2 * (n - S m + 1)) by (clear -Hm ; omega).
    rewrite pow_1_even, Rmult_1_l.
    replace (S (n - S m)) with (n - S m + 1) by now rewrite plus_comm.
    now apply J.div_correct. }
evar_last.
apply IHm.
clear -Hm ; lia.
now rewrite <- (plus_0_r (n - m)), <- H.
rewrite <- H.
replace (2 * (n - S m + 2) + 1) with (S (S (2 * (n - S m + 1) + 1))) by ring.
rewrite 2!fact_simpl.
rewrite 2!mult_INR, <- Rmult_assoc, Rmult_comm.
apply J.mul_correct with (1 := Hdiv).
rewrite Rmult_comm.
apply J.mul_correct.
now rewrite <- Nat.add_1_r, <- plus_assoc.
replace (S (S (2 * (n - S m + 1) + 1))) with (2 * (n - S m + 1) + 2 + 1) by ring.
rewrite plus_INR.
apply J.add_correct with (1 := Hfact).
apply i1_correct.
rewrite <- H.
replace (2 * (n - S m + 2) + 2) with (2 * (n - S m + 1) + 2 + 2) by ring.
rewrite plus_INR.
apply J.add_correct with (1 := Hfact).
now apply I.fromZ_small_correct; compute.
apply f_equal.
change (Si (toR x) (n - S m)%nat + (-1) ^ S (n - S m) * / INR (fact (2 * S (n - S m) + 1)) * toR x ^ (2 * S (n - S m)))%R
  with (Si (toR x) (S (n - S m))).
change (-1 * (-1) ^ (n - S m + 1))%R with ((-1) ^ (S (n - S m + 1)))%R.
rewrite <- plus_Sn_m.
now rewrite -> minus_Sn_m.
}
exact Ix.
Qed.

(* 0 <= input *)
Definition sin_fastP prec x :=
  let th := c1_2 in
  match F'.le' x th with
  | true => sin_fast0 (F.incr_prec prec 1) x
  | _ =>
    let m := F.StoZ (F.mag x) in
    let prec := F.incr_prec prec (Z2P (m + 6)) in
    match sin_cos_reduce prec x (S (Z2nat m)) with
    | (s, c) =>
      let v := I.sqrt prec (I.sub prec i1 (I.sqr prec c)) in
      match s with
      | Lt => I.neg v
      | Gt => v
      | _ => I.bnd cm1 c1
      end
    end
  end.

Lemma sin_fastP_correct :
  forall prec x,
  F.toX x = Xreal (toR x) ->
  (0 <= toR x)%R ->
  contains (I.convert (sin_fastP prec x)) (Xreal (sin (toR x))).
Proof.
intros prec x Hxr Hx0.
unfold sin_fastP.
case_eq (F'.le' x c1_2) ; intros Hx.
{ apply sin_fast0_correct.
  { easy. }
  rewrite Rabs_pos_eq with (1 := Hx0).
  apply F'.le'_correct in Hx.
  revert Hx.
  unfold toR, c1.
  now rewrite Hxr, c1_2_correct. }
generalize (S (Z2nat (F.StoZ (F.mag x)))) (F.incr_prec prec (Z2P (F.StoZ (F.mag x) + 6))).
intros nb prec'.
generalize (sin_cos_reduce_correct prec' nb x Hxr Hx0).
destruct sin_cos_reduce as [ss ci].
intros [Hc Hs].
destruct ss.
{ simpl.
  unfold c1, cm1.
  rewrite F'.neg_correct, F'.valid_lb_neg, F.one_correct, F'.valid_ub_one.
  apply SIN_bound. }
{ rewrite <- (Ropp_involutive (sin (toR x))).
  change (Xreal (- - sin (toR x))) with (Xneg (Xreal (- sin (toR x)))).
  apply I.neg_correct.
  rewrite <- Rabs_left1 with (1 := Hs).
  rewrite <- sqrt_Rsqr_abs.
  replace (Xreal (sqrt (sin (toR x))²)) with (Xsqrt (Xreal (sin (toR x))²)).
  { apply I.sqrt_correct.
    rewrite sin2.
    change (Xreal (1 - (cos (toR x))²)) with (Xsub (Xreal 1) (Xsqr (Xreal (cos (toR x))))).
    apply I.sub_correct.
    { apply i1_correct. }
    now apply I.sqr_correct. }
  unfold Xsqrt'.
  simpl.
  destruct (is_negative_spec (sin (toR x))²).
  { elim (Rlt_not_le _ _ H).
    apply Rle_0_sqr. }
  apply refl_equal. }
rewrite <- (Rabs_pos_eq (sin (toR x))) with (1 := Hs).
rewrite <- sqrt_Rsqr_abs.
replace (Xreal (sqrt (sin (toR x))²)) with (Xsqrt (Xreal (sin (toR x))²)).
{ apply I.sqrt_correct.
  rewrite sin2.
  change (Xreal (1 - (cos (toR x))²)) with (Xsub (Xreal 1) (Xsqr (Xreal (cos (toR x))))).
  apply I.sub_correct.
  { apply i1_correct. }
  now apply I.sqr_correct. }
unfold Xsqrt'.
simpl.
destruct (is_negative_spec (sin (toR x))²).
{ elim (Rlt_not_le _ _ H).
  apply Rle_0_sqr. }
apply refl_equal.
Qed.

Definition sin_fast prec x :=
  match F'.cmp x F.zero with
  | Xeq => I.zero
  | Xlt => I.neg (sin_fastP prec (F.neg x))
  | Xgt => sin_fastP prec x
  | Xund => I.nai
  end.

Theorem sin_fast_correct :
  forall prec x,
  contains (I.convert (sin_fast prec x)) (Xsin (F.toX x)).
Proof.
intros prec x.
unfold sin_fast.
rewrite F'.cmp_correct, F.zero_correct.
case_eq (F.toX x).
easy.
intros r Hr.
simpl.
case Rcompare_spec ; intros H.
(* neg *)
rewrite <- (Xneg_involutive (Xreal _)).
apply I.neg_correct.
simpl.
rewrite <- sin_neg.
replace (Ropp r) with (toR (F.neg x)).
apply sin_fastP_correct.
unfold toR.
now rewrite F'.neg_correct, Hr.
unfold toR.
rewrite F'.neg_correct, Hr.
rewrite <- Ropp_0.
apply Ropp_le_contravar.
now apply Rlt_le.
unfold toR.
now rewrite F'.neg_correct, Hr.
(* zero *)
rewrite H, sin_0.
rewrite I.zero_correct.
split ; apply Rle_refl.
(* pos *)
replace r with (toR x).
apply sin_fastP_correct.
unfold toR.
now rewrite Hr.
unfold toR.
rewrite Hr.
now apply Rlt_le.
unfold toR.
now rewrite Hr.
Qed.

(* 0 <= input *)
Definition tan_fastP prec x :=
  let th := c1_2 in
  match F'.le' x th with
  | true =>
    let prec := F.incr_prec prec 2 in
    let s := sin_fast0 prec x in
    I.div prec s (I.sqrt prec (I.sub prec i1 (I.sqr prec s)))
  | _ =>
    let m := F.StoZ (F.mag x) in
    let prec := F.incr_prec prec (Z2P (m + 7)) in
    match sin_cos_reduce prec x (S (Z2nat m)) with
    | (s, c) =>
      let v := I.sqrt prec (I.sub prec (I.div prec i1 (I.sqr prec c)) i1) in
      match s, I.sign_large c with
      | Lt, Xgt => I.neg v
      | Gt, Xlt => I.neg v
      | Lt, Xlt => v
      | Gt, Xgt => v
      | _, _ => I.nai
      end
    end
  end.

Definition tan_fast prec x :=
  match F'.cmp x F.zero with
  | Xeq => I.zero
  | Xlt => I.neg (tan_fastP prec (F.neg x))
  | Xgt => tan_fastP prec x
  | Xund => I.nai
  end.

Lemma tan_fastP_correct :
  forall prec x,
  F.toX x = Xreal (toR x) ->
  (0 <= toR x)%R ->
  contains (I.convert (tan_fastP prec x)) (Xtan (Xreal (toR x))).
Proof.
intros prec x Rx Bx.
unfold tan_fastP.
case_eq (F'.le' x c1_2) ; intros Hx.
- apply F'.le'_correct in Hx.
  revert Hx.
  rewrite c1_2_correct, Rx.
  intros Bx'.
  replace (Xtan (Xreal (toR x))) with (Xdiv (Xreal (sin (toR x))) (Xsqrt (Xsub (Xreal 1) (Xsqr (Xreal (sin (toR x))))))).
  apply I.div_correct.
  apply sin_fast0_correct with (1 := Rx).
  now rewrite Rabs_pos_eq.
  apply I.sqrt_correct.
  apply I.sub_correct.
  now apply I.fromZ_small_correct.
  apply I.sqr_correct.
  apply sin_fast0_correct with (1 := Rx).
  now rewrite Rabs_pos_eq.
  unfold Xsqrt'.
  simpl.
  set (e := (1 - _)%R).
  case (Rlt_or_le e 0); unfold e.
  { intro H.
    elim Rlt_not_le with (1 := H).
    apply Rle_0_minus.
    rewrite <- (Rmult_1_r 1).
    apply neg_pos_Rsqr_le ; apply SIN_bound. }
  change (sin (toR x) * sin (toR x))%R with (Rsqr (sin (toR x))).
  rewrite <- cos2.
  intros H'.
  assert (Hc: (0 < cos (toR x))%R).
    apply cos_gt_0.
    apply Rlt_le_trans with (2 := Bx).
    apply Ropp_lt_gt_0_contravar.
    apply PI2_RGT_0.
    apply Rle_lt_trans with (1 := Bx').
    apply Rlt_trans with (2 := PI2_1).
    lra.
  unfold Xdiv'.
  case is_zero_spec.
  intros H.
  elim Rgt_not_eq with (1 := Hc).
  apply Rsqr_0_uniq.
  now apply sqrt_eq_0.
  intros H''.
  unfold Xtan'.
  simpl.
  case is_zero_spec.
  intros H.
  rewrite H in Hc.
  elim Rlt_irrefl with (1 := Hc).
  intros _.
  apply (f_equal (fun v => Xreal (_ / v))).
  apply sqrt_Rsqr.
  now apply Rlt_le.
- generalize (F.incr_prec prec (Z2P (F.StoZ (F.mag x) + 7))).
  clear prec. intros prec.
  generalize (sin_cos_reduce_correct prec (S (Z2nat (F.StoZ (F.mag x)))) x Rx Bx).
  case sin_cos_reduce.
  intros s c [Hc Hs].
  assert (Hc1 := i1_correct).
  assert (H: contains (I.convert (I.sqrt prec (I.sub prec (I.div prec i1 (I.sqr prec c)) i1))) (Xabs (Xdiv (Xreal (sin (toR x))) (Xreal (cos (toR x)))))).
  { replace (Xabs (Xdiv (Xreal (sin (toR x))) (Xreal (cos (toR x)))))
      with (Xsqrt (Xsub (Xdiv (Xreal 1) (Xsqr (Xreal (cos (toR x))))) (Xreal 1))).
    { apply I.sqrt_correct.
      apply I.sub_correct; [|easy].
      apply I.div_correct; [easy|].
      now apply I.sqr_correct. }
    unfold Xdiv'.
    simpl.
    case is_zero_spec ; intros Zc.
    { rewrite Rsqr_0_uniq with (1 := Zc).
      now rewrite is_zero_0. }
    case is_zero_spec ; intros Zc'.
    { rewrite Zc' in Zc.
      elim Zc.
      apply Rmult_0_l. }
    unfold Xsqrt'.
    simpl.
    replace (1 / (Rsqr (cos (toR x))) - 1)%R with (Rsqr (sin (toR x) / cos (toR x))).
    { set (e := (_²)%R).
      case (Rlt_or_le e 0); unfold e; intro H.
      { elim Rlt_not_le with (1 := H).
        apply Rle_0_sqr. }
      apply f_equal, sqrt_Rsqr_abs. }
    rewrite Rsqr_div with (1 := Zc').
    rewrite sin2.
    unfold Rsqr.
    now field. }
  unfold Xdiv', Xbind2 in H.
  generalize (I.sign_large_correct c).
  unfold Xtan', Xbind.
  destruct s; [easy| |] ; case I.sign_large; try easy ; intros Hc'.
  { revert H.
    destruct (is_zero_spec (cos (toR x))) as [H0|H0].
    { unfold i1; unfold c1.
      now case I.convert. }
    intro H'.
    evar_last.
  evar_last.
  apply H'.
  apply (f_equal Xreal).
  apply Rabs_pos_eq.
  apply Rmult_le_neg_neg with (1 := Hs).
  apply Rlt_le, Rinv_lt_0_compat.
  apply Rnot_le_lt.
  contradict H0.
  apply Rle_antisym with (2 := H0).
  now specialize (Hc' _ Hc).
  easy. }
  { rewrite <- (Xneg_involutive (if is_zero _ then _ else _)).
    apply I.neg_correct.
    destruct (is_zero_spec (cos (toR x))) as [H0|H0].
    easy.
    evar_last.
    apply H.
    apply (f_equal Xreal).
    apply Rabs_left1.
    apply Rmult_le_neg_pos with (1 := Hs).
    apply Rlt_le, Rinv_0_lt_compat.
    apply Rnot_le_lt.
    contradict H0.
    apply Rle_antisym with (1 := H0).
    now specialize (Hc' _ Hc). }
  { rewrite <- (Xneg_involutive (if is_zero _ then _ else _)).
    apply I.neg_correct.
    destruct (is_zero_spec (cos (toR x))) as [H0|H0].
    easy.
    evar_last.
    apply H.
    apply (f_equal Xreal).
    apply Rabs_left1.
    apply Rmult_le_pos_neg with (1 := Hs).
    apply Rlt_le, Rinv_lt_0_compat.
    apply Rnot_le_lt.
    contradict H0.
    apply Rle_antisym with (2 := H0).
    now specialize (Hc' _ Hc). }
  destruct (is_zero_spec (cos (toR x))) as [H0|H0]; [easy|].
  evar_last.
  apply H.
  apply (f_equal Xreal).
  apply Rabs_pos_eq.
  apply Rmult_le_pos_pos with (1 := Hs).
  apply Rlt_le, Rinv_0_lt_compat.
  apply Rnot_le_lt.
  contradict H0.
  apply Rle_antisym with (1 := H0).
  now specialize (Hc' _ Hc).
Qed.

Theorem tan_fast_correct :
  forall prec x,
  contains (I.convert (tan_fast prec x)) (Xtan (F.toX x)).
Proof.
intros prec x.
unfold tan_fast.
rewrite F'.cmp_correct, F.zero_correct.
case_eq (F.toX x); [easy|].
intros r Hr.
simpl Xcmp.
case Rcompare_spec ; intros H.
{ (* neg *)
  rewrite <- (Xneg_involutive (Xtan _)).
  apply I.neg_correct.
  generalize (tan_fastP_correct prec (F.neg x)).
  unfold toR.
  rewrite F'.neg_correct, Hr.
  simpl.
  intros H'.
  assert (H1 : (0 <= -r)%R).
  { rewrite <- Ropp_0.
    apply Ropp_le_contravar.
    now apply Rlt_le. }
  specialize (H' eq_refl H1).
  revert H'.
  unfold Xtan'.
  simpl.
  rewrite cos_neg.
  case is_zero_spec; [easy|].
  intros _.
  now rewrite tan_neg. }
{ (* zero *)
  simpl.
  rewrite H, F.zero_correct.
  unfold Xtan'.
  simpl.
  case is_zero_spec.
  { rewrite cos_0.
    now intro H'; exfalso; apply R1_neq_R0. }
  intros _.
  rewrite tan_0.
  rewrite F'.valid_lb_zero, F'.valid_ub_zero.
  split ; apply Rle_refl. }
(* pos *)
replace r with (toR x).
{ apply tan_fastP_correct.
  { unfold toR.
    now rewrite Hr. }
  unfold toR.
  rewrite Hr.
  now apply Rlt_le. }
unfold toR.
now rewrite Hr.
Qed.

Definition semi_extension f fi :=
  forall x, contains (I.convert (fi x)) (f (F.toX x)).

Definition cos_correct : forall prec, semi_extension Xcos (cos_fast prec) := cos_fast_correct.
Definition sin_correct : forall prec, semi_extension Xsin (sin_fast prec) := sin_fast_correct.
Definition tan_correct : forall prec, semi_extension Xtan (tan_fast prec) := tan_fast_correct.
Definition atan_correct : forall prec, semi_extension Xatan (atan_fast prec) := atan_fast_correct.

(* 0 <= inputs *)
Fixpoint expn_fast0_aux prec thre powi xi facti divi (nb : nat) { struct nb } :=
  let npwi := I.mul prec powi xi in
  let vali := I.div prec npwi divi in
  match F'.cmp (I.upper vali) thre, nb with
  | Xlt, _
  | _, O => I.bnd F.zero (I.upper vali)
  | _, S n =>
    let nfacti := I.add prec facti i1 in
    let ndivi := I.mul prec divi facti in
    I.sub prec vali (expn_fast0_aux prec thre npwi xi nfacti ndivi n)
  end.

(* 0 <= input <= 1/2 *)
Definition expn_fast0 prec x :=
  let p := F.prec prec in
  let thre := F.scale c1 (F.ZtoS (Zneg p)) in
  let xi := I.bnd x x in
  let rem := expn_fast0_aux prec thre xi xi i3 i2 (nat_of_P p) in
  I.sub prec i1 (I.sub prec xi rem).

(* 0 <= input *)
Definition expn_reduce prec x :=
  let th := c1_8 in
  match F'.le' x th with
  | true => expn_fast0 (F.incr_prec prec 1) x
  | false =>
    let m := F.StoZ (F.mag x) in
    let prec := F.incr_prec prec (Z2P (9 + m)) in
    let fix reduce x (nb : nat) {struct nb} :=
      match F'.le' x th, nb with
      | true, _ => expn_fast0 prec x
      | _, O => I.bnd F.zero c1
      | _, S n => I.sqr prec (reduce (F.div2 x) n)
      end in
    reduce x (8 + Z2nat m)
  end.

Definition exp_fast prec x :=
  match F'.cmp x F.zero with
  | Xeq => i1
  | Xlt => expn_reduce prec (F.neg x)
  | Xgt =>
    let prec := F.incr_prec prec 1 in
    match I.inv prec (expn_reduce prec x) with
    | Ibnd _ _ as b => b
    | Inai => I.bnd c1 F.nan
    end
  | Xund => I.nai
  end.

Lemma expn_fast0_correct :
  forall prec x,
  F.toX x = Xreal (toR x) ->
  (0 <= toR x <= /2)%R ->
  contains (I.convert (expn_fast0 prec x)) (Xreal (exp (- toR x))).
Proof.
intros prec x Rx Bx.
unfold expn_fast0.
replace (exp (-toR x)) with (1 - (toR x - (- (1 - toR x) + exp (-toR x))))%R by ring.
apply J.sub_correct.
apply i1_correct.
set (xi := I.bnd x x).
assert (Ix: contains (I.convert xi) (Xreal (toR x))).
  unfold xi.
  rewrite I.bnd_correct, Rx.
  2: now apply I.valid_lb_real; rewrite Rx.
  2: now apply I.valid_ub_real; rewrite Rx.
  split ; apply Rle_refl.
apply J.sub_correct with (1 := Ix).
assert (Hexit : forall k powi divi,
    contains (I.convert powi) (Xreal (toR x ^ (k + 1))) ->
    contains (I.convert divi) (Xreal (INR (fact (k + 2)))) ->
    contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi xi) divi))))
      (Xreal ((-1) ^ k * (exp (- toR x) + - E1 (- toR x) (k + 1))))).
  intros k powi divi Hpow Hdiv.
  assert (Hne : not_empty (I.convert (I.div prec (I.mul prec powi xi) divi))).
  { exists ((F.toR x ^ (k + 1) * F.toR x)/ INR (fact (k + 2)))%R.
    now apply J.div_correct; [apply J.mul_correct|]. }
  rewrite I.bnd_correct.
  2: now apply I.valid_lb_real; rewrite F.zero_correct.
  2: now apply I.valid_ub_upper.
  rewrite F.zero_correct, I.upper_correct; [|easy].
  assert (A: (0 <= (-1) ^ k * (exp (- toR x) + - E1 (- toR x) (k + 1)) <= toR x ^ (k + 2) / INR (fact (k + 2)))%R).
    replace ((-1) ^ k)%R with ((-1) * ((-1) * (-1) ^ k))%R by ring.
    change ((-1) * ((-1) * (-1) ^ k))%R with ((-1) ^ (S (S k)))%R.
    unfold Rdiv.
    rewrite (Rmult_comm (toR x ^ (k + 2))).
    replace (E1 (- toR x) (k + 1)) with (sum_f_R0 (tg_alt (fun n => / INR (fact n) * toR x ^ n)%R) (k + 1)).
    rewrite <- (plus_n_Sm _ 1).
    replace (S k) with (k + 1) by ring.
    apply alternated_series_ineq'.
    apply Un_decreasing_exp.
    split.
    apply Bx.
    lra.
    eapply Un_cv_ext.
    intros n.
    apply Rmult_comm.
    apply cv_speed_pow_fact.
    generalize (E1_cvg (- toR x)).
    apply Un_cv_ext.
    intros n.
    unfold E1, tg_alt.
    apply sum_eq.
    intros i _.
    rewrite (Rmult_comm _ (toR x ^ i)), <- Rmult_assoc.
    rewrite <- Rpow_mult_distr.
    rewrite Rmult_comm.
    apply (f_equal (fun v => (v ^ i * _)%R)).
    ring.
    unfold E1, tg_alt.
    apply sum_eq.
    intros i _.
    unfold Rdiv.
    rewrite Rmult_comm, Rmult_assoc.
    rewrite <- Rpow_mult_distr.
    apply (f_equal (fun v => (_ * v ^ i)%R)).
    ring.
  apply (conj (proj1 A)).
  assert (H1 := J.mul_correct prec _ _ _ _ Hpow Ix).
  assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv).
  destruct (I.convert (I.div prec _ _)) as [|l [|u]] ; try easy.
  apply Rle_trans with (1 := proj2 A).
  apply Rle_trans with (2 := proj2 H2).
  apply Req_le, Rmult_eq_compat_r.
  rewrite <- plus_n_Sm.
  apply Rmult_comm.
generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)).
intros thre n.
replace (1 - toR x)%R with (E1 (- toR x) (0 + 1)) by (unfold E1 ; simpl ; field).
assert (H2le256 : (Z.abs 2 <= 256)%Z); [now compute|].
assert (H3le256 : (Z.abs 3 <= 256)%Z); [now compute|].
generalize Ix (I.fromZ_small_correct 2 H2le256) (I.fromZ_small_correct 3 H3le256).
fold i2 i3.
generalize i2 i3.
generalize xi at 1 2.
intros powi divi facti.
rewrite <- (pow_1 (toR x)) at 1.
rewrite Rplus_comm.
change 1 with (0 + 1) at 1.
change 3%Z with (Z_of_nat (0 + 3)).
change 2%Z with (Z_of_nat (fact (0 + 2))).
rewrite <- 2!INR_IZR_INZ.
rewrite <- (Rmult_1_l (_ + _)).
change 1%R with ((-1)^0)%R.
rewrite <- (minus_diag n) at 1 3 5 7 8.
generalize (le_refl n).
generalize n at 1 4 6 8 9 11 13.
intros m.
revert powi divi facti.
induction m as [|m IHm] ; intros powi divi facti Hm Hpow Hdiv Hfact.
  simpl expn_fast0_aux.
  cut (contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi xi) divi))))
    (Xreal ((-1) ^ (n - 0) * (exp (- toR x) + - E1 (- toR x) (n - 0 + 1))))).
  now destruct F'.cmp.
  now apply Hexit.
simpl expn_fast0_aux.
set (powi' := I.mul prec powi xi).
set (divi' := I.mul prec divi facti).
set (facti' := I.add prec facti i1).
specialize (IHm powi' divi' facti').
assert (H: forall p, n - m + p = n - S m + p + 1).
  intros p.
  clear -Hm ; omega.
cut (contains (I.convert (I.sub prec (I.div prec powi' divi) (expn_fast0_aux prec thre powi' xi facti' divi' m)))
    (Xreal ((-1) ^ (n - S m) * (exp (- toR x) + - E1 (- toR x) (n - S m + 1))))).
  case F'.cmp ; try easy.
  intros H'.
  now apply Hexit.
replace ((-1) ^ (n - S m) * (exp (- toR x) + - E1 (- toR x) (n - S m + 1)))%R
  with ((toR x) ^ (n - m + 1) * / INR (fact (n - m + 1)) - (((-1) * (-1) ^ (n - S m)) * (exp (- toR x) + - E1 (- toR x) (n - S m + 1)) + / INR (fact (n - m + 1)) * (toR x) ^ (n - m + 1)))%R by ring.
change (-1 * (-1) ^ (n - S m))%R with ((-1) ^ (S (n - S m)))%R.
rewrite -> minus_Sn_m with (1 := Hm).
simpl (S n - S m).
assert (Hpow': contains (I.convert powi') (Xreal (toR x ^ (n - m + 1)))).
  rewrite H.
  rewrite pow_add, pow_1.
  now apply J.mul_correct.
apply J.sub_correct.
  apply J.div_correct with (1 := Hpow').
  now rewrite H, <- plus_assoc.
evar_last.
apply IHm.
clear -Hm ; lia.
exact Hpow'.
rewrite H.
rewrite plus_comm, fact_simpl.
rewrite mult_comm, mult_INR.
apply J.mul_correct with (1 := Hdiv).
now rewrite plus_n_Sm.
rewrite H.
rewrite plus_INR.
apply J.add_correct with (1 := Hfact).
apply i1_correct.
apply f_equal.
rewrite 2!Rmult_plus_distr_l.
rewrite Rplus_assoc.
apply f_equal.
rewrite <- plus_n_Sm at 1.
unfold E1.
change (sum_f_R0 (fun k : nat => / INR (fact k) * (- toR x) ^ k) (S (n - m + 0)))%R
  with (sum_f_R0 (fun k : nat => / INR (fact k) * (- toR x) ^ k) (n - m + 0) + / INR (fact (S (n - m + 0))) * (- toR x) ^ (S (n - m + 0)))%R.
rewrite H, <- plus_assoc at 1.
rewrite Ropp_plus_distr, Rmult_plus_distr_l.
apply f_equal.
rewrite <- Ropp_mult_distr_r_reverse.
rewrite (Rmult_comm (_ ^ _)), Rmult_assoc.
rewrite plus_n_Sm.
apply f_equal.
replace (- (- toR x) ^ (n - m + 1) * (-1) ^ (n - m))%R
  with ((- toR x) ^ (n - m + 1) * ((-1) * (-1) ^ (n - m)))%R by ring.
change (-1 * (-1) ^ (n - m))%R with ((-1) ^ (S (n - m)))%R .
rewrite <- plus_n_Sm, <- plus_n_O.
rewrite <- Rpow_mult_distr.
now replace (- toR x * -1)%R with (toR x) by ring.
Qed.

Lemma expn_reduce_correct :
  forall prec x,
  F.toX x = Xreal (toR x) ->
  (0 < toR x)%R ->
  contains (I.convert (expn_reduce prec x)) (Xreal (exp (- toR x))).
Proof.
assert (forall prec x,
  F.toX x = Xreal (toR x) ->
  (0 < toR x)%R -> F'.le' x c1_8 = true ->
  contains (I.convert (expn_fast0 prec x)) (Xreal (exp (- toR x)))).
{ intros prec x Hx1 Hx2 Hx3.
  apply expn_fast0_correct.
  { exact Hx1. }
  split.
  { now apply Rlt_le. }
  apply F'.le'_correct in Hx3.
  revert Hx3.
  rewrite Hx1.
  rewrite c1_8_correct.
  lra. }
intros prec x Hx H0.
unfold expn_reduce.
case_eq (F'.le' x c1_8) ; intros Hx'.
{ (* . no reduction *)
  now apply H. }
(* . reduction *)
clear Hx'.
generalize (F.incr_prec prec (Z2P (9 + F.StoZ (F.mag x)))).
clear prec. intro prec.
generalize (8 + Z2nat (F.StoZ (F.mag x))).
intro nb.
revert x Hx H0.
induction nb ; intros ; simpl.
{ (* nb = 0 *)
  case_eq (F'.le' x c1_8) ; intros Hx'.
  { now apply H. }
  simpl.
  unfold c1.
  rewrite F'.valid_lb_zero, F'.valid_ub_one, F.zero_correct, F.one_correct.
  split.
  { apply Rlt_le.
    apply exp_pos. }
  simpl.
  rewrite <- exp_0.
  apply Rlt_le.
  apply exp_increasing.
  rewrite <- Ropp_0.
  now apply Ropp_lt_contravar. }
(* nb > 0 *)
case_eq (F'.le' x c1_8) ; intros Hx'.
{ now apply H. }
assert (1 / 256 <= Rabs (F.toR x))%R.
{ rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0)).
  revert Hx'.
  unfold F'.le'.
  rewrite F'.cmp_correct.
  rewrite Hx.
  rewrite c1_8_correct.
  unfold Rdiv; rewrite Rmult_1_l.
  simpl.
  now case Rcompare_spec; [easy..|]; intros H' _; apply Rlt_le. }
assert (toR (F.div2 x) = toR x * /2)%R.
{ unfold toR; rewrite F.div2_correct; [|easy..].
  rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy].
  rewrite Hx; simpl; lra. }
replace (toR x) with (toR (F.div2 x) + toR (F.div2 x))%R.
{ rewrite Ropp_plus_distr.
  rewrite exp_plus.
  change (Xreal (exp (- toR (F.div2 x)) * exp (- toR (F.div2 x))))
    with (Xsqr (Xreal (exp (- toR (F.div2 x))))).
  apply I.sqr_correct.
  apply IHnb.
  { unfold F.toR; rewrite F.div2_correct; [|easy..].
    rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy].
    now rewrite Hx. }
  rewrite H2; lra. }
rewrite H2.
apply sym_eq, double_var.
Qed.

Theorem exp_fast_correct :
  forall prec x,
  contains (I.convert (exp_fast prec x)) (Xexp (F.toX x)).
Proof.
intros prec x.
unfold exp_fast.
rewrite F'.cmp_correct, F.zero_correct.
case_eq (F.toX x).
easy.
intros r Hr.
(* neg *)
simpl.
case Rcompare_spec ; intros H.
replace r with (Ropp (toR (F.neg x))).
apply expn_reduce_correct.
unfold toR.
now rewrite F'.neg_correct, Hr.
unfold toR.
rewrite F'.neg_correct, Hr.
rewrite <- Ropp_0.
now apply Ropp_lt_contravar.
unfold toR.
rewrite F'.neg_correct, Hr.
apply Ropp_involutive.
(* zero *)
rewrite H, exp_0.
apply i1_correct.
(* pos *)
generalize (F.incr_prec prec 1).
clear prec. intro prec.
case_eq (I.inv prec (expn_reduce prec x)) ; intros.
(* pos too big *)
rewrite I.bnd_correct.
2: now apply I.valid_lb_real; unfold c1; rewrite F.one_correct.
2: now apply I.valid_ub_nan.
split ; unfold c1.
rewrite F.one_correct.
simpl.
rewrite <- exp_0.
apply Rlt_le.
now apply exp_increasing.
now rewrite F'.nan_correct.
(* pos fine *)
rewrite <- H0.
rewrite <- (Ropp_involutive r).
rewrite exp_Ropp.
replace (Xreal (/ exp (- r))) with (Xinv (Xreal (exp (- toR x)))).
apply I.inv_correct.
apply expn_reduce_correct.
unfold toR.
now rewrite Hr.
unfold toR.
now rewrite Hr.
unfold toR.
rewrite Hr.
unfold Xinv'.
simpl.
case is_zero_spec ; intro H1.
elim Rgt_not_eq with (2 := H1).
apply exp_pos.
apply refl_equal.
Qed.

End TranscendentalFloatFast.

(*
Require Import Interval_specific_ops.
Require Import Interval_stdz_carrier.
Module F := SpecificFloat StdZRadix2.
Module A := TranscendentalFloatFast F.
Time Eval vm_compute in (A.exp_fast 50%Z (Float 201%Z (-8)%Z)).
Time Eval vm_compute in (A.atan_fast 50%Z (Float 201%Z (-8)%Z)).
Time Eval vm_compute in (A.cos_fast 50%Z (Float 201%Z (-8)%Z)).
Time Eval vm_compute in (A.tan_fast 50%Z (Float 3619%Z (-8)%Z)).
Time Eval vm_compute in (A.sin_fast 50%Z (Float 201%Z (-8)%Z)).
Time Eval vm_compute in (A.ln_fast 50%Z (Float 1%Z 20009%Z)).
Time Eval vm_compute in (A.ln_fast 50%Z (Float 1125899906842623%Z (-50)%Z)).
*)


Require Export BasicDefinitions.
(*** Formalisation of finite types using canonical structures and type classes *)

(** Definition of finite Types *)

Class finTypeC  (type:eqType) : Type := FinTypeC {
                                            enum: list type;
                                            enum_ok: forall x: type, count enum x = 1
                                          }.

Structure finType : Type := FinType {
                                type:> eqType;
                                class: finTypeC type }.

Arguments FinType type {class}.
Existing Instance class | 0.

Canonical Structure finType_CS (X : Type) {p : eq_dec X} {class : finTypeC (EqType X)} : finType := FinType (EqType X).

Definition elem (F: finType) := @enum (type F) (class F).
Hint Unfold elem.
Hint Unfold class.

Lemma elem_spec (X: finType) (x:X) : x el (elem X).
Proof.
  apply countIn.  pose proof (enum_ok x) as H. unfold elem. omega.
Qed.

Hint Resolve elem_spec.
Hint Resolve enum_ok.

Lemma allSub (X: finType) (A:list X) : A <<= elem X.
Proof.
  intros x _. apply elem_spec.
Qed.
Hint Resolve allSub.

(** A properties that hold on every element of (elem X) hold for every element of the finType X *)
Theorem Equivalence_property_all (X: finType) (p: X -> Prop) :
  (forall x, p x) <-> forall x, x el (elem X) -> p x.
Proof.
  split; auto.
Qed.

Theorem Equivalence_property_exists (X: finType) (p:X -> Prop):
  (exists x, p x) <-> exists x, x el (elem X) /\ p x.
Proof.
  split.
  - intros [x P]. eauto.
  - intros [x [E P]]. eauto.
Qed.

Instance finType_forall_dec (X: finType) (p: X -> Prop): (forall x, dec (p x)) -> dec (forall x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_all p).
  - auto.
Qed.

Instance finType_exists_dec (X:finType) (p: X -> Prop) : (forall x, dec (p x)) -> dec (exists x, p x).
Proof.
  intros D. eapply dec_transfer.
  - symmetry. exact (Equivalence_property_exists p).
  - auto.
Qed.

Definition finType_cc (X: finType) (p: X -> Prop) (D: forall x, dec (p x)) : (exists x, p x) -> {x | p x}.
Proof.
  intro H.
  assert(exists x, x el (elem X) /\ p x) as E by firstorder.
  pose proof (list_cc D E) as [x G].
  now exists x.
Defined.

Definition pickx (X: finType): X + (X -> False).
Proof.
  destruct X as [X [enum ok]]. induction enum.
  - right. intro x. discriminate (ok x).
  - tauto.
Defined.

(** Properties of decidable Propositions *)

Lemma DM_notAll (X: finType) (p: X -> Prop) (D:forall x, dec (p x)): (~ (forall x, p x)) <-> exists x, ~ (p x).
Proof.
  decide (exists x,~ p x); firstorder.
Qed.

Lemma DM_exists (X: finType) (p: X -> Prop) (D: forall x, dec (p x)):
  (exists x, p x) <->  ~(forall x, ~ p x).
Proof.
  split.
  - firstorder.
  - decide (exists x, p x); firstorder.
Qed.

(* Index is an injective function *)

Fixpoint  getPosition {E: eqType} (A: list E) x := match A with
                                                   | nil => 0
                                                   | cons x' A' => if Dec (x=x') then 0 else 1 + getPosition A' x end.

Lemma getPosition_correct {E: eqType} (x:E) A: if Dec (x el A) then forall z, (nth (getPosition A x) A z) = x else getPosition A x = |A |.
Proof.
  induction A;cbn.
  -repeat destruct Dec;tauto.
  -repeat destruct Dec;intuition; congruence.
Qed.

Definition pos_def (X : eqType) (x : X) A n :=  match pos x A with None => n | Some n => n end.

Definition index {F: finType} (x:F) := getPosition (elem F) x.

Lemma index_nth {F : finType} (x:F) y: nth (index x) (elem F) y = x.
  unfold index, elem, enum.
  destruct F as [[X E] [A all_A]];cbn.
  assert (H := getPosition_correct x A).
  destruct Dec. auto. apply notInZero in n. now setoid_rewrite all_A in n.
Qed.

Lemma injective_index (A: finType) : injective (@index A).
Proof.
  destruct (elem A) eqn:E.
  - hnf. intros.
    assert (x el elem A) by eauto using elem_spec. rewrite E in H0. firstorder.
  - clear E. eapply (left_inv_inj (f' := (fun y => nth y (elem A) e))).
    hnf. intros. now rewrite index_nth.
Qed.


Require Import Setoid Morphisms RelationClasses Program.Basics Omega.
Require Import Equiv.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section SepAlgSect.
  Class SepAlgOps T:= {
    sa_unit : T;
    sa_mul : T -> T -> T -> Prop
  }.

  Class SepAlg T `{e : Equiv T} `{SAOps: SepAlgOps T} : Type := {
    sa_type            :> Equivalence equiv;
    sa_mon a b c d     : a === b -> sa_mul a c d -> sa_mul b c d;
    sa_mul_eq a b c d  : sa_mul a b c -> sa_mul a b d -> c === d;
    sa_mulC a b c      : sa_mul a b c -> sa_mul b a c;
    sa_mulA a b c      : forall ab abc, sa_mul a b ab -> sa_mul ab c abc ->
                                        exists bc, sa_mul b c bc /\ sa_mul a bc abc;
    sa_unitI a         : sa_mul a sa_unit a
  }.

End SepAlgSect.

Implicit Arguments SepAlg [[e] [SAOps]].

Section SepAlgCompat.
  Context A `{SA: SepAlg A}.

  Definition compat (a b : A) := exists s, sa_mul a b s.
  Definition subheap (a b : A) := exists c, sa_mul a c b.

  Lemma sa_unit_eq a b (H : sa_mul a sa_unit b) : a === b.
  Proof.
    eapply sa_mul_eq; [apply sa_unitI| assumption].
  Qed.

  Lemma sa_monR (a b c d : A) (Habc : sa_mul a b c) (Hcd: c === d) : sa_mul a b d.
  Proof.
    assert (sa_mul c sa_unit d) by (eapply sa_mon; [symmetry; eassumption | apply sa_unitI]).
    pose @sa_mulA as H1; specialize H1.
    specialize (H1 _ _ _ _ _ _ _ _ _ Habc H).
    destruct H1 as [ac [H1 H2]].
    apply sa_unit_eq in H1.
    apply sa_mulC. eapply sa_mon; [symmetry | eapply sa_mulC]; eassumption.
  Qed.

  Lemma sa_mulC2 a b c : sa_mul a b c <-> sa_mul b a c.
  Proof.
    split; apply sa_mulC.
  Qed.

End SepAlgCompat.

Module SepAlgNotations.
Notation "a '·' b" := (sa_mul a b) (at level 50, left associativity) : sa_scope.
Notation "a '·' b |-> c" := (sa_mul a b c) (at level 52, no associativity) : sa_scope.
Notation "^" := sa_unit : sa_scope.
Notation "a # b" := (compat a b) (at level 70, no associativity) : sa_scope.
Notation "a <= b" := (subheap a b) (at level 70, no associativity) : sa_scope.
End SepAlgNotations.

Instance sa_mul_equiv_proper T `{SAP : SepAlg T} :
  Proper (equiv ==> equiv ==> equiv ==> iff) sa_mul.
Proof.
  intros x y Heqxy t u Heqtu s v Heqsv; subst;
  split; intros H;
  (eapply sa_mon; [ first [eassumption | symmetry; eassumption]|]);
  apply sa_mulC;
  (eapply sa_mon; [ first [eassumption | symmetry; eassumption]|]);
  apply sa_mulC;
  (eapply sa_monR; [ first [eassumption | symmetry; eassumption]|]).
  assumption. symmetry; assumption.
Qed.

Import SepAlgNotations.

Delimit Scope sa_scope with sa.

Instance subheap_preo A `{sa : SepAlg A} : PreOrder (@subheap A SAOps).
Proof.
  split.
  + intros a; eexists; apply sa_unitI.
  + intros s0 s1 s2 H1 H2.
    assert (s1 === s1) as H4 by reflexivity.
    destruct H1 as [s10 H1].
    destruct H2 as [s21 H2].
    pose proof (@sa_mulA).
    specialize (H _ _ _ _ _ _ _ _ _ H1 H2).
    destruct H as [s4 [HEqs2 HEqs3]].
    exists s4. assumption.
Qed.

Instance compat_symm Σ `{sa : SepAlg Σ} : Symmetric (compat (A := Σ)).
Proof.
  intros s s0 [s1 Hs]; exists s1; apply sa_mulC; assumption.
Qed.

Section Properties.
  Context Σ `{sa : SepAlg Σ}.
  Open Scope sa_scope.

  Global Instance sa_subheap_equiv_proper :
    Proper (equiv ==> equiv ==> iff) (subheap (A := Σ)).
  Proof.
    intros x y Heqxy t u Heqtu; split; intros [c H]; exists c;
    [rewrite <- Heqxy; rewrite <- Heqtu | rewrite  Heqxy; rewrite Heqtu]; assumption.
  Qed.

  Global Instance sa_compat_equiv_proper :
    Proper (equiv ==> equiv ==> iff) (compat (A := Σ)).
  Proof.
    intros x y Heqxy t u Heqtu; split; [intros [s Heqxst] | intros [s Heqysu]]; exists s.
    + rewrite <- Heqxy, <- Heqtu; assumption.
    + rewrite Heqxy, Heqtu; assumption.
  Qed.

  Lemma compat_subheap {r t : Σ} (s : Σ) (Hsr: r <= s) (Hst: s # t) : r # t.
  Proof.
    destruct Hsr as [sr Hsr]; destruct Hst as [st Hst].
    apply sa_mulC in Hsr.
    pose proof @sa_mulA.
    specialize (H _ _ _ _ _ _ _ _ _ Hsr Hst).
    destruct H as [u [Hst2 Hu]].
    exists u. assumption.
  Qed.

  Lemma subheapT (a b c : Σ) (Hab: a <= b) (Hbc: b <= c) : a <= c.
  Proof.
    unfold subheap in *.
    destruct Hab as [f Hadb].
    destruct Hbc as [g Hbfc].
    destruct (sa_mulA Hadb Hbfc) as [ac [_ H]].
    exists ac. apply H.
  Qed.

  Close Scope sa_scope.

End Properties.

Implicit Arguments subheap [[A] [SAOps]].
Implicit Arguments subheapT [[Σ] [e] [SAOps] [b]].
Implicit Arguments compat_subheap [[Σ] [e] [sa] [r] [t] [SAOps]].

Section SAProd.
  Context A B `{HA: SepAlg A} `{HB: SepAlg B}.

  Global Instance SepAlgOps_prod: SepAlgOps (A * B) := {|
    sa_unit := (sa_unit, sa_unit);
    sa_mul a b c :=
      sa_mul (fst a) (fst b) (fst c) /\
      sa_mul (snd a) (snd b) (snd c)
   |}.

  Global Instance SepAlg_prod: SepAlg (A*B).
  Proof.
    split.
    - apply _.
    - intros * [Hab Hab']. simpl. rewrite Hab, Hab'. auto.
    - intros * [Habc Habc'] [Habd Habd']. split; eapply sa_mul_eq; eassumption.
    - intros * [Habc Habc']. split; eapply sa_mulC; assumption.
    - intros * [Habc Habc'] [Hbc Hbc'].
      destruct (sa_mulA Habc Hbc) as [exA []].
      destruct (sa_mulA Habc' Hbc') as [exB []].
      exists (exA, exB). split; split; assumption.
    - intros *. split; apply sa_unitI.
  Qed.

  Global Instance pair_equiv: Proper (equiv ==> equiv ==> equiv) pair.
  Proof.
    intros a a' Ha b b' Hb. split; simpl; assumption.
  Qed.
End SAProd.


Require Import Setoid.

Section SetoidBug.

Variable ms : Type.
Variable ms_type : ms -> Type.
Variable ms_eq : forall (A:ms), relation (ms_type A).

Variable CR : ms.

Record Ring : Type :=
{Ring_type : Type}.

Variable foo : forall (A:Ring), nat -> Ring_type A.
Variable IR : Ring.
Variable IRasCR : Ring_type IR -> ms_type CR.

Definition CRasCRing : Ring := Build_Ring (ms_type CR).

Hypothesis ms_refl : forall A x, ms_eq A x x.
Hypothesis ms_sym : forall A x y, ms_eq A x y -> ms_eq A y x.
Hypothesis ms_trans : forall A x y z, ms_eq A x y -> ms_eq A y z -> ms_eq A x z.

Add Parametric Relation A : (ms_type A) (ms_eq A)
  reflexivity proved by (ms_refl A)
  symmetry proved by (ms_sym A)
  transitivity proved by (ms_trans A)
  as ms_Setoid.

Hypothesis foobar : forall n, ms_eq CR (IRasCR (foo IR n)) (foo CRasCRing n).

Goal forall (b:ms_type CR),
 ms_eq CR (IRasCR (foo IR O)) b ->
 ms_eq CR (IRasCR (foo IR O)) b.
intros b H.
rewrite foobar.
rewrite foobar in H.
assumption.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defoppositeside_1 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_2 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable axiom_betweennesssymmetry_3 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable postulate_Pasch_inner_4 : (forall A B C P Q : Universe, (exists X : Universe, ((betS_ A P C /\ (betS_ B Q C /\ ~(col_ A C B))) -> (betS_ A X Q /\ betS_ B X P)))).
Variable defcollinear_5 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_6 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_7 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_8 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_9 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_10 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_11 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_inequalitysymmetric_12 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_13 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_collinearorder_14 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_betweennotequal_15 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).

Theorem lemma_9_5b_16 : (forall A B C P Q R : Universe, ((tS_ P A B C /\ (betS_ R Q P /\ (~(col_ C P R) /\ col_ A B R))) -> tS_ Q A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.