From Coq Require Import Reals Lra List.
From Flocq Require Import Core Mult_error.
From Gappa Require Import Gappa_tactic.

Open Scope R_scope.

Definition format :=  generic_format radix2 (FLX_exp 53).
Definition rnd := round radix2 (FLX_exp 53) ZnearestE.
Definition mul x y := rnd (x * y).
Definition fma x y z := rnd (x * y + z).

Lemma mul_error :
  forall x y, format x -> format y ->
  fma x y (- mul x y) = -(mul x y - x * y).
Proof.
intros x y Fx Fy.
unfold fma, rnd.
replace (x*y + - mul x y) with (-(mul x y - x*y)) by ring.
apply round_generic.
apply valid_rnd_N.
apply generic_format_opp.
apply mult_error_FLX ; try easy.
apply valid_rnd_N.
Qed.

Import ListNotations.

Definition cases x l :=
  let aux := fix aux u l :=
    match l with
    | nil => u <= x
    | cons v l => u <= x <= v \/ aux v l
    end in
  match l with
  | nil => True
  | cons u l => x <= u \/ aux u l
  end.

Lemma do_cases :
  forall x l, cases x l.
Proof.
intros x [|u l]. easy.
simpl.
match goal with |- _ \/ ?f u l => set (aux := f) end.
generalize (Rle_refl x).
generalize x at 1 3.
intros v Hv.
cut (aux v (u::l)).
{ intros [H|H].
  left. now apply Rle_trans with x.
  now right. }
revert v Hv.
induction (u :: l) as [|h q IH].
easy.
intros v Hv.
destruct (Rle_or_lt x h) as [Hx|Hx].
now left.
right.
now apply IH, Rlt_le.
Qed.

Definition mul2 '(xh, xl) '(yh, yl) :=
  let uh := mul xh yh in
  let ul := fma xh yh (-uh) in
  let v0 := fma xh yl ul in
  let v1 := fma xl yh v0 in
  (uh, v1).

Lemma mul2_error :
  forall xh xl yh yl,
  format xh -> format yh ->
  1 <= xh + xl <= 2 -> Rabs xl <= 0x1p-53 ->
  1 <= yh + yl <= 2 -> Rabs yl <= 0x1p-53 ->
  let '(zh, zl) := mul2 (xh, xl) (yh, yl) in
  let xy := (xh + xl) * (yh + yl) in
  Rabs (zh + zl - xy) <= 0x5p-106 * Rabs xy /\
  Rabs zl <= 0x1p-51 * Rabs zh.
Proof.
intros xh xl yh yl Fxh Fyh Bx By Bxl Byl.
unfold mul2.
set (xy := (xh + xl) * (yh + yl)).
set (uh := mul xh yh).
rewrite mul_error by easy.
set (ul := -(_ - _)).
cut (uh + (xl*yh + (xh*yl + ul)) - xy = - xl*yl).
2: unfold xy, ul, uh; ring.
generalize (do_cases xy [0x1.6; 0x1.c; 0x2.8]).
simpl cases.
unfold xy, ul, uh, fma, mul, rnd; gappa.
Qed.
