(* Copyright 2021 Joshua M. Cohen

Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
You may obtain a copy of the License at
    http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.
*)

(*The results we need about the specific Vandermonde matrix over the field of bytes (really, these results hold over
  any field generated by a primitive element, but we only need (and prove) the results for the byte field.
  We use a separate file because we need to very careful about the order of imports between VST and ssreflect*)
Require Import VST.floyd.functional_base.
From mathcomp Require Import all_ssreflect.
Require Import mathcomp.algebra.matrix.
Require Import mathcomp.algebra.ssralg.
Require Import mathcomp.algebra.poly.
Require Import mathcomp.algebra.polydiv.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".
Require Import ByteField.
Require Import ListPoly.
Require Import CommonSSR.
Require Import PolyField.
Require Import BoolField.
Require Import Vandermonde.
Require Import ByteFacts.
Require Import Gaussian.
Require Import GaussRestrict.

(** Results about the Weight Matrix*)

Notation B := byte_fieldType.

Section PrimitiveVandermonde.

Local Open Scope ring_scope.

(*Because the C code actually reverses the rows, we need rev of the natural choice 1, x, x^2, etc*)
Definition vandermonde_powers m n : 'M[B]_(m, n) := vandermonde m n (rev (map (fun i => (bx ^+ i)) (iota 0 n))).

(*Alternate definition, useful for rewriting*)
Lemma vandermonde_powers_val: forall (m n: nat) (i : 'I_m) (j: 'I_n),
  vandermonde_powers m n i j = (bx ^+ (i * (n - j - 1))).
Proof.
  move => m n i j. rewrite /vandermonde_powers /vandermonde mxE.
  have Hjsz: (nat_of_ord j < size (iota 0 n))%nat by rewrite size_iota. rewrite -map_rev.
  have->: [seq bx ^+ i0 | i0 <- rev(iota 0 n)]`_j = bx ^+ (n - j - 1). {
  rewrite (nth_map 0%nat) => [|//]. rewrite nth_rev=>[|//]. rewrite size_iota nth_iota.
  by rewrite add0n -subnDA addn1. apply rev_ord_proof. by rewrite size_rev. }
  by rewrite GRing.exprAC GRing.exprM.
Qed.

(*Now we need to prove [strong_inv] for this matrix*)

Lemma qpoly_to_byte_mul: forall q1 q2,
  qpoly_to_byte (@GRing.mul qpoly_p256_fieldType q1 q2)  = (qpoly_to_byte q1) * (qpoly_to_byte q2).
Proof.
  move => q1 q2. have->:(qpoly_to_byte q1 * qpoly_to_byte q2) = byte_mul (qpoly_to_byte q1) (qpoly_to_byte q2) by [].
  by rewrite /byte_mul !qpoly_byte_cancel.
Qed.

Lemma qpoly_to_byte_pow: forall (q: qpoly (Poly p256)) i,
  qpoly_to_byte (@GRing.exp qpoly_p256_fieldType q i) = (qpoly_to_byte q) ^+ i.
Proof.
  move => q i. elim : i => [| n IH /=].
  - rewrite !GRing.expr0. apply byte_to_qpoly_inj. by rewrite qpoly_byte_cancel byte_one_qpoly.
  - rewrite !GRing.exprS. by rewrite -IH qpoly_to_byte_mul.
Qed.

(*To reduce duplication. This is a straightforward application of the injectivity of [qpow_map]
  by requires work to construct and unwrap the ordinals*)

Lemma qpow_map_nonzero_inj: forall x y,
  (x < 255)%N ->
  (y < 255)%N ->
  x != 0%N ->
  (@GRing.exp qpoly_p256_fieldType (qx p256_geq_2) x) = qx p256_geq_2 ^+ y ->
   x = y.
Proof.
  move => x y Hx Hy Hx0.
  have Hxbound: (x < (#|finalg.FinRing.Field.eqType bool_finFieldType| ^ (size (Poly p256)).-1).-1)%N
    by rewrite card_bool size_p256.
  have Hybound: (y < (#|finalg.FinRing.Field.eqType bool_finFieldType| ^ (size (Poly p256)).-1).-1)%N by
    rewrite card_bool size_p256.
  have->:(@GRing.exp qpoly_p256_fieldType (qx p256_geq_2) x) = (qpow_map p256_irred p256_geq_2 (Ordinal Hxbound)) by [].
  have->:(@GRing.exp qpoly_p256_fieldType (qx p256_geq_2) y) = (qpow_map p256_irred p256_geq_2 (Ordinal Hybound)) by [].
  move=>Heqxy. apply val_inj in Heqxy. apply (bij_inj (qpow_map_bij p256_irred p256_primitive' p256_geq_2)) in Heqxy.
  by apply (f_equal (@nat_of_ord _)) in Heqxy.
Qed.

Lemma bx_pows_inj: forall i j,
  (i < 255)%N ->
  (j < 255)%N ->
  bx ^+ i = bx ^+ j ->
  i = j.
Proof.
  move => i j Hi Hj. rewrite /bx => Heq.
  apply (congr1 byte_to_qpoly) in Heq.
  move: Heq. rewrite -!qpoly_to_byte_pow !qpoly_byte_cancel.
  case Hi0: (i == 0%N).
  - apply (elimT eqP) in Hi0. subst.
    case Hj0: (j == 0%N).
    + apply (elimT eqP) in Hj0. by subst.
    + move => Hij. apply esym in Hij. apply qpow_map_nonzero_inj in Hij; try by []. by rewrite Hj0.
  - move => Hij. apply qpow_map_nonzero_inj in Hij; try by []. by rewrite Hi0.
Qed.

(*We need the above in order to prove our lists are uniq for proving the variable vandermonde submatrices invertible*)
Lemma power_list_uniq: forall (n: nat),
  (n < 256)%N ->
  uniq (map (fun i => (bx ^+ i)) (iota 0 n)).
Proof.
  move => n Hn. rewrite map_inj_in_uniq. by rewrite iota_uniq.
  move => x y. rewrite !mem_iota !add0n => /andP[Hxgt Hxn] /andP[Hygt Hyn].
  have Hyup: (y < 255)%N by apply (ltn_leq_trans Hyn).
  have Hxup: (x < 255)%N by apply (ltn_leq_trans Hxn).
  by apply bx_pows_inj.
Qed.

(*Now we deal with the matrices more directly*)

Lemma vandermonde_remove_col_list: forall m n (Hmn: (m <= n)%N) l (r:'I_m) (j: 'I_m),
  submx_remove_col (@vandermonde B m n l) Hmn r j = vandermonde r r (rem_nth (take (r.+1) l) j).
Proof.
  move => m n Hmn l r j. rewrite /submx_remove_col /vandermonde -matrixP /eqrel => x y.
  rewrite !mxE. rewrite rem_nth_nth /=. case Hyj: (y < j)%N.
  - rewrite /=. rewrite nth_take. by []. have Hyr: (y < r)%N by []. by apply (ltn_trans Hyr).
  - rewrite /=. rewrite nth_take. by []. by rewrite -(addn1 y) -(addn1 r) ltn_add2r.
Qed.

Lemma vandermonde_remove_col_unitmx: forall m n (Hmn:( m <= n)%N) (r: 'I_m) (j: 'I_m),
  (j < r)%N ->
  (n < 256)%N ->
  submx_remove_col (vandermonde_powers m n) Hmn r j \in unitmx.
Proof.
  move => m n Hmn r j Hjr Hnbound.
  rewrite vandermonde_remove_col_list. apply vandermonde_unitmx.
  - apply rem_nth_uniq. apply 0. apply take_uniq. rewrite rev_uniq. by apply power_list_uniq.
  - have Hsz: size (take r.+1 (rev  [seq (@GRing.exp _ bx i) | i <- iota 0 n])) = r.+1. {
    rewrite size_take size_rev size_map size_iota.
    have Hrm: (r.+1 <= m)%N by []. have: (r.+1 <= n)%N by apply (leq_trans Hrm Hmn).
    rewrite leq_eqVlt => /orP[/eqP Hr1n | Hr1n].
    + rewrite Hr1n. rewrite ltnn -Hr1n. apply pred_Sn.
    + rewrite Hr1n. apply pred_Sn. }
    rewrite rem_nth_size; rewrite Hsz. apply pred_Sn. by apply (ltn_trans Hjr).
Qed.

(* The row matrix is much more complicated.
  Let P be the original powers matrix. Then p_ij = x^i(n-j-1).
  So row i consists of x^i(n-1), x^i(n-2),..., x^i(n-r). We cannot simply take the transpose, because this
  is the reverse of a vandermonde matrix - every column goes in decreasing powers of x.
  So we proved a result that we can flip all the rows while preserving invertibility, allowing us to
  get x^i(n-r), x^i(n-r+1),... in each column (after transpose). But this is still not good enough, since
  we start with some extra powers of x (ie, a column might be x^4, x^6, x^8,...). So before doing the above,
  we first scalar multiply each row i by p_ir^-1 = x^-(i(n-r-1)).
  So the transformations are as follows:
  p_{ij} = x^{i(n-j-1)}
  p1_{ij} = x^{i(r-j)} (scalar multiply)
  p2_{ij} = x^{j(r-i)} (transpose)
  p3_{ij} = x^{ji} (flip all rows (i -> r.+1 - i - 1)
  Finally, p3 is a vandermonde matrix, so it is invertible. Since all of these transformations preserve
  invertibility, p is also invertible. *)

Definition scalar_mult_last_inv {m n} (Hn: (0 < n)%N) (A: 'M[B]_(m, n)) : 'M[B]_(m, n) :=
  foldr (fun (r: 'I_m) acc => sc_mul acc (A r (pred_ord Hn))^-1 r) A (ord_enum m).

Lemma scalar_mult_last_inv_val: forall {m n} (Hn: (0 < n)%N) (A: 'M[B]_(m, n)) i j,
  scalar_mult_last_inv Hn A i j = (A i j) * (A i (pred_ord Hn))^-1.
Proof.
  move => m n Hn A i j. rewrite mx_row_transform.
  - by rewrite /sc_mul mxE eq_refl GRing.mulrC.
  - move => A' i' j' r Hir'. rewrite /sc_mul mxE.
    by have->:(i' == r = false) by move: Hir'; case (i' == r).
  - move => A' B r Hin Hout j'. by rewrite /sc_mul !mxE eq_refl Hin.
  - apply ord_enum_uniq.
  - apply mem_ord_enum.
Qed.

Lemma qx_not_zero: bx != 0%R.
Proof.
  case: (bx == 0) /eqP => [ |//].
  rewrite /bx. have->:0%R = Byte.zero by []. move => Hx.
  apply (congr1 byte_to_qpoly) in Hx. move: Hx. rewrite qpoly_byte_cancel byte_zero_qpoly => Hx0.
  pose proof (qx_neq0 p256_irred p256_geq_2) as Hxnot0. move: Hxnot0. by rewrite Hx0 eq_refl.
Qed.

(*This is the big lemma that will allow us to prove the transpose of this matrix equivalent to a vandermonde mx*)
Lemma scalar_mult_last_inv_vandermonde_powers: forall {m n} (Hmn: (m <= n)%N) (r : 'I_m) y i j,
  (r <= nat_of_ord y)%N ->
  (scalar_mult_last_inv (ltn0Sn r) (submx_add_row (@vandermonde_powers m n) Hmn r y)) i j =
    bx^+ ((if (i < r)%N then nat_of_ord i else nat_of_ord y) * (r-j)).
Proof.
  move => m n Hmn r y i j Hry. rewrite scalar_mult_last_inv_val !mxE.
  have /eqP Hord: nat_of_ord (widen_ord (leq_trans (ltn_ord r) Hmn) j) == j by []. rewrite !Hord.
  have /eqP Hord' : nat_of_ord (widen_ord (leq_trans (ltn_ord r) Hmn) (pred_ord (ltn0Sn r))) == r by [].
  rewrite {Hord} !Hord' {Hord'} !nth_rev; rewrite !size_map size_iota.
  have Hnsub: forall p, (n - p.+1 < n)%N. { move => p. rewrite ltn_subrL ltn0Sn /=.
  have: (0 <= n)%N by []. rewrite leq_eqVlt => /orP[Hn0 | //]. eq_subst Hn0.
  have Hrm: (r < m)%N by []. rewrite leqn0 in Hmn. eq_subst Hmn. by []. }
  rewrite !(nth_map 0%nat); try (by rewrite size_iota). rewrite !nth_iota; try (by rewrite Hnsub).
  rewrite !add0n.
  have Hsimpl: forall (z : nat),
  (@GRing.exp B bx (n - j.+1)) ^+ z / bx ^+ (n - r.+1) ^+ z = bx ^+ (z * (r - j)). {
  move => z. have: (0 <= z)%N by []. rewrite leq_eqVlt => /orP[Hz0 | Hz].
  + eq_subst Hz0. rewrite -!GRing.exprM !muln0 mul0n !GRing.expr0. apply GRing.mulfV.
    apply GRing.oner_neq0.
  + have: (j <= r)%N by rewrite ltnSE. rewrite leq_eqVlt => /orP[Hjreq | Hlt].
    - eq_subst Hjreq. rewrite Hjreq subnn muln0 GRing.expr0. apply GRing.mulfV.
      rewrite -GRing.exprM. rewrite GRing.expf_neq0. by []. apply qx_not_zero.
    - rewrite -!GRing.exprM. rewrite -!GRing.Theory.expfB.
      2: { have Hjr1: (j.+1 < r.+1)%N by []. rewrite ltn_mul2r Hz /=.
        apply ltn_sub2l.
        have Hrm: (r.+1 <= m)%N by []. have Hjm: (j.+1 < m)%N by apply (ltn_leq_trans Hjr1 Hrm).
        apply (ltn_leq_trans Hjm Hmn). by []. }
      rewrite -mulnBl subnBA. rewrite -addnABC. rewrite addnC -subnBA.
      by rewrite subnn subn0 subSS mulnC. by rewrite leqnn.
      have Hjm: (j < m)%N by apply (ltn_trans Hlt). by apply (ltn_leq_trans Hjm Hmn). by [].
      have Hrm: (r < m)%N by []. by apply (ltn_leq_trans Hrm). }
  have: (i <= r)%N by rewrite ltnSE. rewrite leq_eqVlt => /orP[Hireq | Hlt].
  - eq_subst Hireq. rewrite Hireq ltnn. apply Hsimpl.
  - rewrite Hlt /=. apply Hsimpl.
  - have Hrm: (r < m)%N by []. by apply (ltn_leq_trans Hrm).
  - have Hjr: (j <= r)%N by rewrite -ltnS. have Hrm : (r < m)%N by [].
    have Hjm: (j < m)%N by apply (leq_ltn_trans Hjr Hrm). by apply (ltn_leq_trans Hjm).
Qed.

(*The row matrix is a bit more complicated. The resulting matrix isn't Vandermonde, but
  if we transpose it and then flip all the rows, then it is. So we use the [flip_rows] result as well*)

Lemma vandermonde_powers_add_row_list: forall m n (Hmn: (m <= n)%N) (r j:'I_m),
  (r <= j)%N ->
  flip_rows ((scalar_mult_last_inv (ltn0Sn r) (submx_add_row (@vandermonde_powers m n) Hmn r j))^T) =
    vandermonde (r.+1) (r.+1) ((map (fun i => (bx ^+ i)) (iota 0 r)) ++ (bx ^+ j :: nil)).
Proof.
  move => m n Hmn r j Hrj. rewrite /flip_rows /vandermonde -matrixP /eqrel => x y.
  rewrite mxE mxE scalar_mult_last_inv_vandermonde_powers. 2: by []. rewrite  !mxE.
  have Hxn: (x < n)%N. have Hxr: (x < r.+1)%N by []. rewrite ltnS in Hxr.
    have Hrm: (r < m)%N by []. have Hxm: (x < m)%N by apply (leq_ltn_trans Hxr Hrm).
    by apply (ltn_leq_trans Hxm Hmn).
  have Hx: (r - (r.+1 - x.+1))%nat = x by rewrite subSS subKn // -ltnS.
  have: (y < r.+1)%N by []. rewrite ltnS leq_eqVlt => /orP[/eqP Hyr | Hyr].
  - rewrite Hyr ltnn. rewrite nth_cat.
    rewrite size_map size_iota ltnn subnn /=. by rewrite Hx -GRing.exprM.
  - rewrite Hyr /=. rewrite nth_cat size_map size_iota Hyr.
    rewrite !(nth_map 0%nat) /=. rewrite !nth_iota.
    rewrite !add0n. by rewrite Hx -GRing.exprM. by []. by rewrite size_iota.
Qed.

Lemma vandermonde_add_row_unitmx: forall m n (Hmn: (m <= n)%N) (r j:'I_m),
  (r <= j)%N ->
  (n < 256)%N ->
  submx_add_row (vandermonde_powers m n) Hmn r j \in unitmx.
Proof.
  move => m n Hmn r j Hrj Hn.
  (*lots of layers to show*)
  have Hinv: row_equivalent (submx_add_row (vandermonde_powers m n) Hmn r j)
    (scalar_mult_last_inv (ltn0Sn r) (submx_add_row (vandermonde_powers m n) Hmn r j)). {
  apply mx_row_transform_equiv. move => A' r'. apply ero_row_equiv. apply ero_sc_mul.
  rewrite !mxE /=. (*need to do it here to show that not zero*)
  have Hnr: (n - r.+1 < n)%N.  rewrite ltn_subrL ltn0Sn /=. have: (0 <= n)%N by [].
  rewrite leq_eqVlt => /orP[Hn0 | //]. eq_subst Hn0.
  have Hrm: (r < m)%N by []. rewrite leqn0 in Hmn. eq_subst Hmn. by [].
  rewrite nth_rev size_map size_iota. rewrite (nth_map 0%nat). rewrite nth_iota.
  rewrite add0n -!GRing.exprVn -GRing.exprM GRing.expf_neq0. by [].
  apply GRing.invr_neq0. apply qx_not_zero. by []. by rewrite size_iota.
  have Hrm: (r < m)%N by []. by apply (ltn_leq_trans Hrm). }
  apply row_equivalent_unitmx_iff in Hinv. rewrite Hinv {Hinv}.
  rewrite -unitmx_tr flip_rows_unitmx vandermonde_powers_add_row_list =>[|//].
  apply vandermonde_unitmx.
  - rewrite cats1 rcons_uniq.
    have->: (bx ^+ j \notin [seq (bx ^+ i) | i <- iota 0 r]). {
      case: (bx ^+ j \in [seq bx ^+ i | i <- iota 0 r]) /mapP =>[[i Hi Heq]|//].
      move : Hi; rewrite mem_iota add0n => /andP[H{H} Hir].
      have Hjbound: (j < 255)%N. have Hjm: (j < m)%N by []. have Hjn: (j < n)%N by apply (ltn_leq_trans Hjm Hmn).
        apply (ltn_leq_trans Hjn Hn).
      apply bx_pows_inj in Heq.
      + subst. have: (r < r)%N by apply (leq_ltn_trans Hrj). by rewrite ltnn.
      + by [].
      + have Hij: (i < j)%N by apply (ltn_leq_trans Hir Hrj). apply (ltn_trans Hij Hjbound). }
    rewrite /=. apply power_list_uniq.
    apply (leq_ltn_trans Hrj).  have Hjm: (j < m)%N by []. apply (ltn_trans Hjm).
    by apply (leq_ltn_trans Hmn).
  - by rewrite size_cat /= size_map size_iota addn1.
Qed.

(*Finally, the result we want: The Vandermonde matrix consisting of powers of the primitive element
  satisfied [strong_inv 0]*)
Lemma vandermonde_strong_inv: forall m n (Hmn: (m <= n)%N) (Hm: (0 < m)%N),
  (n < 256)%N ->
  strong_inv (vandermonde_powers m n) Hm Hmn.
Proof.
  move => m n Hmn Hm Hn. rewrite /strong_inv => r' H{H}.
  split; move => j Hrj.
  - by apply vandermonde_remove_col_unitmx.
  - by apply vandermonde_add_row_unitmx.
Qed.

End PrimitiveVandermonde.

Require Import ListMatrix.
Require Import ZSeq.
Require Import MatrixTransform.

(*Weight matrix definition*)
Section WeightMx.

Local Open Scope ring_scope.

Definition weight_mx_list (m n : Z) : lmatrix B :=
  mk_lmatrix m n (fun i j => bx ^+  Z.to_nat (i * (n - j - 1))).

Lemma weight_matrix_wf: forall m n, 0 <= n -> 0 <= m -> wf_lmatrix (weight_mx_list m n) m n.
Proof.
  move => m n Hn Hm. by apply mk_lmatrix_wf.
Qed.

Lemma weight_mx_list_spec: forall m n,
  0 <= m ->
  0 <= n ->
  lmatrix_to_mx m n (weight_mx_list m n) = vandermonde_powers (Z.to_nat m) (Z.to_nat n).
Proof.
  move => m n Hm Hn. rewrite -matrixP => x y.
  have Hx: 0 <= Z.of_nat x < m by apply (Z_ord_bound).
  have Hy: 0 <= Z.of_nat y < n by apply (Z_ord_bound).
  rewrite vandermonde_powers_val mxE mk_lmatrix_get //=. f_equal.
  have->: (x * (Z.to_nat n - y - 1))%N = (x * (Z.to_nat n - y - 1))%coq_nat by []. (*lia and nia not enough*)
  rewrite Z2Nat.inj_mul; try lia. rewrite Nat2Z.id Z2Nat.inj_sub; try lia.
  rewrite Z2Nat.inj_sub; try lia. by rewrite Nat2Z.id Nat.mul_sub_distr_l.
Qed.

Definition weight_mx := (gauss_restrict_list fec_max_h (fec_n -1)
            (weight_mx_list fec_max_h  (fec_n - 1))).

Lemma weight_mx_wf: wf_lmatrix weight_mx (fec_max_h) (fec_n - 1).
Proof.
  apply gauss_restrict_list_wf. apply weight_matrix_wf; rep_lia.
Qed.

End WeightMx.


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

Require Export CoRN.model.ordfields.Qordfield.
Require Export CoRN.reals.Cauchy_CReals.

(**
* Cauchy Real Numbers
Earlier we defined a construction of a real number structure from an
arbitrary archimedian ordered field.  Plugging in [Q] we get the model
of the real numbers as Cauchy sequences of rationals.
*)

Definition Cauchy_IR : CReals := R_as_CReals _ Q_is_archemaedian.

(** The term [Cauchy_IR] is of type [CReals]. *)

Close Scope Q_scope.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                           PickSuccessfulInput.v                          *)
(****************************************************************************)

Require Export SuccessfulInput.
Require Export Manip_BoolLists.

Set Implicit Arguments.
Unset Strict Implicit.

Section Filter_and_Pick.

  Let Inportno := T_Inportno 4.

  Variable actives priorities requests : d_list bool 4.

  Let d_map_andb := d_map2 andb (n:=4).
  Let eq_true (b : bool) := b = true :>bool.

 (* "and" between two bool lists *)
  Let and2 (l m : d_list bool 4) := d_map_andb l m.

 (* "and" between three bool lists *)
  Let and3 (l m n : d_list bool 4) := d_map_andb (and2 l m) n.

 (** Filters out low priority requests for an output and request signals from **)
 (** non-active inputs                                                        **)

  Definition PriorityRequests :=
    match
      Exists1_atleast_or_not eq_true (and3 actives priorities requests)
    with
    | left _ => and3 actives priorities requests
    | right _ => and2 actives requests
    end.

 (** Picks the successful input port **)

  Definition PickSuccessfulInput (last : Inportno) :=
    SuccessfulInput PriorityRequests last.

End Filter_and_Pick.


(**************************************************
 * Author: Ana Nora Evans (ananevans@virginia.edu)
 **************************************************)
Require Import Coq.Bool.Bool.
Require Import Coq.NArith.BinNat.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.

Require Import CompCert.Events.
Require Import TargetSFI.Machine.
Require Import TargetSFI.ExecutionError.
Require Import Tests.TargetSFI.SFITestUtil.
Require Import Tests.IntermediateProgramGeneration.
Require Import Tests.CompilerPBTests.

Require Import Tests.I2SFI.SFIPBTests.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Import QcNotation. Open Scope qc_scope.
Import GenLow GenHigh.

Open Scope string.

Inductive jump_type :=
| Indirect : RiscMachine.Register.t -> jump_type
| Direct : jump_type.
Definition jump_log_entry := (RiscMachine.pc * RiscMachine.address
                              * jump_type * CompCert.Events.trace)%type.

Instance show_jump_type : Show jump_type :=
  {|
    show :=
      fun t =>
        match t with
        | Indirect r => "Jmp " ++ (show r)
        | Direct => "Jal"
        end
  |}.

Definition show_jump_log_entry (entry : jump_log_entry) : string :=
  let '(pc,addr,type,t) := entry in
   "pc: " ++ (show_addr pc)
          ++ " ptr: "
          ++ (show_addr addr)
          ++ " type: "
          ++ ( match type with
               | Indirect r => "Jmp " ++ (show r)
               | Direct => "Jal"
               end)
          ++ " trace: " ++ (show t).

Definition update_jump_log
           (G : Env.t)
           (st : MachineState.t) (t : CompCert.Events.trace)
           (st' : MachineState.t)
           log :=
  let '(mem,pc,regs) := st in
  let '(j_log,addr_log) := log in
  let nlog :=
      (if (Nat.eqb (List.count_occ N.eq_dec addr_log pc) 0%nat)
      then (addr_log ++ pc::nil)%list
      else addr_log)
  in
  match RiscMachine.Memory.get_word mem pc with
  | Some (RiscMachine.Instruction instr) =>
    match instr with
    | RiscMachine.ISA.IJump r  =>
      if (N.eqb r RiscMachine.Register.R_RA) || (N.eqb r RiscMachine.Register.R_T)
      then
        match RiscMachine.RegisterFile.get_register r regs with
        | Some ptr =>
          ( (j_log ++ (pc, RiscMachine.Memory.to_address ptr,Indirect r,t)::nil)%list,
           nlog)
        | _ => (j_log,nlog)
        end
      else (j_log,nlog)
    | RiscMachine.ISA.IJal addr => ((j_log ++ (pc,addr,Direct,t)::nil)%list,nlog)
    | _ => (j_log,nlog)
    end
  | _ => (j_log,nlog)
  end.

(* 1. number of instr exec,
   2. number of internal jumps,
   3. number of cross component jumps
   5. number of static instructions executed
*)
Definition jump_stat := (nat * nat * nat * nat)%type.

(* dynamic instr, static instr,
   # of internal jump instr executed,
   # of cross-component jumps,
 *)
Instance show_jump_stat : Show jump_stat :=
  {|
    show :=
      fun ss =>
        let '(steps, i, e, si) := ss in
        (show  steps)
           ++ "," ++ (show si)
           ++ "," ++ (show i )
           ++ "," ++ (show e)
  |}.

Definition jump_stats
           (log : (log_type jump_log_entry))
           (steps : nat) : jump_stat :=
  let '(l1,l2) := log in
  let i := (List.length
              (List.filter
                 (fun '(pc,addr,type,t) =>
                    (SFI.is_same_component_bool pc addr)
                    || (N.eqb (SFI.C_SFI addr) SFI.MONITOR_COMPONENT_ID)
                    || (N.eqb (SFI.C_SFI pc) SFI.MONITOR_COMPONENT_ID)
                 ) l1
              )
           ) in
  let e := (List.length
              (List.filter
                 (fun  '(pc,addr,type,t) =>
                    negb (
                        (SFI.is_same_component_bool pc addr)
                        || (N.eqb (SFI.C_SFI addr) SFI.MONITOR_COMPONENT_ID)
                        || (N.eqb (SFI.C_SFI pc) SFI.MONITOR_COMPONENT_ID)
                      )
                 ) l1
              )
           ) in
  ((steps,i), e, List.length l2).

Definition entry_checker (entry : jump_log_entry) : Checker :=
  let '(pc,addr,type,t) := entry in
  if (SFI.is_same_component_bool pc addr)
  then
    match t with
    | nil =>  whenFail (  "Register R_T expected in internal jumps "
                          ++ (show_jump_log_entry (pc,addr,type,t)))
                      (match type with
                       | Indirect r => RiscMachine.Register.eqb
                                        RiscMachine.Register.R_T r
                       | Direct => true
                       end)
    | _ => whenFail (  "Unexpectected event at log entry:"
                        ++ (show_jump_log_entry (pc,addr,type,t)))
                   false
    end
  else
    match t with
    | _::_ =>  whenFail ( (show_addr pc)
                          ++ ": Register R_A expected in internal jumps "
                          ++ (show type))
                       (match type with
                        | Indirect r => RiscMachine.Register.eqb
                                         RiscMachine.Register.R_RA r
                        | Direct => true
                        end)
    | nill => whenFail ("Unexpectected empty event at log entry:"
                         ++ (show_jump_log_entry (pc,addr,type,t)))
                      false
    end.

Fixpoint entries_checker (l : list jump_log_entry) : Checker :=
  match l with
  | nil => checker true
  | (pc,addr,type,t)::nil =>
    if (N.eqb (SFI.C_SFI addr) SFI.MONITOR_COMPONENT_ID)
    then checker true
    else entry_checker (pc,addr,type,t)
  | e::xs => conjoin ((entry_checker e)::(entries_checker xs)::nil)
  end.

Definition jump_log_checker
           (log :(log_type jump_log_entry))
           (res : CompCert.Events.trace*MachineState.t*nat) : Checker :=
  let (_,steps) := res in
  let (l1,l2) := log in
  collect
    (jump_stats log steps)
    match l1 with
    | nil => checker tt
    | (pc,addr,type,t)::xsl1 =>
      if (N.eqb (SFI.C_SFI pc) SFI.MONITOR_COMPONENT_ID)
      then
        entries_checker xsl1
      else
        whenFail "jump_checker:"
                 (checker false)
    end.

Definition jump_log_checker_error
           (log : log_type jump_log_entry) err :=
  match err with
  | DataMemoryException _ _ _
  | UninitializedMemory _ _ =>
    whenFail "jump_correct:Datamemoryexception or Uninitializedmemory"
             (checker false)
  | _ =>
    whenFail
      ("TargetExecutionError:" ++ (show err))
      (* TODO get the trace here *)
      (jump_log_checker log ((nil,get_state err),0%nat))
  end.

Definition jump_correct (fuel : nat) :=
  sfi_check_correct NoUndef CJump update_jump_log jump_log_checker_error jump_log_checker fuel.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus Zero lv0) (plus (plus lv1 lv2) (mult lv3 lv2))).
Admitted.
QuickChick conj5synthconj5.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^194 - 33
Base: 48.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 48 + 1/2;
    bitwidth := 64;
    s := 2^194;
    c := [(1, 33)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^321 - 9
Base: 26.75
***)

Definition curve : CurveParameters :=
  {|
    sz := 12%nat;
    base := 26 + 3/4;
    bitwidth := 32;
    s := 2^321;
    c := [(1, 9)];
    carry_chains := Some [seq 0 (pred 12); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import progs.conclib.
Require Import List.
Require Import msl.eq_dec.
Require Import Arith.
Require Import Wf_nat.
Require Import VectorClocks.
Import ListNotations.

Close Scope Z.
Set Implicit Arguments.

(* Step 1: treat acquire loads and release stores as acquires and releases.
   In fact, since atomics can't race, atomic locations are treated as locks rather than variables.
   Relaxed operations are just noops... at first. *)

(* Race detection occurs in two phases. First, we take an SC trace and use vector clocks on it.
   Second, we use lifting to generate a set of relaxed traces represented by the SC trace.
   Section 6 describes the correctness property for the latter part. It may not be useful to prove any
   properties of just part 1. *)

Section C11Clocks.
  Context `{Types : VC_base}.

  (* Basic definitions (Section 2) *)
  Inductive operation :=
  | rd (t : tid) (x : var)
  | wr (t : tid) (x : var)
  | ldacq (t : tid) (m : lock)
  | strel (t : tid) (m : lock)
  | ldrlx (t : tid) (m : lock)
  | strlx (t : tid) (m : lock)
  | rmwrlx (t : tid) (m : lock)
  | rmwacq (t : tid) (m : lock)
  | rmwrel (t : tid) (m : lock)
  | facq (t : tid)
  | frel (t : tid).

  Global Instance op_eq : EqDec operation.
  Proof. hnf. decide equality. Qed.

  Definition trace := list operation.

(*  Definition thread_of a := match a with
  | rd t _ => t
  | wr t _ => t
  | acq t _ => t
  | rel t _ => t
  | fork t _ => t
  | join t _ => t
  end.

  Definition locks a m := exists t, a = acq t m \/ a = rel t m.
  Definition fjs a u := exists t, a = fork t u \/ a = join t u.
  Definition writes a x := exists t, a = wr t x.
  Definition accesses a x := exists t, a = rd t x \/ a = wr t x.
  Definition uses_thread a t := thread_of a = t \/ fjs a t.

  Inductive happens_before (tr : trace) i j : Prop :=
  | hb_prog_order a b (Hlt : i < j) (Ha : nth_error tr i = Some a)
      (Hb : nth_error tr j = Some b) (Hthread : thread_of a = thread_of b)
  | hb_locking a b (Hlt : i < j) (Ha : nth_error tr i = Some a)
      (Hb : nth_error tr j = Some b) m (Hlocka : locks a m) (Hlockb : locks b m)
  | hb_fork_join a b (Hlt : i < j) (Ha : nth_error tr i = Some a)
      (Hb : nth_error tr j = Some b)
(*      (Hfj : fjs a (thread_of b) \/ fjs b (thread_of a))
    Most of the feasibility conditions of FastTrack serve solely to produce
    the following looser definition of fork-join synchronization. *)
      t (Ha : uses_thread a t) (Hb : uses_thread b t)
  | hb_trans k (Hhb1 : happens_before tr i k) (Hhb2 : happens_before tr k j).*)

End VectorClocks.


From iris Require Import program_logic.weakestpre.
From iris.proofmode Require Import tactics.

From st.STLCmuVS Require Import lang.
From st.STLCmuST Require Import lang wkpre.

Section lift.

  Context `{Σ : !gFunctors}.
  Context `{irisGS_inst : !irisGS STLCmuST_lang Σ}.

  Context (s : stuckness).

  Definition lift (Φ : valO -n> STLCmuVS.lang.valO -n> iPropO Σ) : exprO → STLCmuVS.lang.exprO → iProp Σ :=
    fun eᵢ eₛ => (WP eᵢ @ s ; top {{ vᵢ, ∃ vₛ, ⌜ rtc STLCmuVS_step eₛ (STLCmuVS.lang.of_val vₛ) ⌝ ∧ Φ vᵢ vₛ }})%I.

  Lemma lift_bind (Kᵢ : list ectx_item) (Kₛ : list STLCmuVS.lang.ectx_item) (Φ Ψ : valO -n> STLCmuVS.lang.valO -n> iPropO Σ)
        (eᵢ : expr) (eₛ  : STLCmuVS.lang.expr) :
    ⊢ lift Φ eᵢ eₛ -∗ (∀ vᵢ vₛ, Φ vᵢ vₛ -∗ lift Ψ (fill Kᵢ (of_val vᵢ)) (fill Kₛ (STLCmuVS.lang.of_val vₛ))) -∗ lift Ψ (fill Kᵢ eᵢ) (fill Kₛ eₛ).
  Proof.
    iIntros "HΦeN H". rewrite /lift.
    iApply wp_bind'. iApply (wp_wand with "HΦeN").
    iIntros (v). iIntros "des". iDestruct "des" as (v') "[%HNv' Hvv']".
    iSpecialize ("H" $! v v' with "Hvv'").
    iApply (wp_wand with "H").
    iIntros (w). iIntros "des". iDestruct "des" as (w') "[%HKₛv'w' Hww']".
    iExists w'. iFrame. iPureIntro.
    apply (rtc_transitive _ (fill Kₛ v')); auto. simpl in *.
    by apply (rtc_STLCmuVS_step_ctx (fill Kₛ)).
  Qed.

  Lemma lift_rtc_steps Φ eᵢ e e' (H : rtc STLCmuVS_step e e') : lift Φ eᵢ e' ⊢ lift Φ eᵢ e.
  Proof.
    iIntros "H". iApply (wp_wand with "H").
    iIntros (v) "des". iDestruct "des" as (w') "[%H1 H2]". iExists w'. iFrame "H2".
    iPureIntro. by eapply rtc_transitive.
  Qed.

  Lemma lift_pure_step_later Φ e e' eₛ (H : pure_step e e') : ▷ lift Φ e' eₛ ⊢ lift Φ e eₛ.
  Proof. by iApply wp_pure_step_later. Qed.

  Lemma lift_step Φ eᵢ e e' (H : STLCmuVS_step e e') : lift Φ eᵢ e' ⊢ lift Φ eᵢ e.
  Proof. iApply lift_rtc_steps. by apply rtc_once. Qed.

  Lemma lift_val (Ψ : valO -n> STLCmuVS.lang.valO -n> iPropO Σ) vᵢ vₛ : (Ψ vᵢ vₛ) ⊢ lift Ψ vᵢ vₛ.
  Proof. iIntros "Hv". rewrite /lift. iApply wp_value'. iExists vₛ. auto. Qed.

  Lemma lift_val_fupd (Ψ : valO -n> STLCmuVS.lang.valO -n> iPropO Σ) vᵢ vₛ : (|={⊤}=> Ψ vᵢ vₛ) ⊢ lift Ψ vᵢ vₛ.
  Proof. iIntros "Hv". rewrite /lift. iApply wp_value_fupd'. iExists vₛ. iMod "Hv". iModIntro. iSplit; auto. Qed.

  Lemma lift_wand (Φ Ψ : valO -n> STLCmuVS.lang.valO -n> iPropO Σ) e e' :
    ⊢ (∀ v v', Φ v v' -∗ Ψ v v') -∗ lift Φ e e' -∗ lift Ψ e e'.
  Proof.
    iIntros "H Hee'". rewrite /lift.
    iApply (wp_wand with "Hee'"). iIntros (v) "Hdes".
    iDestruct "Hdes" as (v') "[%He'v' HΦ]".
    iExists v'. iSplit. auto. by iApply "H".
  Qed.

End lift.


Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Export Maps.
Require Import Events.
Require Import Globalenvs.

Require Import mem_lemmas. (*for mem_forward*)
Require Import semantics.
Require Import effect_semantics.

Require Import Cop. (*for sem_cast*)
Require Import Ctypes. (*for access_mode*)
Require Import Clight.
Require Import Clight_coop.
Require Import BuiltinEffects.

Definition assign_loc_Effect (ty:type) (b: block) (ofs: int) : (block -> Z -> bool)  :=
  match access_mode ty with
     By_value chunk => fun b' z' => eq_block b b'
              && zle (Int.unsigned ofs) z'
              && zlt z' ((Int.unsigned ofs) + Z.of_nat (size_chunk_nat chunk))
   | By_copy => fun b' z' => eq_block b' b
              && zle (Int.unsigned ofs) z'
              && zlt z' ((Int.unsigned ofs) + (sizeof ty))
   | _ => fun b' z' => false
  end.

Lemma assign_loc_Effect_Sound: forall a m loc ofs v m'
      (AL: assign_loc (typeof a) m loc ofs v m'),
     Mem.unchanged_on (fun b z => assign_loc_Effect (typeof a)
                            loc ofs b z = false) m m'.
Proof. intros. inv AL.
inv H0.
(*access_mode (typeof a) = By_value chunk*)
  split; intros.
  (*perm*)
    split; intros.
    eapply Mem.perm_store_1; eassumption.
    eapply Mem.perm_store_2; eassumption.
  (*memcontents*)
    rewrite (Mem.store_mem_contents _ _ _ _ _ _ H2).
    unfold assign_loc_Effect in H0; rewrite H in H0.
    destruct (eq_block loc b); subst; simpl in H0.
      rewrite PMap.gss. rewrite andb_false_iff in H0.
      apply Mem.setN_other. intros; intros N. subst.
      destruct H3.
      destruct (zle (Int.unsigned ofs) ofs0); simpl in *.
        destruct H0; try discriminate.
        rewrite encode_val_length in H4.
        destruct (zlt ofs0 (Int.unsigned ofs + Z.of_nat (size_chunk_nat chunk))); simpl in *. discriminate.
        omega.
      omega.
    rewrite PMap.gso; trivial. intros N; subst; apply n; trivial.
(*access_mode (typeof a) = By_copy*)
  split; intros.
  (*perm*)
    split; intros.
    eapply Mem.perm_storebytes_1; eassumption.
    eapply Mem.perm_storebytes_2; eassumption.
  (*memcontents*)
    rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H4).
    unfold assign_loc_Effect in H5; rewrite H in H5.
    destruct (eq_block b loc); subst; simpl in H5.
      rewrite PMap.gss. rewrite andb_false_iff in H5.
      apply Mem.setN_other. intros; intros N. subst.
      destruct H7.
      destruct (zle (Int.unsigned ofs) ofs0); simpl in *.
        destruct H5; try discriminate.
        destruct (zlt ofs0 (Int.unsigned ofs + sizeof (typeof a))); simpl in *. discriminate.
        apply Mem.loadbytes_length in H3. rewrite H3 in H8.
          rewrite nat_of_Z_eq in H8. omega.
          assert (ZZZ:= sizeof_pos (typeof a)). omega.
      omega.
    rewrite PMap.gso; trivial.
Qed.

Lemma alloc_variables_unchanged_on:
      forall P args env m e m' (H:alloc_variables env m args e m'),
      Mem.unchanged_on P m m'.
Proof. intros P args.
  induction args; simpl; intros; inv H.
    apply Mem.unchanged_on_refl.
  apply IHargs  in H7.
  specialize (alloc_forward _ _ _ _ _ H4). intros.
  eapply unchanged_on_trans;  try eassumption.
  eapply Mem.alloc_unchanged_on. eassumption.
Qed.

Lemma alloc_variables_freshblocks: forall vars E m e m1
      (AL: alloc_variables E m vars e m1)
      id b t (Hid: e!id = Some (b,t)),
      E!id = Some (b,t) \/ ~Mem.valid_block m b.
Proof. intros vars.
  induction vars; simpl; intros; inv AL; simpl in *.
    left; trivial.
  destruct (IHvars _ _ _ _ H6 _ _ _ Hid); clear IHvars.
    rewrite PTree.gsspec in H.
    destruct (peq id id0); subst.
      inv H. right. eapply Mem.fresh_block_alloc; eassumption.
      left; trivial.
    right. intros N; elim H; clear H.
      eapply Mem.valid_block_alloc; eassumption.
Qed.

Lemma assign_loc_forward: forall ty m b ofs v m1
      (A: assign_loc ty m b ofs v m1),
      mem_forward m m1.
Proof. intros.
  inv A.
   inv H0. eapply (store_forward _ _ _ _ _ _ H2).
   eapply (storebytes_forward _ _ _ _ _ H4).
Qed.

Section CLIGHT_EFF.
Variable hf : I64Helpers.helper_functions.

Section EFFSEM.
Variable FE:function -> list val -> mem -> env -> temp_env -> mem -> Prop.

Inductive clight_effstep (ge:genv): (block -> Z -> bool) ->
            CL_core -> mem -> CL_core -> mem -> Prop :=
  | clight_effstep_assign:   forall f a1 a2 k e le m loc ofs v2 v m',
      eval_lvalue ge e le m a1 loc ofs ->
      eval_expr ge e le m a2 v2 ->
      sem_cast v2 (typeof a2) (typeof a1) = Some v ->
      assign_loc (typeof a1) m loc ofs v m' ->
      clight_effstep ge (assign_loc_Effect (typeof a1) loc ofs)
        (CL_State f (Sassign a1 a2) k e le) m
        (CL_State f Sskip k e le) m'

  | clight_effstep_set:   forall f id a k e le m v,
      eval_expr ge e le m a v ->
      clight_effstep ge EmptyEffect (CL_State f (Sset id a) k e le) m
        (CL_State f Sskip k e (PTree.set id v le)) m

  | clight_effstep_call:   forall f optid a al k e le m tyargs tyres vf vargs fd,
      classify_fun (typeof a) = fun_case_f tyargs tyres ->
      eval_expr ge e le m a vf ->
      eval_exprlist ge e le m al tyargs vargs ->
      Genv.find_funct ge vf = Some fd ->
      type_of_fundef fd = Tfunction tyargs tyres ->
      clight_effstep ge EmptyEffect (CL_State f (Scall optid a al) k e le) m
        (CL_Callstate fd vargs (Kcall optid f e le k)) m

  | clight_effstep_builtin:   forall f optid ef tyargs al k e le m vargs t vres m',
      eval_exprlist ge e le m al tyargs vargs ->
      external_call ef ge vargs m t vres m' ->
      ~ observableEF hf ef ->
      clight_effstep ge (BuiltinEffect ge ef vargs m)
         (CL_State f (Sbuiltin optid ef tyargs al) k e le) m
         (CL_State f Sskip k e (set_opttemp optid vres le)) m'

  | clight_effstep_seq:  forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect (CL_State f (Ssequence s1 s2) k e le) m
        (CL_State f s1 (Kseq s2 k) e le) m

  | clight_effstep_skip_seq: forall f s k e le m,
      clight_effstep ge EmptyEffect (CL_State f Sskip (Kseq s k) e le) m
        (CL_State f s k e le) m
  | clight_effstep_continue_seq: forall f s k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Scontinue (Kseq s k) e le) m
        (CL_State f Scontinue k e le) m

  | clight_effstep_break_seq: forall f s k e le m,
      clight_effstep ge EmptyEffect (CL_State f Sbreak (Kseq s k) e le) m
        (CL_State f Sbreak k e le) m

  | clight_effstep_ifthenelse:  forall f a s1 s2 k e le m v1 b,
      eval_expr ge e le m a v1 ->
      bool_val v1 (typeof a) = Some b ->
      clight_effstep ge EmptyEffect
        (CL_State f (Sifthenelse a s1 s2) k e le) m
        (CL_State f (if b then s1 else s2) k e le) m

  | clight_effstep_loop: forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f (Sloop s1 s2) k e le) m
        (CL_State f s1 (Kloop1 s1 s2 k) e le) m
  | clight_effstep_skip_or_continue_loop1:  forall f s1 s2 k e le m x,
      x = Sskip \/ x = Scontinue ->
      clight_effstep ge EmptyEffect
        (CL_State f x (Kloop1 s1 s2 k) e le) m
        (CL_State f s2 (Kloop2 s1 s2 k) e le) m
  | clight_effstep_break_loop1:  forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Sbreak (Kloop1 s1 s2 k) e le) m
        (CL_State f Sskip k e le) m
  | clight_effstep_skip_loop2: forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Sskip (Kloop2 s1 s2 k) e le) m
        (CL_State f (Sloop s1 s2) k e le) m
  | clight_effstep_break_loop2: forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Sbreak (Kloop2 s1 s2 k) e le) m
        (CL_State f Sskip k e le) m

  | clight_effstep_return_0: forall f k e le m m',
      Mem.free_list m (blocks_of_env e) = Some m' ->
      clight_effstep ge (FreelistEffect m (blocks_of_env e))
        (CL_State f (Sreturn None) k e le) m
        (CL_Returnstate Vundef (call_cont k)) m'
  | clight_effstep_return_1: forall f a k e le m v v' m',
      eval_expr ge e le m a v ->
      sem_cast v (typeof a) f.(fn_return) = Some v' ->
      Mem.free_list m (blocks_of_env e) = Some m' ->
      clight_effstep ge (FreelistEffect m (blocks_of_env e))
        (CL_State f (Sreturn (Some a)) k e le) m
        (CL_Returnstate v' (call_cont k)) m'
  | clight_effstep_skip_call: forall f k e le m m',
      is_call_cont k ->
      Mem.free_list m (blocks_of_env e) = Some m' ->
      clight_effstep ge (FreelistEffect m (blocks_of_env e))
        (CL_State f Sskip k e le) m
        (CL_Returnstate Vundef k) m'

  | clight_effstep_switch: forall f a sl k e le m n,
      eval_expr ge e le m a (Vint n) ->
      clight_effstep ge EmptyEffect
       (CL_State f (Sswitch a sl) k e le) m
        (CL_State f (seq_of_labeled_statement (select_switch n sl)) (Kswitch k) e le) m
  | clight_effstep_skip_break_switch: forall f x k e le m,
      x = Sskip \/ x = Sbreak ->
      clight_effstep ge EmptyEffect
        (CL_State f x (Kswitch k) e le) m
        (CL_State f Sskip k e le) m
  | clight_effstep_continue_switch: forall f k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Scontinue (Kswitch k) e le) m
        (CL_State f Scontinue k e le) m

  | clight_effstep_label: forall f lbl s k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f (Slabel lbl s) k e le) m
        (CL_State f s k e le) m

  | clight_effstep_goto: forall f lbl k e le m s' k',
      find_label lbl f.(fn_body) (call_cont k) = Some (s', k') ->
      clight_effstep ge EmptyEffect
        (CL_State f (Sgoto lbl) k e le) m
        (CL_State f s' k' e le) m

  | clight_effstep_internal_function: forall f vargs k m e le m',
      FE f vargs m e le m' ->
      clight_effstep ge EmptyEffect
        (CL_Callstate (Internal f) vargs k) m
        (CL_State f f.(fn_body) k e le) m'

(*All external calls in this language at handled by atExternal
  | step_external_function: forall ef targs tres vargs k m vres t m',
      external_call ef ge vargs m t vres m' ->
      clight_effstep (CL_Callstate (External ef targs tres) vargs k) m
         (CL_Returnstate vres k) m'
*)

  | clight_effstep_returnstate: forall v optid f e le k m,
      clight_effstep ge EmptyEffect
        (CL_Returnstate v (Kcall optid f e le k)) m
        (CL_State f Sskip k e (set_opttemp optid v le)) m.

Variable FE_FWD: forall f vargs m e le m', FE f vargs m e le m' -> mem_forward m m'.
Variable FE_UNCH: forall f vargs m e le m', FE f vargs m e le m'->
         Mem.unchanged_on (fun b z => EmptyEffect b z = false) m m'.

Lemma clightstep_effax1: forall (M : block -> Z -> bool) ge c m c' m'
      (H: clight_effstep ge M c m c' m'),
       corestep (CL_coop_sem hf FE FE_FWD) ge c m c' m' /\
       Mem.unchanged_on (fun (b : block) (ofs : Z) => M b ofs = false) m m'.
Proof.
intros.
  induction H.
  split. econstructor; try eassumption.
         eapply assign_loc_Effect_Sound; eassumption.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl. econstructor; eassumption.
         eapply BuiltinEffect_unchOn; eassumption.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         eapply FreelistEffect_freelist; eassumption.
  split. econstructor; try eassumption.
         eapply FreelistEffect_freelist; eassumption.
  split. econstructor; try eassumption.
         eapply FreelistEffect_freelist; eassumption.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         eapply FE_UNCH; eassumption.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
Qed.

Lemma clightstep_effax2: forall ge c m c' m',
      corestep (CL_coop_sem hf FE FE_FWD) ge c m c' m' ->
      exists M, clight_effstep ge M c m c' m'.
Proof.
intros. inv H.
  eexists. eapply clight_effstep_assign; eassumption.
  eexists. eapply clight_effstep_set; eassumption.
  eexists. eapply clight_effstep_call; eassumption.
  eexists. eapply clight_effstep_builtin; eassumption.
  eexists. eapply clight_effstep_seq; eassumption.
  eexists. eapply clight_effstep_skip_seq; eassumption.
  eexists. eapply clight_effstep_continue_seq; eassumption.
  eexists. eapply clight_effstep_break_seq; eassumption.
  eexists. eapply clight_effstep_ifthenelse; eassumption.
  eexists. eapply clight_effstep_loop; eassumption.
  eexists. eapply clight_effstep_skip_or_continue_loop1; eassumption.
  eexists. eapply clight_effstep_break_loop1; eassumption.
  eexists. eapply clight_effstep_skip_loop2; eassumption.
  eexists. eapply clight_effstep_break_loop2; eassumption.
  eexists. eapply clight_effstep_return_0; eassumption.
  eexists. eapply clight_effstep_return_1; eassumption.
  eexists. eapply clight_effstep_skip_call; eassumption.
  eexists. eapply clight_effstep_switch; eassumption.
  eexists. eapply clight_effstep_skip_break_switch; eassumption.
  eexists. eapply clight_effstep_continue_switch; eassumption.
  eexists. eapply clight_effstep_label; eassumption.
  eexists. eapply clight_effstep_goto; eassumption.
  eexists. eapply clight_effstep_internal_function; eassumption.
  eexists. eapply clight_effstep_returnstate; eassumption.
Qed.

Lemma clight_effstep_valid: forall (M : block -> Z -> bool) g c m c' m',
      clight_effstep g M c m c' m' ->
       forall b z, M b z = true -> Mem.valid_block m b.
Proof.
intros.
  induction H; try (solve [inv H0]).

  inv H3; unfold assign_loc_Effect in H0; rewrite H4 in H0.
     destruct (eq_block loc b); subst; simpl in *; try discriminate.
     apply Mem.store_valid_access_3 in H5.
     eapply Mem.perm_valid_block. eapply H5.
       destruct (zle (Int.unsigned ofs) z); simpl in *; try discriminate.
       destruct (zlt z (Int.unsigned ofs + Z.of_nat (size_chunk_nat chunk))); simpl in *; try discriminate.
       split. eassumption. rewrite <- size_chunk_conv in l0. trivial.

     destruct (eq_block b loc); subst; simpl in *; try discriminate.
     apply Mem.loadbytes_length in H8.
     eapply Mem.perm_valid_block with (ofs:=z).
        eapply Mem.storebytes_range_perm. eassumption.
       destruct (zle (Int.unsigned ofs) z); simpl in *; try discriminate.
       destruct (zlt z (Int.unsigned ofs + sizeof (typeof a1))); simpl in *; try discriminate.
       split. eassumption. rewrite H8. rewrite nat_of_Z_eq. trivial.
              specialize (sizeof_pos (typeof a1)). omega.

  eapply BuiltinEffect_valid_block; eassumption.

  eapply FreelistEffect_validblock; eassumption.
  eapply FreelistEffect_validblock; eassumption.
  eapply FreelistEffect_validblock; eassumption.
Qed.

Definition clight_eff_sem
  :  @EffectSem Clight.genv CL_core.
Proof.
eapply Build_EffectSem with (sem := CL_coop_sem hf _ FE_FWD)
         (effstep:=clight_effstep).
eapply clightstep_effax1.
apply clightstep_effax2.
eapply clight_effstep_valid.
Defined.

End EFFSEM.

Lemma function_entry1_UNCH: forall f vargs m e le m',
      function_entry1 f vargs m e le m'->
      Mem.unchanged_on (fun b z => EmptyEffect b z = false) m m'.
Proof. intros. inv H.
  assert (FRESH: forall id b ty,
           e ! id = Some (b, ty) -> ~ Mem.valid_block m b).
    intros.
    destruct (alloc_variables_freshblocks _ _ _ _ _ H1 _ _ _ H); trivial.
      rewrite PTree.gempty in H3. discriminate.
  clear H0.
  apply unchanged_on_validblock with (V:= fun b z => Mem.valid_block m b /\ EmptyEffect b z = false).
    simpl; intros. split; trivial.
  specialize (alloc_variables_forward _ _ _ _ _ H1).
  eapply unchanged_on_trans; try eassumption.
    eapply alloc_variables_unchanged_on; eassumption.
  clear H1. remember (fn_params f) as pars. clear Heqpars.
  generalize dependent m1. generalize dependent vargs.
  induction pars; simpl; intros.
    inv H2. apply Mem.unchanged_on_refl.
    inv H2. specialize (IHpars _ _ H7).
    apply FRESH in H1.
    eapply unchanged_on_trans; try eassumption;
      try (eapply assign_loc_forward; eassumption).
    clear H7 IHpars FRESH.
    inv H4.
      inv H0.
      split; intros.
        split; intros.
          eapply Mem.perm_store_1; eassumption.
          eapply Mem.perm_store_2; eassumption.
      rewrite (Mem.store_mem_contents _ _ _ _ _ _ H3).
        rewrite PMap.gso. trivial.
        destruct H0. intros N; subst. contradiction.
    split; intros.
      split; intros.
        eapply Mem.perm_storebytes_1; eassumption.
        eapply Mem.perm_storebytes_2; eassumption.
      rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H6).
        rewrite PMap.gso. trivial.
        destruct H4. intros N; subst. contradiction.
Qed.

Lemma function_entry2_UNCH: forall f vargs m e le m',
      function_entry2 f vargs m e le m'->
      Mem.unchanged_on (fun b z => EmptyEffect b z = false) m m'.
Proof. intros. inv H.
    eapply alloc_variables_unchanged_on; eassumption.
Qed.

Definition CL_eff_sem1: @EffectSem Clight.genv CL_core.
Proof.
  eapply (clight_eff_sem function_entry1).
  apply function_entry1_forward.
  apply function_entry1_UNCH.
Defined.

Definition CL_eff_sem2: @EffectSem Clight.genv CL_core.
Proof.
  eapply (clight_eff_sem function_entry2).
  apply function_entry2_forward.
  apply function_entry2_UNCH.
Defined.

End CLIGHT_EFF.


Require Export Base.Basic.

Module Category.

Structure mixin_of@{i j} (obj: Type@{i}) := Mixin {
  hom: obj -> obj -> Type@{j};
  id (a: obj): hom a a;
  comp {a b c: obj}: hom b c -> hom a b -> hom a c;
  comp_assoc (a b c d: obj) (f: hom c d) (g: hom b c) (h: hom a b): comp f (comp g h) = comp (comp f g) h;
  comp_id_l (a b: obj) (f: hom a b): comp (id b) f = f;
  comp_id_r (a b: obj) (f: hom a b): comp f (id a) = f;
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type@{i j} := Pack { obj: Type@{i}; _: class_of@{i j} obj }.
Local Coercion obj: type >-> Sortclass.

Variable (C: type).
Definition class := match C return class_of C with Pack _ c => c end.

End ClassDef.

Module Exports.

Coercion obj: type >-> Sortclass.
Notation Category := type.

End Exports.

End Category.

Export Category.Exports.

Section Category1.
Context {C: Category}.

Definition hom: C -> C -> Type := Category.hom C (Category.class C).
Definition id: forall a: C, hom a a := Category.id C (Category.class C).
Definition comp: forall {a b c: C}, hom b c -> hom a b -> hom a c := @Category.comp C (Category.class C).
Lemma comp_assoc {a b c d: C} (f: hom c d) (g: hom b c) (h: hom a b): comp f (comp g h) = comp (comp f g) h.
Proof. apply Category.comp_assoc. Qed.
Lemma comp_id_l {a b: C} (f: hom a b): comp (id b) f = f.
Proof. apply Category.comp_id_l. Qed.
Lemma comp_id_r {a b: C} (f: hom a b): comp f (id a) = f.
Proof. apply Category.comp_id_r. Qed.

End Category1.

Infix "~>" := hom (at level 70, right associativity).
Infix "∘" := comp (at level 40, left associativity).

Theorem cat_mixin_eq {T} (C D: Category.mixin_of T): C = D <->
  (forall x y: T, Category.hom T C x y = Category.hom T D x y) /\
  (forall (x: T) (e: Category.hom T C x x = Category.hom T D x x), match e in (_ = X) return X with eq_refl => (Category.id T C x) end = Category.id T D x) /\
  (forall (x y z: T) (f: Category.hom T C y z) (g: Category.hom T C x y) (xy: Category.hom T C x y = Category.hom T D x y) (yz: Category.hom T C y z = Category.hom T D y z) (xz: Category.hom T C x z = Category.hom T D x z),
    match xz in _ = X return X with eq_refl => Category.comp T C f g end = Category.comp T D (match yz in (_ = X) return X with eq_refl => f end) (match xy in (_ = X) return X with eq_refl => g end)
  ).
Proof.
  split.
  + intros H.
    subst D.
    repeat split.
    intros x e.
    replace e with (@eq_refl _ (Category.hom T C x x)) by apply proof_irrelevance.
    reflexivity.
    intros x y z f g xy yz xz.
    replace xy with (@eq_refl _ (Category.hom T C x y)) by apply proof_irrelevance.
    replace yz with (@eq_refl _ (Category.hom T C y z)) by apply proof_irrelevance.
    replace xz with (@eq_refl _ (Category.hom T C x z)) by apply proof_irrelevance.
    reflexivity.
  + intros [Hhom [Hid Hcomp]].
    destruct C, D.
    simpl in *.
    assert (hom0 = hom1).
    extensionality x.
    extensionality y.
    apply Hhom.
    subst hom1; clear Hhom.
    assert (id0 = id1).
    extensionality x.
    apply (Hid x eq_refl).
    subst id1; clear Hid.
    assert (comp0 = comp1).
    extensionality x.
    extensionality y.
    extensionality z.
    extensionality f.
    extensionality g.
    apply (Hcomp x y z f g eq_refl eq_refl eq_refl).
    subst comp1; clear Hcomp.
    f_equal.
    all: apply proof_irrelevance.
Qed.

Definition co_mixin@{i j} C (m: Category.mixin_of@{i j} C): Category.mixin_of@{i j} C :=
  Category.Mixin C
  (fun x y => Category.hom C m y x)
  (Category.id C m)
  (fun _ _ _ f g => Category.comp C m g f)
  (fun _ _ _ _ f g h => eq_sym (Category.comp_assoc C m _ _ _ _ h g f))
  (fun _ _ f => Category.comp_id_r C m _ _ f)
  (fun _ _ f => Category.comp_id_l C m _ _ f).

Definition co@{i j} (C: Category@{i j}): Category@{i j} :=
  Category.Pack C (co_mixin C (Category.class C)).

Lemma co_invol (C: Category): co (co C) = C.
Proof.
  destruct C.
  unfold co; simpl.
  f_equal.
  destruct m.
  unfold co_mixin; simpl.
  f_equal.
  apply proof_irrelevance.
Qed.

Lemma gen_eq_l {C: Category} {x y: C} (f g: x ~> y): f = g <-> forall (z: C) (a: y ~> z), a ∘ f = a ∘ g.
Proof.
  split; intros H.
  now subst g.
  setoid_rewrite <- comp_id_l.
  apply H.
Qed.

Lemma gen_eq_r {C: Category} {x y: C} (f g: x ~> y): f = g <-> forall (z: C) (a: z ~> x), f ∘ a = g ∘ a.
Proof.
  split; intros H.
  now subst g.
  setoid_rewrite <- comp_id_r.
  apply H.
Qed.

Lemma gen_eq {C: Category} {x y: C} (f g: x ~> y): f = g <-> forall (x' y': C) (a: x' ~> x) (b: y ~> y'), b ∘ f ∘ a = b ∘ g ∘ a.
Proof.
  split; intros H.
  now subst g.
  setoid_rewrite <- comp_id_l.
  setoid_rewrite <- comp_id_r.
  apply H.
Qed.


(**
Here we define the initial setoid algebra.
The carrier of this setoid is the initial prealgebra of the point constructor.
The equivalence relation is the freely generated congruence relation.
 *)
Require Import prelude.all.

Require Import setoids.base.
Require Import setoids.setoid_category.

Require Import syntax.hit_signature.

Require Import algebras.set_algebra.
Require Import algebras.setoid_algebra.
Require Import algebras.univalent_algebra.

Require Import existence.initial_prealgebra.
Require Import existence.free_congruence.

Section InitialSetoidAlgebra.
  Variable (Σ : hit_signature).

  Local Notation P := (point_arg Σ).

  Local Definition carrier_initial
    : Initial (set_prealgebras P)
    := initial_prealgebra P.

  (** The carrier *)
  Local Definition carrier
    : set_prealgebras P
    := pr1 carrier_initial.

  (** The equivalence relation *)
  Definition initial_setoid_algebra_carrier
    := mod_congruence carrier.

  (** Proof of initiality *)
  Definition initial_setoid_algebra_is_initial
    : isInitial _ initial_setoid_algebra_carrier.
  Proof.
    intros X.
    apply iscontraprop1.
    - apply invproofirrelevance.
      intros f g.
      use subtypePath.
      { intro ; apply isapropunit. }
      use subtypePath.
      { intro ; apply homset_property. }
      use setoid_morphism_eq.
      intros x.
      pose (φ :=
              (pr111 f ,, funextsec _ _ _ (λ z, eqtohomot (maponpaths pr1 (pr21 f)) z))
              : set_prealgebras P ⟦ pr1 carrier_initial,
                                    setoid_prealgebra_to_set_prealgebra P (pr1 X) ⟧).
      pose (χ :=
              (pr111 g ,, funextsec _ _ _ (λ z, eqtohomot (maponpaths pr1 (pr21 g)) z))
              : set_prealgebras P ⟦ pr1 carrier_initial,
                                    setoid_prealgebra_to_set_prealgebra P (pr1 X) ⟧).
      pose (proofirrelevance
              _
              (isapropifcontr
                 (pr2 carrier_initial (setoid_prealgebra_to_set_prealgebra _ (pr1 X))))
              φ χ) as i.
      exact (eqtohomot (maponpaths pr1 i) x).
    - apply map_mod_congruence.
      apply carrier_initial.
  Defined.

  Definition initial_setoid_algebra
    : Initial (setoid_algebra Σ).
  Proof.
    use tpair.
    - exact initial_setoid_algebra_carrier.
    - exact initial_setoid_algebra_is_initial.
  Defined.
End InitialSetoidAlgebra.


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

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

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.
*)

(** * Relative error of the roundings *)
Require Import Core.
Require Import Psatz.  (* for lra *)

Section Fprop_relative.

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

Section Fprop_relative_generic.

Variable fexp : Z -> Z.
Context { prop_exp : Valid_exp fexp }.

Section relative_error_conversion.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma relative_error_lt_conversion :
  forall x b, (0 < b)%R ->
  (x <> 0 -> Rabs (round beta fexp rnd x - x) < b * Rabs x)%R ->
  exists eps,
  (Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].
(* *)
exists 0%R.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...
(* *)
specialize (Hxb Hx0).
exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_lt_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

Lemma relative_error_le_conversion :
  forall x b, (0 <= b)%R ->
  (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R ->
  exists eps,
  (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].
(* *)
exists 0%R.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...
(* *)
exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_le_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

Lemma relative_error_le_conversion_inv :
  forall x b,
  (exists eps,
   (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R) ->
  (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x b (eps, (Beps, Heps)).
assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|].
rewrite Heps; replace (_ - _)%R with (eps * x)%R; [|ring].
now rewrite Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|].
Qed.

Lemma relative_error_le_conversion_round_inv :
  forall x b,
  (exists eps,
   (Rabs eps <= b)%R /\ x = (round beta fexp rnd x * (1 + eps))%R) ->
  (Rabs (round beta fexp rnd x - x) <= b * Rabs (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances.
intros x b.
set (rx := round _ _ _ _).
intros (eps, (Beps, Heps)).
assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|].
rewrite Heps; replace (_ - _)%R with (- (eps * rx))%R; [|ring].
now rewrite Rabs_Ropp, Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|].
Qed.

End relative_error_conversion.

Variable emin p : Z.
Hypothesis Hmin : forall k, (emin < k)%Z -> (p <= k - fexp k)%Z.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error :
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
assert (Hx': (x <> 0)%R).
intros T; contradict Hx; rewrite T, Rabs_R0.
apply Rlt_not_le, bpow_gt_0.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply error_lt_ulp...
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

(** 1+#ε# property in any rounding *)
Theorem relative_error_ex :
  forall x,
  (bpow emin <= Rabs x)%R ->
  exists eps,
  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
intros _.
now apply relative_error.
Qed.

Theorem relative_error_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof.
intros m x Hx.
apply relative_error.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_F2R_emin.
Qed.

Theorem relative_error_round :
  (0 < p)%Z ->
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances.
intros Hp x Hx.
assert (Hx': (x <> 0)%R).
intros T; contradict Hx; rewrite T, Rabs_R0.
apply Rlt_not_le, bpow_gt_0.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply error_lt_ulp.
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x _ Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
omega.
Qed.

Theorem relative_error_round_F2R_emin :
  (0 < p)%Z ->
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof.
intros Hp m x Hx.
apply relative_error_round.
exact Hp.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N :
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof.
intros x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply error_le_half_ulp.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

(** 1+#ε# property in rounding to nearest *)
Theorem relative_error_N_ex :
  forall x,
  (bpow emin <= Rabs x)%R ->
  exists eps,
  (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N.
Qed.

Theorem relative_error_N_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
apply relative_error_N.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_N_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_F2R_emin.
Qed.

Theorem relative_error_N_round :
  (0 < p)%Z ->
  forall x,
  (bpow emin <= Rabs x)%R ->
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hp x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply error_le_half_ulp.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x _ Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
omega.
Qed.

Theorem relative_error_N_round_F2R_emin :
  (0 < p)%Z ->
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hp m x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
apply relative_error_N_round with (1 := Hp).
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

End Fprop_relative_generic.

Section Fprop_relative_FLX.

Variable prec : Z.
Variable Hp : Z.lt 0 prec.

Lemma relative_error_FLX_aux :
  forall k, (prec <= k - FLX_exp prec k)%Z.
Proof.
intros k.
unfold FLX_exp.
omega.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error_FLX :
  forall x,
  (x <> 0)%R ->
  (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (mag beta x) as (ex, He).
specialize (He Hx).
apply relative_error with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

(** 1+#ε# property in any rounding in FLX *)
Theorem relative_error_FLX_ex :
  forall x,
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLX.
Qed.

Theorem relative_error_FLX_round :
  forall x,
  (x <> 0)%R ->
  (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (mag beta x) as (ex, He).
specialize (He Hx).
apply relative_error_round with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLX :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x.
destruct (Req_dec x 0) as [Hx|Hx].
(* . *)
rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.
(* . *)
destruct (mag beta x) as (ex, He).
specialize (He Hx).
apply relative_error_N with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

(** unit roundoff *)
Definition u_ro := (/2 * bpow (-prec + 1))%R.

Lemma u_ro_pos : (0 <= u_ro)%R.
Proof. apply Rmult_le_pos; [lra|apply bpow_ge_0]. Qed.

Lemma u_ro_lt_1 : (u_ro < 1)%R.
Proof.
unfold u_ro; apply (Rmult_lt_reg_l 2); [lra|].
rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, Rmult_1_r; [|lra].
apply (Rle_lt_trans _ (bpow 0));
  [apply bpow_le; omega|simpl; lra].
Qed.

Lemma u_rod1pu_ro_pos : (0 <= u_ro / (1 + u_ro))%R.
Proof.
apply Rmult_le_pos; [|apply Rlt_le, Rinv_0_lt_compat];
assert (H := u_ro_pos); lra.
Qed.

Lemma u_rod1pu_ro_le_u_ro : (u_ro / (1 + u_ro) <= u_ro)%R.
Proof.
assert (Pu_ro := u_ro_pos).
apply (Rmult_le_reg_r (1 + u_ro)); [lra|].
unfold Rdiv; rewrite Rmult_assoc, Rinv_l; [|lra].
assert (0 <= u_ro * u_ro)%R; [apply Rmult_le_pos|]; lra.
Qed.

Theorem relative_error_N_FLX' :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x)
   <= u_ro / (1 + u_ro) * Rabs x)%R.
Proof with auto with typeclass_instances.
intro x.
assert (Pu_ro : (0 <= u_ro)%R).
{ apply Rmult_le_pos; [lra|apply bpow_ge_0]. }
destruct (Req_dec x 0) as [Zx|Nzx].
{ rewrite Zx, Rabs_R0, Rmult_0_r, round_0...
  now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. }
set (ufpx := bpow (mag beta x - 1)%Z).
set (rx := round _ _ _ _).
assert (Pufpx : (0 <= ufpx)%R); [now apply bpow_ge_0|].
assert (H_2_1 : (Rabs (rx - x) <= u_ro * ufpx)%R).
{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _);
    [now apply FLX_exp_valid|right].
  unfold ulp, cexp, FLX_exp, u_ro, ufpx; rewrite (Req_bool_false _ _ Nzx).
  rewrite Rmult_assoc, <-bpow_plus; do 2 f_equal; ring. }
assert (H_2_3 : (ufpx + Rabs (rx - x) <= Rabs x)%R).
{ apply (Rplus_le_reg_r (- ufpx)); ring_simplify.
  destruct (Rle_or_lt 0 x) as [Sx|Sx].
  { apply (Rle_trans _ (Rabs (ufpx - x))).
    { apply round_N_pt; [now apply FLX_exp_valid|].
      apply generic_format_bpow; unfold FLX_exp; lia. }
    rewrite Rabs_minus_sym, Rabs_pos_eq.
    { now rewrite Rabs_pos_eq; [right; ring|]. }
    apply (Rplus_le_reg_r ufpx); ring_simplify.
    now rewrite <-(Rabs_pos_eq _ Sx); apply bpow_mag_le. }
  apply (Rle_trans _ (Rabs (- ufpx - x))).
  { apply round_N_pt; [now apply FLX_exp_valid|].
    apply generic_format_opp, generic_format_bpow; unfold FLX_exp; lia. }
  rewrite Rabs_pos_eq; [now rewrite Rabs_left; [right|]|].
  apply (Rplus_le_reg_r x); ring_simplify.
  rewrite <-(Ropp_involutive x); apply Ropp_le_contravar; unfold ufpx.
  rewrite <-mag_opp, <-Rabs_pos_eq; [apply bpow_mag_le|]; lra. }
assert (H : (Rabs ((rx - x) / x) <= u_ro / (1 + u_ro))%R).
{ assert (H : (0 < ufpx + Rabs (rx - x))%R).
  { apply Rplus_lt_le_0_compat; [apply bpow_gt_0|apply Rabs_pos]. }
  apply (Rle_trans _ (Rabs (rx - x) / (ufpx + Rabs (rx - x)))).
  { unfold Rdiv; rewrite Rabs_mult; apply Rmult_le_compat_l; [apply Rabs_pos|].
    now rewrite (Rabs_Rinv _ Nzx); apply Rinv_le. }
  apply (Rmult_le_reg_r ((ufpx + Rabs (rx - x)) * (1 + u_ro))).
  { apply Rmult_lt_0_compat; lra. }
  field_simplify; [try unfold Rdiv; rewrite ?Rinv_1, ?Rmult_1_r| |]; lra. }
revert H; unfold Rdiv; rewrite Rabs_mult, (Rabs_Rinv _ Nzx); intro H.
apply (Rmult_le_reg_r (/ Rabs x)); [now apply Rinv_0_lt_compat, Rabs_pos_lt|].
now apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0|lra].
Qed.

(** 1+#ε# property in rounding to nearest in FLX *)
Theorem relative_error_N_FLX_ex :
  forall x,
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_FLX.
Qed.

Theorem relative_error_N_FLX'_ex :
  forall x,
  exists eps,
  (Rabs eps <= u_ro / (1 + u_ro))%R /\
  round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x.
apply relative_error_le_conversion...
{ apply u_rod1pu_ro_pos. }
now apply relative_error_N_FLX'.
Qed.

Lemma relative_error_N_round_ex_derive :
  forall x rx,
  (exists eps, (Rabs eps <= u_ro / (1 + u_ro))%R /\ rx = (x * (1 + eps))%R) ->
  exists eps, (Rabs eps <= u_ro)%R /\ x = (rx * (1 + eps))%R.
Proof.
intros x rx (d, (Bd, Hd)).
assert (Pu_ro := u_ro_pos).
assert (H := Rabs_le_inv _ _ Bd).
assert (H' := u_rod1pu_ro_le_u_ro); assert (H'' := u_ro_lt_1).
destruct (Req_dec rx 0) as [Zfx|Nzfx].
{ exists 0%R; split; [now rewrite Rabs_R0|].
  rewrite Rplus_0_r, Rmult_1_r, Zfx.
  now rewrite Zfx in Hd; destruct (Rmult_integral _ _ (sym_eq Hd)); [|lra]. }
destruct (Req_dec x 0) as [Zx|Nzx].
{ now exfalso; revert Hd; rewrite Zx, Rmult_0_l. }
set (d' := ((x - rx) / rx)%R).
assert (Hd' : (Rabs d' <= u_ro)%R).
{ unfold d'; rewrite Hd.
  replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra].
  unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp.
  rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra].
  apply (Rmult_le_reg_r (1 + d)); [lra|].
  rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra].
  apply (Rle_trans _ _ _ Bd).
  unfold Rdiv; apply Rmult_le_compat_l; [now apply u_ro_pos|].
  apply (Rle_trans _ (1 - u_ro / (1 + u_ro))); [right; field|]; lra. }
now exists d'; split; [|unfold d'; field].
Qed.

Theorem relative_error_N_FLX_round_ex :
  forall x,
  exists eps,
  (Rabs eps <= u_ro)%R /\
  x = (round beta (FLX_exp prec) (Znearest choice) x * (1 + eps))%R.
Proof.
intro x; apply relative_error_N_round_ex_derive, relative_error_N_FLX'_ex.
Qed.

Theorem relative_error_N_FLX_round :
  forall x,
  (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs(round beta (FLX_exp prec) (Znearest choice) x))%R.
Proof.
intro x.
apply relative_error_le_conversion_round_inv, relative_error_N_FLX_round_ex.
Qed.

End Fprop_relative_FLX.

Section Fprop_relative_FLT.

Variable emin prec : Z.
Variable Hp : Z.lt 0 prec.

Lemma relative_error_FLT_aux :
  forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z.
Proof.
intros k Hk.
unfold FLT_exp.
generalize (Zmax_spec (k - prec) emin).
omega.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error_FLT :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_FLT_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (x <> 0)%R ->
  (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x Zx.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_lt_0_compat.
apply bpow_gt_0.
now apply Rabs_pos_lt.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
now apply relative_error_FLT.
Qed.

Theorem relative_error_FLT_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLT_F2R_emin.
Qed.

(** 1+#ε# property in any rounding in FLT *)
Theorem relative_error_FLT_ex :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  exists eps,
  (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
intros _; now apply relative_error_FLT.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLT :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_N with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

(** 1+#ε# property in rounding to nearest in FLT *)
Theorem relative_error_N_FLT_ex :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_FLT.
Qed.

Theorem relative_error_N_FLT_round :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros x Hx.
apply relative_error_N_round with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_N_FLT_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
apply Rabs_pos.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
now apply relative_error_N_FLT.
Qed.

Theorem relative_error_N_FLT_F2R_emin_ex :
  forall m, let x := F2R (Float beta m emin) in
  exists eps,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances.
intros m x.
apply relative_error_le_conversion...
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
now apply relative_error_N_FLT_F2R_emin.
Qed.

Theorem relative_error_N_FLT_round_F2R_emin :
  forall m, let x := F2R (Float beta m emin) in
  (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros m x.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
apply Rabs_pos.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
apply relative_error_N_round with (emin := (emin + prec - 1)%Z)...
apply relative_error_FLT_aux.
Qed.

Lemma error_N_FLT_aux :
  forall x,
  (0 < x)%R ->
  exists eps, exists  eta,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\
  (Rabs eta <= /2 * bpow (emin))%R      /\
  (eps*eta=0)%R /\
  round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps) + eta)%R.
Proof.
intros x Hx2.
case (Rle_or_lt (bpow (emin+prec)) x); intros Hx.
(* *)
destruct relative_error_N_ex with (FLT_exp emin prec) (emin+prec)%Z prec choice x
  as (eps,(Heps1,Heps2)).
now apply FLT_exp_valid.
intros; unfold FLT_exp.
rewrite Zmax_left; omega.
rewrite Rabs_right;[assumption|apply Rle_ge; now left].
exists eps; exists 0%R.
split;[assumption|split].
rewrite Rabs_R0; apply Rmult_le_pos.
apply Rlt_le, pos_half_prf.
apply bpow_ge_0.
split;[apply Rmult_0_r|idtac].
now rewrite Rplus_0_r.
(* *)
exists 0%R; exists (round beta (FLT_exp emin prec) (Znearest choice) x - x)%R.
split.
rewrite Rabs_R0; apply Rmult_le_pos.
apply Rlt_le, pos_half_prf.
apply bpow_ge_0.
split.
apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R.
apply error_le_half_ulp.
now apply FLT_exp_valid.
apply Rmult_le_compat_l.
apply Rlt_le, pos_half_prf.
rewrite ulp_neq_0.
2: now apply Rgt_not_eq.
apply bpow_le.
unfold FLT_exp, cexp.
rewrite Zmax_right.
omega.
destruct (mag beta x) as (e,He); simpl.
assert (e-1 < emin+prec)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2:=Hx).
rewrite <- (Rabs_pos_eq x) by now apply Rlt_le.
now apply He, Rgt_not_eq.
omega.
split ; ring.
Qed.

Theorem relative_error_N_FLT'_ex :
  forall x,
  exists eps eta : R,
  (Rabs eps <= u_ro prec / (1 + u_ro prec))%R /\
  (Rabs eta <= /2 * bpow emin)%R /\
  (eps * eta = 0)%R /\
  round beta (FLT_exp emin prec) (Znearest choice) x
  = (x * (1 + eps) + eta)%R.
Proof.
intro x.
set (rx := round _ _ _ x).
assert (Pb := u_rod1pu_ro_pos prec).
destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs x)) as [MX|Mx].
{ destruct (relative_error_N_FLX'_ex prec Hp choice x) as (d, (Bd, Hd)).
  exists d, 0%R; split; [exact Bd|]; split.
  { rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]. }
  rewrite Rplus_0_r, Rmult_0_r; split; [reflexivity|].
  now rewrite <- Hd; apply round_FLT_FLX. }
assert (H : (Rabs (rx - x) <= /2 * bpow emin)%R).
{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _);
    [now apply FLT_exp_valid|].
  rewrite ulp_FLT_small; [now right|now simpl|].
  apply (Rlt_le_trans _ _ _ Mx), bpow_le; lia. }
exists 0%R, (rx - x)%R; split; [now rewrite Rabs_R0|]; split; [exact H|].
now rewrite Rmult_0_l, Rplus_0_r, Rmult_1_r; split; [|ring].
Qed.

Theorem relative_error_N_FLT'_ex_separate :
  forall x,
  exists x' : R,
  round beta (FLT_exp emin prec) (Znearest choice) x'
  = round beta (FLT_exp emin prec) (Znearest choice) x /\
  (exists eta, Rabs eta <= /2 * bpow emin /\ x' = x + eta)%R /\
  (exists eps, Rabs eps <= u_ro prec / (1 + u_ro prec) /\
               round beta (FLT_exp emin prec) (Znearest choice) x'
               = x' * (1 + eps))%R.
Proof.
intro x.
set (rx := round _ _ _ x).
destruct (relative_error_N_FLT'_ex x) as (d, (e, (Bd, (Be, (Hde0, Hde))))).
destruct (Rlt_or_le (Rabs (d * x)) (Rabs e)) as [HdxLte|HeLedx].
{ exists rx; split; [|split].
  { apply round_generic; [now apply valid_rnd_N|].
    now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. }
  { exists e; split; [exact Be|].
    unfold rx; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze].
    { now rewrite Zd, Rplus_0_r, Rmult_1_r. }
    exfalso; revert HdxLte; rewrite Ze, Rabs_R0; apply Rle_not_lt, Rabs_pos. }
  exists 0%R; split; [now rewrite Rabs_R0; apply u_rod1pu_ro_pos|].
  rewrite Rplus_0_r, Rmult_1_r; apply round_generic; [now apply valid_rnd_N|].
  now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. }
exists x; split; [now simpl|split].
{ exists 0%R; split;
    [rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]|ring]. }
exists d; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze].
{ split; [exact Bd|].
  assert (Ze : e = 0%R); [|now rewrite Ze, Rplus_0_r].
  apply Rabs_eq_R0, Rle_antisym; [|now apply Rabs_pos].
  now revert HeLedx; rewrite Zd, Rmult_0_l, Rabs_R0. }
now rewrite Ze, Rplus_0_r.
Qed.

End Fprop_relative_FLT.

Theorem error_N_FLT :
  forall (emin prec : Z), (0 < prec)%Z ->
  forall (choice : Z -> bool),
  forall (x : R),
  exists eps eta : R,
  (Rabs eps <= /2 * bpow (-prec + 1))%R /\
  (Rabs eta <= /2 * bpow emin)%R /\
  (eps * eta = 0)%R /\
  (round beta (FLT_exp emin prec) (Znearest choice) x
   = x * (1 + eps) + eta)%R.
Proof.
intros emin prec Pprec choice x.
destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
{ assert (Pmx : (0 < - x)%R).
  { now rewrite <- Ropp_0; apply Ropp_lt_contravar. }
  destruct (@error_N_FLT_aux emin prec Pprec
                             (fun t : Z => negb (choice (- (t + 1))%Z))
                             (- x)%R Pmx)
    as (d,(e,(Hd,(He,(Hde,Hr))))).
  exists d; exists (- e)%R; split; [exact Hd|split; [|split]].
  { now rewrite Rabs_Ropp. }
  { now rewrite Ropp_mult_distr_r_reverse, <- Ropp_0; apply f_equal. }
  rewrite <- (Ropp_involutive x), round_N_opp.
  now rewrite Ropp_mult_distr_l_reverse, <- Ropp_plus_distr; apply f_equal. }
{ assert (Ph2 : (0 <= / 2)%R).
  { apply (Rmult_le_reg_l 2 _ _ Rlt_0_2).
    rewrite Rmult_0_r, Rinv_r; [exact Rle_0_1|].
    apply Rgt_not_eq, Rlt_gt, Rlt_0_2. }
  exists 0%R; exists 0%R; rewrite Zx; split; [|split; [|split]].
  { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. }
  { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. }
  { now rewrite Rmult_0_l. }
  now rewrite Rmult_0_l, Rplus_0_l, round_0; [|apply valid_rnd_N]. }
now apply error_N_FLT_aux.
Qed.

End Fprop_relative.