From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
From Coq Require Import ssrfun.
Require Import AutosubstSsr ARS Context.
Require Import Program.Equality.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import ast.
Require Import smallstep.
Require Import confluence.

(* typing, in the style of type assignemnt *)

Notation "Gamma `_ i" := (dget Gamma i) (at level 2).

Reserved Notation "[ Gamma |- ]".
Reserved Notation "[ Gamma |- s :- A ]".

Inductive has_type : list term -> term -> term -> Prop :=
| ty_var Gamma x :
  x < size Gamma ->
  [ Gamma |- Var x :- Gamma`_x ]
| ty_tt Gamma :
  [ Gamma |- TT :- TT ]
| ty_pi Gamma A B :
  [ Gamma |- A :- TT ] ->
  [ A :: Gamma |- B :- TT ] ->
  [ Gamma |- Pi A B :- TT ]
| ty_fun Gamma A B s :
  [ Gamma |- Pi A B :- TT ] ->
  [ (Pi A B).[ren (+1)] :: A :: Gamma |- s :- B.[ren (+1)] ] ->
  (* why +1 ? what is the orientation of gamma and the bound
   * vars inside of it. seems more reasonable to do A+1 *)
  [ Gamma |- Fun s :- Pi A B ]
| ty_app Gamma A B s t :
  [ Gamma |- s :- Pi A B ] ->
  [ Gamma |- t :- A ] ->
  [ Gamma |- App s t :- B.[t/] ]
| ty_cast Gamma A s :
  [ Gamma |- s :- A ] ->
  [ Gamma |- Cast s A :- A ]
  (* with the reductoin behavour, at the type level some
   * weirdness is allowed by this rule *)
| ty_conv Gamma A B s :
  A === B ->
  [ Gamma |- s :- A ] ->
  [ Gamma |- s :- B ]
where "[ Gamma |- s :- A ]" := (has_type Gamma s A).

(* for progress *)

Lemma canonical_form_pi s P A B :
  [ [::] |- s :- P ] -> value s -> P === Pi A B ->
  exists s', s = Fun s'.
Proof.
  elim=> [].
  - move=> Gamma x si v eq. inv v.
  - move=> Gamma v eq.
    apply conv_sym in eq.
    apply conv_pi_tt in eq => //.
  - move=> Gamma A0 B0 _ ih1 _ ih2 v eq.
    apply conv_sym in eq.
    apply conv_pi_tt in eq => //.
  - move=> Gamma A0 B0 s0 _ ih1 _ ih2 v eq.
    exists s0 => //.
  - move=> Gamma A0 B0 s0 t _ ih1 _ ih2 v eq. inv v.
  - move=> Gamma A0 s0 _ ih v eq. inv v.
  - move=> Gamma A0 B0 s0 eq1 _ ih v eq2.
    apply: ih => //. eapply conv_trans.
    exact: eq1. exact: eq2.
Qed.

Lemma ty_app' Gamma A B s t u :
  [ Gamma |- s :- Pi A B ] ->
  [ Gamma |- t :- A ] ->
  u = B.[t/] ->
  [ Gamma |- App s t :- u ].
Proof.
 intros.
 rewrite H1.
 apply: ty_app.
 eauto.
 auto.
Qed.

Inductive context_ok : list term -> Prop :=
| ctx_nil :
[ [::] |- ]
| ctx_ncons Gamma A :
[ Gamma |- A :- TT ] ->
[ Gamma |- ] ->
[ A :: Gamma |- ]
where "[ Gamma |- ]" := (context_ok Gamma).

Lemma ty_evar Gamma (A : term) (x : var) :
A = Gamma`_x -> x < size Gamma -> [ Gamma |- Var x :- A ].
Proof. move->. exact: ty_var. Qed.

Lemma ty_eapp Gamma (A B C s t : term) :
C = B.[t/] ->
[ Gamma |- s :- Pi A B ] -> [ Gamma |- t :- A ] ->
[ Gamma |- App s t :- C ].
Proof. move=>->. exact: ty_app. Qed.

Notation "[ Gamma |- s ]" := [ Gamma |- s :- TT ].

Lemma ty_tt_wf Gamma : [ Gamma |- TT ].
Proof. exact: ty_tt. Qed.
Hint Resolve ty_tt_wf ty_tt.

Lemma ty_pi_wf Gamma A B :
[ Gamma |- A ] -> [ A :: Gamma |- B ] -> [ Gamma |- Pi A B ].
Proof. exact: ty_pi. Qed.

Notation "[ Delta |- sigma -| Gamma ]" :=
(forall x, x < size Gamma -> [ Delta |- sigma x :- (Gamma`_x).[(sigma : _ -> _)] ]).

Lemma ty_renaming xi Gamma Delta s A :
[ Gamma |- s :- A ] ->
(forall x, x < size Gamma -> xi x < size Delta) ->
(forall x, x < size Gamma -> (Gamma`_x).[ren xi] = Delta`_(xi x)) ->
[ Delta |- s.[ren xi] :- A.[ren xi] ].
Proof with eauto using has_type.
move=> tp. elim: tp xi Delta => {Gamma s A} /=.
- move=> Gamma x si xi Delta subctx ->...
- move=> Gamma xi Delta subctx eqn...
- move=> Gamma A B _ ih1 _ ih2 xi Delta subctx eqn.
apply: ty_pi. exact: ih1. asimpl. apply: ih2.
+ by move=> [//|x /subctx].
+ by move=> [_|x /eqn/=<-]; autosubst.
- move=> Gamma A B s _ ih1 _ ih2 xi Delta subctx eqn.
apply ty_fun. by apply ih1. asimpl.
replace (B.[ren (1 .: xi >>> (+2))]) with
    (B.[ren (+1)].[ren (0 .: 1 .: xi >>> (+2))]) by asimpl => //.
apply ih2.
+ move=> [//|]. by move => [//|x /subctx].
+ move=> [|]. autosubst.
  move=> [|n /eqn/=<-]; autosubst.
- move=> Gamma A B s t _ ih1 _ ih2 xi Delta subctx eqn //=.
apply: (@ty_eapp _ A.[ren xi] B.[up (ren xi)]). autosubst.
  exact: ih1. exact: ih2.
- move=> Gamma A s _ ih xi Delta subctx eqn.
apply: ty_cast...
- move=> Gamma A B s eq _ ih xi Delta subctx eqn.
apply: (@ty_conv _ A.[ren xi] B.[ren xi]).
exact: conv_subst. exact: ih.
Qed.

Lemma weakening Gamma s A B :
[ Gamma |- s :- A ] -> [ B :: Gamma |- s.[ren (+1)] :- A.[ren (+1)] ].
Proof. move=> /ty_renaming. exact. Qed.

Lemma eweakening Gamma s s' A A' B :
s' = s.[ren (+1)] -> A' = A.[ren (+1)] ->
[ Gamma |- s :- A ] -> [ B :: Gamma |- s' :- A' ].
Proof. move=>->->. exact: weakening. Qed.

Lemma ty_ok Gamma :
[ Gamma |- ] -> forall x, x < size Gamma -> [ Gamma |- Gamma`_x ].
Proof.
elim=> // {Gamma} Gamma A tp _ ih [_|x /ih {tp} tp];
      exact: weakening tp.
Qed.

Lemma sty_up sigma Gamma Delta A :
[ Delta |- sigma -| Gamma ] ->
[ A.[sigma] :: Delta |- up sigma -| A :: Gamma ].
Proof.
move=> stp [_//|x /stp tp] /=. apply: ty_evar => //=. autosubst.
apply: eweakening tp; autosubst.
Qed.

Lemma ty_subst sigma Gamma Delta s A :
[ Delta |- sigma -| Gamma ] -> [ Gamma |- s :- A ] ->
[ Delta |- s.[sigma] :- A.[sigma] ].
Proof.
move=> stp tp. elim: tp sigma Delta stp => {Gamma s A} /=.
- move=> Gamma x si sigma Delta stp.
exact: stp.
- move=> Gamma sigma Delta stp => //.
- move=> Gamma A B _ ih1 _ ih2 sigma Delta stp.
apply: ty_pi. exact: ih1. apply ih2. exact: sty_up.
- move=> Gamma A B s _ ih1 _ ih2 sigma Delta stp.
apply: ty_fun. by eapply ih1.
replace (B.[up sigma].[ren (+1)]) with
    (B.[ren (+1)].[upn 2 sigma]) by asimpl => //.
apply: ih2 => x si.
rewrite <- fold_up_up.
replace ((Pi A.[sigma] B.[up sigma]).[ren (+1)]) with
    ((Pi A.[ren (+1)] B.[up (ren (+1))]).[up sigma]) by asimpl => //.
apply: sty_up => // => {x si} x si.
exact: sty_up.
- move=> Gamma A B s t _ ih1 _ ih2 sigma Delta stp.
apply: (@ty_eapp _ A.[sigma] B.[up sigma]). autosubst.
exact: ih1. exact: ih2.
- move=> Gamma A s _ ih sigma Delta stp.
apply: ty_cast. exact: ih.
- move=> Gamma A B s eq _ ih sigma Delta stp.
apply: (@ty_conv _ A.[sigma] B.[sigma]).
exact: conv_subst. exact: ih.
Qed.

Lemma ty_cut Gamma s t A B :
[ A :: Gamma |- s :- B ] -> [ Gamma |- t :- A ] ->
[ Gamma |- s.[t/] :- B.[t/] ].
Proof.
move=> /ty_subst h tp. apply: h => -[_|x leq]; asimpl => //.
exact: ty_var.
Qed.

Lemma ty_ctx_conv1 Gamma s A B C :
[ A :: Gamma |- s :- C ] -> B === A -> [ Gamma |- A :- TT ] ->
[ B :: Gamma |- s :- C ].
Proof.
move=> tp1 conv tp2. cut ([ B :: Gamma |- s.[ids] :- C.[ids] ]). autosubst.
apply: ty_subst tp1. move=> [_|x //=]. asimpl. eapply ty_conv.
apply: conv_subst conv.
eapply ty_var => //.
move=> le. asimpl. exact: ty_var.
Qed.

Lemma ty_ctx_conv2 Gamma s A1 A2 B1 B2 C :
[ A1 :: B1 :: Gamma |- s :- C ] -> A2 === A1 -> B2 === B1 ->
[ Gamma |- B1 :- TT ] -> [ B1 :: Gamma |- A1 :- TT ] ->
[ A2 :: B2 :: Gamma |- s :- C ].
Proof.
move=> tp1 conv1 conv2 tp2 tp3.
cut ([ A2 :: B2 :: Gamma |- s.[ids] :- C.[ids] ]).
autosubst.
apply: ty_subst tp1. move=> [_|[_|x]].
- asimpl. eapply ty_conv. apply: conv_subst conv1. exact: ty_var.
- asimpl. eapply ty_conv. apply: conv_subst conv2.
replace (B2.[ren (+2)]) with
    ([:: A2, B2 & Gamma]`_1) by autosubst.
exact: ty_var.
- move=> le. asimpl.
replace (ids x.+2) with
    ((Var x).[ren (+1)].[ren (+1)]) by autosubst.
replace (Gamma`_ x.[ren (+2)]) with
    ((Gamma`_ x).[ren (+1)].[ren (+1)]) by autosubst.
apply weakening. apply weakening.
exact: ty_var.
Qed.

Lemma ty_pi_inv Gamma A B :
[ Gamma |- Pi A B :- TT ] ->
[ Gamma |- A :- TT ] /\ [ A :: Gamma |- B :- TT ].
Proof.
move e:(Pi A B) => s tp. elim: tp A B e => //{Gamma s}.
- move=> Gamma A B tp1 _ tp2 _ A' B' [->->] => //.
- move=> Gamma A B s eq tp ih A' B' e.
subst. elim: (ih A' B') => // => tp1 tp2.
eauto using has_type.
Qed.

Lemma ty_fun_invX Gamma s A B C :
[ Gamma |- Fun s :- C ] -> (C === Pi A B) ->
[ (Pi A B).[ren (+1)] :: A :: Gamma |- s :- B.[ren (+1)] ].
Proof with eauto using conv_subst, conv_sym, conv_pi.
move e:(Fun s) => t tp eq. elim: tp A B s e eq => // {Gamma C t}.
- move => Gamma A B s tp1 ih1 tp2 ih2 A' B' s' [->].
move=> /inj_pi[e1 e2].
apply: ty_conv. apply: conv_subst e2.
apply: (ty_ctx_conv2 tp2)...
elim: (ty_pi_inv tp1) => //.
replace (TT) with (TT.[ren (+1)]) by autosubst.
by apply: weakening.
- move=> Gamma A B s eq1 tp1 ih A' B' s' e eq2. subst.
+ apply: ih => //.
  exact: conv_trans eq1 eq2.
Qed.

Lemma ty_fun_inv Gamma s A B :
[ Gamma |- Fun s :- Pi A B ] ->
[ (Pi A B).[ren (+1)] :: A :: Gamma |- s :- B.[ren (+1)] ].
Proof. move=> tp. apply: (ty_fun_invX tp). apply: convR. Qed.

(* non bidirectional *)
Lemma nonbi :
  [ nil |- App (Fun (Var 1)) TT :- TT ].
Proof.
 intros.
 apply: ty_app'.
 Focus 2.
 apply: ty_tt.
 apply: ty_fun.
 apply: ty_pi.
 apply: ty_tt.
 apply: ty_tt.
 simpl.
 apply: ty_var.
 auto.
 auto.
Qed.

Print nonbi.


From stdpp Require Import base.

Declare Scope noix_scope.
Delimit Scope noix_scope with Nx.

(** Noix Proposition *)
Inductive nProp : Type :=
| Sep : nProp → nProp → nProp
| Forall (A : Type) : (A → nProp) → nProp.
Bind Scope noix_scope with nProp.

Notation "P ∗ Q" := (Sep P Q)%Nx
  (at level 80, right associativity, format "P  ∗  '/' Q") : noix_scope.

Definition from_Empty_set {A : Type} (x : Empty_set) : A := match x with end.
Notation "'True'" := (Forall Empty_set from_Empty_set)%Nx : noix_scope.

Check (True ∗ True)%Nx.


(** * Utility functions for PHOAS *)
Require Import Reify.Common.
Require Import Reify.PHOAS.

Module PHOAS.
  Export Reify.PHOAS.

  Fixpoint beq_helper (e1 e2 : @expr nat) (base : nat) : bool
    := match e1, e2 with
       | LetIn v1 f1, LetIn v2 f2
         => if beq_helper v1 v2 base
            then beq_helper (f1 base) (f2 base) (S base)
            else false
       | Var v1, Var v2 => Nat.eqb v1 v2
       | NatO, NatO => true
       | NatS x, NatS y => beq_helper x y base
       | NatMul x1 y1, NatMul x2 y2
         => andb (beq_helper x1 x2 base) (beq_helper y1 y2 base)
       | LetIn _ _, _
       | Var _, _
       | NatO, _
       | NatS _, _
       | NatMul _ _, _
         => false
       end.
  Definition beq (e1 e2 : @expr nat) : bool := beq_helper e1 e2 O.
  Definition Beq (e1 e2 : Expr) : bool := beq (e1 _) (e2 _).
End PHOAS.


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

Copyright (C) 2014-2018 Sylvie Boldo

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Core Plus_error.

Open Scope R_scope.

Section av1.

Lemma Rmin_Rmax_overflow: forall x y z M, Rabs x <= M -> Rabs y <= M ->
        Rmin x y <= z <= Rmax x y -> Rabs z <= M.
Proof.
intros x y z M Hx Hy H.
case (Rle_or_lt 0 z); intros Hz.
rewrite Rabs_right.
apply Rle_trans with (1:=proj2 H).
generalize (proj2 H).
apply Rmax_case_strong.
intros; apply Rle_trans with (2:=Hx).
apply RRle_abs.
intros; apply Rle_trans with (2:=Hy).
apply RRle_abs.
now apply Rle_ge.
rewrite Rabs_left; try assumption.
apply Rle_trans with (Rmax (-x) (-y)).
rewrite Rmax_opp.
apply Ropp_le_contravar, H.
apply Rmax_case_strong.
intros; apply Rle_trans with (2:=Hx).
rewrite <- Rabs_Ropp.
apply RRle_abs.
intros; apply Rle_trans with (2:=Hy).
rewrite <- Rabs_Ropp.
apply RRle_abs.
Qed.

Definition radix2 := Build_radix 2 (refl_equal true).
Notation bpow e := (bpow radix2 e).

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

Notation format := (generic_format radix2 (FLT_exp emin prec)).
Notation round_flt :=(round radix2 (FLT_exp emin prec) ZnearestE).
Notation ulp_flt :=(ulp radix2 (FLT_exp emin prec)).
Notation cexp := (cexp radix2 (FLT_exp emin prec)).
Notation pred_flt := (pred radix2 (FLT_exp emin prec)).

Lemma FLT_format_double: forall u, format u -> format (2*u).
Proof with auto with typeclass_instances.
intros u Fu.
apply generic_format_FLT.
apply FLT_format_generic in Fu...
destruct Fu as [uf H1 H2 H3].
exists (Float radix2 (Fnum uf) (Fexp uf+1)).
rewrite H1; unfold F2R; simpl.
rewrite bpow_plus, bpow_1.
simpl;ring.
easy.
apply Z.le_trans with (1:=H3).
apply Zle_succ.
Qed.

Lemma FLT_format_half: forall u,
   format u -> bpow (prec+emin) <= Rabs u -> format (u/2).
Proof with auto with typeclass_instances.
intros u Fu H.
apply FLT_format_generic in Fu...
destruct Fu as [[n e] H1 H2 H3].
simpl in H1, H2, H3.
apply generic_format_FLT.
exists (Float radix2 n (e-1)).
rewrite H1; unfold F2R; simpl.
unfold Zminus; rewrite bpow_plus.
change (bpow (-(1))) with (/2).
unfold Rdiv; ring.
easy.
cut (prec + emin < prec +e)%Z.
  simpl ; lia.
apply lt_bpow with radix2.
apply Rle_lt_trans with (1:=H).
rewrite H1; unfold F2R; simpl.
rewrite Rabs_mult; rewrite (Rabs_right (bpow e)).
2: apply Rle_ge, bpow_ge_0.
rewrite bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
rewrite <- abs_IZR.
rewrite <- IZR_Zpower.
now apply IZR_lt.
now apply Zlt_le_weak.
Qed.

Lemma FLT_round_half: forall z, bpow (prec+emin) <= Rabs z ->
   round_flt (z/2)= round_flt z /2.
Proof with auto with typeclass_instances.
intros z Hz.
apply Rmult_eq_reg_l with 2.
2: apply sym_not_eq; auto with real.
apply trans_eq with (round_flt z).
2: field.
assert (z <> 0)%R.
intros K; contradict Hz.
rewrite K, Rabs_R0; apply Rlt_not_le.
apply bpow_gt_0.
assert (cexp (z/2) = cexp z -1)%Z.
assert (prec+emin < mag radix2 z)%Z.
apply lt_bpow with radix2.
destruct mag as (e,He); simpl.
apply Rle_lt_trans with (1:=Hz).
now apply He.
unfold cexp, FLT_exp.
replace ((mag radix2 (z/2))-prec)%Z with ((mag radix2 z -1) -prec)%Z.
rewrite Z.max_l; lia.
apply Zplus_eq_compat; try reflexivity.
apply sym_eq, mag_unique.
destruct (mag radix2 z) as (e,He); simpl.
unfold Rdiv; rewrite Rabs_mult.
rewrite (Rabs_right (/2)).
split.
apply Rmult_le_reg_l with (bpow 1).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (1+(e-1-1))%Z with (e-1)%Z by ring.
apply Rle_trans with (Rabs z).
now apply He.
change (bpow 1) with 2%R.
right; simpl; field.
apply Rmult_lt_reg_l with (bpow 1).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (1+(e-1))%Z with e by ring.
apply Rle_lt_trans with (Rabs z).
change (bpow 1) with 2.
right; field.
now apply He.
lra.
unfold round, scaled_mantissa, F2R.
rewrite H0; simpl.
rewrite Rmult_comm, Rmult_assoc.
apply f_equal2.
apply f_equal, f_equal.
replace (-(cexp z -1))%Z with (-cexp z +1)%Z by ring.
rewrite bpow_plus.
change (bpow 1) with 2.
field.
unfold Zminus; rewrite bpow_plus.
change (bpow (-(1))) with (/2).
field.
Qed.

Lemma FLT_ulp_le_id: forall u, bpow emin <= u -> ulp_flt u <= u.
Proof with auto with typeclass_instances.
intros u H.
rewrite ulp_neq_0.
2: apply Rgt_not_eq, Rlt_le_trans with (2:=H), bpow_gt_0.
case (Rle_or_lt (bpow (emin+prec-1)) u); intros Hu.
unfold ulp; rewrite cexp_FLT_FLX.
unfold cexp, FLX_exp.
destruct (mag radix2 u) as (e,He); simpl.
apply Rle_trans with (bpow (e-1)).
apply bpow_le.
unfold Prec_gt_0 in prec_gt_0_; lia.
rewrite <- (Rabs_right u).
apply He.
apply Rgt_not_eq, Rlt_gt.
apply Rlt_le_trans with (2:=Hu).
apply bpow_gt_0.
apply Rle_ge, Rle_trans with (2:=Hu), bpow_ge_0.
rewrite Rabs_right.
assumption.
apply Rle_ge, Rle_trans with (2:=Hu), bpow_ge_0.
unfold ulp; rewrite cexp_FLT_FIX.
apply H.
apply Rgt_not_eq, Rlt_gt.
apply Rlt_le_trans with (2:=H).
apply bpow_gt_0.
rewrite Rabs_right.
apply Rlt_le_trans with (1:=Hu).
apply bpow_le; lia.
apply Rle_ge, Rle_trans with (2:=H), bpow_ge_0.
Qed.

Lemma FLT_ulp_double: forall u, ulp_flt (2*u) <= 2*ulp_flt(u).
Proof.
intros u.
case (Req_bool_spec u 0); intros Hu'.
rewrite Hu', Rmult_0_r.
rewrite <- (Rmult_1_l (ulp_flt 0)) at 1.
apply Rmult_le_compat_r.
apply ulp_ge_0.
left; apply Rlt_plus_1.
rewrite 2!ulp_neq_0; trivial.
2: lra.
change 2 at 2 with (bpow 1).
rewrite <- bpow_plus.
apply bpow_le.
case (Rle_or_lt (bpow (emin+prec-1)) (Rabs u)); intros Hu.
(* *)
rewrite cexp_FLT_FLX.
rewrite cexp_FLT_FLX; trivial.
unfold cexp, FLX_exp.
change 2 with (bpow 1).
rewrite Rmult_comm, mag_mult_bpow.
lia.
intros H; contradict Hu.
apply Rlt_not_le; rewrite H, Rabs_R0.
apply bpow_gt_0.
apply Rle_trans with (1:=Hu).
rewrite Rabs_mult.
pattern (Rabs u) at 1; rewrite <- (Rmult_1_l (Rabs u)).
apply Rmult_le_compat_r.
apply Rabs_pos.
rewrite <- (abs_IZR 2).
now apply IZR_le.
(* *)
rewrite cexp_FLT_FIX.
rewrite cexp_FLT_FIX; trivial.
unfold FIX_exp, cexp; lia.
apply Rlt_le_trans with (1:=Hu).
apply bpow_le; lia.
lra.
rewrite Rabs_mult.
rewrite Rabs_pos_eq.
2: now apply IZR_le.
apply Rlt_le_trans with (2*bpow (emin + prec - 1)).
apply Rmult_lt_compat_l with (1 := Rlt_0_2).
assumption.
change 2 with (bpow 1).
rewrite <- bpow_plus.
apply bpow_le; lia.
Qed.

Lemma round_plus_small_id_aux: forall f h, format f -> (bpow (prec+emin) <= f) -> 0 < f
   -> Rabs h <= /4* ulp_flt f -> round_flt (f+h) = f.
Proof with auto with typeclass_instances.
intros f h Ff H1 H2 Hh.
case (Rle_or_lt 0 h); intros H3;[destruct H3|idtac].
(* 0 < h *)
rewrite Rabs_right in Hh.
2: now apply Rle_ge, Rlt_le.
apply round_N_eq_DN_pt with (f+ ulp_flt f)...
pattern f at 2; rewrite <- (round_DN_plus_eps_pos radix2 (FLT_exp emin prec) f) with (eps:=h); try assumption.
apply round_DN_pt...
now left.
split.
now left.
apply Rle_lt_trans with (1:=Hh).
rewrite <- (Rmult_1_l (ulp_flt f)) at 2.
apply Rmult_lt_compat_r.
rewrite ulp_neq_0; try now apply Rgt_not_eq.
apply bpow_gt_0.
lra.
rewrite <- (round_UP_plus_eps_pos radix2 (FLT_exp emin prec) f) with (eps:=h); try assumption.
apply round_UP_pt...
now left.
split; trivial.
apply Rle_trans with (1:=Hh).
rewrite <- (Rmult_1_l (ulp_flt f)) at 2.
apply Rmult_le_compat_r.
apply ulp_ge_0.
lra.
apply Rplus_lt_reg_l with (-f); ring_simplify.
apply Rlt_le_trans with (/2*ulp_flt f).
2: right; field.
apply Rle_lt_trans with (1:=Hh).
apply Rmult_lt_compat_r.
rewrite ulp_neq_0; try now apply Rgt_not_eq.
apply bpow_gt_0.
lra.
(* h = 0 *)
rewrite <- H, Rplus_0_r.
apply round_generic...
(* h < 0 *)
(*  - assertions *)
rewrite Rabs_left in Hh; try assumption.
assert (0 < pred_flt f).
apply Rlt_le_trans with (bpow emin).
apply bpow_gt_0.
apply pred_ge_gt...
apply generic_format_FLT_bpow...
apply Z.le_refl.
apply Rlt_le_trans with (2:=H1).
apply bpow_lt.
unfold Prec_gt_0 in prec_gt_0_; lia.
assert (M:(prec + emin +1 <= mag radix2 f)%Z).
apply mag_ge_bpow.
replace (prec+emin+1-1)%Z with (prec+emin)%Z by ring.
rewrite Rabs_right; try assumption.
apply Rle_ge; now left.
assert (T1:(ulp_flt (pred_flt f) = ulp_flt f)
     \/ ( ulp_flt (pred_flt f) = /2* ulp_flt f
               /\ f = bpow (mag radix2 f -1))).
generalize H; rewrite pred_eq_pos; [idtac|now left].
unfold pred_pos; case Req_bool_spec; intros K HH.
(**)
right; split; try assumption.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
apply trans_eq with (bpow (mag radix2 f- prec -1)).
apply f_equal.
unfold cexp.
apply trans_eq with (FLT_exp emin prec (mag radix2 f -1)%Z).
apply f_equal.
unfold FLT_exp.
rewrite Z.max_l by lia.
apply mag_unique.
rewrite Rabs_right.
split.
apply Rplus_le_reg_l with (bpow (mag radix2 f -1-prec)).
ring_simplify.
apply Rle_trans with (bpow (mag radix2 f - 1 - 1) + bpow (mag radix2 f - 1 - 1)).
apply Rplus_le_compat_r.
apply bpow_le.
unfold Prec_gt_0 in prec_gt_0_; lia.
apply Rle_trans with (bpow 1*bpow (mag radix2 f - 1 - 1)).
change (bpow 1) with 2.
right; ring.
rewrite <- bpow_plus.
apply Rle_trans with (bpow (mag radix2 f -1)).
apply bpow_le; lia.
rewrite <- K; now right.
rewrite <- K.
apply Rplus_lt_reg_l with (-f+bpow (mag radix2 f-1-prec)); ring_simplify.
apply bpow_gt_0.
apply Rle_ge.
rewrite K at 1.
apply Rplus_le_reg_l with (bpow (mag radix2 f - 1 - prec)).
ring_simplify.
apply bpow_le.
unfold Prec_gt_0 in prec_gt_0_; lia.
unfold FLT_exp.
rewrite Z.max_l by lia.
ring.
replace (/2) with (bpow (-1)) by reflexivity.
rewrite ulp_neq_0; try now apply Rgt_not_eq.
rewrite <- bpow_plus.
apply f_equal.
unfold cexp, FLT_exp.
rewrite Z.max_l by lia.
ring.
(**)
left.
assert (bpow (mag radix2 f -1) < f).
destruct (mag radix2 f); simpl in *.
destruct a.
now apply Rgt_not_eq.
rewrite Rabs_right in H0.
destruct H0; try assumption.
contradict H0.
now apply sym_not_eq.
apply Rle_ge; now left.
assert (bpow (mag radix2 f -1) + ulp_flt (bpow (mag radix2 f-1)) <= f).
rewrite <- succ_eq_pos;[idtac|apply bpow_ge_0].
apply succ_le_lt...
apply generic_format_FLT_bpow...
unfold Prec_gt_0 in prec_gt_0_;lia.
rewrite ulp_bpow in H4.
unfold FLT_exp in H4.
rewrite Z.max_l in H4 by lia.
replace (mag radix2 f - 1 + 1 - prec)%Z with  (mag radix2 f - prec)%Z in H4 by ring.
rewrite ulp_neq_0; try now apply Rgt_not_eq.
rewrite ulp_neq_0 at 2; try now apply Rgt_not_eq.
unfold cexp.
apply f_equal; apply f_equal.
replace (ulp_flt f) with (bpow (mag radix2 f -prec)).
apply mag_unique.
rewrite Rabs_right.
split.
apply Rplus_le_reg_l with (bpow (mag radix2 f -prec)).
ring_simplify.
apply Rle_trans with (2:=H4); right; ring.
apply Rlt_trans with f.
apply Rplus_lt_reg_l with (-f+bpow (mag radix2 f - prec)).
ring_simplify.
apply bpow_gt_0.
apply Rle_lt_trans with (1:=RRle_abs _).
apply bpow_mag_gt.
apply Rle_ge.
apply Rplus_le_reg_l with (bpow (mag radix2 f - prec)).
ring_simplify.
left; apply Rle_lt_trans with (2:=H0).
apply bpow_le.
unfold Prec_gt_0 in prec_gt_0_;lia.
rewrite ulp_neq_0; try now apply Rgt_not_eq.
unfold cexp, FLT_exp.
rewrite Z.max_l.
reflexivity.
lia.
assert (T: (ulp_flt (pred_flt f) = ulp_flt f \/
              (ulp_flt (pred_flt f) = / 2 * ulp_flt f /\ - h < / 4 * ulp_flt f))
         \/ (ulp_flt (pred_flt f) = / 2 * ulp_flt f /\
              f = bpow (mag radix2 f - 1) /\
              - h = / 4 * ulp_flt f) ).
destruct T1.
left; now left.
case Hh; intros P.
left; right.
split; try apply H0; assumption.
right.
split; try split; try apply H0; assumption.
clear T1.
(*  - end of assertions *)
destruct T.
(* normal case *)
apply round_N_eq_UP_pt with (pred_flt f)...
rewrite <- (round_DN_minus_eps_pos radix2 (FLT_exp emin prec) f) with (eps:=-h); try assumption.
replace (f--h) with (f+h) by ring.
apply round_DN_pt...
split.
auto with real.
apply Rle_trans with (1:=Hh).
apply Rle_trans with (/2*ulp_flt f).
apply Rmult_le_compat_r.
apply ulp_ge_0.
lra.
case H0.
intros Y; rewrite Y.
rewrite <- (Rmult_1_l (ulp_flt f)) at 2.
apply Rmult_le_compat_r.
apply ulp_ge_0.
lra.
intros Y; rewrite (proj1 Y); now right.
replace (f+h) with (pred_flt f + (f-pred_flt f+h)) by ring.
pattern f at 4; rewrite <- (round_UP_pred_plus_eps_pos radix2 (FLT_exp emin prec) f) with (eps:=(f - pred_flt f + h)); try assumption.
apply round_UP_pt...
replace (f-pred_flt f) with (ulp_flt (pred_flt f)).
split.
apply Rplus_lt_reg_l with (-h); ring_simplify.
case H0; [intros Y|intros (Y1,Y2)].
apply Rle_lt_trans with (1:=Hh).
rewrite Y.
rewrite <- (Rmult_1_l (ulp_flt f)) at 2.
apply Rmult_lt_compat_r.
rewrite ulp_neq_0;[apply bpow_gt_0|now apply Rgt_not_eq].
lra.
apply Rlt_le_trans with (1:=Y2).
rewrite Y1.
apply Rmult_le_compat_r.
apply ulp_ge_0.
lra.
apply Rplus_le_reg_l with (-ulp_flt (pred_flt f)); ring_simplify.
now left.
rewrite pred_eq_pos; try now left.
pattern f at 2; rewrite <- (pred_pos_plus_ulp radix2 (FLT_exp emin prec) f)...
ring.
apply Rplus_lt_reg_l with (-f); ring_simplify.
apply Rle_lt_trans with (-(/2 * ulp_flt (pred_flt f))).
right.
apply trans_eq with ((pred_flt f - f) / 2).
field.
rewrite pred_eq_pos; try now left.
pattern f at 2; rewrite <- (pred_pos_plus_ulp radix2 (FLT_exp emin prec) f)...
field.
replace h with (--h) by ring.
apply Ropp_lt_contravar.
case H0;[intros Y|intros (Y1,Y2)].
apply Rle_lt_trans with (1:=Hh).
rewrite Y.
apply Rmult_lt_compat_r.
rewrite ulp_neq_0; try apply bpow_gt_0; now apply Rgt_not_eq.
lra.
apply Rlt_le_trans with (1:=Y2).
rewrite Y1.
right; field.
(* complex case: even choosing *)
elim H0; intros  T1 (T2,T3); clear H0.
assert (pred_flt f = bpow (mag radix2 f - 1) - bpow (mag radix2 f - 1 -prec)).
rewrite pred_eq_pos; try now left.
unfold pred_pos; case Req_bool_spec.
intros _; rewrite <- T2.
apply f_equal, f_equal.
unfold FLT_exp.
rewrite Z.max_l.
ring.
lia.
intros Y; now contradict T2.
assert (round radix2 (FLT_exp emin prec) Zfloor (f+h) = pred_flt f).
replace (f+h) with (f-(-h)) by ring.
apply round_DN_minus_eps_pos...
split.
auto with real.
rewrite T3, T1.
apply Rmult_le_compat_r.
apply ulp_ge_0.
lra.
assert (round radix2 (FLT_exp emin prec) Zceil (f+h) = f).
replace (f+h) with (pred_flt f + /2*ulp_flt (pred_flt f)).
apply round_UP_pred_plus_eps_pos...
split.
apply Rmult_lt_0_compat.
lra.
rewrite ulp_neq_0; try now apply Rgt_not_eq.
apply bpow_gt_0.
rewrite <- (Rmult_1_l (ulp_flt (pred_flt f))) at 2.
apply Rmult_le_compat_r.
apply ulp_ge_0.
lra.
rewrite T1, H0, <- T2.
replace h with (--h) by ring; rewrite T3.
replace (bpow (mag radix2 f - 1 - prec)) with (/2*ulp_flt f).
field.
replace (/2) with (bpow (-1)) by reflexivity.
rewrite T2 at 1.
rewrite ulp_bpow, <- bpow_plus.
apply f_equal; unfold FLT_exp.
rewrite Z.max_l.
ring.
lia.
assert ((Z.even (Zfloor (scaled_mantissa radix2 (FLT_exp emin prec) (f + h)))) = false).
replace (Zfloor (scaled_mantissa radix2 (FLT_exp emin prec) (f + h)))
   with (Zpower radix2 prec -1)%Z.
unfold Zminus; rewrite Z.even_add.
rewrite Z.even_opp.
rewrite Z.even_pow.
reflexivity.
unfold Prec_gt_0 in prec_gt_0_; lia.
apply eq_IZR.
rewrite <- scaled_mantissa_DN...
2: rewrite H4; assumption.
rewrite H4.
unfold scaled_mantissa.
rewrite bpow_opp.
rewrite <- ulp_neq_0; try now apply Rgt_not_eq.
rewrite T1.
rewrite Rinv_mult_distr.
2: apply Rgt_not_eq; lra.
2: apply Rgt_not_eq; rewrite ulp_neq_0; try apply bpow_gt_0.
2: now apply Rgt_not_eq.
rewrite Rinv_involutive.
2: apply Rgt_not_eq; lra.
rewrite T2 at 2.
rewrite ulp_bpow.
rewrite <- bpow_opp.
unfold FLT_exp at 2.
rewrite Z.max_l by lia.
replace 2 with (bpow 1) by reflexivity.
rewrite <- bpow_plus.
rewrite H0.
rewrite Rmult_minus_distr_r, <- 2!bpow_plus.
rewrite minus_IZR.
apply f_equal2.
rewrite IZR_Zpower.
apply f_equal.
ring.
unfold Prec_gt_0 in prec_gt_0_; lia.
apply trans_eq with (bpow 0).
reflexivity.
apply f_equal.
ring.
rewrite round_N_middle.
rewrite H5.
rewrite H6.
reflexivity.
rewrite H5, H4.
pattern f at 1; rewrite <- (pred_pos_plus_ulp radix2 (FLT_exp emin prec) f); try assumption.
ring_simplify.
rewrite <- pred_eq_pos;[idtac|now left].
rewrite T1.
replace h with (--h) by ring.
rewrite T3.
field.
Qed.

Lemma round_plus_small_id: forall f h, format f -> (bpow (prec+emin) <= Rabs f)
   -> Rabs h <= /4* ulp_flt f -> round_flt (f+h) = f.
intros f h Ff H1 H2.
case (Rle_or_lt 0 f); intros V.
case V; clear V; intros V.
apply round_plus_small_id_aux; try assumption.
rewrite Rabs_right in H1; try assumption.
apply Rle_ge; now left.
contradict H1.
rewrite <- V, Rabs_R0.
apply Rlt_not_le, bpow_gt_0.
rewrite <- (Ropp_involutive f), <- (Ropp_involutive h).
replace (--f + --h) with (-(-f+-h)) by ring.
rewrite round_NE_opp.
apply f_equal.
apply round_plus_small_id_aux.
now apply generic_format_opp.
rewrite Rabs_left in H1; try assumption.
auto with real.
now rewrite Rabs_Ropp, ulp_opp.
Qed.

Definition avg_naive (x y : R) :=round_flt(round_flt(x+y)/2).

Variables x y:R.
Hypothesis Fx: format x.
Hypothesis Fy: format y.

Let a:=(x+y)/2.
Let av:=avg_naive x y.

Lemma avg_naive_correct: av = round_flt a.
Proof with auto with typeclass_instances.
case (Rle_or_lt (bpow (prec + emin)) (Rabs (x+y))).
(* normal case: division by 2 is exact *)
intros H.
unfold av,a,avg_naive.
rewrite round_generic...
now apply sym_eq, FLT_round_half.
apply FLT_format_half.
apply generic_format_round...
apply abs_round_ge_generic...
apply generic_format_FLT_bpow...
unfold Prec_gt_0 in prec_gt_0_; lia.
(* subnormal case: addition is exact, but division by 2 is not *)
intros H.
unfold av, avg_naive.
replace (round_flt (x + y)) with (x+y).
reflexivity.
apply sym_eq, round_generic...
apply FLT_format_plus_small...
left; assumption.
Qed.

Lemma avg_naive_symmetry: forall u v, avg_naive u v = avg_naive v u.
Proof.
intros u v; unfold avg_naive.
rewrite Rplus_comm; reflexivity.
Qed.

Lemma avg_naive_symmetry_Ropp: forall u v, avg_naive (-u) (-v) = - avg_naive u v.
Proof.
intros u v; unfold avg_naive.
replace (-u+-v) with (-(u+v)) by ring.
rewrite round_NE_opp.
replace (- round_flt (u + v) / 2) with (- (round_flt (u + v) / 2)) by (unfold Rdiv; ring).
now rewrite round_NE_opp.
Qed.

Lemma avg_naive_same_sign_1: 0 <= a -> 0 <= av.
Proof with auto with typeclass_instances.
intros H.
rewrite avg_naive_correct.
apply round_ge_generic...
apply generic_format_0.
Qed.

Lemma avg_naive_same_sign_2: a <= 0-> av <= 0.
Proof with auto with typeclass_instances.
intros H.
rewrite avg_naive_correct.
apply round_le_generic...
apply generic_format_0.
Qed.

Lemma avg_naive_between: Rmin x y <= av <= Rmax x y.
Proof with auto with typeclass_instances.
rewrite avg_naive_correct.
split.
apply round_ge_generic...
now apply P_Rmin.
apply Rmult_le_reg_l with (1 := Rlt_0_2).
replace (2 * Rmin x y) with (Rmin x y + Rmin x y) by ring.
replace (2 * a) with (x + y) by (unfold a; field).
apply Rplus_le_compat.
apply Rmin_l.
apply Rmin_r.
(* *)
apply round_le_generic...
now apply Rmax_case.
apply Rmult_le_reg_l with (1 := Rlt_0_2).
replace (2 * a) with (x + y) by (unfold a; field).
replace (2 * Rmax x y) with (Rmax x y + Rmax x y) by ring.
apply Rplus_le_compat.
apply Rmax_l.
apply Rmax_r.
Qed.

Lemma avg_naive_zero: a = 0 -> av = 0.
Proof with auto with typeclass_instances.
intros H1; rewrite avg_naive_correct, H1.
rewrite round_0...
Qed.

Lemma avg_naive_no_underflow: (bpow emin) <= Rabs a -> av <> 0.
Proof with auto with typeclass_instances.
intros H.
(* *)
cut (bpow emin <= Rabs av).
intros H1 H2.
rewrite H2 in H1; rewrite Rabs_R0 in H1.
contradict H1.
apply Rlt_not_le.
apply bpow_gt_0.
(* *)
rewrite avg_naive_correct.
apply abs_round_ge_generic...
apply generic_format_FLT_bpow...
lia.
Qed.

Lemma avg_naive_correct_weak1: Rabs (av -a) <= /2*ulp_flt a.
Proof with auto with typeclass_instances.
rewrite avg_naive_correct.
apply error_le_half_ulp...
Qed.

Lemma avg_naive_correct_weak2: Rabs (av -a) <= 3/2*ulp_flt a.
Proof with auto with typeclass_instances.
apply Rle_trans with (1:=avg_naive_correct_weak1).
apply Rmult_le_compat_r.
unfold ulp; apply ulp_ge_0.
lra.
Qed.

(* Hypothesis diff_sign: (0 <= x /\ y <= 0) \/ (x <= 0 /\ 0 <= y).
  is useless for properties: only useful for preventing overflow *)

Definition avg_sum_half (x y : R) :=round_flt(round_flt(x/2) + round_flt(y/2)).

Let av2:=avg_sum_half x y.

Lemma avg_sum_half_correct: bpow (emin +prec+prec+1) <= Rabs x -> av2 = round_flt a.
Proof with auto with typeclass_instances.
intros Hx.
assert (G:(0 < prec)%Z).
unfold Prec_gt_0 in prec_gt_0_; assumption.
unfold av2, avg_sum_half.
replace (round_flt (x/2)) with (x/2).
2: apply sym_eq, round_generic...
2: apply FLT_format_half; try assumption.
2: apply Rle_trans with (2:=Hx).
2: apply bpow_le; lia.
case (Rle_or_lt (bpow (prec + emin)) (Rabs y)).
(* y is big enough so that y/2 is correct *)
intros Hy.
replace (round_flt (y/2)) with (y/2).
apply f_equal; unfold a; field.
apply sym_eq, round_generic...
apply FLT_format_half; assumption.
(* y is a subnormal, then it is too small to impact the result *)
intros Hy.
assert (format (x/2)).
apply FLT_format_half.
assumption.
apply Rle_trans with (2:=Hx).
apply bpow_le.
lia.
assert (bpow (prec+emin) <= Rabs (x/2)).
apply Rmult_le_reg_l with (bpow 1).
apply bpow_gt_0.
rewrite <- bpow_plus.
apply Rle_trans with (Rabs x).
apply Rle_trans with (2:=Hx).
apply bpow_le.
lia.
rewrite <- (Rabs_right (bpow 1)).
rewrite <- Rabs_mult.
right; apply f_equal.
change (bpow 1) with 2.
field.
apply Rle_ge, bpow_ge_0.
assert (K1: Rabs (y / 2) <= bpow (prec+emin-1)).
unfold Rdiv; rewrite Rabs_mult.
unfold Zminus; rewrite bpow_plus.
simpl; rewrite (Rabs_pos_eq (/2)).
apply (Rmult_le_compat_r (/2)).
lra.
now left.
lra.
assert (K2:bpow (prec+emin-1) <= / 4 * ulp_flt (x / 2)).
assert (Z: x/2 <> 0).
intros K; contradict H0.
rewrite K, Rabs_R0.
apply Rlt_not_le, bpow_gt_0.
rewrite ulp_neq_0; trivial.
replace (/4) with (bpow (-2)) by reflexivity.
rewrite <- bpow_plus.
apply bpow_le.
unfold cexp, FLT_exp.
assert (emin+prec+prec+1 -1 < mag radix2 (x/2))%Z.
destruct (mag radix2 (x/2)) as (e,He).
simpl.
apply lt_bpow with radix2.
apply Rle_lt_trans with (Rabs (x/2)).
unfold Rdiv; rewrite Rabs_mult.
unfold Zminus; rewrite bpow_plus.
simpl; rewrite (Rabs_right (/2)).
apply Rmult_le_compat_r.
lra.
exact Hx.
lra.
apply He; trivial.
rewrite Z.max_l.
lia.
lia.
(* . *)
apply trans_eq with (x/2).
apply round_plus_small_id; try assumption.
apply Rle_trans with (2:=K2).
apply abs_round_le_generic...
apply generic_format_FLT_bpow...
lia.
unfold a; apply sym_eq.
replace ((x+y)/2) with (x/2+y/2) by field.
apply round_plus_small_id; try assumption.
now apply Rle_trans with (2:=K2).
Qed.

End av1.

Section av3.

Notation bpow e := (bpow radix2 e).

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

Notation format := (generic_format radix2 (FLT_exp emin prec)).
Notation round_flt :=(round radix2 (FLT_exp emin prec) ZnearestE).
Notation ulp_flt :=(ulp radix2 (FLT_exp emin prec)).
Notation cexp := (cexp radix2 (FLT_exp emin prec)).

Definition avg_half_sub (x y : R) :=round_flt(x+round_flt(round_flt(y-x)/2)).

Variables x y:R.
Hypothesis Fx: format x.
Hypothesis Fy: format y.

Let a:=(x+y)/2.
Let av:=avg_half_sub x y.

Lemma avg_half_sub_symmetry_Ropp: forall u v, avg_half_sub (-u) (-v) = - avg_half_sub u v.
intros u v; unfold avg_half_sub.
replace (-v--u) with (-(v-u)) by ring.
rewrite round_NE_opp.
replace (- round_flt (v-u) / 2) with (- (round_flt (v-u) / 2)) by (unfold Rdiv; ring).
rewrite round_NE_opp.
replace (- u + - round_flt (round_flt (v - u) / 2)) with
   (-(u+round_flt (round_flt (v - u) / 2))) by ring.
apply round_NE_opp.
Qed.

Lemma avg_half_sub_same_sign_1: 0 <= a -> 0 <= av.
Proof with auto with typeclass_instances.
intros H.
apply round_ge_generic...
apply generic_format_0.
apply Rplus_le_reg_l with (-x).
ring_simplify.
apply round_ge_generic...
now apply generic_format_opp.
apply Rmult_le_reg_l with (1 := Rlt_0_2).
apply Rle_trans with (-(2*x)).
right; ring.
apply Rle_trans with (round_flt (y - x)).
2: right; field.
apply round_ge_generic...
apply generic_format_opp.
now apply FLT_format_double...
apply Rplus_le_reg_l with (2*x).
apply Rmult_le_reg_r with (/2).
lra.
apply Rle_trans with 0;[right; ring|idtac].
apply Rle_trans with (1:=H).
right; unfold a, Rdiv; ring.
Qed.

Lemma avg_half_sub_same_sign_2: a <= 0-> av <= 0.
Proof with auto with typeclass_instances.
intros H.
apply round_le_generic...
apply generic_format_0.
apply Rplus_le_reg_l with (-x).
ring_simplify.
apply round_le_generic...
now apply generic_format_opp.
apply Rmult_le_reg_l with (1 := Rlt_0_2).
apply Rle_trans with (-(2*x)).
2: right; ring.
apply Rle_trans with (round_flt (y - x)).
right; field.
apply round_le_generic...
apply generic_format_opp.
now apply FLT_format_double...
apply Rplus_le_reg_l with (2*x).
apply Rmult_le_reg_r with (/2).
lra.
apply Rle_trans with 0;[idtac|right; ring].
apply Rle_trans with (2:=H).
right; unfold a, Rdiv; ring.
Qed.

Lemma avg_half_sub_between_aux: forall u v, format u -> format v -> u <= v ->
    u <= avg_half_sub u v <= v.
Proof with auto with typeclass_instances.
clear Fx Fy a av x y.
intros x y Fx Fy M.
split.
(* . *)
apply round_ge_generic...
apply Rplus_le_reg_l with (-x).
ring_simplify.
apply round_ge_generic...
apply generic_format_0.
unfold Rdiv; apply Rmult_le_pos.
apply round_ge_generic...
apply generic_format_0.
apply Rplus_le_reg_l with x.
now ring_simplify.
lra.
(* . *)
apply round_le_generic...
assert (H:(0 <= round radix2 (FLT_exp emin prec) Zfloor (y-x))).
apply round_ge_generic...
apply generic_format_0.
apply Rplus_le_reg_l with x.
now ring_simplify.
destruct H as [H|H].
(* .. *)
pattern y at 2; replace y with (x + (y-x)) by ring.
apply Rplus_le_compat_l.
case (generic_format_EM radix2 (FLT_exp emin prec) (y-x)); intros K.
apply round_le_generic...
rewrite round_generic...
apply Rmult_le_reg_l with (1 := Rlt_0_2).
apply Rplus_le_reg_l with (2*x-y).
apply Rle_trans with x.
right; field.
apply Rle_trans with (1:=M).
right; field.
apply Rle_trans with (round radix2 (FLT_exp emin prec) Zfloor (y - x)).
apply round_le_generic...
apply generic_format_round...
apply Rmult_le_reg_l with (1 := Rlt_0_2).
apply Rle_trans with (round_flt (y - x)).
right; field.
case (round_DN_or_UP radix2 (FLT_exp emin prec) ZnearestE (y-x));
   intros H1; rewrite H1.
apply Rplus_le_reg_l with (-round radix2 (FLT_exp emin prec) Zfloor (y - x)).
ring_simplify.
now left.
rewrite round_UP_DN_ulp.
apply Rplus_le_reg_l with (-round radix2 (FLT_exp emin prec) Zfloor (y - x)); ring_simplify.
apply round_DN_pt...
apply generic_format_ulp...
case (Rle_or_lt (bpow (emin + prec - 1))  (y-x)); intros P.
apply FLT_ulp_le_id...
apply Rle_trans with (2:=P).
apply bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia.
contradict K.
apply FLT_format_plus_small...
now apply generic_format_opp.
rewrite Rabs_right.
apply Rle_trans with (bpow (emin+prec-1)).
left; exact P.
apply bpow_le; lia.
apply Rle_ge; apply Rplus_le_reg_l with x; now ring_simplify.
assumption.
apply round_DN_pt...
(* .. *)
case M; intros H1.
2: rewrite H1; replace (y-y) with 0 by ring.
2: rewrite round_0...
2: unfold Rdiv; rewrite Rmult_0_l.
2: rewrite round_0...
2: right; ring.
apply Rle_trans with (x+0).
2: rewrite Rplus_0_r; assumption.
apply Rplus_le_compat_l.
replace 0 with (round_flt (bpow emin/2)).
apply round_le...
unfold Rdiv; apply Rmult_le_compat_r.
lra.
apply round_le_generic...
apply generic_format_FLT_bpow...
lia.
case (Rle_or_lt (y-x) (bpow emin)); trivial.
intros H2.
contradict H.
apply Rlt_not_eq.
apply Rlt_le_trans with (bpow emin).
apply bpow_gt_0.
apply round_DN_pt...
apply generic_format_FLT_bpow...
lia.
now left.
replace (bpow emin /2) with (bpow (emin-1)).
unfold round, scaled_mantissa, cexp, FLT_exp.
rewrite mag_bpow.
replace (emin - 1 + 1 - prec)%Z with (emin-prec)%Z by ring.
rewrite Z.max_r.
2: unfold Prec_gt_0 in prec_gt_0_; lia.
rewrite <- bpow_plus.
replace (emin-1+-emin)%Z with (-1)%Z by ring.
replace (ZnearestE (bpow (-1))) with 0%Z.
unfold F2R; simpl; ring.
change (bpow (-1)) with (/2).
simpl; unfold Znearest.
replace (Zfloor (/2)) with 0%Z.
rewrite Rcompare_Eq.
reflexivity.
simpl; ring.
apply sym_eq, Zfloor_imp.
simpl ; lra.
unfold Zminus; rewrite bpow_plus.
reflexivity.
Qed.

Lemma avg_half_sub_between: Rmin x y <= av <= Rmax x y.
Proof with auto with typeclass_instances.
case (Rle_or_lt x y); intros M.
(* x <= y *)
rewrite Rmin_left; try exact M.
rewrite Rmax_right; try exact M.
now apply avg_half_sub_between_aux.
(* y < x *)
rewrite Rmin_right; try now left.
rewrite Rmax_left; try now left.
unfold av; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y).
rewrite avg_half_sub_symmetry_Ropp.
split; apply Ropp_le_contravar.
apply avg_half_sub_between_aux.
now apply generic_format_opp.
now apply generic_format_opp.
apply Ropp_le_contravar; now left.
apply avg_half_sub_between_aux.
now apply generic_format_opp.
now apply generic_format_opp.
apply Ropp_le_contravar; now left.
Qed.

Lemma avg_half_sub_zero: a = 0 -> av = 0.
Proof with auto with typeclass_instances.
intros H.
assert (y=-x).
apply Rplus_eq_reg_l with x.
apply Rmult_eq_reg_r with (/2).
apply trans_eq with a.
reflexivity.
rewrite H; ring.
lra.
unfold av, avg_half_sub.
rewrite H0.
replace (-x-x) with (-(2*x)) by ring.
rewrite round_generic with (x:=(-(2*x)))...
replace (-(2*x)/2) with (-x) by field.
rewrite round_generic with (x:=-x)...
replace (x+-x) with 0 by ring.
apply round_0...
now apply generic_format_opp.
apply generic_format_opp.
now apply FLT_format_double.
Qed.

Lemma avg_half_sub_no_underflow_aux_aux: forall z:Z, (0 < z)%Z ->
    (ZnearestE (IZR z / 2) < z)%Z.
Proof.
intros z H1.
case (Zle_lt_or_eq 1 z); [lia|intros H2|intros H2].
apply lt_IZR.
apply Rplus_lt_reg_r with (- ((IZR z)/2)).
apply Rle_lt_trans with (-(((IZR z) /2) - IZR (ZnearestE (IZR z / 2)))).
right; ring.
apply Rle_lt_trans with (1:= RRle_abs _).
rewrite Rabs_Ropp.
apply Rle_lt_trans with (1:=Znearest_half (fun x => negb (Z.even x)) _).
apply Rle_lt_trans with (1*/2);[right; ring|idtac].
apply Rlt_le_trans with ((IZR z)*/2);[idtac|right; field].
apply Rmult_lt_compat_r.
lra.
now apply IZR_lt.
rewrite <- H2.
unfold Znearest; simpl.
replace (Zfloor (1 / 2)) with 0%Z.
rewrite Rcompare_Eq.
simpl; lia.
simpl; field.
unfold Rdiv; rewrite Rmult_1_l.
apply sym_eq, Zfloor_imp.
simpl; lra.
Qed.

Lemma avg_half_sub_no_underflow_aux1: forall f, format f -> 0 < f ->
  f <= round_flt (f/2) -> False.
Proof with auto with typeclass_instances.
intros f Ff Hf1 Hf2.
apply FLT_format_generic in Ff...
destruct Ff as [g H1 H2 H3].
case (Zle_lt_or_eq emin (Fexp g)); try exact H3; intros H4.
contradict Hf2.
apply Rlt_not_le.
rewrite round_generic...
apply Rplus_lt_reg_l with (-(f/2)).
apply Rle_lt_trans with 0;[right; ring|idtac].
apply Rlt_le_trans with (f*/2);[idtac|right;field].
apply Rmult_lt_0_compat; try assumption.
lra.
apply generic_format_FLT.
exists (Float radix2 (Fnum g) (Fexp g-1)).
rewrite H1; unfold F2R; simpl.
unfold Zminus; rewrite bpow_plus.
apply Rmult_assoc.
easy.
simpl; lia.
contradict Hf2; apply Rlt_not_le.
unfold round, scaled_mantissa.
replace (cexp (f/2)) with emin.
rewrite H1; unfold F2R; simpl.
rewrite <- H4.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply IZR_lt.
replace (IZR (Fnum g) * bpow emin / 2 * bpow (- emin)) with (IZR (Fnum g) /2).
apply avg_half_sub_no_underflow_aux_aux.
apply lt_IZR.
apply Rmult_lt_reg_r with (bpow (Fexp g)).
apply bpow_gt_0.
rewrite Rmult_0_l.
apply Rlt_le_trans with (1:=Hf1).
right; rewrite H1; reflexivity.
unfold Rdiv; apply trans_eq with (IZR (Fnum g) * / 2 * (bpow (- emin)*bpow emin)).
rewrite <- bpow_plus.
ring_simplify (-emin+emin)%Z.
simpl; ring.
ring.
apply sym_eq, cexp_FLT_FIX.
apply Rgt_not_eq, Rlt_gt.
lra.
rewrite H1; unfold F2R, Rdiv; simpl.
replace (/2) with (bpow (-1)) by reflexivity.
rewrite Rmult_assoc, <- bpow_plus.
rewrite Rabs_mult.
rewrite (Rabs_right (bpow _)).
2: apply Rle_ge, bpow_ge_0.
rewrite (Zplus_comm emin _).
rewrite (bpow_plus _ prec _).
apply Rmult_lt_compat.
apply Rabs_pos.
apply bpow_ge_0.
rewrite <- IZR_Zpower, <- abs_IZR.
now apply IZR_lt.
unfold Prec_gt_0 in prec_gt_0_; lia.
rewrite <- H4; apply bpow_lt.
lia.
Qed.

Lemma avg_half_sub_no_underflow_aux2: forall u v, format u -> format v ->
    (0 <= u /\ 0 <= v) \/ (u <= 0 /\ v <= 0) ->
    u <= v ->
   (bpow emin) <= Rabs ((u+v)/2) -> avg_half_sub u v <> 0.
Proof with auto with typeclass_instances.
clear Fx Fy a av x y; intros x y Fx Fy same_sign xLey H; unfold avg_half_sub.
apply round_plus_neq_0...
apply generic_format_round...
intros J.
assert (H1:x <= 0).
apply Rplus_le_reg_r with (round_flt (round_flt (y - x) / 2)).
rewrite J, Rplus_0_l.
apply round_ge_generic...
apply generic_format_0.
unfold Rdiv; apply Rmult_le_pos.
apply round_ge_generic...
apply generic_format_0.
apply Rplus_le_reg_l with x; now ring_simplify.
lra.
destruct H1 as [H1|H1].
(* *)
destruct same_sign as [(H2,H3)|(_,H2)].
contradict H2; now apply Rlt_not_le.
apply avg_half_sub_no_underflow_aux1 with (-x).
now apply generic_format_opp.
rewrite <- Ropp_0; now apply Ropp_lt_contravar.
apply Rle_trans with (round_flt (round_flt (y - x) / 2)).
apply Rplus_le_reg_l with x.
rewrite J; right; ring.
apply round_le...
unfold Rdiv; apply Rmult_le_compat_r.
lra.
apply round_le_generic...
now apply generic_format_opp.
apply Rplus_le_reg_l with x.
now ring_simplify.
(* *)
rewrite H1 in J, H.
rewrite Rplus_0_l in H.
contradict J; apply Rgt_not_eq, Rlt_gt.
rewrite Rplus_0_l.
unfold Rminus; rewrite Ropp_0, Rplus_0_r.
rewrite round_generic with (x:=y)...
apply Rlt_le_trans with (bpow emin).
apply bpow_gt_0.
apply round_ge_generic...
apply generic_format_FLT_bpow...
lia.
apply Rle_trans with (1:=H).
right; apply Rabs_right.
apply Rle_ge; unfold Rdiv; apply Rmult_le_pos.
rewrite <- H1; assumption.
lra.
Qed.

Lemma avg_half_sub_no_underflow_aux3: forall u v, format u -> format v ->
    (0 <= u /\ 0 <= v) \/ (u <= 0 /\ v <= 0) ->
   (bpow emin) <= Rabs ((u+v)/2) -> avg_half_sub u v <> 0.
Proof with auto with typeclass_instances.
clear Fx Fy a av x y; intros x y Fx Fy.
intros same_sign H.
case (Rle_or_lt x y); intros H1.
now apply avg_half_sub_no_underflow_aux2.
rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y).
rewrite avg_half_sub_symmetry_Ropp.
apply Ropp_neq_0_compat.
apply avg_half_sub_no_underflow_aux2.
now apply generic_format_opp.
now apply generic_format_opp.
rewrite <- Ropp_0; case same_sign; intros (T1,T2).
right; split; now apply Ropp_le_contravar.
left; split; now apply Ropp_le_contravar.
apply Ropp_le_contravar; now left.
apply Rle_trans with (1:=H).
rewrite <- Rabs_Ropp.
right; apply f_equal.
unfold Rdiv; ring.
Qed.

Lemma avg_half_sub_no_underflow:
  (0 <= x /\ 0 <= y) \/ (x <= 0 /\ y <= 0) ->
  (bpow emin) <= Rabs a -> av <> 0.
Proof with auto with typeclass_instances.
intros; now apply avg_half_sub_no_underflow_aux3.
Qed.

Lemma avg_half_sub_correct_aux: forall u v, format u -> format v -> u <= v ->
     (0 <= u /\ 0 <= v) \/ (u <= 0 /\ v <= 0) ->
     0 < Rabs ((u+v)/2) < bpow emin ->
     Rabs (avg_half_sub u v -((u+v)/2)) <= 3/2 * ulp_flt ((u+v)/2).
Proof with auto with typeclass_instances.
clear Fx Fy x y a av.
intros u v Fu Fv uLev same_sign.
pose (b:=(u+v)/2); fold b.
(* mostly forward proof *)
intros (H1,H2).
apply generic_format_FIX_FLT,FIX_format_generic in Fu.
apply generic_format_FIX_FLT,FIX_format_generic in Fv.
destruct Fu as [[nu eu] J1 J2].
destruct Fv as [[nv ev] J3 J4]; simpl in J2, J4.
(* b is bpow emin /2 *)
assert (b = IZR (nu+nv) * bpow (emin-1)).
unfold b; rewrite J1, J3; unfold F2R; rewrite J2,J4; simpl.
unfold Zminus; rewrite bpow_plus, plus_IZR.
change (bpow (-(1))) with (/2).
field.
assert (Z.abs (nu+nv) = 1)%Z.
cut (0 < Z.abs (nu+nv) < 2)%Z. lia.
split; apply lt_IZR; simpl; rewrite abs_IZR;
 apply Rmult_lt_reg_l with (bpow (emin-1)); try apply bpow_gt_0.
rewrite Rmult_0_r.
apply Rlt_le_trans with (1:=H1).
right; rewrite H, Rabs_mult.
rewrite (Rabs_right (bpow (emin -1))).
ring.
apply Rle_ge, bpow_ge_0.
apply Rle_lt_trans with (Rabs b).
right; rewrite H, Rabs_mult.
rewrite (Rabs_right (bpow (emin -1))).
ring.
apply Rle_ge, bpow_ge_0.
apply Rlt_le_trans with (1:=H2).
right; unfold Zminus; rewrite bpow_plus.
change (bpow (-(1))) with (/2).
field.
(* only 2 possible values for u and v *)
assert (((nu=0)/\ (nv=1)) \/ ((nu=-1)/\(nv=0)))%Z.
assert (nu <= nv)%Z.
apply le_IZR.
apply Rmult_le_reg_r with (bpow emin).
apply bpow_gt_0.
apply Rle_trans with u.
right; rewrite J1,J2; reflexivity.
apply Rle_trans with (1:=uLev).
right; rewrite J3,J4; reflexivity.
case same_sign; intros (L1,L2).
rewrite J1 in L1; apply Fnum_ge_0 in L1; simpl in L1.
rewrite J3 in L2; apply Fnum_ge_0 in L2; simpl in L2.
left.
rewrite Z.abs_eq in H0.
lia.
lia.
rewrite J1 in L1; apply Fnum_le_0 in L1; simpl in L1.
rewrite J3 in L2; apply Fnum_le_0 in L2; simpl in L2.
right.
rewrite Z.abs_neq in H0.
lia.
lia.
(* look into the 2 possible cases *)
assert (G1:(round_flt (bpow emin/2) = 0)).
replace (bpow emin /2) with (bpow (emin-1)).
unfold round, scaled_mantissa.
rewrite cexp_FLT_FIX.
unfold cexp, FIX_exp; simpl.
rewrite <- bpow_plus.
replace (bpow (emin - 1 + - emin)) with (/2).
replace (ZnearestE (/ 2)) with 0%Z.
unfold F2R; simpl; ring.
unfold Znearest.
replace (Zfloor (/2)) with 0%Z.
rewrite Rcompare_Eq.
reflexivity.
simpl; ring.
apply sym_eq, Zfloor_imp.
simpl; lra.
ring_simplify (emin-1+-emin)%Z; reflexivity.
apply Rgt_not_eq, Rlt_gt, bpow_gt_0.
rewrite Rabs_right.
apply bpow_lt.
unfold Prec_gt_0 in prec_gt_0_; lia.
apply Rle_ge, bpow_ge_0.
unfold Zminus; rewrite bpow_plus.
reflexivity.
case H3; intros (T1,T2).
unfold b, avg_half_sub.
rewrite J1,J3,J2,J4,T1,T2; unfold F2R; simpl.
rewrite Rmult_0_l, Rmult_1_l, 2!Rplus_0_l.
unfold Rminus; rewrite Ropp_0, Rplus_0_r.
rewrite (round_generic _ _ _ (bpow (emin)))...
2: apply generic_format_FLT_bpow...
2: lia.
rewrite G1.
rewrite round_0...
rewrite Rplus_0_l, Rabs_Ropp.
rewrite Rabs_right.
2: apply Rle_ge, Rmult_le_pos.
2: apply bpow_ge_0.
2: lra.
apply Rle_trans with ((3*ulp_flt (bpow emin / 2))/2);[idtac|right; unfold Rdiv; ring].
unfold Rdiv; apply Rmult_le_compat_r.
lra.
apply Rle_trans with (3*bpow emin).
apply Rle_trans with (1*bpow emin).
right; ring.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply IZR_le.
apply Rmult_le_compat_l.
now apply IZR_le.
rewrite ulp_neq_0.
2: apply Rmult_integral_contrapositive_currified.
2: apply Rgt_not_eq, bpow_gt_0.
2: apply Rinv_neq_0_compat, Rgt_not_eq; lra.
apply bpow_le.
unfold cexp, FLT_exp.
apply Z.le_max_r.
unfold b, avg_half_sub.
rewrite J1,J3,J2,J4,T1,T2; unfold F2R; simpl.
rewrite Rmult_0_l, Rplus_0_r.
replace (0 - _ * bpow emin) with (bpow emin) by ring.
rewrite (round_generic _ _ _ (bpow emin))...
2: apply generic_format_FLT_bpow...
2: lia.
rewrite G1.
replace (_ * bpow emin + 0) with (-bpow emin) by ring.
rewrite round_generic...
2: apply generic_format_opp.
2: apply generic_format_FLT_bpow...
2: lia.
replace (- bpow emin - _ * bpow emin / 2) with (-(bpow emin/2)) by field.
rewrite Rabs_Ropp.
rewrite Rabs_right.
replace (_ * bpow emin / 2) with (-(bpow emin/2)) by field.
rewrite ulp_opp.
apply Rle_trans with ((3*ulp_flt (bpow emin / 2))/2);[idtac|right; unfold Rdiv; ring].
unfold Rdiv; apply Rmult_le_compat_r.
lra.
apply Rle_trans with (3*bpow emin).
apply Rle_trans with (1*bpow emin).
right; ring.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply IZR_le.
apply Rmult_le_compat_l.
now apply IZR_le.
rewrite ulp_neq_0.
2: apply Rmult_integral_contrapositive_currified.
2: apply Rgt_not_eq, bpow_gt_0.
2: apply Rinv_neq_0_compat, Rgt_not_eq; lra.
apply bpow_le.
unfold cexp, FLT_exp.
apply Z.le_max_r.
apply Rle_ge, Rmult_le_pos.
apply bpow_ge_0.
lra.
Qed.

Lemma avg_half_sub_correct_aux2: forall u v, format u -> format v -> u <= v ->
     (0 <= u /\ 0 <= v) \/ (u <= 0 /\ v <= 0) ->
     Rabs (avg_half_sub u v -((u+v)/2)) <= 3/2 * ulp_flt ((u+v)/2).
Proof with auto with typeclass_instances.
clear Fx Fy a av x y.
intros u v Fu Fv uLev same_sign.
pose (b:=(u+v)/2); fold b.
assert (T: forall z, Rabs (2*z) = 2* Rabs z).
intros z; rewrite Rabs_mult.
rewrite Rabs_pos_eq; try reflexivity.
apply Rlt_le, Rlt_0_2.
destruct uLev as [uLtv|uEqv].
(* when u < v *)
assert (B: u <= v) by now left.
assert (K1: b <> 0).
unfold b ; lra.
(* . initial lemma *)
assert (Y:(Rabs (round_flt (v - u) - (v-u)) <= ulp_flt b)).
apply Rle_trans with (/2*ulp_flt (v-u)).
apply error_le_half_ulp...
apply Rmult_le_reg_l with (1 := Rlt_0_2).
rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l.
2: apply Rgt_not_eq, Rlt_0_2.
apply Rle_trans with (ulp_flt (2*b)).
case same_sign; intros (T1,T2).
apply ulp_le_pos...
lra.
unfold b ; lra.
rewrite <- (ulp_opp _ _ (2*b)).
apply ulp_le_pos...
lra.
unfold b ; lra.
rewrite 2!ulp_neq_0; trivial.
2: lra.
change 2 with (bpow 1).
rewrite <- bpow_plus.
apply bpow_le.
unfold cexp, FLT_exp.
rewrite Rmult_comm, mag_mult_bpow; trivial.
rewrite <- Z.add_max_distr_l.
replace (mag radix2 b + 1 - prec)%Z with (1 + (mag radix2 b - prec))%Z by ring.
apply Z.max_le_compat_l.
lia.
(* . splitting case of av=0 *)
case (Rle_or_lt (bpow emin) (Rabs b)); intros D.
(* . main proof *)
unfold avg_half_sub.
case (Rle_or_lt (bpow (prec+emin)) (v-u)); intros H1.
(* .. v-u is big enough: division by 2 is exact *)
cut (round_flt (round_flt (v - u) / 2) = round_flt (v - u) / 2).
intros Z; rewrite Z.
replace (round_flt (u + round_flt (v - u) / 2) - b) with
   ((round_flt (u + round_flt (v - u) / 2) - (u + round_flt (v - u) / 2)) +/2*(round_flt (v - u)-(v-u))).
2: unfold b; field.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (ulp_flt b+/2*ulp_flt b);[idtac|right; field].
apply Rplus_le_compat.
apply Rle_trans with (/2*ulp_flt (u + round_flt (v - u) / 2)).
apply error_le_half_ulp...
apply Rmult_le_reg_l with (1 := Rlt_0_2).
rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l.
2: apply Rgt_not_eq, Rlt_0_2.
apply Rle_trans with (2:=FLT_ulp_double _ _ _).
apply ulp_le...
replace (u + round_flt (v - u) / 2) with (b+/2*(round_flt (v - u) - (v - u))).
2: unfold b; field.
rewrite (T b).
replace (2 * Rabs b) with (Rabs b + Rabs b) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rplus_le_compat_l.
rewrite Rabs_mult.
rewrite Rabs_pos_eq.
2: lra.
apply Rmult_le_reg_l with (1 := Rlt_0_2).
rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l.
2: apply Rgt_not_eq, Rlt_0_2.
apply Rle_trans with (1:=Y).
apply Rle_trans with (ulp_flt (2*b)).
apply ulp_le...
rewrite <- (Rmult_1_l (Rabs b)).
rewrite (T b).
apply Rmult_le_compat_r.
apply Rabs_pos.
now apply IZR_le.
rewrite <- (T b).
rewrite <- ulp_abs.
apply FLT_ulp_le_id...
assert (H:generic_format radix2 (FIX_exp emin) (2*b)).
replace (2*b) with (u+v).
2: unfold b; field.
apply generic_format_FIX_FLT,FIX_format_generic in Fu.
apply generic_format_FIX_FLT,FIX_format_generic in Fv.
destruct Fu as [fu J1 J2].
destruct Fv as [fv J3 J4].
apply generic_format_FIX.
exists (Float radix2 (Fnum fu+Fnum fv) emin).
rewrite J1,J3; unfold F2R; simpl.
rewrite J2,J4, plus_IZR; ring.
easy.
apply FIX_format_generic in H.
destruct H as [[n e] J1 J2].
rewrite J1; unfold F2R; rewrite J2.
simpl; rewrite Rabs_mult.
pattern (bpow emin) at 1; rewrite <- (Rmult_1_l (bpow emin)).
rewrite (Rabs_right (bpow emin)).
2: apply Rle_ge, bpow_ge_0.
apply Rmult_le_compat_r.
apply bpow_ge_0.
rewrite <- abs_IZR.
apply IZR_le.
cut (0 < Z.abs n)%Z. lia.
apply Z.abs_pos.
intros M; apply K1.
apply Rmult_eq_reg_l with 2.
2: apply Rgt_not_eq, Rlt_0_2.
rewrite Rmult_0_r, J1, M.
apply F2R_0.
rewrite Rabs_mult.
rewrite Rabs_right.
2: lra.
apply Rmult_le_compat_l with (2 := Y).
lra.
apply round_generic...
apply FLT_format_half...
apply generic_format_round...
apply abs_round_ge_generic...
apply generic_format_FLT_bpow...
unfold Prec_gt_0 in prec_gt_0_; lia.
rewrite Rabs_right; try assumption.
apply Rle_ge; left; apply Rplus_lt_reg_l with u; now ring_simplify.
(* .. v-u is small: subtraction is exact *)
cut ((round_flt (v - u)= (v-u))).
intros Z; rewrite Z.
replace (u + round_flt ((v-u) / 2)) with (b+((round_flt ((v-u) / 2) - (v-u)/2))).
2: unfold b; field.
pose (eps:=(round_flt ((v - u) / 2) - (v - u) / 2)%R); fold eps.
assert (Rabs eps <= /2*bpow emin).
unfold eps.
apply Rle_trans with (1:=error_le_half_ulp _ _ _ _)...
right; apply f_equal.
apply ulp_FLT_small...
rewrite Zplus_comm; apply Rle_lt_trans with (2:=H1).
rewrite Rabs_pos_eq ; lra.
replace (round_flt (b + eps) - b) with ((round_flt (b+eps) -(b+eps)) + eps) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rle_trans with (/2*ulp_flt (b+eps) + /2*bpow emin).
apply Rplus_le_compat.
apply error_le_half_ulp...
assumption.
apply Rmult_le_reg_l with (1 := Rlt_0_2).
apply Rle_trans with (ulp_flt (b + eps)+bpow emin).
right; field.
apply Rle_trans with (2*ulp_flt b + ulp_flt b).
2: right; field.
apply Rplus_le_compat.
apply Rle_trans with (2:=FLT_ulp_double _ _ _).
apply ulp_le...
rewrite (T b).
replace (2 * Rabs b) with (Rabs b + Rabs b) by ring.
apply Rle_trans with (1:=Rabs_triang _ _).
apply Rplus_le_compat_l.
apply Rle_trans with (2:=D).
rewrite <- (Rmult_1_l (bpow emin)).
apply Rle_trans with (1:=H).
apply Rmult_le_compat_r.
apply bpow_ge_0.
lra.
rewrite <- ulp_FLT_small with radix2 emin prec 0...
apply ulp_ge_ulp_0...
rewrite Rabs_R0; apply bpow_gt_0.
apply round_generic...
apply FLT_format_plus_small...
now apply generic_format_opp.
rewrite Rabs_right.
now left.
apply Rle_ge, Rplus_le_reg_l with u; now ring_simplify.
(* . when b = bpow emin /2 *)
apply avg_half_sub_correct_aux; trivial.
split; trivial.
now apply Rabs_pos_lt.
(* . x = y *)
unfold avg_half_sub,b.
rewrite uEqv.
replace (v-v) with 0 by ring.
rewrite round_0...
unfold Rdiv; rewrite Rmult_0_l.
rewrite round_0...
rewrite Rplus_0_r.
rewrite round_generic...
replace ((v+v)*/2) with v by field.
replace (v-v) with 0 by ring.
rewrite Rabs_R0.
apply Rmult_le_pos.
apply Rmult_le_pos.
now apply IZR_le.
lra.
apply ulp_ge_0.
Qed.

(* tight example x=1/2 and y=2^p-1: error is 5/4 ulp *)

Lemma avg_half_sub_correct: (0 <= x /\ 0 <= y) \/ (x <= 0 /\ y <= 0) ->
     Rabs (av-a) <= 3/2 * ulp_flt a.
Proof with auto with typeclass_instances.
intros same_sign; case (Rle_or_lt x y); intros H.
now apply avg_half_sub_correct_aux2.
unfold av, a.
rewrite <- (Ropp_involutive x), <- (Ropp_involutive y).
rewrite avg_half_sub_symmetry_Ropp.
rewrite <- Rabs_Ropp.
replace (- (- avg_half_sub (- x) (- y) - (- - x + - - y) / 2)) with
   (avg_half_sub (-x) (-y) - ((-x+-y)/2)).
2: unfold Rdiv; ring.
apply Rle_trans with (3 / 2 * ulp_flt ((- x + - y) / 2)).
apply avg_half_sub_correct_aux2.
now apply generic_format_opp.
now apply generic_format_opp.
apply Ropp_le_contravar; now left.
rewrite <- Ropp_0; case same_sign; intros (T1,T2).
right; split; now apply Ropp_le_contravar.
left; split; now apply Ropp_le_contravar.
right; apply f_equal.
rewrite <- ulp_opp.
apply f_equal.
unfold Rdiv; ring.
Qed.

(* Lemma avg_half_sub_symmetry: forall u v, avg_half_sub u v = avg_half_sub v u.
   is false *)

End av3.

Section average.

Notation bpow e := (bpow radix2 e).

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

Notation format := (generic_format radix2 (FLT_exp emin prec)).
Notation round_flt :=(round radix2 (FLT_exp emin prec) ZnearestE).
Notation ulp_flt :=(ulp radix2 (FLT_exp emin prec)).
Notation cexp := (cexp radix2 (FLT_exp emin prec)).

Definition average (x y : R) :=
   let samesign :=  match (Rle_bool 0 x), (Rle_bool 0 y) with
        true  , true   => true
      | false , false => true
      | _,_ => false
   end in
     if samesign then
       match (Rle_bool (Rabs x) (Rabs y)) with
            true => avg_half_sub emin prec x y
          | false => avg_half_sub emin prec y x
        end
      else avg_naive emin prec x y.

Variables x y:R.
Hypothesis Fx: format x.
Hypothesis Fy: format y.

Let a:=(x+y)/2.
Let av:=average x y.

Lemma average_symmetry: forall u v, average u v = average v u.
Proof.
intros u v; unfold average.
case (Rle_bool_spec 0 u); case (Rle_bool_spec 0 v); intros.
rewrite 2!Rabs_right; try apply Rle_ge; try assumption.
case (Rle_bool_spec u v); case (Rle_bool_spec v u); trivial.
intros; replace u with v; trivial; auto with real.
intros H1 H2; contradict H1; auto with real.
apply avg_naive_symmetry.
apply avg_naive_symmetry.
rewrite 2!Rabs_left; try assumption.
case (Rle_bool_spec (-u) (-v)); case (Rle_bool_spec (-v) (-u)); trivial.
intros; replace u with v; trivial; auto with real.
intros H1 H2; contradict H1; auto with real.
Qed.

Lemma average_symmetry_Ropp: forall u v, format u -> format v ->
  average (-u) (-v) = - average u v.
Proof with auto with typeclass_instances.
(* first: nonnegative u *)
assert (forall u v, 0 <= u -> format u -> format v ->
  average (-u) (-v) = - average u v).
intros u v Hu Fu Fv; unfold average.
rewrite 2!Rabs_Ropp.
destruct Hu as [Hu|Hu].
 (* 0 < u *)
 rewrite Rle_bool_false.
 2: apply Ropp_lt_cancel.
 2: now rewrite Ropp_involutive, Ropp_0.
 rewrite (Rle_bool_true 0 u); [idtac|now left].
 rewrite Rabs_right.
 2: apply Rle_ge; now left.
 destruct (total_order_T 0 v) as [Hv|Hv];[destruct Hv as [Hv|Hv] |idtac].
 (* . 0 < u and 0 < v *)
   rewrite Rle_bool_false.
   2: apply Ropp_lt_cancel.
   2: now rewrite Ropp_involutive, Ropp_0.
   rewrite (Rle_bool_true 0 v); [idtac|now left].
   rewrite Rabs_right.
   2: apply Rle_ge; now left.
   case (Rle_bool_spec u v);intros.
   apply avg_half_sub_symmetry_Ropp.
   apply avg_half_sub_symmetry_Ropp.
 (* . 0 < u and v = 0 *)
   rewrite <- Hv, Ropp_0, Rabs_R0.
   rewrite Rle_bool_true ;[idtac|now right].
   rewrite Rle_bool_false; try exact Hu.
   unfold avg_naive, avg_half_sub.
   unfold Rminus; rewrite Ropp_0, Rplus_0_l, 2!Rplus_0_r.
   rewrite (round_generic _ _ _ u); trivial.
   rewrite (round_generic _ _ _ (-u)).
   2: now apply generic_format_opp.
   rewrite <- round_NE_opp.
   rewrite <- round_NE_opp.
   rewrite (round_generic _ _ _ (round_flt (-(u/2)))).
   apply f_equal; field.
   apply generic_format_round...
 (* . 0 < u and v < 0 *)
   rewrite Rabs_left; trivial.
   rewrite Rle_bool_true.
   rewrite Rle_bool_false; trivial.
   apply avg_naive_symmetry_Ropp.
   rewrite <- Ropp_0; apply Ropp_le_contravar.
   now left.
 (* u = 0 *)
   rewrite <- Hu, Ropp_0, Rabs_R0.
   rewrite Rle_bool_true.
   2: now right.
   rewrite (Rle_bool_true 0 (Rabs v)).
   2: apply Rabs_pos.
   destruct (total_order_T 0 v) as [Hv|Hv];[destruct Hv as [Hv|Hv] |idtac].
   (* . u=0 and 0 < v *)
   rewrite Rle_bool_false.
   rewrite Rle_bool_true.
   unfold avg_naive, avg_half_sub.
   unfold Rminus; rewrite Ropp_0, 2!Rplus_0_l, Rplus_0_r.
   rewrite (round_generic _ _ _ v); trivial.
   rewrite (round_generic _ _ _ (-v)).
   2: now apply generic_format_opp.
   rewrite <- round_NE_opp.
   rewrite <- round_NE_opp.
   rewrite (round_generic _ _ _ (round_flt (-(v/2)))).
   apply f_equal; field.
   apply generic_format_round...
   now left.
   rewrite <- Ropp_0; now apply Ropp_lt_contravar.
  (* . u=0 and v=0 *)
   rewrite <- Hv, Ropp_0.
   rewrite Rle_bool_true.
   2: now right.
   unfold avg_half_sub.
   replace (0-0) with 0 by ring; rewrite round_0...
   unfold Rdiv; rewrite Rmult_0_l, round_0, Rplus_0_l...
  rewrite round_0...
  ring.
  (* . u=0 and v < 0 *)
  rewrite Rle_bool_true.
  rewrite Rle_bool_false.
   unfold avg_naive, avg_half_sub.
   unfold Rminus; rewrite Ropp_0, 2!Rplus_0_l, Rplus_0_r.
   rewrite (round_generic _ _ _ v); trivial.
   rewrite (round_generic _ _ _ (-v)).
   2: now apply generic_format_opp.
   rewrite <- round_NE_opp.
   rewrite (round_generic _ _ _ (round_flt (-v/2))).
   apply f_equal; field.
   apply generic_format_round...
   exact Hv.
   rewrite <- Ropp_0; apply Ropp_le_contravar; now left.
(* any u *)
intros u v Fu Fv.
case (Rle_or_lt 0 u).
intros Hu; now apply H.
intros Hu.
apply trans_eq with (- average (--u) (--v)).
rewrite (H (-u) (-v)).
ring.
rewrite <- Ropp_0; apply Ropp_le_contravar; now left.
apply generic_format_opp...
apply generic_format_opp...
apply f_equal, f_equal2; ring.
Qed.

Lemma average_same_sign_1: 0 <= a -> 0 <= av.
Proof with auto with typeclass_instances.
intros H; unfold av, average.
case (Rle_bool_spec 0 x); case (Rle_bool_spec 0 y); intros.
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_same_sign_1...
apply avg_half_sub_same_sign_1...
now rewrite Rplus_comm.
apply avg_naive_same_sign_1...
apply avg_naive_same_sign_1...
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_same_sign_1...
apply avg_half_sub_same_sign_1...
now rewrite Rplus_comm.
Qed.

Lemma average_same_sign_2: a <= 0-> av <= 0.
Proof with auto with typeclass_instances.
intros H; unfold av, average.
case (Rle_bool_spec 0 x); case (Rle_bool_spec 0 y); intros.
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_same_sign_2...
apply avg_half_sub_same_sign_2...
now rewrite Rplus_comm.
apply avg_naive_same_sign_2...
apply avg_naive_same_sign_2...
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_same_sign_2...
apply avg_half_sub_same_sign_2...
now rewrite Rplus_comm.
Qed.

Lemma average_correct: Rabs (av -a) <= 3/2 * ulp_flt a.
Proof with auto with typeclass_instances.
unfold av,a,average.
case (Rle_bool_spec 0 x); case (Rle_bool_spec 0 y); intros.
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_correct...
rewrite Rplus_comm.
apply avg_half_sub_correct...
apply avg_naive_correct_weak2...
apply avg_naive_correct_weak2...
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_correct...
right; split; now left.
rewrite Rplus_comm.
apply avg_half_sub_correct...
right; split; now left.
Qed.

Lemma average_between: Rmin x y <= av <= Rmax x y.
Proof with auto with typeclass_instances.
unfold av,a,average.
case (Rle_bool_spec 0 x); case (Rle_bool_spec 0 y); intros.
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_between...
rewrite Rmin_comm, Rmax_comm.
apply avg_half_sub_between...
apply avg_naive_between...
apply avg_naive_between...
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_between...
rewrite Rmin_comm, Rmax_comm.
apply avg_half_sub_between...
Qed.

Lemma average_zero: a = 0 -> av = 0.
Proof with auto with typeclass_instances.
unfold av,a,average.
case (Rle_bool_spec 0 x); case (Rle_bool_spec 0 y); intros.
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_zero...
apply avg_half_sub_zero...
now rewrite Rplus_comm.
apply avg_naive_zero...
apply avg_naive_zero...
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_zero...
apply avg_half_sub_zero...
now rewrite Rplus_comm.
Qed.

Lemma average_no_underflow: (bpow emin) <= Rabs a -> av <> 0.
Proof with auto with typeclass_instances.
unfold av,a,average.
case (Rle_bool_spec 0 x); case (Rle_bool_spec 0 y); intros.
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_no_underflow...
apply avg_half_sub_no_underflow...
now rewrite Rplus_comm.
apply avg_naive_no_underflow...
apply avg_naive_no_underflow...
case (Rle_bool_spec (Rabs x) (Rabs y)); intros.
apply avg_half_sub_no_underflow...
right; split; now left.
apply avg_half_sub_no_underflow...
right; split; now left.
now rewrite Rplus_comm.
Qed.

End average.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A C : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (col_ O E A /\ (col_ O E O /\ (col_ O E C /\ col_ O C Eprime)))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e256m2e32m977_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Export Category.
Require Import Common StrictCategory.

Set Implicit Arguments.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Section BoolCat.
  Local Notation obj := Bool (only parsing).
  Local Notation mor s d := (if (implb s d) then Unit else Empty) (only parsing).

  Definition BoolCat_Compose s d d' (m1 : mor d d') (m2 : mor s d) : mor s d'.
    destruct_head Bool; trivial.
  Defined.

  Definition BoolCat_Identity x : mor x x :=
    if x return mor x x then tt else tt.

  Global Arguments BoolCat_Compose [!s !d !d'] m1 m2 / .
  Global Arguments BoolCat_Identity !x / .

  Definition BoolCat : PreCategory.
    refine (@Build_PreCategory Bool
                               (fun s d => mor s d)
                               BoolCat_Identity
                               BoolCat_Compose
                               _
                               _
                               _
                               _);
    abstract (
        intros;
        destruct_head Bool;
        destruct_head Empty;
        destruct_head Unit;
        trivial;
        typeclasses eauto
      ).
  Defined.
End BoolCat.

Instance BoolCatIsStrict : IsStrictCategory BoolCat.
Proof.
  apply hset_decidable.
  repeat intro;
    destruct_head_hnf Bool;
    solve [ left; trivial
          | right; trivial ].
Defined.


Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.
Set Printing Universes.

Set Printing All.

Record PreCategory :=
  {
    Object :> Type;
    Morphism : Object -> Object -> Type
  }.

Inductive paths A (x : A) : A -> Type := idpath : @paths A x x.
Inductive Unit : Prop := tt. (* Changing this to [Set] fixes things *)
Inductive Bool : Set := true | false.

Definition DiscreteCategory X : PreCategory
  := @Build_PreCategory X
                        (@paths X).

Definition IndiscreteCategory X : PreCategory
  := @Build_PreCategory X
                        (fun _ _ => Unit).

Check (IndiscreteCategory Unit).
Check (DiscreteCategory Bool).
Definition NatCategory (n : nat) :=
  match n with
    | 0 => IndiscreteCategory Unit
    | _ => DiscreteCategory Bool
  end. (* Error: Universe inconsistency (cannot enforce Set <= Prop). *)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e266m3_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Coqprime.elliptic.ZEll.
Require Import Coqprime.elliptic.ZEll.
Require Import Coq.ZArith.Znumtheory.
Require Import Coq.ZArith.BinInt.

From STLCZK Require Import GaloisField.
From STLCZK Require Import Ltac.
From Coq Require Import Vectors.VectorDef.
From Coq Require Import Init.Nat.
From Coq  Require Import Program.Equality.

Set Implicit Arguments.
Set Maximal Implicit Insertion.

Module Stlc(Import PF: GaloisField.GaloisField).
  Import PF.

  (** Use the same reified type for the whole development *)
  Inductive type : Type :=
  | TBool: type
  | TNum: type
  | TArrow : type -> type -> type.

  Declare Custom Entry stlc_ty.
  Notation "<{{ e }}>" := e (e custom stlc_ty at level 99).
  Notation "( x )" := x (in custom stlc_ty, x at level 99).
  Notation "x" := x (in custom stlc_ty at level 0, x constr at level 0).
  Notation "S -> T" := (TArrow S T)
                         (in custom stlc_ty at level 2, right associativity).
  Notation "'Num'" := TNum (in custom stlc_ty at level 0).
  Notation "'Bool'" := TBool (in custom stlc_ty at level 0).

  (** This is STLC PHOAS syntax with strong normalization *)
  Fixpoint typeDenote(t: type): Type :=
    match t with
    | <{{ Bool }}> => bool
    | <{{ Num }}> => Fp
    | <{{ a -> b }}> => (typeDenote a) -> (typeDenote b)
    end.

  Section pterms.
    Variable var: type -> Type.

    Inductive PTerm : type -> Type :=
    (* Pure *)
    (* Finite field arithmetic *)
    | ADD: PTerm <{{ Num }}> -> PTerm <{{ Num }}> -> PTerm <{{ Num }}>
    | SUB: PTerm <{{ Num }}> -> PTerm <{{ Num }}> -> PTerm <{{ Num }}>
    | MUL: PTerm <{{ Num }}> -> PTerm <{{ Num }}> -> PTerm <{{ Num }}>
    | DIV: PTerm <{{ Num }}> -> PTerm <{{ Num }}> -> PTerm <{{ Num }}>
    | ITE: forall t, PTerm <{{ Bool }}> -> PTerm t -> PTerm t -> PTerm t
    (* Logical formulas *)
    | EQ: PTerm <{{ Num }}> -> PTerm <{{ Num }}> -> PTerm <{{ Bool }}>
    | AND: PTerm <{{ Bool }}> -> PTerm <{{ Bool }}> -> PTerm <{{ Bool }}>
    | OR: PTerm <{{ Bool }}> -> PTerm <{{ Bool }}> -> PTerm <{{ Bool }}>
    | NOT: PTerm <{{ Bool }}> -> PTerm <{{ Bool }}>
    | L: forall a, LTerm a -> PTerm a
    with LTerm: type -> Type :=
    (* Constants *)
    | NUM: Fp -> LTerm <{{ Num }}>
    | BOOL: bool -> LTerm <{{ Bool }}>
    (* Lambda *)
    | APP: forall a b, LTerm <{{ a -> b }}> -> LTerm a -> LTerm b
    | VAR: forall a, var a -> LTerm a
    | LAM: forall a b, (var a -> LTerm b) -> LTerm <{{ a ->  b }}>
    | P: forall a, PTerm a -> LTerm a.

    (**
PTerm_LTerm_rec
     : forall (P0 : forall t : type, PTerm t -> Type) (P1 : forall t : type, LTerm t -> Type),
       (forall p : PTerm <{{ Num }}>,
        P0 <{{ Num }}> p ->
        forall p0 : PTerm <{{ Num }}>, P0 <{{ Num }}> p0 -> P0 <{{ Num }}> (ADD p p0)) ->
       (forall p : PTerm <{{ Num }}>,
        P0 <{{ Num }}> p ->
        forall p0 : PTerm <{{ Num }}>, P0 <{{ Num }}> p0 -> P0 <{{ Num }}> (SUB p p0)) ->
       (forall p : PTerm <{{ Num }}>,
        P0 <{{ Num }}> p ->
        forall p0 : PTerm <{{ Num }}>, P0 <{{ Num }}> p0 -> P0 <{{ Num }}> (MUL p p0)) ->
       (forall p : PTerm <{{ Num }}>,
        P0 <{{ Num }}> p ->
        forall p0 : PTerm <{{ Num }}>, P0 <{{ Num }}> p0 -> P0 <{{ Num }}> (DIV p p0)) ->
       (forall (t : type) (p : PTerm <{{ Bool }}>),
        P0 <{{ Bool }}> p ->
        forall p0 : PTerm t, P0 t p0 -> forall p1 : PTerm t, P0 t p1 -> P0 t (ITE p p0 p1)) ->
       (forall p : PTerm <{{ Num }}>,
        P0 <{{ Num }}> p ->
        forall p0 : PTerm <{{ Num }}>, P0 <{{ Num }}> p0 -> P0 <{{ Bool }}> (EQ p p0)) ->
       (forall p : PTerm <{{ Bool }}>,
        P0 <{{ Bool }}> p ->
        forall p0 : PTerm <{{ Bool }}>, P0 <{{ Bool }}> p0 -> P0 <{{ Bool }}> (AND p p0)) ->
       (forall p : PTerm <{{ Bool }}>,
        P0 <{{ Bool }}> p ->
        forall p0 : PTerm <{{ Bool }}>, P0 <{{ Bool }}> p0 -> P0 <{{ Bool }}> (OR p p0)) ->
       (forall p : PTerm <{{ Bool }}>, P0 <{{ Bool }}> p -> P0 <{{ Bool }}> (NOT p)) ->
       (forall (a : type) (l : LTerm a), P1 a l -> P0 a (L l)) ->
       (forall f9 : Fp, P1 <{{ Num }}> (NUM f9)) ->
       (forall b : bool, P1 <{{ Bool }}> (BOOL b)) ->
       (forall (a b : type) (l : LTerm <{{ a -> b }}>),
        P1 <{{ a -> b }}> l -> forall l0 : LTerm a, P1 a l0 -> P1 b (APP l l0)) ->
       (forall (a : type) (v : var a), P1 a (VAR v)) ->
       (forall (a b : type) (l : var a -> LTerm b),
        (forall v : var a, P1 b (l v)) -> P1 <{{ a -> b }}> (LAM l)) ->
       (forall (a : type) (p : PTerm a), P0 a p -> P1 a (P p)) ->
       forall (t : type) (p : PTerm t), P0 t p
*)
    Scheme PTerm_LTerm_rec := Induction for PTerm Sort Type
      with LTerm_PTerm_rec := Induction for LTerm Sort Type.
  End pterms.

  Arguments VAR [var a].
  Arguments NUM {var}.
  Arguments BOOL {var}.
  Arguments APP [var a b].
  Arguments LAM [var a b].
  Arguments L {var a}.

  Arguments ADD {var}.
  Arguments SUB {var}.
  Arguments MUL {var}.
  Arguments DIV {var}.
  Arguments ITE {var t}.
  Arguments EQ {var}.
  Arguments AND {var}.
  Arguments OR {var}.
  Arguments NOT {var}.
  Arguments P {var a}.

  Fixpoint ptermDenote t (e: PTerm typeDenote t): typeDenote t :=
    match e in (PTerm _ t) return (typeDenote t) with
    | ADD a b => pkplus (ptermDenote a) (ptermDenote b)
    | SUB a b => pksub (ptermDenote a) (ptermDenote b)
    | MUL a b => pkmul (ptermDenote a) (ptermDenote b)
    | DIV a b => pkdiv (ptermDenote a) (ptermDenote b)
    | ITE c a b => if (ptermDenote c) then (ptermDenote a) else (ptermDenote b)
    | EQ a b => if eq_field (ptermDenote a) (ptermDenote b) then true else false
    | AND a b => andb (ptermDenote a) (ptermDenote b)
    | OR a b => orb (ptermDenote a) (ptermDenote b)
    | NOT a => negb (ptermDenote a)
    | L a => ltermDenote a
    end
  with ltermDenote t (e : LTerm typeDenote t) {struct e} : typeDenote t :=
    match e in (LTerm _ t) return (typeDenote t) with
    | VAR v => v
    | NUM f => f
    | BOOL v => v
    | APP e1 e2 => (ltermDenote e1) (ltermDenote e2)
    | LAM e' => fun x => ltermDenote (e' x)
    | P e => ptermDenote e
    end.

  (* Normalization via reify/reflect Danvy et al. for LTerms *)
  Class LNbe (t: type) := {
    reify: typeDenote t -> LTerm typeDenote t;
    reflect: LTerm typeDenote t -> typeDenote t;
                         }.

  Instance LNbe_lam {a b: type} `(LNbe a) `(LNbe b) : LNbe <{{ a -> b }}> := {
    reify v := LAM (fun x => reify (v (reflect (VAR x))));
    reflect e := fun x => reflect (APP e (reify x));
                                                                           }.

  Instance LNbe_num : LNbe <{{ Num }}> := {
    reify v := NUM v;
    reflect v := ltermDenote v;
                                        }.

  Instance LNbe_bool : LNbe <{{ Bool }}> := {
    reify v := BOOL v;
    reflect v := ltermDenote v;
                                          }.

  (* Fine-grained normalization co-recursively in PrimaryOps terms (PTerms) and
     Lambda Calculus terms (LTerms) *)
  Class Nbe (t: type) := {
    pnorm: PTerm typeDenote t -> PTerm typeDenote t;
    lnorm: LTerm typeDenote t -> LTerm typeDenote t
                        }.

  (* This is needed so instance resolution succeeds *)
  Hint Extern 5 (Nbe ?X) =>
  match goal with
  | [ H : ?a =  <{{ ?b }}> |- ?g ] => idtac a b g; inversion H; subst; clear H; eauto
  end: typeclass_instances.

  Hint Extern 5 (LNbe ?X) =>
  match goal with
  | [ H : ?a =  <{{ ?b }}> |- ?g ] => idtac a b g; inversion H; subst; clear H; eauto
  end: typeclass_instances.

  Program Fixpoint pnorm_num(e: PTerm typeDenote <{{ Num }}>): PTerm typeDenote <{{ Num }}> :=
      match e with
      | ADD e1 e2 =>
        let p1 := pnorm_num e1 in
        let p2 := pnorm_num e2 in
        match p1, p2 return (PTerm typeDenote <{{ Num }}>) with
        | L (NUM n1), L (NUM n2) => L (NUM (pkplus n1 n2))
        | _, _ => ADD p1 p2
        end
      | SUB e1 e2 =>
        let p1 := pnorm_num e1 in
        let p2 := pnorm_num e2 in
        match p1, p2 return (PTerm typeDenote <{{ Num }}>) with
        | L (NUM n1), L (NUM n2) => L (NUM (pksub n1 n2))
        | _, _ => SUB p1 p2
        end
      | MUL e1 e2 =>
        let p1 := pnorm_num e1 in
        let p2 := pnorm_num e2 in
        match p1, p2 return (PTerm typeDenote <{{ Num }}>) with
        | L (NUM n1), L (NUM n2) => L (NUM (pkmul n1 n2))
        | _, _ => MUL p1 p2
        end
      | DIV e1 e2 =>
        let p1 := pnorm_num e1 in
        let p2 := pnorm_num e2 in
        match p1, p2 return (PTerm typeDenote <{{ Num }}>) with
        | L (NUM n1), L (NUM n2) => L (NUM (pkdiv n1 n2))
        | _, _ => DIV p1 p2
        end
      | ITE c a b =>
        let pc := pnorm_bool c in
        match pc return (PTerm typeDenote <{{ Num }}>) with
        | L (BOOL true) => pnorm_num a
        | L (BOOL false) => pnorm_num b
        | _ => ITE pc (pnorm_num a) (pnorm_num b)
        end
      | L a => L (lnorm_num a)
      (* Bogus cases *)
      | EQ a b => EQ a b
      | AND e1 e2 => AND e1 e2
      | OR e1 e2 => OR e1 e2
      | NOT a => NOT a
      end
  with lnorm_num (e: LTerm typeDenote <{{ Num }}>): LTerm typeDenote <{{ Num }}> :=
         match e with
         | P p => P (pnorm_num p)
         | APP e1 e2 => reify (reflect e)
         | LAM _ => reify (reflect e)
         | VAR _ => reify (reflect e)
         | NUM f => NUM f
         (* Bogus terms *)
         | BOOL v => BOOL v
         end
  with pnorm_bool(e: PTerm typeDenote <{{ Bool }}>): PTerm typeDenote <{{ Bool }}> :=
         match e with
         | EQ e1 e2 =>
           let p1 := pnorm_num e1 in
           let p2 := pnorm_num e2 in
           match p1, p2 return (PTerm typeDenote <{{ Bool }}>) with
           | L (NUM n1), L (NUM n2) => L (BOOL (if eq_field n1 n2 then true else false))
           | _, _ => EQ p1 p2
           end
         | AND e1 e2 =>
           let p1 := pnorm_bool e1 in
           let p2 := pnorm_bool e2 in
           match p1, p2 return (PTerm typeDenote <{{ Bool }}>) with
           | L (BOOL b1), L (BOOL b2) => L (BOOL (andb b1 b2))
           | _, _ => AND p1 p2
           end
         | OR e1 e2 =>
           let p1 := pnorm_bool e1 in
           let p2 := pnorm_bool e2 in
           match p1, p2 return (PTerm typeDenote <{{ Bool }}>) with
           | L (BOOL b1), L (BOOL b2) => L (BOOL (orb b1 b2))
           | _, _ => OR p1 p2
           end
         | NOT a =>
           let p1 := pnorm_bool a in
           match p1 return (PTerm typeDenote <{{ Bool }}>) with
           | L (BOOL b1) => L (BOOL (negb b1))
           | _ => NOT p1
           end
         | L a => L (lnorm_bool a)
         | ITE c a b =>
           let pc := pnorm_bool c in
           match pc return (PTerm typeDenote <{{ Bool }}>) with
           | L (BOOL true) => pnorm_bool a
           | L (BOOL false) => pnorm_bool b
           | _ => ITE pc (pnorm_bool a) (pnorm_bool b)
           end
         (* Bogus patterns *)
         | ADD a b => ADD a b
         | SUB a b => SUB a b
         | MUL a b => MUL a b
         | DIV a b => DIV a b
         end
  with lnorm_bool (e: LTerm typeDenote <{{ Bool }}>): LTerm typeDenote <{{ Bool }}> :=
         match e with
         | P p => P (pnorm_bool p)
         | APP e1 e2 => reify (reflect e)
         | LAM _ => reify (reflect e)
         | VAR _ => reify (reflect e)
         | BOOL v => BOOL v
         (* Bogus terms *)
         | NUM f => NUM f
         end.

  Instance Nbe_num : Nbe <{{ Num }}> := {
    pnorm := pnorm_num;
    lnorm := lnorm_num;
    }.

  Instance Nbe_bool: Nbe <{{ Bool }}> := {
    pnorm := pnorm_bool;
    lnorm := lnorm_bool
                                        }.

  Program Fixpoint lnorm_arr{a b: type} `{Nbe <{{ Bool }}>}
          `{LNbe a} `{LNbe b} `{Nbe a} `{Nbe b} `{Nbe <{{Bool}}>}
          (e: LTerm typeDenote <{{a -> b }}>) : LTerm typeDenote <{{ a -> b }}> :=
    match e with
    | P p => P (pnorm_arr p)
    | APP e1 e2 => reify (reflect e)
    | LAM e' => LAM (fun x => lnorm (e' x))
    | VAR _ => reify (reflect e)
    (* Bogus terms *)
    | NUM f => NUM f
    | BOOL v => BOOL v
    end
  with pnorm_arr{a b: type}
          `{LNbe a} `{LNbe b} `{Nbe <{{Bool}}>} `{Nbe a} `{Nbe b}
          (e: PTerm typeDenote <{{a -> b }}>) : PTerm typeDenote <{{ a -> b }}> :=
    match e with
    | ITE c e1 e2 =>
      L (LAM (fun x => P (ITE (pnorm c)
                           (L (lnorm (APP (P (pnorm_arr e1)) (VAR x))))
                           (L (lnorm (APP (P (pnorm_arr e2)) (VAR x)))))))
    | L p => L (lnorm_arr p)
    (* Bogus terms *)
    | ADD a b => ADD a b
    | SUB a b => SUB a b
    | MUL a b => MUL a b
    | DIV a b => DIV a b
    | EQ a b => EQ a b
    | AND a b => AND a b
    | OR a b => OR a b
    | NOT a => NOT a
    end.

  Instance Nbe_lam {a b: type} `(Nbe a) `(Nbe b) `(LNbe a) `(LNbe b): Nbe <{{ a -> b }}> := {
    pnorm := pnorm_arr;
    lnorm := lnorm_arr
                                                                                }.

  Declare Custom Entry stlc.
  Notation "'fp' n" := (NUM n) (in custom stlc at level 0).
  Notation "'true'"  := true (at level 1).
  Notation "'true'" := (BOOL true) (in custom stlc at level 0).
  Notation "'false'"  := false (at level 1).
  Notation "'false'" := (BOOL false) (in custom stlc at level 0).
  Notation "<{ e }>" := e (e custom stlc at level 99).
  Notation "( x )" := x (in custom stlc, x at level 99).
  Notation "x" := x (in custom stlc at level 0, x constr at level 0).
  Notation "x y" := (APP x y) (in custom stlc at level 1, left associativity).
  Notation "\ x , y" :=
    (LAM (fun x => y)) (in custom stlc at level 90,
                        x constr,
                        y custom stlc at level 80,
                        left associativity).
  Notation "\_ , y" :=
    (LAM (fun _ => y)) (in custom stlc at level 90,
                        y custom stlc at level 80,
                        left associativity).
  Notation "# n" := (VAR n) (in custom stlc at level 0).
  Notation "{ x }" := x (in custom stlc at level 1, x constr).
  Notation "x + y" := (ADD x y) (in custom stlc at level 2,
                                            left associativity).
  Notation "x - y" := (SUB x y) (in custom stlc at level 2,
                                            left associativity).
  Notation "x * y" := (MUL x y) (in custom stlc at level 1,
                                            left associativity).
  Notation "x && y" := (AND x y) (in custom stlc at level 4,
                                             left associativity).
  Notation "x || y" := (OR x y) (in custom stlc at level 4,
                                             left associativity).
  Notation "x == y" := (EQ x y) (in custom stlc at level 3,
                                      left associativity).
  Notation "! x " := (NOT x) (in custom stlc at level 3).
  Notation "'ifi' x 'then' y 'else' z" :=
    (ITE x y z) (in custom stlc at level 89,
                    x custom stlc at level 99,
                    y custom stlc at level 99,
                    z custom stlc at level 99,
                    left associativity).

  Coercion P: PTerm >-> LTerm.
  Coercion L: LTerm >-> PTerm.

  Definition t: LTerm typeDenote <{{ Bool -> Bool }}> :=
    <{ \x, (ifi # x then \y, # y else \z, ! # z) # x }>.

  Print t.
  Eval cbv in lnorm_arr t.

  Inductive fof: type -> Prop :=
  | fo_bool: fof <{{ Bool }}>
  | fo_num: fof <{{ Num }}>
  | fof_bool: forall a,
      fof <{{ a }}> ->
      fof <{{ Bool -> a }}>
  | fof_num: forall a,
      fof <{{ a }}> ->
      fof <{{ Num -> a }}>.

  Inductive value: forall (t: type), LTerm typeDenote t -> Prop :=
  | Value_bool: forall x, @value <{{ Bool }}> (@VAR typeDenote <{{ Bool }}> x)
  | Value_btrue: @value <{{ Bool }}> <{ true }>
  | Value_bfalse: @value <{{ Bool }}> <{ false }>
  | Value_var: forall x, @value <{{ Num }}> (@VAR typeDenote <{{ Num }}> x)
  | Value_const: forall (x: Fp), @value <{{ Num }}> (NUM x).

  Inductive hnff: forall (t: type), LTerm typeDenote t -> Prop :=
  | HNF_bool_ar: forall a f,
      (forall (arg: typeDenote <{{ Bool }}>), @hnff <{{ a }}> (f arg)) ->
      @hnff <{{ Bool -> a }}> (LAM f)
  | HNF_num_ar: forall a f,
      (forall (arg: typeDenote <{{ Num }}>), @hnff <{{ a }}> (f arg)) ->
      @hnff <{{ Num -> a }}> (LAM f)
  | HNF_bool: forall e,
      value e ->
      @hnff <{{ Bool }}> e
  | HNF_num: forall e,
      value e ->
      @hnff <{{ Num }}> e.

  (** Provide default witnesses for hnff *)
  (* Hint Extern 3 (typeDenote <{{ Bool }}>) => exact (true).
  Hint Extern 3 (typeDenote <{{ Num }}>) => exact (0:%p).
  *)
  Theorem normalize_correct: forall (t: type) (e: LTerm typeDenote t),
      fof t  ->
      @hnff t (normalize e).
  Proof with eauto.
    intros.
    generalize dependent e.
    generalize dependent H.
    induction t; intros; dependent destruction e; cbn; try constructor;
      invert H; cbn; try constructor...
    - destruct b; constructor.
    - destruct (ltermDenote e1); constructor.
    - destruct t; constructor.
    - admit.
    - admit.
  Admitted.

  Example notnormal: @hnff <{{ Bool -> Bool }}> (normalize t).
  Proof.
    constructor.
    intros.
    constructor.
    unfold t; simpl.
    destruct arg.
    - constructor.
    - constructor.
  Qed.

End Stlc.