From Coq Require Import ZArith.
From mathcomp Require Import ssreflect ssrbool ssrnat seq.
From Common Require Import Var Bits.
From mQhasm Require Import bvDSL bvVerify Options zVerify.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* This is a buggy implementation of fe25519_mul with
   radix 2^64 representation. *)

Open Scope N_scope.
Open Scope bvdsl_scope.

Definition fe25519r64_mul_bug : program :=

let         wsize :=   64%nat in

let            xp0 :=   0 in (* *[uint64 *](xp +  0) *)
let            xp1 :=   1 in (* *[uint64 *](xp +  8) *)
let            xp2 :=   2 in (* *[uint64 *](xp + 16) *)
let            xp3 :=   3 in (* *[uint64 *](xp + 24) *)
let            yp0 :=   4 in (* *[uint64 *](yp +  0) *)
let            yp1 :=   5 in (* *[uint64 *](yp +  8) *)
let            yp2 :=   6 in (* *[uint64 *](yp + 16) *)
let            yp3 :=   7 in (* *[uint64 *](yp + 24) *)
let         carry := 999 in

let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in

let         mulr4 := 30 in
let         mulr5 := 31 in
let         mulr6 := 32 in
let         mulr7 := 33 in

let        mulrax := 40 in
let        mulrdx := 41 in

let         mulx0 := 50 in
let         mulx1 := 51 in
let         mulx2 := 52 in
let         mulx3 := 53 in

let          mulc := 60 in
let       mulzero := 61 in
let        muli38 := 62 in
[::

   (* int64 rp *)
   (* int64 xp *)
   (* int64 yp *)

   (* input rp *)
   (* input xp *)
   (* input yp *)

   (* int64 r0 *)
   (* int64 r1 *)
   (* int64 r2 *)
   (* int64 r3 *)

   (* #BEGIN MACRO callerregs_declare *)
   (* int64 caller1 *)
   (* int64 caller2 *)
   (* int64 caller3 *)
   (* int64 caller4 *)
   (* int64 caller5 *)
   (* int64 caller6 *)
   (* int64 caller7 *)
   (* caller caller1 *)
   (* caller caller2 *)
   (* caller caller3 *)
   (* caller caller4 *)
   (* caller caller5 *)
   (* caller caller6 *)
   (* caller caller7 *)
   (* stack64 caller1_stack *)
   (* stack64 caller2_stack *)
   (* stack64 caller3_stack *)
   (* stack64 caller4_stack *)
   (* stack64 caller5_stack *)
   (* stack64 caller6_stack *)
   (* stack64 caller7_stack *)
   (* #END MACRO callerregs_declare *)

   (* # Required for the mul template *)
   (* int64 mulr4 *)
   (* int64 mulr5 *)
   (* int64 mulr6 *)
   (* int64 mulr7 *)
   (* int64 mulrax *)
   (* int64 mulrdx *)
   (* int64 mulx0 *)
   (* int64 mulx1 *)
   (* int64 mulx2 *)
   (* int64 mulx3 *)
   (* int64 mulc *)
   (* int64 mulzero *)
   (* int64 muli38 *)

   (* enter fe25519_mul *)

   (* #BEGIN MACRO callerregs_save *)
   (* caller1_stack = caller1 *)
   (* caller2_stack = caller2 *)
   (* caller3_stack = caller3 *)
   (* caller4_stack = caller4 *)
   (* caller5_stack = caller5 *)
   (* caller6_stack = caller6 *)
   (* caller7_stack = caller7 *)
   (* #END MACRO callerregs_save *)

   (* yp = yp *)

   (* #BEGIN MACRO mul *)

   (* mulr4 = 0 *)
   (* mulr5 = 0 *)
   (* mulr6 = 0 *)
   (* mulr7 = 0 *)
   bvAssign mulr4 (bvConst 0);
   bvAssign mulr5 (bvConst 0);
   bvAssign mulr6 (bvConst 0);
   bvAssign mulr7 (bvConst 0);

   (* mulx0 = *[uint64 *](xp + 0) *)
   (* mulrax = *[uint64 *](yp + 0) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx0 *)
   (* r0 = mulrax *)
   (* r1 = mulrdx *)
   bvAssign mulx0 (bvVar xp0);
   bvAssign mulrax (bvVar yp0);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx0);
   bvAssign r0 (bvVar mulrax);
   bvAssign r1 (bvVar mulrdx);

   (* mulrax = *[uint64 *](yp + 8) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx0 *)
   (* carry? r1 += mulrax *)
   (* r2 = 0 *)
   (* r2 += mulrdx + carry *)
   bvAssign mulrax (bvVar yp1);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx0);
   bvAddC carry r1 (bvVar r1) (bvVar mulrax);
   bvAssign r2 (bvConst 0);
   bvAdc r2 (bvVar r2) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 16) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx0 *)
   (* carry? r2 += mulrax *)
   (* r3 = 0 *)
   (* r3 += mulrdx + carry *)
   bvAssign mulrax (bvVar yp2);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx0);
   bvAddC carry r2 (bvVar r2) (bvVar mulrax);
   bvAssign r3 (bvConst 0);
   bvAdc r3 (bvVar r3) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 24) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx0 *)
   (* carry? r3 += mulrax *)
   (* mulr4 += mulrdx + carry *)
   bvAssign mulrax (bvVar yp3);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx0);
   bvAddC carry r3 (bvVar r3) (bvVar mulrax);
   bvAdc mulr4 (bvVar mulr4) (bvVar mulrdx) carry;

   (* mulx1 = *[uint64 *](xp + 8) *)
   (* mulrax = *[uint64 *](yp + 0) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx1 *)
   (* carry? r1 += mulrax *)
   (* mulc = 0 *)
   (* mulc += mulrdx + carry *)
   bvAssign mulx1 (bvVar xp1);
   bvAssign mulrax (bvVar yp0);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx1);
   bvAddC carry r1 (bvVar r1) (bvVar mulrax);
   bvAssign mulc (bvConst 0);
   bvAdc mulc (bvVar mulc) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 8) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx1 *)
   (* carry? r2 += mulrax *)
   (* mulrdx += 0 + carry *)
   (* carry? r2 += mulc *)
   (* mulc = 0 *)
   (* mulc += mulrdx + carry *)
   bvAssign mulrax (bvVar yp1);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx1);
   bvAddC carry r2 (bvVar r2) (bvVar mulrax);
   bvAdc mulrdx (bvVar mulrdx) (bvConst 0) carry;
   bvAddC carry r2 (bvVar r2) (bvVar mulc);
   bvAssign mulc (bvConst 0);
   bvAdc mulc (bvVar mulc) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 16) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx1 *)
   (* carry? r3 += mulrax *)
   (* mulrdx += 0 + carry *)
   (* carry? r3 += mulc *)
   (* mulc = 0 *)
   (* mulc += mulrdx + carry *)
   bvAssign mulrax (bvVar yp2);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx1);
   bvAddC carry r3 (bvVar r3) (bvVar mulrax);
   bvAdc mulrdx (bvVar mulrdx) (bvConst 0) carry;
   bvAddC carry r3 (bvVar r3) (bvVar mulc);
   bvAssign mulc (bvConst 0);
   bvAdc mulc (bvVar mulc) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 24) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx1 *)
   (* carry? mulr4 += mulrax *)
   (* mulrdx += 0 + carry *)
   (* carry? mulr4 += mulc *)
   (* mulr5 += mulrdx + carry *)
   bvAssign mulrax (bvVar yp3);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx1);
   bvAddC carry mulr4 (bvVar mulr4) (bvVar mulrax);
   bvAdc mulrdx (bvVar mulrdx) (bvConst 0) carry;
   bvAddC carry mulr4 (bvVar mulr4) (bvVar mulc);
   bvAdc mulr5 (bvVar mulr5) (bvVar mulrdx) carry;

   (* mulx2 = *[uint64 *](xp + 16) *)
   (* mulrax = *[uint64 *](yp + 0) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx2 *)
   (* carry? r2 += mulrax *)
   (* mulc = 0 *)
   (* mulc += mulrdx + carry *)
   bvAssign mulx2 (bvVar xp2);
   bvAssign mulrax (bvVar yp0);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx2);
   bvAddC carry r2 (bvVar r2) (bvVar mulrax);
   bvAssign mulc (bvConst 0);
   bvAdc mulc (bvVar mulc) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 8) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx2 *)
   (* carry? r3 += mulrax *)
   (* mulrdx += 0 + carry *)
   (* carry? r3 += mulc *)
   (* mulc = 0 *)
   (* mulc += mulrdx + carry *)
   bvAssign mulrax (bvVar yp1);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx2);
   bvAddC carry r3 (bvVar r3) (bvVar mulrax);
   bvAdc mulrdx (bvVar mulrdx) (bvConst 0) carry;
   bvAddC carry r3 (bvVar r3) (bvVar mulc);
   bvAssign mulc (bvConst 0);
   bvAdc mulc (bvVar mulc) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 16) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx2 *)
   (* carry? mulr4 += mulrax *)
   (* mulrdx += 0 + carry *)
   (* carry? mulr4 += mulc *)
   (* mulc = 0 *)
   (* mulc += mulrdx + carry *)
   bvAssign mulrax (bvVar yp2);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx2);
   bvAddC carry mulr4 (bvVar mulr4) (bvVar mulrax);
   bvAdc mulrdx (bvVar mulrdx) (bvConst 0) carry;
   bvAddC carry mulr4 (bvVar mulr4) (bvVar mulc);
   bvAssign mulc (bvConst 0);
   bvAdc mulc (bvVar mulc) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 24) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx2 *)
   (* carry? mulr5 += mulrax *)
   (* mulrdx += 0 + carry *)
   (* carry? mulr5 += mulc *)
   (* mulr6 += mulrdx + carry *)
   bvAssign mulrax (bvVar yp3);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx2);
   bvAddC carry mulr5 (bvVar mulr5) (bvVar mulrax);
   bvAdc mulrdx (bvVar mulrdx) (bvConst 0) carry;
   bvAddC carry mulr5 (bvVar mulr5) (bvVar mulc);
   bvAdc mulr6 (bvVar mulr6) (bvVar mulrdx) carry;

   (* mulx3 = *[uint64 *](xp + 24) *)
   (* mulrax = *[uint64 *](yp + 0) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx3 *)
   (* carry? r3 += mulrax *)
   (* mulc = 0 *)
   (* mulc += mulrdx + carry *)
   bvAssign mulx3 (bvVar xp3);
   bvAssign mulrax (bvVar yp0);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx3);
   bvAddC carry r3 (bvVar r3) (bvVar mulrax);
   bvAssign mulc (bvConst 0);
   bvAdc mulc (bvVar mulc) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 8) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx3 *)
   (* carry? mulr4 += mulrax *)
   (* mulrdx += 0 + carry *)
   (* carry? mulr4 += mulc *)
   (* mulc = 0 *)
   (* mulc += mulrdx + carry *)
   bvAssign mulrax (bvVar yp1);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx3);
   bvAddC carry mulr4 (bvVar mulr4) (bvVar mulrax);
   bvAdc mulrdx (bvVar mulrdx) (bvConst 0) carry;
   bvAddC carry mulr4 (bvVar mulr4) (bvVar mulc);
   bvAssign mulc (bvConst 0);
   bvAdc mulc (bvVar mulc) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 16) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx3 *)
   (* carry? mulr5 += mulrax *)
   (* mulrdx += 0 + carry *)
   (* carry? mulr5 += mulc *)
   (* mulc = 0 *)
   (* mulc += mulrdx + carry *)
   bvAssign mulrax (bvVar yp2);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx3);
   bvAddC carry mulr5 (bvVar mulr5) (bvVar mulrax);
   bvAdc mulrdx (bvVar mulrdx) (bvConst 0) carry;
   bvAddC carry mulr5 (bvVar mulr5) (bvVar mulc);
   bvAssign mulc (bvConst 0);
   bvAdc mulc (bvVar mulc) (bvVar mulrdx) carry;

   (* mulrax = *[uint64 *](yp + 24) *)
   (* (uint128) mulrdx mulrax = mulrax * mulx3 *)
   (* carry? mulr6 += mulrax *)
   (* mulrdx += 0 + carry *)
   (* carry? mulr6 += mulc *)
   (* mulr7 += mulrdx + carry *)
   bvAssign mulrax (bvVar yp3);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvVar mulx3);
   bvAddC carry mulr6 (bvVar mulr6) (bvVar mulrax);
   bvAdc mulrdx (bvVar mulrdx) (bvConst 0) carry;
   bvAddC carry mulr6 (bvVar mulr6) (bvVar mulc);
   bvAdc mulr7 (bvVar mulr7) (bvVar mulrdx) carry;

   (* mulrax = mulr4 *)
   (* (uint128) mulrdx mulrax = mulrax * *[uint64 *]&crypto_sign_ed25519_amd64_64_38 *)
   (* carry? r0 += mulrax *)
   (* carry? r1 += mulrdx + carry *)
   (* r1 += 0 + carry *)
   bvAssign mulrax (bvVar mulr4);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvConst (fromPosZ 38%Z));
   bvAddC carry r0 (bvVar r0) (bvVar mulrax);
   bvAdcC carry r1 (bvVar r1) (bvVar mulrdx) carry;
   bvAdc r1 (bvVar r1) (bvConst 0) carry;

   (* mulrax = mulr5 *)
   (* (uint128) mulrdx mulrax = mulrax * *[uint64 *]&crypto_sign_ed25519_amd64_64_38 *)
   (* carry? r1 += mulrax *)
   (* carry? r2 += mulrdx + carry *)
   (* r2 += 0 + carry *)
   bvAssign mulrax (bvVar mulr5);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvConst (fromPosZ 38%Z));
   bvAddC carry r1 (bvVar r1) (bvVar mulrax);
   bvAdcC carry r2 (bvVar r2) (bvVar mulrdx) carry;
   bvAdc r2 (bvVar r2) (bvConst 0) carry;

   (* mulrax = mulr6 *)
   (* (uint128) mulrdx mulrax = mulrax * *[uint64 *]&crypto_sign_ed25519_amd64_64_38 *)
   (* carry? r2 += mulrax *)
   (* carry? r3 += mulrdx + carry *)
   (* r3 += 0 + carry *)
   bvAssign mulrax (bvVar mulr6);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvConst (fromPosZ 38%Z));
   bvAddC carry r2 (bvVar r2) (bvVar mulrax);
   bvAdcC carry r3 (bvVar r3) (bvVar mulrdx) carry;
   bvAdc r3 (bvVar r3) (bvConst 0) carry;

   (* mulrax = mulr7 *)
   (* (uint128) mulrdx mulrax = mulrax * *[uint64 *]&crypto_sign_ed25519_amd64_64_38 *)
   (* carry? r3 += mulrax *)
   (* mulr4 = 0 *)
   (* mulr4 += mulrdx + carry *)
   bvAssign mulrax (bvVar mulr7);
   bvMulf mulrdx mulrax (bvVar mulrax) (bvConst (fromPosZ 38%Z));
   bvAddC carry r3 (bvVar r3) (bvVar mulrax);
   bvAssign mulr4 (bvConst 0);
   bvAdc mulr4 (bvVar mulr4) (bvVar mulrdx) carry;

   (* mulr4 *= 38 *)
   bvMul mulr4 (bvVar mulr4) (bvConst (fromPosZ 38%Z));

   (* carry? r0 += mulr4 *)
   (* carry? r1 += 0 + carry *)
   (* carry? r2 += 0 + carry *)
   (* carry? r3 += 0 + carry *)
   bvAddC carry r0 (bvVar r0) (bvVar mulr4);
   bvAdcC carry r1 (bvVar r1) (bvConst 0) carry;
   bvAdcC carry r2 (bvVar r2) (bvConst 0) carry;
   bvAdcC carry r3 (bvVar r3) (bvConst 0) carry;

   (* mulzero = 0 *)
   (* muli38 = 38 *)
   (* mulzero = muli38 if carry *)
   (* r0 += mulzero *)
   bvAssign mulzero (bvConst (fromPosZ 0%Z));
   bvAssign muli38 (bvConst (fromPosZ 38%Z));
   bvMul mulzero (bvVar muli38) (bvVar carry);
   bvAdd r0 (bvVar r0) (bvVar mulzero)

   (* #END MACRO mul *)

] .

Definition fe25519r64_mul_bug_inputs : VS.t :=
let            xp0 :=   0 in
let            xp1 :=   1 in
let            xp2 :=   2 in
let            xp3 :=   3 in
let            yp0 :=   4 in
let            yp1 :=   5 in
let            yp2 :=   6 in
let            yp3 :=   7 in
VSLemmas.OP.P.of_list [:: xp0; xp1; xp2; xp3; yp0; yp1; yp2; yp3].

Definition fe25519r64_mul_bug_pre : bexp := bvTrue.

Definition radix64 := @limbs 64.

Definition fe25519r64_mul_bug_post : bexp :=
let            xp0 :=   0 in
let            xp1 :=   1 in
let            xp2 :=   2 in
let            xp3 :=   3 in
let            yp0 :=   4 in
let            yp1 :=   5 in
let            yp2 :=   6 in
let            yp3 :=   7 in
let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
bvands2
  [::
     bveEqMod
     (
       (radix64 [:: bvevar xp0; bvevar xp1; bvevar xp2; bvevar xp3])
       *e
       (radix64 [:: bvevar yp0; bvevar yp1; bvevar yp2; bvevar yp3])
     )
     (radix64 [:: bvevar r0; bvevar r1; bvevar r2; bvevar r3])
     (bvconst n25519)
  ]
  [:: ].

Definition fe25519r64_mul_bug_spec :=
  {| spre := fe25519r64_mul_bug_pre;
     sprog := fe25519r64_mul_bug;
     spost := fe25519r64_mul_bug_post |}.

Lemma valid_fe25519r64_mul_bug :
  valid_bvspec (fe25519r64_mul_bug_inputs, fe25519r64_mul_bug_spec).
Proof.
  time "valid_fe25519r64_mul_bug" verify_bvspec.
Qed.

Close Scope bvdsl_scope.
Close Scope N_scope.


(* * FOL Reductions *)

From Undecidability.DiophantineConstraints Require Import H10C.
From Undecidability.DiophantineConstraints.Util Require Import H10UPC_facts.
From Undecidability.FOL Require Import Utils.FriedmanTranslationFragment Syntax.Facts Deduction.FragmentNDFacts Semantics.Tarski.FragmentSoundness Semantics.Tarski.FragmentFacts Syntax.BinSig Semantics.Kripke.FragmentCore  Semantics.Kripke.FragmentSoundness Semantics.Kripke.FragmentToTarski.
From Undecidability.Shared Require Import Dec.
From Undecidability.Shared.Libs.PSL Require Import Numbers.
From Coq Require Import Arith Lia List.
From Undecidability.FOL.Undecidability.Reductions Require Import H10UPC_to_FOL_constructions.

Import FragmentSyntax.

(* ** Validity *)

(*
Idea: The relation (###) has the following properties:#
#
#
#n ~ p: n is left component of p#
#
#
#p ~ n: p is right component of p#
#
#
#p ~ p: the special relationship of H10UPC#
#
#
#n ~ m: n = m. Special case n=0, m=1: #
#
          The instance h10 of H10UPC is a yes-instance. #
#
          This is to facilitate Friedman translation#
#
*)

Set Default Proof Using "Type".
Set Default Goal Selector "!".

(* The validity reduction.
    We assume a generic falsity flag and a list h10 for which we build a formula.
 *)
Section Fr_validity.

  Context {ff : falsity_flag}.
  Context {h10 : list h10upc}.
  Definition F_Fr := Fr (@F ff h10).
  (* We now define our standard model. *)
  Section FrInverseTransport.
    (* An element of the standard model is either a number or a pair. *)
    Inductive dom : Type := Num : nat -> dom | Pair : nat  -> nat -> dom.
    (* The interpretation of our single binary relation *)
    Definition dom_rel' (a : dom) (b:dom) : Prop := match (a,b) with
    | (Num  0, Num  1) => H10UPC_SAT h10
    | (Num n1, Num n2) => n1 = n2
    | (Num n1, Pair x2 _) => n1 = x2
    | (Pair _ y1, Num n2) => n2 = y1
    | (Pair x1 y1, Pair x2 y2) => h10upc_sem_direct ((x1, y1), (x2, y2))
    end.

    Local Instance IB : @interp _ (@extended_preds sig_binary) (dom) | 0.
    Proof using h10.
      split; intros [] v.
      - exact (H10UPC_SAT h10).
      - exact (dom_rel' (Vector.hd v) (Vector.hd (Vector.tl v))).
    Defined.
    #[local] Notation "rho ⊨ phi" := (sat rho (Fr phi)) (at level 20).
    (* Now we need rewrite helpers which transform our syntactic sugar into useful statements in the model *)
    Lemma IB_sFalse rho : rho ⊨ (∀ ∀ Pr $0 $1) <-> H10UPC_SAT h10.
    Proof.
    split.
    * intros H. specialize (H (Num 0) (Num 1)). cbn in H. apply H. intros Hf. congruence.
    * intros H d1 d2 Hc. apply H.
    Qed.
    Opaque sFalse.

    Notation dFalse := (H10UPC_SAT h10).
    Notation mDN P := ((P -> dFalse) -> dFalse).
    Notation dom_rel a b := (mDN (dom_rel' a b)).

    Lemma IB_sNot rho f : rho ⊨ (f → sFalse) <-> ((rho ⊨ f) -> H10UPC_SAT h10).
    Proof.
    split.
    * intros H. cbn in H. now rewrite IB_sFalse in H.
    * intros H. cbn. now rewrite IB_sFalse.
    Qed.

    Definition rho_canon' n (rho : nat -> dom) := rho n = Num 0 /\ rho (S n) = Num 0 /\ rho (S (S n)) = Num 1.
    Notation rho_canon rho := (rho_canon' 0 rho).
    Lemma IB_wFalse rho t : rho ⊨ wFalse t <-> dom_rel (rho t) (rho (S t)).
    Proof.
    split.
    * intros H. apply H.
    * intros H. unfold wFalse, Fr. intros P. apply H. apply P.
    Qed.
    Opaque wFalse.

    Lemma IB_dFalse rho t : rho t = Num 0 -> rho (S t) = Num 1 -> rho ⊨ wFalse t <-> dFalse.
    Proof.
    intros H1 H2. rewrite IB_wFalse. rewrite H1,H2. cbn. tauto.
    Qed.
    Opaque wFalse.

    Lemma IB_Not rho f t : rho ⊨ Not f t <-> ((rho ⊨ f) -> rho ⊨ wFalse t).
    Proof.
    split.
    * intros H. cbn in H. now rewrite IB_wFalse in H.
    * intros H. cbn. now rewrite IB_wFalse.
    Qed.
    Opaque Not.

    Lemma IB_F_zero rho : rho_canon rho -> rho ⊨ F_zero.
    Proof.
      intros (H0&H1&H2). cbn. rewrite !H0. tauto.
    Qed.

    Ltac dn := let H := fresh "H" in intros H; apply H.
    Lemma IB_N_e rho i n : rho i = n -> rho ⊨ N i -> mDN {m:nat | Num m = n}.
    Proof.
    intros Hrho H. destruct n as [m|a b].
    * dn. now exists m.
    * intros H1. apply H; cbn -[dom_rel']. intros Hh. apply H1. rewrite Hrho in Hh. exfalso. apply (@h10_rel_irref (a,b) Hh).
    Qed.

    Lemma IB_N_i rho i n : rho i = Num n -> (rho) ⊨ N i.
    Proof. cbn. intros ->. dn. now destruct n as [|n'] eqn:Heq.
    Qed.
    Opaque N.

    Lemma IB_P'_e rho i n : rho i = n -> rho ⊨ P' i -> mDN {a:nat & {b:nat & n = Pair a b}}.
    Proof.
    intros Hrho H. destruct n as [m|a b].
    * unfold P' in H. rewrite IB_sNot in H. intros Hc1. apply H.
      eapply IB_N_i, Hrho.
    * dn. now exists a, b.
    Qed.

    Lemma IB_P'_i rho i a b : rho i = (Pair a b) -> rho ⊨ P' i.
    Proof.
    unfold P'. rewrite IB_sNot. intros Hrho H. apply (@IB_N_e rho i (Pair a b)).
    1-2:easy. intros (m & Hm). congruence.
    Qed.
    Opaque P'.

    Lemma IB_P_e rho p l r ip il ir c :
        rho ip = p -> rho il = l -> rho ir = r
     -> rho ⊨ P ip il ir c -> {a:nat & {b:nat & p = Pair a b /\ l = Num a /\ r = Num b}}
     -> rho ⊨ c.
    Proof.
    intros Hp Hl Hr H [a [b [Hp' [Hl' Hr']]]]. cbn in H.
    rewrite Hp, Hl, Hr, Hp', Hl', Hr' in H. cbn in H. apply H.
    - eapply IB_P'_i. now rewrite Hp, Hp'.
    - eapply IB_N_i. now rewrite Hl, Hl'.
    - eapply IB_N_i. now rewrite Hr, Hr'.
    - dn. now destruct a.
    - dn. easy.
    Qed.

    Lemma mDN_sat rho phi : mDN (rho ⊨ phi) -> rho ⊨ phi.
    Proof.
      induction phi as [| |?[]|?[]] in rho|-*; cbn -[dom_rel']; intros H.
      - apply H. tauto.
      - intros Hc. apply H. intros Hc2. now apply Hc2.
      - intros H1. apply IHphi2. intros Hc. apply H. intros Hv. apply Hc, Hv, H1.
      - intros d. apply IHphi. intros Hc. apply H. intros Hc2. apply Hc, Hc2.
    Qed.

    Lemma IB_P_i rho ip il ir c : (forall a b, rho ip = (Pair a b)
                                 -> rho il = (Num a) -> rho ir = (Num b) -> rho ⊨ c)
                                 -> rho ⊨ P ip il ir c.
    Proof.
      intros Hc1 Hc3 Hc4 Hc5 Hpl Hpr.
      apply mDN_sat. intros Hc8.
      unshelve eapply (IB_P'_e (n:=rho ip) _ Hc3); [easy|]. intros [pa [pb Hp]].
      unshelve eapply (IB_N_e (n:=rho il) _ Hc4); [easy|]. intros [la Ha].
      unshelve eapply (IB_N_e (n:=rho ir) _ Hc5); [easy|]. intros [lb Hb].
      apply Hpl; cbn -[dom_rel']; intros Hpl'.
      apply Hpr; cbn -[dom_rel']; intros Hpr'.
      rewrite Hp in *.
      rewrite <-Ha in *.
      rewrite <-Hb in *. unfold dom_rel' in *.
      apply Hc8. destruct la; eapply (Hc1 pa pb); congruence.
    Qed.
    Opaque P.

    (* We show our model fulfills axiom 1 *)

    Lemma IB_F_succ_left rho : rho_canon rho -> rho ⊨ F_succ_left.
    Proof.
      intros (H0&H1&H2). unfold F_succ_left. intros n Hc1.
      rewrite IB_Not. intros Hc.
      rewrite IB_wFalse; cbn; rewrite H1, H2; intros _.
      eapply (IB_N_e (n:=n) (i:=0) eq_refl Hc1).
      intros [m Hnm]. cbn in Hc.
      specialize (Hc (Pair m 0) (Num (S m)) (Pair (S m) 0)).
      eapply IB_P_e in Hc; cbn. 2-4: reflexivity. 2: eexists; eexists; repeat split; congruence.
      eapply IB_P_e in Hc; cbn. 2-4: reflexivity. 2: eexists; eexists; repeat split; congruence.
      cbn in Hc. rewrite IB_dFalse in Hc. 2-3: cbv; congruence.
      apply Hc. dn. lia.
    Qed.

    (* We show we can extract constraints from our model *)

    Lemma IB_rel_e rho ipl ipr ia ib ic id t : rho ⊨ rel ipl ipr ia ib ic id t
                -> {a&{b&{c&{d|rho ipl=Pair a b
                            /\ rho ipr = Pair c d
                            /\ rho ia=Num a
                            /\ rho ib=Num b
                            /\ rho ic=Num c
                            /\ rho id=Num d
                            /\ h10upc_sem_direct ((a,b),(c,d))}}}}
                -> rho ⊨ t.
    Proof.
    intros H [a [b [c [d [Hpl [Hpr [Ha [Hb [Hc [Hd Habcd]]]]]]]]]].
    unfold rel in H.
    eapply IB_P_e in H; cbn. 2-4: reflexivity. 2: eexists; eexists; repeat split; eassumption.
    eapply IB_P_e in H; cbn. 2-4: reflexivity. 2: eexists; eexists; repeat split; eassumption.
    cbn in H.
    apply H. dn. rewrite Hpl, Hpr. easy.
    Qed.

    Lemma IB_rel_i rho ipl ipr ia ib ic id t :
                ({a&{b&{c&{d|rho ipl=Pair a b
                            /\ rho ipr = Pair c d
                            /\ rho ia=Num a
                            /\ rho ib=Num b
                            /\ rho ic=Num c
                            /\ rho id=Num d
                            /\ h10upc_sem_direct ((a,b),(c,d))}}}} -> rho ⊨ t)
             -> rho ⊨ rel ipl ipr ia ib ic id t.
    Proof.
    intros H.
    apply IB_P_i.
    intros a b Hpl Ha Hb. apply IB_P_i.
    intros c d Hpr Hc Hd Habcd. cbn -[dom_rel'] in Habcd.
    apply mDN_sat. intros Hc'. apply Habcd. intros Habcd'.
    apply Hc'. apply H. exists a,b,c,d. cbn in Habcd'.
    rewrite Hpl, Hpr in Habcd'. now repeat split.
    Qed.

    (* We show our model fulfills axiom 2 *)

    Lemma IB_F_succ_right rho : rho_canon rho -> rho ⊨ F_succ_right.
    Proof.
      intros (H0&H1&H2). unfold F_succ_right. intros p1 p2 p3 p4 p5 p6 p7 p8 a' y' c b a y x.
      apply IB_rel_i. cbn. intros [nx [ny [na [nb [Hp8 [Hp7 [Hx [Hy [Ha [Hb [Hr1l Hr1r]]]]]]]]]]].
      apply IB_rel_i. cbn. intros [nb' [ny' [nc [nb'' [Hp6 [Hp5 [Hb' [Hy' [Hc [Hb'' [Hr2l Hr2r]]]]]]]]]]].
      apply IB_rel_i. cbn. intros [ny'' [z [n'y [z' [Hp4 [Hp3 [Hy'' [Hz [H'y [Hz' [Hr3l Hr3r]]]]]]]]]]].
      apply IB_rel_i. cbn. intros [na' [z'' [n'a [z''' [Hp2 [Hp1 [Ha' [Hz'' [H'a [Hz''' [Hr4l Hr4r]]]]]]]]]]].
      unfold erel. cbn.
      rewrite IB_Not. intros H.
      rewrite H0 in *. cbn in H.
      specialize (H (Pair n'a (nc)) (Pair nx n'y)).
      eapply IB_P_e in H. 2-4: easy. 2: exists nx, n'y; cbn; firstorder.
      eapply IB_P_e in H. 2-4: easy. 2: exists n'a, nc; cbn; firstorder.
      cbn in H. rewrite IB_wFalse in H. rewrite IB_dFalse. 2-3: cbv; congruence.
      cbn -[dom_rel'] in H.
      assert (z=0 /\ z' = 0 /\ z'' = 0 /\ z''' = 0) as [-> [-> [-> ->]]].
      1:firstorder;congruence.
      assert (ny'' = ny /\ na' = na) as [-> ->].
      1:firstorder;congruence.
      assert (nb' = nb /\ ny' = ny) as [-> ->].
      1:firstorder;congruence.
      subst n'y. subst nc. subst n'a.
      rewrite <- IB_dFalse. 2: apply H1. 2: apply H2. apply IB_wFalse.
      apply H.
      dn. lia.
    Qed.

    (* We show we can encode constraints into our model *)

    (* rho_descr_phi describes that rho is defined by the solution to h10 *)
    Definition rho_descr_phi rho (φ:nat->nat) n :=
         forall k, k < n -> match rho k with Num n => n = (φ k) | _ => True end.
    Lemma IB_single_constr rho φ (n:nat) (h:h10upc) : rho_descr_phi rho φ n
                                           -> highest_var h < n
                                           -> rho_canon' n rho
                                           -> rho ⊨ translate_single h (S n)
                                           -> (h10upc_sem φ h -> dom_rel (rho (1+n)) (rho (2+n)))
                                           -> dom_rel (rho (1+n)) (rho (2+n)).
    Proof.
      intros Hrhophi Hmaxhall (Hr0&Hr1&Hr2).
      destruct h as [[a b][c d]]. unfold translate_single. cbn in Hmaxhall.
      intros Htr Hcon Hcon'. unfold erel in Htr. rewrite IB_Not in Htr.
      rewrite IB_dFalse in Htr. 2-3:easy. apply Htr.
      intros p2 p1.
      apply IB_P_i. cbn. intros na nb Hp1 Ha Hb.
      apply IB_P_i. cbn. intros nc nd Hp2 Hc Hd. rewrite Hp1, Hp2.
      intros Habcd.
      rewrite IB_dFalse. 2-3:easy.
      assert (na = φ a) as ->. 1: pose (@Hrhophi a) as Hp; rewrite Ha in Hp; apply Hp; lia.
      assert (nb = φ b) as ->. 1: pose (@Hrhophi b) as Hp; rewrite Hb in Hp; apply Hp; lia.
      assert (nc = φ c) as ->. 1: pose (@Hrhophi c) as Hp; rewrite Hc in Hp; apply Hp; lia.
      assert (nd = φ d) as ->. 1: pose (@Hrhophi d) as Hp; rewrite Hd in Hp; apply Hp; lia.
      apply Habcd. intros Habcd'.
      apply Hcon. 2: apply Hcon'.
      apply Habcd'.
    Qed.
    (* Helper for working with nested quantifiers *)

    Lemma IB_emplace_forall rho n i :
        (forall f, (fun k => if k <? n then f (k) else rho (k-n)) ⊨ i)
     -> rho ⊨ emplace_forall n i.
    Proof.
      intros H.
      induction n as [|n IH] in rho,H|-*.
      - cbn. eapply (sat_ext IB (rho := rho) (xi:=fun k => rho(k-0))).
        2: apply (H (fun _ => Num 0)).
        intros x. now rewrite Nat.sub_0_r.
      - intros d.
        specialize (IH (d.:rho)). apply IH. intros f.
        eapply (sat_ext IB (xi:=fun k => if k <? S n
                                         then (fun kk => if kk =? n then d
                                         else f kk) k else (rho) (k - S n))).
        2: eapply H.
        intros x.
        destruct (Nat.eq_dec x n) as [Hxn|Hnxn].
        + destruct (Nat.ltb_ge x n) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt.
          destruct (Nat.ltb_lt x (S n)) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt. cbn.
          assert (x-n=0) as ->. 1: lia. cbn. destruct (Nat.eqb_eq x n) as [_ HH]. now rewrite HH.
        + destruct (x <? n) eqn:Hneq.
          * destruct (Nat.ltb_lt x n) as [Hlt _]. apply Hlt in Hneq. clear Hlt.
            destruct (Nat.ltb_lt x (S n)) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt.
            cbn. destruct (Nat.eqb_neq x n) as [_ HH]. rewrite HH. 1: easy. lia.
          * destruct (Nat.ltb_ge x n) as [Hlt _]. apply Hlt in Hneq. clear Hlt.
            destruct (Nat.ltb_ge x (S n)) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt.
            assert (x-n=S(x-S n)) as ->. 1:lia. easy.
    Qed.
    Opaque emplace_forall.
    (* Final utility lemma: translate the entire list of constraints *)

    Lemma IB_translate_rec rho phi f e hv : rho_descr_phi rho phi hv
                            -> rho_canon' hv rho
                            -> (rho ⊨ f <-> dom_rel (rho (1+hv)) (rho (2+hv)))
                            -> highest_var_list e < hv
                            -> ((forall c, In c e -> h10upc_sem phi c) -> rho ⊨ f)
                            -> rho ⊨ translate_rec f (S hv) e.
    Proof.
    intros Hrhophi (Hr0&Hr1&Hr2) Hsat Hhv H.
    induction e as [|eh er IH] in H,Hsat,Hhv|-*.
    - apply H. intros l [].
    - cbn. intros Hts. apply IH.
      + easy.
      + cbn in Hhv. lia.
      + intros HH. rewrite Hsat. eapply (IB_single_constr (h:=eh)).
        * exact Hrhophi.
        * pose proof (@highest_var_list_descr (eh::er) eh ltac:(now left)). lia.
        * easy.
        * easy.
        * intros Hsem. rewrite <- Hsat. apply H. intros c [il|ir]. 2:now apply HH. congruence.
    Qed.
    (* We can now extract the constraints from our translate_constraints function*)

    Lemma less_ge a b : a >= b -> a <? b = false.
    Proof.
      intros H. rewrite Nat.ltb_nlt. lia.
    Qed.

    Lemma IB_aux_transport rho : rho_canon rho
                              -> rho ⊨ translate_constraints h10
                              -> H10UPC_SAT h10.
    Proof.
      intros (Hrho0&Hrho1&Hrho2).
      pose ((S (highest_var_list h10))) as h10vars.
      unfold translate_constraints. fold h10vars. intros H.
      cbn in H. rewrite Hrho1, Hrho2 in H.
      apply H. 2:easy.
      apply IB_emplace_forall. intros f.
      pose (fun n => match (f n) with (Num k) => k | _ => 0 end) as phi.
      eapply (IB_translate_rec (e:=h10) (hv:=h10vars) (phi:= phi)).
      - intros x HH. destruct (Nat.ltb_lt x h10vars) as [_ Hr]. rewrite Hr. 2:easy.
        unfold phi. now destruct (f x).
      - split. 2:split. all: rewrite less_ge; [|lia].
        1: rewrite <- Hrho0. 2: rewrite <- Hrho1. 3: rewrite <- Hrho2. all: f_equal; lia.
      - cbn -[dom_rel' Nat.leb Nat.sub]. easy.
      - lia.
      - intros HG. cbn -[dom_rel' Nat.leb Nat.sub].
        destruct (Nat.ltb_ge (S h10vars) h10vars) as [_ H1]. rewrite H1. 2:lia.
        destruct (Nat.ltb_ge (S (S h10vars)) h10vars) as [_ H2]. rewrite H2. 2:lia.
        assert (S h10vars-h10vars = 1) as ->. 1:lia.
        assert (S(S h10vars)-h10vars = 2) as ->. 1:lia.
        rewrite Hrho1, Hrho2. cbn. exists phi. easy.
    Qed.

    (* To conclude, we can wrap the axioms around it.*)
    Lemma IB_fulfills rho : rho ⊨ (@F ff h10) -> H10UPC_SAT h10.
    Proof.
      intros H. unfold F in H. pose (Num 0 .: Num 0 .: Num 1 .: rho) as nrho.
      assert (rho_canon nrho) as nrho_canon.
      1: split; easy.
      apply (@IB_aux_transport nrho), H.
      - easy.
      - now apply IB_F_zero.
      - now apply IB_F_succ_left.
      - now apply IB_F_succ_right.
    Qed.
  End FrInverseTransport.

  (* If F is valid, h10 has a solution: *)
  Lemma FrInverseTransport : valid (Fr (@F ff h10)) -> H10UPC_SAT h10.
  Proof.
    intros H. apply (@IB_fulfills (fun b => Num 0)). apply H.
  Qed.

End Fr_validity.

(* We also have classical provability, assuming LEM *)
Section classical_provability.
  Context {ff : falsity_flag}.
  Context {h10 : list h10upc}.

  Lemma classicalProvabilityTransport : H10UPC_SAT h10 -> nil ⊢C F (h10:=h10).
  Proof.
  intros [φ Hφ]. apply intuitionistic_is_classical. eapply transport_prove. exact Hφ.
  Qed.

  Lemma classicalProvabilityInverseTransport : nil ⊢C F (h10:=h10) -> H10UPC_SAT h10.
  Proof.
  intros H%(Fr_cl_to_min)%soundness. apply FrInverseTransport. intros D I rho.
  apply H. easy.
  Qed.
End classical_provability.


Require Import Bool.
Require Import ZArith.
Require Import Reals.
Require Import Flocq.Core.Fcore.
Require Import Flocq.Calc.Fcalc_digits.
Require Import Flocq.Calc.Fcalc_round.
Require Import Flocq.Prop.Fprop_relative.
Require Import Gappa_definitions.
Require Import Gappa_dyadic.
Require Import Gappa_pred_bnd.
Require Import Gappa_round_def.
Require Import Gappa_round_aux.
Require Import Gappa_round.

Global Notation rounding_float rdir p d :=
  (Fcore_generic_fmt.round radix2 (FLT_exp d (Zpos p)) rdir) (only parsing).

Global Notation rounding_floatx rdir p :=
  (Fcore_generic_fmt.round radix2 (FLX_exp (Zpos p)) rdir) (only parsing).

Definition float_ulp (p : positive) (d m e : Z) :=
 match m with
 | Zpos n => FLT_exp d (Zpos p) (e + Zpos (digits n))%Z
 | Zneg n => FLT_exp d (Zpos p) (e + Zpos (digits n))%Z
 | Z0 => d
 end.

Definition floatx_ulp (p : positive) (m e : Z) :=
 match m with
 | Zpos n => FLX_exp (Zpos p) (e + Zpos (digits n))%Z
 | Zneg n => FLX_exp (Zpos p) (e + Zpos (digits n))%Z
 | Z0 => Z0
 end.

Lemma float_absolute_ne_sym :
  forall p d x,
  (Rabs (rounding_float rndNE p d x - x) = Rabs (rounding_float rndNE p d (Rabs x) - Rabs x))%R.
Proof.
intros p d x.
destruct (Rle_or_lt 0 x) as [H|H].
rewrite (Rabs_right _ (Rle_ge _ _ H)).
exact (refl_equal _).
rewrite (Rabs_left _ H).
rewrite round_NE_opp.
unfold Rminus.
rewrite <- Ropp_plus_distr.
now rewrite Rabs_Ropp.
Qed.

Lemma floatx_absolute_ne_sym :
  forall p x,
  (Rabs (rounding_floatx rndNE p x - x) = Rabs (rounding_floatx rndNE p (Rabs x) - Rabs x))%R.
Proof.
intros p x.
destruct (Rle_or_lt 0 x) as [H|H].
rewrite (Rabs_right _ (Rle_ge _ _ H)).
exact (refl_equal _).
rewrite (Rabs_left _ H).
rewrite round_NE_opp.
unfold Rminus.
rewrite <- Ropp_plus_distr.
now rewrite Rabs_Ropp.
Qed.

Instance zpos_gt_0 : forall p, Prec_gt_0 (Zpos p).
easy.
Qed.

Lemma float_absolute_n_whole :
  forall c p d k x,
  (Rabs x < bpow radix2 k)%R ->
  (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p d k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold canonic_exp.
apply monotone_exp...
now apply ln_beta_le_bpow.
Qed.

Lemma floatx_absolute_n_whole :
  forall c p k x,
  (Rabs x < bpow radix2 k)%R ->
  (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (FLX_exp (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold canonic_exp.
apply monotone_exp...
now apply ln_beta_le_bpow.
Qed.

Lemma float_absolute_inv_n_whole :
  forall c p d k x,
  (Rabs (rounding_float (Znearest c) p d x) < bpow radix2 k)%R ->
  (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p d k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold canonic_exp.
destruct (Zle_or_lt (ln_beta radix2 x) k) as [Hk1|Hk1].
apply monotone_exp...
destruct (Zle_or_lt (ln_beta radix2 x) d) as [Hk2|Hk2].
unfold FLT_exp.
clear -Hk1 Hk2 ; zify ; omega.
elim Rlt_not_le with (1 := Hx) ; clear Hx.
apply Rle_trans with (bpow radix2 (Zmax k d)).
apply bpow_le.
apply Zle_max_l.
apply abs_round_ge_generic...
apply generic_format_bpow.
unfold FLT_exp.
clear ; zify ; omega.
destruct (ln_beta radix2 x) as (ex,Ex) ; simpl in *.
apply Rle_trans with (2 := proj1 (Ex Hx0)).
apply bpow_le.
clear -Hk1 Hk2 ; zify ; omega.
Qed.

Lemma floatx_absolute_inv_n_whole :
  forall c p k x,
  (Rabs (rounding_floatx (Znearest c) p x) < bpow radix2 k)%R ->
  (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (FLX_exp (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold canonic_exp.
apply monotone_exp...
destruct (Zle_or_lt (ln_beta radix2 x) k) as [Hk1|Hk1].
exact Hk1.
elim Rlt_not_le with (1 := Hx) ; clear Hx.
apply abs_round_ge_generic...
apply generic_format_bpow.
unfold FLX_exp.
clear ; zify ; omega.
destruct (ln_beta radix2 x) as (ex,Ex) ; simpl in *.
apply Rle_trans with (2 := proj1 (Ex Hx0)).
apply bpow_le.
clear -Hk1 ; omega.
Qed.

Lemma Zmax_inf_l :
 forall m n : Z, (n <= m)%Z -> Zmax m n = m.
intros m n H.
generalize (Zle_ge _ _ H).
unfold Zmax, Zge.
case (m ?= n)%Z ; intros ; try exact (refl_equal _).
elim H0.
exact (refl_equal _).
Qed.

Lemma float_relative_n_whole :
  forall c p d x,
  (bpow radix2 (d + Zpos p - 1) <= Rabs x)%R ->
  (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (-Zpos p))%R.
Proof.
intros c p d x Hx.
assert (Hx0: x <> R0).
intros Hx0.
apply Rle_not_lt with (1 := Hx).
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
destruct (relative_error_N_FLT_ex radix2 d (Zpos p) (refl_equal _) c x Hx) as (eps, (Hr1, Hr2)).
rewrite Hr2.
replace ((x * (1 + eps) - x) / x)%R with eps by now field.
revert Hr1.
rewrite <- (bpow_plus radix2 (-1)%Z).
now rewrite (Zplus_comm (- Zpos p)), Zplus_assoc.
Qed.

Lemma float_relative_inv_n_whole :
  forall c p d x,
  (bpow radix2 (d + Zpos p - 1) < Rabs (rounding_float (Znearest c) p d x))%R ->
  (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (-Zpos p))%R.
Proof with auto with typeclass_instances.
intros c p d x Hx.
apply float_relative_n_whole.
apply Rnot_lt_le.
contradict Hx.
apply Rle_not_lt.
apply abs_round_le_generic...
apply generic_format_bpow.
unfold FLT_exp.
ring_simplify (d + Zpos p - 1 + 1 - Zpos p)%Z.
rewrite Zmax_idempotent.
clear ; zify ; omega.
now apply Rlt_le.
Qed.

Theorem fix_of_float :
  forall rdir x p k1 k2,
  Zle_bool k2 k1 = true ->
  FIX (rounding_float rdir p k1 x) k2.
Proof.
intros rdir x p k1 k2 H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
unfold FIX.
eexists (Float2 _ _) ; repeat split.
simpl.
unfold canonic_exp.
apply Zle_trans with (1 := H).
apply Zle_max_r.
Qed.

Theorem flt_of_float :
  forall rdir {Hrnd : Valid_rnd rdir} x p1 p2 k,
  Zle_bool (Zpos p1) (Zpos p2) = true ->
  FLT (rounding_float rdir p1 k x) p2.
Proof with auto with typeclass_instances.
intros rdir Hrnd x p1 p2 k H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
unfold FLT.
destruct (FLT_format_generic radix2 k (Zpos p1) (Fcore_generic_fmt.round radix2 (FLT_exp k (Zpos p1)) rdir x))
  as ((m, e), (H1, (H2, _))).
apply generic_format_round...
rewrite H1.
eexists (Float2 _ _) ; repeat split.
apply Zlt_le_trans with (1 := H2).
change (Zpower_pos 2 p2) with (Zpower radix2 (Zpos p2)).
now apply Zpower_le.
Qed.

Theorem flt_of_floatx :
  forall rdir {Hrnd : Valid_rnd rdir} x p1 p2,
  Zle_bool (Zpos p1) (Zpos p2) = true ->
  FLT (rounding_floatx rdir p1 x) p2.
Proof with auto with typeclass_instances.
intros rdir Hrnd x p1 p2 H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
unfold FLT.
destruct (FLX_format_generic radix2 (Zpos p1) (Fcore_generic_fmt.round radix2 (FLX_exp (Zpos p1)) rdir x))
  as ((m, e), (H1, H2)).
apply generic_format_round...
rewrite H1.
eexists (Float2 _ _) ; repeat split.
apply Zlt_le_trans with (1 := H2).
change (Zpower_pos 2 p2) with (Zpower radix2 (Zpos p2)).
now apply Zpower_le.
Qed.

Theorem float_of_fix_flt :
  forall rdir {Hrnd : Valid_rnd rdir},
  forall x : R,
  forall d1 d2 : Z, forall p1 p2 : positive,
  FIX x d1 -> FLT x p1 ->
  Zle_bool d2 d1 && Zle_bool (Zpos p1) (Zpos p2) = true ->
  rounding_float rdir p2 d2 x = x.
Proof with auto with typeclass_instances.
intros rdir Hrnd x d1 d2 p1 p2 (f1,(Hx1,Hx2)) (f2,(Hx3,Hx4)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
apply round_generic...
destruct f1 as (m1, e1).
destruct f2 as (m2, e2).
destruct (Z_eq_dec m2 0) as [Hm|Hm].
rewrite <- Hx3.
unfold float2R.
rewrite Hm, F2R_0.
apply generic_format_0.
assert (ln_beta radix2 (F2R (Float radix2 m2 e2)) <= Zpos p2 + e2)%Z.
rewrite ln_beta_F2R with (1 := Hm).
apply Zplus_le_compat_r.
apply Zle_trans with (2 := H2).
apply bpow_lt_bpow with radix2.
destruct (ln_beta radix2 (Z2R m2)) as (n2, Hn).
simpl.
specialize (Hn (Z2R_neq _ _ Hm)).
apply Rle_lt_trans with (1 := proj1 Hn).
rewrite <- Z2R_abs.
now apply Z2R_lt.
destruct (Zle_or_lt e1 e2) as [He|He].
(* *)
rewrite <- Hx3.
apply generic_format_F2R.
intros _ ; simpl.
apply Zmax_lub.
clear -H ; omega.
apply Zle_trans with (1 := H1).
now apply Zle_trans with e1.
(* *)
rewrite <- Hx1.
apply generic_format_F2R.
intros _ ; simpl.
apply Zmax_lub.
unfold float2R in Hx1. simpl in Hx1.
rewrite Hx1, <- Hx3.
unfold float2R. simpl.
omega.
now apply Zle_trans with d1.
Qed.

Theorem floatx_of_flt :
  forall rdir {Hrnd : Valid_rnd rdir},
  forall x : R,
  forall p1 p2 : positive,
  FLT x p1 ->
  Zle_bool (Zpos p1) (Zpos p2) = true ->
  rounding_floatx rdir p2 x = x.
Proof with auto with typeclass_instances.
intros rdir Hrnd x p1 p2 [[m e] [Hx1 Hx2]] Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply round_generic...
rewrite <- Hx1.
apply generic_format_F2R.
unfold canonic_exp.
intros Hm ; simpl.
rewrite ln_beta_F2R with (1 := Hm).
simpl.
unfold FLX_exp.
cut (ln_beta radix2 (Z2R m) <= Zpos p1)%Z.
clear -H1 ; omega.
apply bpow_lt_bpow with radix2.
destruct (ln_beta radix2 (Z2R m)) as [n Hn].
simpl.
specialize (Hn (Z2R_neq _ _ Hm)).
apply Rle_lt_trans with (1 := proj1 Hn).
rewrite <- Z2R_abs.
now apply Z2R_lt.
Qed.

Existing Instance valid_rnd_Gf.

Definition round_helper (rnd : float2 -> float2) (xi zi : FF) :=
 Fle2 (lower zi) (rnd (lower xi)) &&
 Fle2 (rnd (upper xi)) (upper zi).

Theorem float_round :
  forall rdir p d x xi zi,
  BND x xi ->
  round_helper (round (rndG_g rdir) (FLT_exp d (Zpos p))) xi zi = true ->
  BND (rounding_float (rndG_f rdir) p d x) zi.
Proof with auto with typeclass_instances.
intros rdir p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
apply round_le...
apply Hx.
apply Rle_trans with (2 := H2).
apply round_le...
apply Hx.
Qed.

Definition float_round_dn := float_round roundDN_cs.
Definition float_round_up := float_round roundUP_cs.
Definition float_round_zr := float_round roundZR_cs.
Definition float_round_ne := float_round roundNE_cs.
Definition float_round_na := float_round roundNA_cs.

Theorem floatx_round :
  forall rdir p x xi zi,
  BND x xi ->
  round_helper (round (rndG_g rdir) (FLX_exp (Zpos p))) xi zi = true ->
  BND (rounding_floatx (rndG_f rdir) p x) zi.
Proof with auto with typeclass_instances.
intros rdir p x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
apply round_le...
apply Hx.
apply Rle_trans with (2 := H2).
apply round_le...
apply Hx.
Qed.

Definition floatx_round_dn := floatx_round roundDN_cs.
Definition floatx_round_up := floatx_round roundUP_cs.
Definition floatx_round_zr := floatx_round roundZR_cs.
Definition floatx_round_ne := floatx_round roundNE_cs.
Definition floatx_round_na := floatx_round roundNA_cs.

Definition enforce_helper (fexp : Z -> Z) (xi zi : FF) :=
 Fle2 (lower zi) (round roundUP fexp (lower xi)) &&
 Fle2 (round roundDN fexp (upper xi)) (upper zi).

Theorem float_enforce :
  forall rdir {Hrnd : Valid_rnd rdir} p d x xi zi,
  BND (rounding_float rdir p d x) xi ->
  enforce_helper (FLT_exp d (Zpos p)) xi zi = true ->
  BND (rounding_float rdir p d x) zi.
Proof with auto with typeclass_instances.
intros rdir Hrnd p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite (rndG_conversion roundUP_cs). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite (rndG_conversion roundDN_cs). clear H2. intro H2.
revert Hx.
intros (Hx1, Hx2).
split.
apply Rle_trans with (1 := H1).
rewrite <- (round_generic _ _ rndUP _ (generic_format_round radix2 (FLT_exp d (Zpos p)) rdir x)).
apply round_le...
apply Rle_trans with (2 := H2).
rewrite <- (round_generic _ _ rndDN _ (generic_format_round radix2 (FLT_exp d (Zpos p)) rdir x)).
apply round_le...
Qed.

Theorem floatx_enforce :
  forall rdir {Hrnd : Valid_rnd rdir} p x xi zi,
  BND (rounding_floatx rdir p x) xi ->
  enforce_helper (FLX_exp (Zpos p)) xi zi = true ->
  BND (rounding_floatx rdir p x) zi.
Proof with auto with typeclass_instances.
intros rdir Hrnd p x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite (rndG_conversion roundUP_cs). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite (rndG_conversion roundDN_cs). clear H2. intro H2.
revert Hx.
intros (Hx1, Hx2).
split.
apply Rle_trans with (1 := H1).
rewrite <- (round_generic _ _ rndUP _ (generic_format_round radix2 (FLX_exp (Zpos p)) rdir x)).
apply round_le...
apply Rle_trans with (2 := H2).
rewrite <- (round_generic _ _ rndDN _ (generic_format_round radix2 (FLX_exp (Zpos p)) rdir x)).
apply round_le...
Qed.

Definition float_absolute_n_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 let u := upper xi in
 let e := (float_ulp p d (Fnum u) (Fexp u) - 1)%Z in
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem float_absolute_n :
  forall c p d x xi zi,
  ABS x xi ->
  float_absolute_n_helper p d xi zi = true ->
  BND (rounding_float (Znearest c) p d x - x) zi.
Proof with auto with typeclass_instances.
intros c p d x xi zi Hx Hb.
assert (H: (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R).
(* *)
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
replace (bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1)) with (/2 * ulp radix2 (FLT_exp d (Zpos p)) (upper xi))%R.
(* . *)
apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R.
apply error_le_half_ulp...
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
rewrite <- ulp_abs.
apply ulp_le_pos...
apply Rabs_pos.
apply Hx.
(* . *)
assert (Hm0: (Fnum (upper xi)) <> Z0).
assert (Hx1 := Rabs_no_R0 _ Hx0).
contradict Hx1.
apply Rle_antisym.
replace R0 with (float2R (upper xi)).
apply Hx.
clear -Hx1.
destruct (upper xi).
simpl in Hx1.
rewrite Hx1.
apply float2_zero.
apply Rabs_pos.
rewrite ulp_neq_0.
2: now apply F2R_neq_0_compat.
rewrite <- (bpow_plus radix2 (-1)).
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply (f_equal (fun e => bpow radix2 (-1 + e))).
clear -Hm0.
destruct (upper xi) as (m, e).
unfold canonic_exp, float2R.
rewrite ln_beta_F2R with (1 := Hm0).
rewrite <- Zdigits_ln_beta with (1 := Hm0).
simpl.
rewrite <- Fcore_digits.Zdigits_abs.
rewrite Zplus_comm.
destruct m as [|m|m] ; unfold Zabs.
now elim Hm0.
now rewrite <- digits2_digits.
now rewrite <- digits2_digits.
(* *)
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
unfold float2R.
rewrite (F2R_Zopp _ 1%Z).
rewrite F2R_bpow.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply (Rle_trans _ _ _ (Rabs_idem _)).
now rewrite Rabs_Ropp.
apply Rle_trans with (2 := H2).
unfold float2R.
rewrite F2R_bpow.
now apply (Rle_trans _ _ _ (Rabs_idem _)).
Qed.

Definition float_absolute_ne := float_absolute_n (fun x => negb (Zeven x)).
Definition float_absolute_na := float_absolute_n (Zle_bool 0).

Theorem float_absolute_inv_n :
  forall c p d x xi zi,
  ABS (rounding_float (Znearest c) p d x) xi ->
  float_absolute_n_helper p d xi zi = true ->
  BND (rounding_float (Znearest c) p d x - x) zi.
Proof with auto with typeclass_instances.
intros c p d x xi zi Hx Hb.
assert (H: (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R).
(* *)
replace (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi))) with
  (FLT_exp d (Zpos p) (if Z_eq_dec (Fnum (upper xi)) Z0 then d else (Fexp (upper xi) + Zpos (digits (pos_of_Z (Zabs (Fnum (upper xi))))))%Z)).
apply float_absolute_inv_n_whole.
apply Rle_lt_trans with (1 := proj2 (proj2 Hx)).
unfold float2R.
case Z_eq_dec ; intros Zx.
rewrite Zx, F2R_0.
apply bpow_gt_0.
rewrite digits2_digits.
rewrite Zpos_pos_of_Z.
rewrite Fcore_digits.Zdigits_abs, Zplus_comm.
rewrite <- Fcalc_digits.ln_beta_F2R_Zdigits with (1 := Zx).
destruct ln_beta as (ex,Ex) ; simpl.
apply Rle_lt_trans with (1 := RRle_abs _).
apply Ex.
contradict Zx.
apply F2R_eq_0_reg with (1 := Zx).
clear -Zx ; zify ; omega.
unfold float_ulp.
case Z_eq_dec ; intros Zx.
rewrite Zx.
unfold FLT_exp.
clear ; zify ; omega.
revert Zx.
case Fnum ; simpl ; [|easy|easy].
intros H.
now elim H.
(* *)
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
unfold float2R.
rewrite (F2R_Zopp _ 1%Z).
rewrite F2R_bpow.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply (Rle_trans _ _ _ (Rabs_idem _)).
now rewrite Rabs_Ropp.
apply Rle_trans with (2 := H2).
unfold float2R.
rewrite F2R_bpow.
now apply (Rle_trans _ _ _ (Rabs_idem _)).
Qed.

Definition float_absolute_inv_ne := float_absolute_inv_n (fun x => negb (Zeven x)).
Definition float_absolute_inv_na := float_absolute_inv_n (Zle_bool 0).

Definition float_absolute_wide_ne_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 let u := upper xi in
 let e := (float_ulp p d (Fnum u) (Fexp u) - 2)%Z in
 Zle_bool d (Fexp u - Zpos p) &&
 Fle2 u (Float2 (Zpos (xI (shift_pos p xH))) e) &&
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem float_absolute_wide_ne :
  forall p d x xi zi,
  ABS x xi ->
  float_absolute_wide_ne_helper p d xi zi = true ->
  BND (rounding_float rndNE p d x - x) zi.
Proof with auto with typeclass_instances.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3.
generalize (Fle2_correct _ _ H4). unfold float2R. simpl. rewrite F2R_bpow. clear H4. intro H4.
set (e := (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 2)%Z) in H2, H3, H4.
cut (Rabs (rounding_float rndNE p d x - x) <= bpow radix2 e)%R.
(* *)
split.
apply Rle_trans with (1 := H3).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H4).
apply Rle_trans with (2 := H).
apply Rabs_idem.
(* *)
destruct Hx as (_,(_,Hx)).
clear H3 H4 zi.
induction (upper xi).
induction Fnum ; simpl.
cutrewrite (x = R0).
rewrite round_0...
rewrite Rminus_0_r.
rewrite Rabs_R0.
apply bpow_ge_0.
elim (Req_dec x 0) ; intro H.
exact H.
elim Rlt_not_le with (2 := Hx).
rewrite float2_zero.
now apply Rabs_pos_lt.
(* *)
simpl in e, H1.
assert (H9: (e = Fexp + Zpos (digits p0) - Zpos p - 2)%Z).
unfold e, FLT_exp.
rewrite Zmax_inf_l.
exact (refl_equal _).
generalize (Zgt_pos_0 (digits p0)).
omega.
destruct (Rle_or_lt (bpow radix2 (Fexp + Zpos (digits p0) - 1)) (Rabs x)).
(* . *)
rewrite float_absolute_ne_sym.
cutrewrite (rounding_float rndNE p d (Rabs x) = bpow radix2 (Fexp + Zpos (digits p0) - 1) :>R).
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
apply Rle_trans with (Fcore_defs.F2R (Float radix2 (Zpos (xI (shift_pos p 1))) e) - bpow radix2 (Fexp + Zpos (digits p0) - 1))%R.
unfold Rminus.
apply Rplus_le_compat_r.
exact (Rle_trans _ _ _ Hx H2).
rewrite H9.
rewrite <- F2R_bpow.
change (Float2 (Zpos (shift_pos p 1)~1) (Fexp + Zpos (digits p0) - Zpos p - 2) - Float2 1 (Fexp + Zpos (digits p0) - 1) <=
  bpow radix2 (Fexp + Zpos (digits p0) - Zpos p - 2))%R.
rewrite <- Fminus2_correct.
unfold Fminus2, Fshift2.
simpl.
clear H H9 H2 e H1 Hx xi x d.
cutrewrite (Fexp + Zpos (digits p0) - Zpos p - 2 - (Fexp + Zpos (digits p0) - 1) = Zneg (p + 1))%Z.
cutrewrite (Zpos (xI (shift_pos p 1)) - Zpos (shift_pos (p + 1) 1) = 1)%Z.
unfold float2R.
rewrite F2R_bpow.
apply Rle_refl.
unfold shift_pos.
repeat rewrite iter_nat_of_P.
rewrite <- Pplus_one_succ_r.
rewrite nat_of_P_succ_morphism.
simpl.
now rewrite Z.pos_sub_diag.
rewrite <- Zneg_plus_distr.
rewrite <- (Zopp_neg p).
ring.
apply Rplus_le_reg_r with (Rabs x).
unfold Rminus.
now rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r, Rplus_0_l.
apply Rle_antisym.
cutrewrite (bpow radix2 (Fexp + Zpos (digits p0) - 1) =
  Fcore_generic_fmt.round radix2 (FLT_exp d (Zpos p)) rndNE (F2R (Float radix2 (Zpos (xI (shift_pos p 1))) e)) :>R).
(* .. *)
apply round_le...
exact (Rle_trans _ _ _ Hx H2).
change (F2R (Float radix2 (Zpos (shift_pos p 1)~1) e)) with (float2R (Float2 (Zpos (shift_pos p 1)~1) e)).
rewrite <- (rndG_conversion roundNE_cs).
unfold round, round_pos.
simpl.
cutrewrite (FLT_exp d (Zpos p) (e + Zpos (Psucc (digits (shift_pos p 1)))) = e + 2)%Z.
cutrewrite (e + 2 - e = 2)%Z. 2: ring.
unfold shr, shr_aux, shift_pos.
simpl.
rewrite iter_nat_of_P.
destruct (ZL4 p) as (p1,H3).
rewrite H3.
simpl.
rewrite H9.
cutrewrite (Fexp + Zpos (digits p0) - Zpos p - 2 + 2 = Fexp + Zpos (digits p0) - Zpos p)%Z.
2: ring.
destruct (Psucc_pred p) as [H4|H4].
rewrite H4.
rewrite H4 in H3.
injection H3.
intro H5.
rewrite <- H5.
now rewrite <- F2R_bpow.
rewrite <- F2R_bpow.
change (F2R (Float radix2 1 (Fexp + Zpos (digits p0) - 1))) with (float2R (Float2 1 (Fexp + Zpos (digits p0) - 1))).
rewrite <- (float2_shl_correct 1 (Fexp + Zpos (digits p0) - 1)%Z (Ppred p)).
simpl.
unfold shift_pos.
rewrite iter_nat_of_P.
rewrite <- H4 in H3.
rewrite nat_of_P_succ_morphism in H3.
injection H3.
intro H5.
rewrite H5.
cutrewrite (Fexp + Zpos (digits p0) - Zpos p = Fexp + Zpos (digits p0) - 1 - Zpos (Ppred p))%Z.
exact (refl_equal _).
pattern p at 1 ; rewrite <- H4.
rewrite Zpos_succ_morphism.
unfold Zsucc.
ring.
rewrite H9.
cutrewrite (digits (shift_pos p 1) = Psucc p)%Z.
repeat rewrite Zpos_succ_morphism.
unfold Zsucc.
cutrewrite (Fexp + Zpos (digits p0) - Zpos p - 2 + (Zpos p + 1 + 1) = Fexp + Zpos (digits p0))%Z. 2: ring.
unfold FLT_exp.
rewrite Zmax_inf_l.
ring.
generalize (Zgt_pos_0 (digits p0)).
omega.
clear H H9 H2 e H1 Hx Fexp p0 xi x d.
unfold shift_pos.
rewrite iter_nat_of_P.
rewrite <- P_of_succ_nat_o_nat_of_P_eq_succ.
induction (nat_of_P p).
exact (refl_equal _).
simpl.
rewrite IHn.
exact (refl_equal _).
(* .. *)
rewrite <- (round_generic radix2 (FLT_exp d (Zpos p)) rndNE (bpow radix2 (Fexp + Zpos (digits p0) - 1))).
apply round_le...
(* . *)
apply generic_format_bpow.
unfold FLT_exp.
rewrite Zmax_inf_l.
generalize (Zgt_pos_0 p).
omega.
generalize (Zgt_pos_0 (digits p0)).
omega.
cutrewrite (e = FLT_exp d (Zpos p) (Fexp + Zpos (digits p0) - 1) - 1)%Z.
now apply float_absolute_n_whole.
unfold e, FLT_exp.
assert (H3 := Zgt_pos_0 (digits p0)).
assert (H4 := Zgt_pos_0 p).
repeat rewrite Zmax_inf_l ; omega.
elim Rlt_not_le with (2 := Hx).
apply Rlt_le_trans with (Float2 0 Fexp).
now apply F2R_lt_compat.
unfold float2R.
rewrite F2R_0.
apply Rabs_pos.
Qed.

Definition float_relative_n_helper (p : positive) (d : Z) (xi zi : FF) :=
 Fle2 (Float2 1 (d + Zpos p - 1)) (lower xi) &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem float_relative_n :
  forall c p d x xi zi,
  ABS x xi ->
  float_relative_n_helper p d xi zi = true ->
  REL (rounding_float (Znearest c) p d x) x zi.
Proof.
intros c p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R. simpl. rewrite F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
exists ((rounding_float (Znearest c) p d x - x) / x)%R.
split.
assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R.
apply float_relative_n_whole.
apply Rle_trans with (1 := H1).
apply Hx.
split.
apply Rle_trans with (1 := H2).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := H).
apply Rabs_idem.
field.
intros H.
apply Rle_not_lt with (1 := H1).
apply Rle_lt_trans with (1 := proj1 (proj2 Hx)).
rewrite H, Rabs_R0.
apply bpow_gt_0.
Qed.

Definition float_relative_ne := float_relative_n (fun x => negb (Zeven x)).
Definition float_relative_na := float_relative_n (Zle_bool 0).

Definition floatx_relative_n_helper (p : positive) (zi : FF) :=
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem floatx_relative_n :
  forall c p x zi,
  floatx_relative_n_helper p zi = true ->
  REL (rounding_floatx (Znearest c) p x) x zi.
Proof.
intros c p x zi Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite F2R_bpow. clear H2. intro H2.
destruct (relative_error_N_FLX_ex radix2 (Zpos p) (refl_equal _) c x) as (eps, (Hr1, Hr2)).
exists eps.
refine (conj _ Hr2).
rewrite <- (bpow_plus radix2 (-1)%Z) in Hr1.
rewrite (Zplus_comm (- Zpos p)), Zplus_assoc in Hr1.
split.
apply Rle_trans with (1 := H1).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := Hr1).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H2).
apply Rle_trans with (2 := Hr1).
apply Rabs_idem.
Qed.

Definition floatx_relative_ne := floatx_relative_n (fun x => negb (Zeven x)).
Definition floatx_relative_na := floatx_relative_n (Zle_bool 0).

Definition float_relative_inv_n_helper (p : positive) (d : Z) (xi zi : FF) :=
 Flt2 (Float2 1 (d + Zpos p - 1)) (lower xi) &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem float_relative_inv_n :
  forall c p d x xi zi,
  ABS (rounding_float (Znearest c) p d x) xi ->
  float_relative_inv_n_helper p d xi zi = true ->
  REL (rounding_float (Znearest c) p d x) x zi.
Proof with auto with typeclass_instances.
intros c p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Flt2_correct _ _ H1). unfold float2R. simpl. rewrite F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
exists ((rounding_float (Znearest c) p d x - x) / x)%R.
split.
assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R.
apply float_relative_inv_n_whole.
apply Rlt_le_trans with (1 := H1).
apply Hx.
split.
apply Rle_trans with (1 := H2).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := H).
apply Rabs_idem.
field.
intros H.
apply Rlt_not_le with (1 := H1).
apply Rle_trans with (1 := proj1 (proj2 Hx)).
rewrite H, round_0, Rabs_R0...
apply bpow_ge_0.
Qed.

Definition float_relative_inv_ne := float_relative_inv_n (fun x => negb (Zeven x)).
Definition float_relative_inv_na := float_relative_inv_n (Zle_bool 0).

Definition rel_of_fix_float_n_helper (p : positive) (d xn : Z) (zi : FF) :=
 Zle_bool d xn &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem rel_of_fix_float_n :
  forall c p d xn x zi,
  FIX x xn ->
  rel_of_fix_float_n_helper p d xn zi = true ->
  REL (rounding_float (Znearest c) p d x) x zi.
Proof with auto with typeclass_instances.
intros c p d xn x zi ((mx, ex), (Hx1, Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
destruct (Rle_or_lt (Rabs x) (bpow radix2 (d + Zpos p))) as [He|He].
(* *)
rewrite round_generic...
exists R0.
repeat split.
apply Rle_trans with (1 := H2).
rewrite <- Ropp_0.
apply Ropp_le_contravar.
apply bpow_ge_0.
apply Rle_trans with (2 := H3).
apply bpow_ge_0.
now rewrite Rplus_0_r, Rmult_1_r.
apply generic_format_FLT_FIX...
rewrite <- Hx1.
apply generic_format_F2R.
intros _.
now apply Zle_trans with xn.
(* *)
exists ((rounding_float (Znearest c) p d x - x) / x)%R.
assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R.
apply float_relative_n_whole.
apply Rlt_le.
apply Rlt_trans with (2 := He).
apply bpow_lt.
pattern (d + Zpos p)%Z at 2 ; rewrite <- Zplus_0_r.
now apply Zplus_lt_compat_l.
repeat split.
apply Rle_trans with (1 := H2).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := H).
apply Rabs_idem.
field.
intros H0.
apply Rlt_not_le with (1 := He).
rewrite H0, Rabs_R0.
apply bpow_ge_0.
Qed.

Definition rel_of_fix_float_ne := rel_of_fix_float_n (fun x => negb (Zeven x)).
Definition rel_of_fix_float_na := rel_of_fix_float_n (Zle_bool 0).

Theorem fix_float_of_fix :
  forall rdir {Hrnd : Valid_rnd rdir} p d xn zn x,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (rounding_float rdir p d x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p d xn zn x Hx Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FIX_iff_generic.
apply generic_round_generic...
apply FIX_iff_generic.
now apply fix_le with xn.
Qed.

Theorem fix_floatx_of_fix :
  forall rdir {Hrnd : Valid_rnd rdir} p xn zn x,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (rounding_floatx rdir p x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p xn zn x Hx Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FIX_iff_generic.
apply generic_round_generic...
apply FIX_iff_generic.
now apply fix_le with xn.
Qed.

Theorem flt_float_of_flt :
  forall rdir {Hrnd : Valid_rnd rdir} p d xn zn x,
  FLT x xn ->
  Zle_bool (Zpos xn) (Zpos zn) = true ->
  FLT (rounding_float rdir p d x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p d xn zn x H Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FLT_iff_generic.
apply generic_round_generic...
apply FLT_iff_generic.
now apply flt_le with xn.
Qed.

Theorem flt_floatx_of_flt :
  forall rdir {Hrnd : Valid_rnd rdir} p xn zn x,
  FLT x xn ->
  Zle_bool (Zpos xn) (Zpos zn) = true ->
  FLT (rounding_floatx rdir p x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p xn zn x H Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FLT_iff_generic.
apply generic_round_generic...
apply FLT_iff_generic.
now apply flt_le with xn.
Qed.


Set Implicit Arguments.

Lemma b : forall X Y Z:bool,
andb (andb (negb(andb (andb (negb X) Y) (negb Z))) (negb (andb(andb X Y) Z))) (andb (andb X (negb Y)) (negb Z)) = andb (andb X (negb Y)) (negb Z).
Proof.
intros a b c.
destruct a, b, c.
+ reflexivity.
+ reflexivity.
+ reflexivity.
+ reflexivity.
+ reflexivity.
+ reflexivity.
+ reflexivity.
+ reflexivity.
Qed.


(*
  Reduction from:
    Turing Machine Halting (HaltTM 1)
  to:
    Halting of one counter machines (CM1_HALT)
*)

(* ** HaltTM 1 reduces to CM1_HALT  *)

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

Require Import Undecidability.TM.TM.

Require Import Undecidability.FRACTRAN.Reductions.HaltTM_1_to_FRACTRAN_HALTING.

From Undecidability.MinskyMachines
  Require Import FRACTRAN_to_MMA2 MMA2_to_MM2.

From Undecidability.CounterMachines
  Require Import CM1 MM2_HALTING_to_CM2_HALT CM2_HALT_to_CM1_HALT.

(* Many-one reduction from Turing machine halting to
  one counter machine halting *)
Theorem reduction : HaltTM 1 ⪯ CM1_HALT.
Proof.
  apply (reduces_transitive HaltTM_to_FRACTRAN_REG_HALTING).
  apply (reduces_transitive FRACTRAN_REG_MMA2_HALTING).
  apply (reduces_transitive MMA2_MM2_HALTING).
  apply (reduces_transitive MM2_HALTING_to_CM2_HALT.reduction).
  exact CM2_HALT_to_CM1_HALT.reduction.
Qed.