Require Import
        Coq.Strings.String
        Coq.Arith.Mult
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Common.DecideableEnsembles
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.BinLib.AlignedByteString
        Fiat.Narcissus.BinLib.AlignedDecoders.

Require Import
        Bedrock.Word.

Section AlignedFix.

  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.

  Lemma byte_align_Fix_encode {A}
        (lt_A : A -> A -> Prop)
        (wf_lt_A : well_founded lt_A)
    : forall
      (body : FixComp.funType [A; CacheFormat] (ByteString * CacheFormat)
              -> FixComp.funType [A; CacheFormat] (ByteString * CacheFormat))
      (body' : forall r : A,
          (forall r' : A, lt_A r' r -> FixComp.LeastFixedPointFun.cfunType [CacheFormat] ({n : _ & ByteBuffer.t n} * CacheFormat)) ->
          FixComp.LeastFixedPointFun.cfunType [CacheFormat] ({n : _ & ByteBuffer.t n} * CacheFormat))

      (refine_body_OK : forall (r : A)
                               (x : A -> CacheFormat  ->
                                    Comp (ByteString * CacheFormat))
                               (y : forall r' : A,
                                   lt_A r' r ->
                                   CacheFormat ->
                                   {n : _ & ByteBuffer.t n} * CacheFormat),
          (forall (a' : A) (wf_r : lt_A a' r) (ce : CacheFormat),
              refine (x a' ce)
                     (ret (let (v, ce') := y a' wf_r ce in
                           (build_aligned_ByteString (projT2 v), ce'))))
          -> forall ce, refine (body x r ce) (ret (let (v, ce') := body' r y ce in
                                                   (build_aligned_ByteString (projT2 v), ce'))))

      (body_monotone : forall rec rec' : FixComp.funType [A; CacheFormat] (ByteString * CacheFormat),
          FixComp.refineFun rec rec' -> FixComp.refineFun (body rec) (body rec'))
      (body'_monotone : forall (x0 : A)
                               (f
                                  g : {y : A | lt_A y x0} ->
                                      CacheFormat ->
                                      {n : nat & t (word 8) n} * (CacheFormat)),
          (forall y : {y : A | lt_A y x0}, f y = g y) ->
          body' x0 (fun (a' : A) (lt_a' : lt_A a' x0) => f (exist (fun a'0 : A => lt_A a'0 x0) a' lt_a')) =
          body' x0 (fun (a' : A) (lt_a' : lt_A a' x0) => g (exist (fun a'0 : A => lt_A a'0 x0) a' lt_a')))
      (a : A) (ce : CacheFormat),
      refine (FixComp.LeastFixedPointFun.LeastFixedPoint body a ce)
             (ret (let (v, ce') := Fix wf_lt_A _ body' a ce in
                   (build_aligned_ByteString (projT2 v), ce'))).
  Proof.
    intros.
    unfold FixComp.LeastFixedPointFun.LeastFixedPoint, respectful_hetero; intros.
    simpl.
    revert ce; pattern a; eapply (well_founded_ind wf_lt_A).
    simpl; intros.
    pose proof (proj1 (Frame.Is_GreatestFixedPoint (O := @FixComp.LeastFixedPointFun.funDefOps [A; CacheFormat] (ByteString * CacheFormat)) _ (body_monotone))); etransitivity.
    eapply H0; eauto.
    destruct (Fix wf_lt_A
                  (fun _ : A =>
                     CacheFormat ->
                     {n : nat & t (word 8) n} * (CacheFormat)) body' x ce) eqn: ?.
    pose proof (Fix_eq _ _ wf_lt_A _ (fun a rec => body' a (fun a' lt_a' => rec (exist (fun a' => lt_A a' a) a' lt_a')))).
    simpl in H1; unfold Fix_sub, Fix_F_sub in H1; unfold Fix, Fix_F in Heqp.
    rewrite H1 in Heqp; simpl in Heqp; clear H1; eauto.
    etransitivity.
    eapply refine_body_OK.
    instantiate (1 := (fun (a' : A) (_ : lt_A a' x) =>
                         (fix Fix_F_sub (x0 : A) (r : Acc lt_A x0) {struct r} :
                            CacheFormat ->
                            {n : nat & t (word 8) n} * (CacheFormat) :=
                            body' x0 (fun (a'0 : A) (lt_a'0 : lt_A a'0 x0) => Fix_F_sub a'0 (Acc_inv r lt_a'0))) a'
                                                                                (wf_lt_A a'))).
    eapply H; eauto.
    admit.
  Admitted.

  Lemma byte_align_Fix_encode_inv {A}
        (A_OK : A -> Prop)
        (lt_A : _ -> _ -> Prop)
        (wf_lt_A : well_founded lt_A)
    : forall
      (body : FixComp.funType [A; CacheFormat] (ByteString * CacheFormat)
              -> FixComp.funType [A; CacheFormat] (ByteString * CacheFormat))
      (body' : forall r : { a : _ & A_OK a},
          (forall r' : { a : _ & A_OK a},
              lt_A r' r
              -> FixComp.LeastFixedPointFun.cfunType [CacheFormat] ({n : _ & ByteBuffer.t n} * CacheFormat)) ->
          FixComp.LeastFixedPointFun.cfunType [CacheFormat] ({n : _ & ByteBuffer.t n} * CacheFormat))
      (refine_body_OK : forall (r : { a : _ & A_OK a})
                               (x : A -> CacheFormat ->
                                    Comp (ByteString * CacheFormat))
                               (y : forall r' : { a : _ & A_OK a},
                                   lt_A r' r ->
                                   CacheFormat ->
                                   {n : _ & ByteBuffer.t n} * CacheFormat),
          (forall (a' : { a : _ & A_OK a}) (wf_r : lt_A a' r) (ce : CacheFormat),
              refine (x (projT1 a') ce)
                     (ret (let (v, ce') := y a' wf_r ce in
                           (build_aligned_ByteString (projT2 v), ce'))))
          -> forall ce, refine (body x (projT1 r) ce) (ret (let (v, ce') := body' r y ce in
                                                            (build_aligned_ByteString (projT2 v), ce'))))

      (body_monotone : forall rec rec' : FixComp.funType [A; CacheFormat] (ByteString * CacheFormat),
          FixComp.refineFun rec rec' -> FixComp.refineFun (body rec) (body rec'))
      (body'_monotone : forall (x0 : { a : _ & A_OK a})
                               (f
                                  g : {y : { a : _ & A_OK a} | lt_A y x0} ->
                                      CacheFormat ->
                                      {n : nat & t (word 8) n} * (CacheFormat)),
          (forall y : {y : { a : _ & A_OK a} | lt_A y x0}, f y = g y) ->
          body' x0 (fun (a' : { a : _ & A_OK a}) (lt_a' : lt_A a' x0) => f (exist (fun a'0 : { a : _ & A_OK a} => lt_A a'0 x0) a' lt_a')) =
          body' x0 (fun (a' : { a : _ & A_OK a}) (lt_a' : lt_A a' x0) => g (exist (fun a'0 : { a : _ & A_OK a} => lt_A a'0 x0) a' lt_a')))
      (a : A) (ce : CacheFormat) (a_OK : A_OK a),
      refine (FixComp.LeastFixedPointFun.LeastFixedPoint body a ce)
             (ret (let (v, ce') := Fix wf_lt_A _ body' (existT _ _ a_OK) ce in
                   (build_aligned_ByteString (projT2 v), ce'))).
  Proof.
    (* 8.4 script *)
    intros.
    unfold FixComp.LeastFixedPointFun.LeastFixedPoint, respectful_hetero; intros.
    simpl.
    replace a with (projT1 (existT _ a a_OK)) at 1.
    revert ce; pattern (existT _ a a_OK); eapply (well_founded_ind wf_lt_A).
    simpl; intros.
    pose proof (proj1 (Frame.Is_GreatestFixedPoint (O := @FixComp.LeastFixedPointFun.funDefOps [A; CacheFormat] (ByteString * CacheFormat)) _ (body_monotone))); etransitivity.
    eapply H0; eauto.
    destruct ( Fix wf_lt_A
                   (fun _ : {a0 : A & A_OK a0} =>
                      CacheFormat ->
                      {n : nat & t (word 8) n} * (CacheFormat)) body' x ce) eqn: ?.
    pose proof (Fix_eq _ _ wf_lt_A _ (fun a rec => body' a (fun a' lt_a' => rec (exist (fun a' => lt_A a' a) a' lt_a')))).
    simpl in H1; unfold Fix_sub, Fix_F_sub in H1; unfold Fix, Fix_F in Heqp.
    rewrite H1 in Heqp; simpl in Heqp; clear H1; eauto.
    etransitivity.
    eapply refine_body_OK.
    instantiate (1 := fun (a' : {a0 : A & A_OK a0}) (_ : lt_A a' x) =>
                        (fix Fix_F_sub (x0 : {a0 : A & A_OK a0}) (r : Acc lt_A x0) {struct r} :
                           CacheFormat ->
                           {n : nat & t (word 8) n} * (CacheFormat) :=
                           body' x0 (fun (a'0 : {a0 : A & A_OK a0}) (lt_a'0 : lt_A a'0 x0) => Fix_F_sub a'0 (Acc_inv r lt_a'0))) a'
                                                                                (wf_lt_A a')).
    admit. (* works in 8.4: eapply H; eauto. *)
    admit. (* works in 8.4: rewrite Heqp; reflexivity.*)
    reflexivity.
  Admitted.

End AlignedFix.


Require Import Functors.
Require Import List.
Require Import FunctionalExtensionality.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.

Section ESound_Pure.

  (** SuperFunctor for Types. **)
  Variable DT : Set -> Set.
  Context {Fun_DT : Functor DT}.
  (* Definition DType := UP'_F DT. *)

  (** SuperFunctor for Values. **)
  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.
  (* Definition Value := UP'_F V. *)

  (** SuperFunctor for Expressions. **)
  Variable E : Set -> Set.
  Context {Fun_E : Functor E}.
  (* Definition Exp := UP'_F E. *)

  Variable MT : Set -> Set.
  Context {Fun_MT : Functor MT}.
  Context {Mon_MT : Monad MT}.
  Context {Fail_MT : FailMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.

  Variable ME : Set -> Set.
  Context {Functor_ME : Functor ME}.
  Context {Monad_ME : Monad ME}.
  Context {Fail_ME : FailMonad ME}.

  Variable WFV : (WFValue_i DT V unit -> Prop) -> WFValue_i DT V unit -> Prop.
  Context {funWFV : iFunctor WFV}.

  Variable WFVM : (WFValueM_i DT V MT ME unit -> Prop) -> WFValueM_i DT V MT ME unit -> Prop.
  Context {funWFVM : iFunctor WFVM}.

  Definition Pure_Sound_P (i : WFValueM_i DT V MT ME unit) :=
    forall T, wfvm_T DT V MT ME _ i = return_ T ->
      exists v : Value V,
        wfvm_v DT V MT ME unit i = return_ (M := ME) v /\
        WFValueC DT V unit WFV tt v T.

  Inductive Pure_Sound_Name := pure_sound_name.

  Context {WFV_proj1_b_WFV :
    iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P DT V unit WFV) WFV}.

  Global Instance Pure_Sound_WFVM_base :
    iPAlgebra Pure_Sound_Name Pure_Sound_P (WFValueM_base DT V MT ME unit WFV).
  Proof.
    econstructor.
    unfold iAlgebra; intros; eapply ind_alg_WFVM_base with (WFV := WFV);
      try assumption; unfold Pure_Sound_P; intros.
    - (* WFVM_Return' *)
      exists v; split; simpl in *; auto.
      destruct H1 as [mt' mt'_eq]; subst.
      destruct (fmap_exists _ _ _ _ _ H2) as [[T' T_eq] T'_eq].
      simpl in *; subst; auto.
      destruct T0 as [T0 T0_UP'].
      destruct Sigma.
      apply (WFV_proj1_b DT V _ _ _ _ H0); simpl; auto.
    - (* WFVM_Untyped' *)
      simpl in H0; apply sym_eq in H0.
      apply FailMonad_Disc in H0; destruct H0; auto.
  Qed.

  Context {Pure_Sound_WFVM : iPAlgebra Pure_Sound_Name Pure_Sound_P WFVM}.
  Context {Typeof_E : forall T, FAlgebra TypeofName T (typeofR DT MT) E}.
  Context {eval_E : forall T, FAlgebra EvalName T (evalR V) E}.
  Context {evalM_E : forall T, FAlgebra EvalName T (evalMR V ME) E}.
  Context {WF_MAlg_typeof : WF_MAlgebra Typeof_E}.
  Context {WF_MAlg_eval : WF_MAlgebra evalM_E}.
  Context {eval_soundness_Exp_E : DAlgebra ES_ExpName E E (UP'_SP (eval_soundness_P DT V E MT ME unit WFVM))}.
  Context {eval_soundness'_Exp_E : forall typeof_rec eval_rec,
    P2Algebra ES'_ExpName E E E
    (UP'_P2 (eval_soundness'_P DT V E MT ME unit WFVM unit _ _ (fun _ _ _ _ => True) tt typeof_rec eval_rec
      (f_algebra (FAlgebra := Typeof_E _)) (f_algebra (FAlgebra := evalM_E _))))}.

  Theorem eval_Pure_Sound' :
    forall (e : Exp E) (T : DType DT),
      typeof DT E MT (proj1_sig e) = return_ T ->
      exists v : Value V,
        evalM _ _ _ (proj1_sig e) = return_ (M := ME) v /\
        WFValueC _ _ _ WFV tt v T.
  Proof.
    intro; apply (ifold_ WFVM _ (ip_algebra (iPAlgebra := Pure_Sound_WFVM)) _
    (eval_soundness DT V E MT ME WFVM e tt)).
  Qed.

End ESound_Pure.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import ssreflect.
Require Import Tweetnacl.Libs.Export.
Require Import Tweetnacl.Gen.Get_abcdef.
Require Import Tweetnacl.Gen.AMZubSqSel.
Require Import Tweetnacl.Gen.ABCDEF.
Require Import Tweetnacl.Gen.abstract_rec_rev.
Require Import Recdef.

Section Abstract_Rec_Rev.

Open Scope Z.

Context {T : Type}.
Context {T' : Type}.
Context {Mod : T -> T}.
Context {O : Ops T T' Mod}.

Lemma abstract_step_rev_a : forall n p (z : T') (a b c d e f x : T),
  Gen.fa (Getbit (Z.of_nat (p - n)) z)
   (get_a (abstract_rec_rev n p z a b c d e f x))
   (get_b (abstract_rec_rev n p z a b c d e f x))
   (get_c (abstract_rec_rev n p z a b c d e f x))
   (get_d (abstract_rec_rev n p z a b c d e f x))
   (get_e (abstract_rec_rev n p z a b c d e f x))
   (get_f (abstract_rec_rev n p z a b c d e f x))
   x
  =
  get_a (abstract_rec_rev (S n) p z a b c d e f x).
Proof.
intros; simpl; remember (abstract_rec_rev n p z a b c d e f x) as k.
destruct k as (((((a0,b0),c0),d0),e0),f0); reflexivity.
Qed.

Lemma abstract_step_rev_b : forall n p (z : T') (a b c d e f x : T),
  Gen.fb (Getbit (Z.of_nat (p - n)) z)
   (get_a (abstract_rec_rev n p z a b c d e f x))
   (get_b (abstract_rec_rev n p z a b c d e f x))
   (get_c (abstract_rec_rev n p z a b c d e f x))
   (get_d (abstract_rec_rev n p z a b c d e f x))
   (get_e (abstract_rec_rev n p z a b c d e f x))
   (get_f (abstract_rec_rev n p z a b c d e f x))
   x
  =
  get_b (abstract_rec_rev (S n) p z a b c d e f x).
Proof.
intros; simpl; remember (abstract_rec_rev n p z a b c d e f x) as k.
destruct k as (((((a0,b0),c0),d0),e0),f0); reflexivity.
Qed.

Lemma abstract_step_rev_c : forall n p (z : T') (a b c d e f x : T),
  Gen.fc (Getbit (Z.of_nat (p - n)) z)
   (get_a (abstract_rec_rev n p z a b c d e f x))
   (get_b (abstract_rec_rev n p z a b c d e f x))
   (get_c (abstract_rec_rev n p z a b c d e f x))
   (get_d (abstract_rec_rev n p z a b c d e f x))
   (get_e (abstract_rec_rev n p z a b c d e f x))
   (get_f (abstract_rec_rev n p z a b c d e f x))
   x
  =
  get_c (abstract_rec_rev (S n) p z a b c d e f x).
Proof.
intros; simpl; remember (abstract_rec_rev n p z a b c d e f x) as k.
destruct k as (((((a0,b0),c0),d0),e0),f0); reflexivity.
Qed.

Lemma abstract_step_rev_d : forall n p (z : T') (a b c d e f x : T),
  Gen.fd (Getbit (Z.of_nat (p - n)) z)
   (get_a (abstract_rec_rev n p z a b c d e f x))
   (get_b (abstract_rec_rev n p z a b c d e f x))
   (get_c (abstract_rec_rev n p z a b c d e f x))
   (get_d (abstract_rec_rev n p z a b c d e f x))
   (get_e (abstract_rec_rev n p z a b c d e f x))
   (get_f (abstract_rec_rev n p z a b c d e f x))
   x
  =
  get_d (abstract_rec_rev (S n) p z a b c d e f x).
Proof.
intros; simpl; remember (abstract_rec_rev n p z a b c d e f x) as k.
destruct k as (((((a0,b0),c0),d0),e0),f0); reflexivity.
Qed.

Lemma abstract_step_rev_e : forall n p (z : T') (a b c d e f x : T),
  Gen.fe (Getbit (Z.of_nat (p - n)) z)
   (get_a (abstract_rec_rev n p z a b c d e f x))
   (get_b (abstract_rec_rev n p z a b c d e f x))
   (get_c (abstract_rec_rev n p z a b c d e f x))
   (get_d (abstract_rec_rev n p z a b c d e f x))
   (get_e (abstract_rec_rev n p z a b c d e f x))
   (get_f (abstract_rec_rev n p z a b c d e f x))
   x
  =
  get_e (abstract_rec_rev (S n) p z a b c d e f x).
Proof.
intros; simpl; remember (abstract_rec_rev n p z a b c d e f x) as k.
destruct k as (((((a0,b0),c0),d0),e0),f0); reflexivity.
Qed.

Lemma abstract_step_rev_f : forall n p (z : T') (a b c d e f x : T),
  Gen.ff (Getbit (Z.of_nat (p - n)) z)
   (get_a (abstract_rec_rev n p z a b c d e f x))
   (get_b (abstract_rec_rev n p z a b c d e f x))
   (get_c (abstract_rec_rev n p z a b c d e f x))
   (get_d (abstract_rec_rev n p z a b c d e f x))
   (get_e (abstract_rec_rev n p z a b c d e f x))
   (get_f (abstract_rec_rev n p z a b c d e f x))
   x
  =
  get_f (abstract_rec_rev (S n) p z a b c d e f x).
Proof.
intros; simpl; remember (abstract_rec_rev n p z a b c d e f x) as k.
destruct k as (((((a0,b0),c0),d0),e0),f0); reflexivity.
Qed.

Close Scope Z.

End Abstract_Rec_Rev.


Require Import Arith.
Require Import Omega.
Require Import String.
Require Import List.
Import ListNotations.

Require Import OrderedType OrderedTypeEx.
Require FMapList.
Require FMapFacts.
Module NatMap := FMapList.Make Nat_as_OT.
Module NatMapFacts := FMapFacts.WFacts_fun Nat_as_OT NatMap.

Require Import stringfacts.
Require Import base.
Require Import ast.
Require Import logic.

(* ************************************************************ *)
(* ************************************************************ *)
(*                                                              *)
(*                             vfs                              *)
(*                                                              *)
(* ************************************************************ *)
(* ************************************************************ *)

(*
 * ghost state traces for vfs-level specifications
 *)

Section filetraces.

(* why must this be a Type when dirop can be a Set? *)
Inductive fileop: Type :=
| FileWrite: bytes -> nat -> fileop
| FileTruncate: nat -> fileop
.

Inductive file_trace: Type :=
| FileTrace: forall j (ops : list fileop), j <= length ops -> file_trace
.

(*
 * This stuff is in specification space so I don't care how inefficient it is.
 *)

Function fileops_currentlength ops sofar :=
   match ops with
   | [] => sofar
   | op :: more => match op with
        | FileWrite bytes offset =>
             fileops_currentlength more (max sofar (offset + length bytes))
        | FileTruncate len =>
             fileops_currentlength more len
        end
   end.

(* why does coq have <=? but not >=? ...? *)

Function fileops_readbyte ops offset sofar :=
   match ops with
   | nil => sofar
   | op :: more => match op with
        | FileWrite bytes offset' =>
             fileops_readbyte more offset (
                if ((offset' <=? offset) && (offset <? offset' + length bytes))%bool then
                   nth (offset - offset') bytes sofar
                else
                   sofar
             )
        | FileTruncate _ =>
             fileops_readbyte more offset sofar
        end
   end.

Function fileops_readbytes ops len offset :=
   match len with
   | 0 => []
   | S len' => fileops_readbyte ops offset 0 :: fileops_readbytes ops len' (S offset)
   end.

Function fileops_read ops len offset :=
   let maxoffset := fileops_currentlength ops 0 in
   if maxoffset <=? offset then []
   else let maxlen := maxoffset - offset in
      fileops_readbytes ops (min len maxlen) offset
.

Function filetrace_read t len offset :=
   match t with
   | FileTrace j ops p => fileops_read ops len offset
   end.

Definition filetrace_append (t : file_trace) (op : fileop): file_trace.
Proof.
   destruct t.
   refine (FileTrace j (ops ++ [op]) _).
   rewrite app_length.
   simpl.
   omega.
Defined.

Definition filetrace_sync (t : file_trace): file_trace.
Proof.
   destruct t.
   refine (FileTrace (length ops) ops _).
   omega.
Defined.

Definition filetrace_empty: file_trace.
Proof.
   refine (FileTrace 0 [] _).
   omega.
Defined.

End filetraces.

Section dirtraces.

Inductive dirop: Set :=
| DirCreate: string -> nat -> dirop
| DirUnlink: string -> dirop
.

Inductive dir_trace: Set :=
| DirTrace: forall j (ops : list dirop), j <= length ops -> dir_trace
.

Function dirops_get ops name :=
   match ops with
   | nil => None
   | op :: more => match (dirops_get more name) with
        | Some (Some result) => Some (Some result) (* found *)
        | Some None => Some None (* removed *)
        | None => match op with (* not seen downstream *)
             | DirCreate tname ino => if string_eq tname name then Some (Some ino) else None
             | DirUnlink tname => if string_eq tname name then Some None else None
             end
        end
    end.

Function dirtrace_get (t : dir_trace) name :=
   match t with
   | DirTrace j ops p => match dirops_get ops name with
        | Some (Some result) => Some result
        | Some None => None
        | None => None
        end
   end.

Definition dirtrace_append (t : dir_trace) (op : dirop): dir_trace.
Proof.
   destruct t.
   refine (DirTrace j (ops ++ [op]) _).
   rewrite app_length.
   simpl.
   omega.
Defined.

Definition dirtrace_sync (t : dir_trace): dir_trace.
Proof.
   destruct t.
   refine (DirTrace (length ops) ops _).
   omega.
Defined.

Definition dirtrace_empty: dir_trace.
Proof.
   refine (DirTrace 0 [] _).
   omega.
Defined.

End dirtraces.

(*
 * vfs objects
 *)

Section vfsobjects.

Definition Pair (t1 t2: Set): Set := (t1 * t2)%type.

Class vnodeclass (vnode : Type) := {
  inum_of_vnode: vnode -> nat;
  isdir: vnode -> bool;
  isfile: vnode -> bool;
  dirtrace_of_vnode: vnode -> dir_trace;
  filetrace_of_vnode: vnode -> file_trace;

(*
  foo: Proc unit unit;
  foo_spec: ProcHoare unit unit (fun _ => True) foo (fun _ _ => True);
*)

  VOP_LOOKUP: proc (vnode * string)%type (option vnode);
  lookup_spec: forall t,
     ProcHoare
        (vnode * string) (option vnode)
        (fun arg => let (dir, name) := arg in
            isdir dir = true /\
            dirtrace_of_vnode dir = t)
        (VOP_LOOKUP)
        (fun arg retvn => let (dir, name) := arg in
            dirtrace_of_vnode dir = t /\ (
               match retvn with
               | Some rvn => dirtrace_get t name = Some (inum_of_vnode rvn)
               | None => dirtrace_get t name = None
               end
            ));

  VOP_CREATE: proc (vnode * string) (option vnode);
  create_spec: forall t ino,
     ProcHoare
        (vnode * string) (option vnode)
        (fun arg => let (dir, name) := arg in
            isdir dir = true /\
            dirtrace_of_vnode dir = t)
        (VOP_CREATE)
        (fun arg retvn => let (dir, name) := arg in
            match retvn with
               | Some rvn => (
                    dirtrace_of_vnode dir = dirtrace_append t (DirCreate name ino) /\
                    inum_of_vnode rvn = ino /\
                    filetrace_of_vnode rvn = filetrace_empty
                 )
               | None =>
                    dirtrace_of_vnode dir = t
               end
         );

  VOP_UNLINK: proc (vnode * string) (option unit);
  unlink_spec: forall t,
     ProcHoare
        (vnode * string) (option unit)
        (fun arg => let (dir, name) := arg in
            isdir dir = true /\
            dirtrace_of_vnode dir = t)
        VOP_UNLINK
        (fun arg ret => let (dir, name) := arg in
           match ret with
           | Some _ => dirtrace_of_vnode dir = dirtrace_append t (DirUnlink name)
           | None => dirtrace_of_vnode dir = t
           end
        );

  VOP_READ: proc (vnode * nat * nat) bytes;
  read_spec: forall t,
     ProcHoare
        (vnode * nat * nat) bytes
        (fun arg => let (arg', offset) := arg in let (file, len) := arg' in
           isfile file = true /\
           filetrace_of_vnode file = t)
        VOP_READ
        (fun arg ret => let (arg', offset) := arg in let (file, len) := arg' in
           filetrace_of_vnode file = t /\ ret = filetrace_read t len offset);

  VOP_WRITE: proc (vnode * bytes * nat) unit;
  write_spec: forall t,
     ProcHoare
        (vnode * bytes * nat) unit
        (fun arg => let (arg', offset) := arg in let (file, data) := arg' in
           isfile file = true /\
           filetrace_of_vnode file = t)
        VOP_WRITE
        (fun arg ret => let (arg', offset) := arg in let (file, data) := arg' in
           filetrace_of_vnode file = filetrace_append t (FileWrite data offset));

  VOP_TRUNCATE: proc (vnode * nat) unit;
  truncate_spec: forall t,
     ProcHoare
        (vnode * nat) unit
        (fun arg => let (file, size) := arg in
           isfile file = true /\
           filetrace_of_vnode file = t)
        VOP_TRUNCATE
        (fun arg ret => let (file, size) := arg in
           filetrace_of_vnode file = filetrace_append t (FileTruncate size));

  VOP_FSYNC: proc vnode unit;
  fsync_spec: forall t,
     ProcHoare
        vnode unit
        (fun file =>
           isfile file = true /\
           filetrace_of_vnode file = t)
        VOP_FSYNC
        (fun file ret =>
           filetrace_of_vnode file = filetrace_sync t);
}.

Section tracetable.

Inductive trace_table: Type :=
| TraceTable: NatMap.t dir_trace -> NatMap.t file_trace -> trace_table
.

Definition tracetable_dirprop {vnt : Type} {q: vnodeclass vnt}
                              (vn: vnt) (dtbl: NatMap.t dir_trace) (p : dir_trace -> Prop) :=
   forall t,
   isdir vn = true -> NatMap.find (inum_of_vnode vn) dtbl = Some t -> p t.

Definition tracetable_fileprop {vnt : Type} {q: vnodeclass vnt}
                               (vn : vnt) (ftbl: NatMap.t file_trace) (p: file_trace -> Prop) :=
   forall t,
   isfile vn = true -> NatMap.find (inum_of_vnode vn) ftbl = Some t -> p t.

Definition tracetable_has {vnt : Type} {q : vnodeclass vnt}
                          (vn: vnt) ttbl: Prop :=
   match ttbl with
   | TraceTable dtbl ftbl =>
        (tracetable_dirprop vn dtbl (fun t => dirtrace_of_vnode vn = t)) \/
        (tracetable_fileprop vn ftbl (fun t => filetrace_of_vnode vn = t))
   end.

Definition tracetable_apply {vnt: Type} {q: vnodeclass vnt}
                            (vn: vnt) df ff ttbl: Prop :=
   match ttbl with
   | TraceTable dtbl ftbl =>
        (tracetable_dirprop vn dtbl (fun t => dirtrace_of_vnode vn = df t)) \/
        (tracetable_fileprop vn ftbl (fun t => filetrace_of_vnode vn = ff t))
   end.

End tracetable.

Class fsclass (vfs : Type) := {
  vnode: Type;
  vnode_is_vnodeclass: vnodeclass vnode;

  root_inum: nat;
  getvnode: vfs -> nat -> vnode;

  VFS_GETROOT: proc vfs vnode;
  getroot_spec:
     ProcHoare
        vfs vnode
        (fun fs => True)
        VFS_GETROOT
        (fun fs rootvn => inum_of_vnode rootvn = root_inum /\
           isdir rootvn = true);

  VFS_SYNC: proc vfs unit;
  sync_spec: forall ttbl,
     ProcHoare
        vfs unit
        (fun fs => forall inum vn,
            getvnode fs inum = vn -> tracetable_has vn ttbl)
        VFS_SYNC
        (fun fs _ => forall inum vn,
           getvnode fs inum = vn ->
              tracetable_apply vn dirtrace_sync filetrace_sync ttbl);

  newfs: proc unit vfs;
  newfs_spec:
     ProcHoare
        unit vfs
        (fun _ => True)
        newfs
        (fun _ fs => forall inum vn,
           getvnode fs inum = vn -> inum = root_inum /\
           dirtrace_of_vnode vn = dirtrace_empty);
}.

End vfsobjects.


Require Import Framework FSParameters.
Require Export DiskLayer CryptoLayer.
Import ListNotations.

Set Implicit Arguments.

Definition CryptoDiskOperation  :=  HorizontalComposition CryptoOperation (DiskOperation addr_dec value (fun a => a < disk_size)).
Definition CryptoDiskLang := Build_Layer CryptoDiskOperation.

Notation "'|CP|' p" := (@lift_L1 CryptoOperation (DiskOperation addr_dec value (fun a => a < disk_size)) CryptoLang _ p) (at level 59).
Notation "'|DP|' p" := (@lift_L2 CryptoOperation (DiskOperation addr_dec value (fun a => a < disk_size)) (DiskLang addr_dec value (fun a => a < disk_size)) _ p) (at level 59).
Notation "'|CO|' p" := (@lift_L1 CryptoOperation (DiskOperation addr_dec value (fun a => a < disk_size)) CryptoLang _ (Op CryptoOperation p)) (at level 59).
Notation "'|DO|' p" := (@lift_L2 CryptoOperation (DiskOperation addr_dec value (fun a => a < disk_size)) (DiskLang addr_dec value (fun a => a < disk_size)) _ (Op (DiskOperation addr_dec value (fun a => a < disk_size)) p)) (at level 59).

(** Selector does not cause a hash collision. **)
Definition non_colliding_selector selector (s: CryptoDiskLang.(state)) :=
  forall old_log_blocksets new_log_blocks,
    length old_log_blocksets = length new_log_blocks ->
    length old_log_blocksets <= log_length ->
    (forall i, i < length old_log_blocksets ->
          (snd s) (log_start + i) = seln old_log_blocksets i (value0, [])) ->
    (forall i, i < length new_log_blocks ->
          (select_total_mem selector (snd s)) (log_start + i) = seln (map (fun v => (v, [])) new_log_blocks) i (value0, [])) ->
    rolling_hash hash0 (map fst old_log_blocksets) = rolling_hash hash0 new_log_blocks ->
    map fst old_log_blocksets = new_log_blocks.


Require Import Bool Arith List Omega.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Sorting.Permutation.
Import ListNotations.
Module NatMap := FMapList.Make Nat_as_OT.

Definition address := nat.
Definition version := nat.
Definition value := nat.
Definition lock := bool.
Definition variable := nat.
Definition store := NatMap.t value.
Definition heap :=  address -> option (value * lock * version).
Definition tid := nat.

Ltac myauto :=
  repeat match goal with
  | |- context[_] =>
      auto 100; intuition; cbn in *; simpl in *; auto 100
  | |- context[_] =>
      try contradiction; try discriminate
end.

Inductive action:=
|dummy: action
|start_txn: action
|read_item: version -> action
|write_item: value -> action
|try_commit_txn: action
|lock_write_item: action
|seq_point: action
|validate_read_item: version -> action
|abort_txn: action
|unlock_write_item: action
(*|restart_txn: action*)
|commit_txn: action
|complete_write_item: (*value -> action*)version -> action
(*|unlock_write_item: version -> action*)
(*|invalid_write_item: value -> action*)
|commit_done_txn: action.
(*|obtain_global_tid: action.*)
(*sp later than last lock, but must before the first commit*)
Definition trace := list (tid * action).

(* Return the “phase” of an action. *)
Definition action_phase (a:action) :=
  match a with
  | dummy => 0
  | start_txn => 1
  | read_item _ => 1
  | write_item _ => 1
  | try_commit_txn => 2
  | lock_write_item => 2
  | seq_point => 3
  | validate_read_item _ => 3
  | commit_txn => 4
  | complete_write_item _ => 4
  | commit_done_txn => 4
  | abort_txn => 6
  | unlock_write_item => 6
  end.

Fixpoint trace_tid_phase tid t: nat :=
  match t with
  | (tid', a) :: t' =>
    if Nat.eq_dec tid tid'
    then action_phase a
    else trace_tid_phase tid t'
  | [] => 0
  end.

(* Return the version number of the last committed write *)
Fixpoint trace_write_version (t:trace): version :=
  match t with
  | (_, complete_write_item v) :: _ => v
  | _ :: t' => trace_write_version t'
  | [] => 0
  end.

Fixpoint trace_tid_last_write tid t: option value :=
  match t with
  | (tid', a) :: t' =>
    if Nat.eq_dec tid tid'
    then match a with
         | write_item v => Some v
         | complete_write_item _ => None
         | _ => trace_tid_last_write tid t'
         end
    else trace_tid_last_write tid t'
  | [] => None
  end.

Fixpoint trace_validate_read tid vers aborted (t:trace) :=
  match t with
  | (tid', lock_write_item) :: t' =>
    (tid = tid' \/ aborted) /\ trace_validate_read tid vers False t'
  | (_, unlock_write_item) :: t' =>
    trace_validate_read tid vers True t'
  | (_, complete_write_item vers') :: _ => vers = vers'
  | _ :: t' => trace_validate_read tid vers aborted t'
  | [] => vers = 0
  end.

Fixpoint locked_by (t:trace) default : tid :=
  match t with
  | (tid, lock_write_item) :: _ => tid
  | (_, unlock_write_item) :: _ => default
  | (_, complete_write_item _) :: _ => default
  | _ :: t' => locked_by t' default
  | [] => default
  end.

Inductive sto_trace : trace -> Prop :=

| empty_step : sto_trace []

| start_txn_step: forall t tid,
    tid > 0
    -> trace_tid_phase tid t = 0
    -> sto_trace t
    -> sto_trace ((tid, start_txn)::t)

| read_item_step: forall t tid,
    trace_tid_phase tid t = 1
    -> locked_by t 0 = 0
    -> sto_trace t
    -> sto_trace ((tid, read_item (trace_write_version t)) :: t)

| write_item_step: forall t tid val,
    trace_tid_phase tid t = 1
    -> sto_trace t
    -> sto_trace ((tid, write_item val) :: t)

| try_commit_txn_step: forall t tid,
    trace_tid_phase tid t = 1
    -> sto_trace t
    -> sto_trace ((tid, try_commit_txn)::t)

| lock_write_item_step: forall t tid v,
    trace_tid_phase tid t = 2
    -> In (tid, write_item v) t
    -> locked_by t 0 = 0
    -> sto_trace t
    -> sto_trace ((tid, lock_write_item) :: t)

(*sequential point*)
| seq_point_step: forall t tid,
    trace_tid_phase tid t = 2
    -> (forall v, In (tid, write_item v) t
                  -> In (tid, lock_write_item) t)
    -> sto_trace t
    -> sto_trace ((tid, seq_point) :: t)

| validate_read_item_step: forall t tid vers,
    trace_tid_phase tid t = 3
    -> locked_by t tid = tid (* unlocked or locked by me *)
    -> trace_write_version t = vers
    -> sto_trace t
    -> sto_trace ((tid, validate_read_item vers) :: t)

| abort_txn_step: forall t tid,
    trace_tid_phase tid t > 0
    -> trace_tid_phase tid t < 4
    -> sto_trace t
    -> sto_trace ((tid, abort_txn) :: t)

| unlock_item_step: forall t tid,
    trace_tid_phase tid t = 6
    -> locked_by t 0 = tid
    -> sto_trace t
    -> sto_trace ((tid, unlock_write_item) :: t)

| commit_txn_step: forall t tid,
    trace_tid_phase tid t = 3
    -> (forall vers, In (tid, read_item vers) t
                     -> In (tid, validate_read_item vers) t)
    -> sto_trace t
    -> sto_trace ((tid, commit_txn) :: t)

| complete_write_item_step: forall t tid val,
    trace_tid_phase tid t = 4
    -> locked_by t 0 = tid
    -> trace_tid_last_write tid t = Some val
    -> sto_trace t
    -> sto_trace ((tid, complete_write_item (S (trace_write_version t))) :: t)

| commit_done_step: forall t tid,
    trace_tid_phase tid t = 4
    -> locked_by t 0 <> tid
    -> sto_trace t
    -> sto_trace ((tid, commit_done_txn) :: t).
Hint Constructors sto_trace.

Definition example_txn:=
[(2, commit_done_txn); (2, complete_write_item 1); (2, commit_txn); (2, validate_read_item 0); (2, seq_point); (2, lock_write_item); (2, try_commit_txn); (2, write_item 4); (2, read_item 0); (2, start_txn); (1, commit_done_txn); (1, commit_txn); (1, validate_read_item 0); (1, seq_point); (1, try_commit_txn); (1, read_item 0); (1, start_txn)].

Definition example_txn2:=
[(3, commit_done_txn); (3, commit_txn); (3, validate_read_item 1); (3, seq_point); (3, try_commit_txn); (3, read_item 1); (3, start_txn); (1, abort_txn); (1, validate_read_item 1); (1, try_commit_txn); (2, commit_txn); (2, complete_write_item 1); (2, commit_txn); (2, validate_read_item 0); (2, seq_point); (2, lock_write_item); (2, try_commit_txn); (2, write_item 4); (1, read_item 0); (2, read_item 0); (2, start_txn); (1, start_txn)].

Lemma sto_trace_cons ta t:
  sto_trace (ta :: t) -> sto_trace t.
Proof.
  intros.
  inversion H; subst; auto.
Qed.

Lemma sto_trace_app t1 t2:
  sto_trace (t1 ++ t2) -> sto_trace t2.
Proof.
  intros.
  induction t1. rewrite app_nil_l in H. auto.
  apply IHt1.
  now apply sto_trace_cons with (ta:=a).
Qed.

(*
Returns the serialized sequence of transactions in the STO trace based on seq_point of each transaction
The first element (tid) of the sequence is the first transaction that completes in the serial trace
Note that STO-trace is constructed in a reverse order: the first (tid * action) pair is the last operation in the trace
*)

Function seq_list (sto_trace: trace): list nat:=
  match sto_trace with
  | [] => []
  | (tid, seq_point) :: tail => seq_list tail ++ [tid]
  | _ :: tail => seq_list tail
  end.

Eval compute in seq_list example_txn.

Eval compute in seq_list example_txn2.

Lemma phase_increase_head tid a t:
  sto_trace ((tid, a) :: t) ->
  action_phase a >= trace_tid_phase tid t.
Proof.
  intros; inversion H; cbn; omega.
Qed.

Lemma phase_increase_app tid t1 t2:
  sto_trace (t1 ++ t2) ->
  trace_tid_phase tid (t1 ++ t2) >= trace_tid_phase tid t2.
Proof.
  induction t1; intros.
  - simpl; omega.
  - rewrite <- app_comm_cons in H; destruct a.
    assert (sto_trace (t1 ++ t2)) by (now apply sto_trace_cons in H).
    apply IHt1 in H0.
    simpl; destruct (Nat.eq_dec tid t).
    + subst; apply phase_increase_head in H; omega.
    + auto.
Qed.

Lemma phase_increase_in tid a t:
  sto_trace t ->
  In (tid, a) t ->
  trace_tid_phase tid t >= action_phase a.
Proof.
  intros H I; apply in_split in I.
  destruct I as [l1 [l2 L]].
  assert (trace_tid_phase tid ((tid, a) :: l2) = action_phase a). {
    cbn; destruct (Nat.eq_dec tid tid); omega.
  }
  rewrite L in *; rewrite <- H0; now apply phase_increase_app.
Qed.

Lemma phase_increase_in_app tid a (t1 t2:trace):
  sto_trace (t1 ++ t2) ->
  In (tid, a) (t1 ++ t2) ->
  action_phase a > trace_tid_phase tid t2 ->
  In (tid, a) t1.
Proof.
  intros T I A.
  apply in_app_or in I; destruct I as [I | I]; auto.
  apply sto_trace_app in T.
  apply (phase_increase_in _ _ _ T) in I.
  omega.
Qed.

Lemma at_most_one_seq_point tid t:
  sto_trace ((tid, seq_point) :: t) ->
  ~ In (tid, seq_point) t.
Proof.
  intros H F.
  apply (phase_increase_in _ _ _ (sto_trace_cons _ _ H)) in F.
  inversion H; subst; cbn in *.
  omega.
Qed.

Lemma trace_phase_in tid t:
  trace_tid_phase tid t > 0 ->
  exists a, In (tid, a) t.
Proof.
  induction t; intros; cbn in *.
  omega.
  destruct a.
  destruct (Nat.eq_dec tid n).
  exists a; subst; now left.
  apply IHt in H; destruct H as [a' H]; exists a'; now right.
Qed.

Lemma tid_nonzero tid a t:
  sto_trace t ->
  In (tid, a) t ->
  tid > 0.
Proof.
  revert tid a; induction t.
  - intros tid a H I; destruct I.
  - intros tid' a' H I.
    destruct I; [ | now apply (IHt _ _ (sto_trace_cons _ _ H)) in H0 ].
    subst; inversion H; auto.
    all: assert (trace_tid_phase tid' t > 0) as GZ by omega.
    all: apply trace_phase_in in GZ.
    all: destruct GZ as [a GZ].
    all: now apply (IHt tid' a).
Qed.

Lemma trace_phase_nonzero tid t:
  sto_trace t ->
  trace_tid_phase tid t > 0 ->
  tid > 0.
Proof.
  intros T; induction T; intros P; simpl in P.
  omega.
  all: destruct (Nat.eq_dec tid tid0); [subst; auto | now apply IHT].
  all: try solve [apply IHT; omega].
Qed.

Lemma track_lock_cons tid tid' t a:
  sto_trace ((tid', a) :: t) ->
  locked_by t 0 = tid ->
  locked_by ((tid', a) :: t) 0 = tid
  \/ tid = 0 /\ a = lock_write_item
  \/ tid = tid' /\ a = unlock_write_item
  \/ tid = tid' /\ exists val, a = complete_write_item val.
Proof.
  intros T L.
  assert (tid' > 0) as TG. {
    apply tid_nonzero with (a:=a) (t:=(tid', a)::t); cbn; auto.
  }
  inversion T; subst; cbn; auto.
  right; right; right; eauto.
Qed.

Lemma locked_phase tid t:
  sto_trace t ->
  locked_by t 0 = tid ->
  tid > 0 ->
  trace_tid_phase tid t >= 2.
Proof.
  intros T; revert tid; induction T; intros tid L G.
  1: cbn in L; omega.
  all: cbn.
  all: destruct (Nat.eq_dec tid tid0); try omega.
  all: try (now apply IHT).
  1-3: subst; apply IHT in e; omega.
  1-3: simpl in L; omega.
Qed.

Lemma commit_phase_cons tid p t:
  sto_trace (p :: t) ->
  trace_tid_phase tid t = 4 ->
  trace_tid_phase tid (p :: t) = 4.
Proof.
  destruct p as [tid' a]; intros T Fo; inversion T; cbn in *.
  all: destruct (Nat.eq_dec tid tid'); auto.
  all: subst; omega.
Qed.

Lemma commit_phase_app tid t1 t2:
  sto_trace (t1 ++ t2) ->
  trace_tid_phase tid t2 = 4 ->
  trace_tid_phase tid (t1 ++ t2) = 4.
Proof.
  induction t1; intros.
  now simpl.
  rewrite <- app_comm_cons in *.
  apply commit_phase_cons; auto.
  apply IHt1; auto.
  now apply sto_trace_cons in H.
Qed.

Lemma phase_2_preserves_lock tid t1 t2:
  sto_trace (t1 ++ t2) ->
  trace_tid_phase tid (t1 ++ t2) = 2 ->
  locked_by t2 0 = tid ->
  locked_by (t1 ++ t2) 0 = tid.
Proof.
  revert t2.
  induction t1; intros t2 T P L.
  now cbn.
  destruct a as [tid' a].
  cbn in P; destruct (Nat.eq_dec tid tid').
  - destruct a; simpl in *; try omega.
    + rewrite e in *; clear e tid.
      assert (trace_tid_phase tid' t2 >= 2). {
        apply locked_phase.
        now apply sto_trace_app with (t1:=(tid',try_commit_txn)::t1).
        auto.
        apply tid_nonzero with (a:=try_commit_txn) (t:=(tid', try_commit_txn)::t1 ++ t2).
        auto.
        simpl; now left.
      }
      inversion T; subst.
      apply (phase_increase_app (locked_by t2 0)) in H3; omega.
    + auto.
  - assert (locked_by (t1 ++ t2) 0 = tid) as LA. {
      apply IHt1; auto.
      now apply (sto_trace_cons _ _ T).
    }
    clear IHt1 L.

    assert (tid > 0). {
      apply trace_phase_nonzero with (t:=t1++t2).
      now apply sto_trace_cons with (ta:=(tid',a)).
      omega.
    }

    inversion T; cbn in *; auto; omega.
Qed.

Lemma locked_at_commit tid t1 t2 v:
  sto_trace ((tid, seq_point) :: t1 ++ (tid, write_item v) :: t2) ->
  locked_by (t1 ++ (tid, write_item v) :: t2) 0 = tid.
Proof.
  intros T.
  inversion T.
  assert (tid > 0) as TG. {
    apply tid_nonzero with (a:=write_item v) (t:=t); rewrite H0; auto.
    apply in_or_app; right; now left.
  }

  assert (In (tid, lock_write_item) t1). {
    assert (In (tid, lock_write_item) t). {
      rewrite H0.
      apply H2 with (v0:=v).
      apply in_or_app; cbn; intuition.
    }
    apply phase_increase_in_app with (t2:=(tid, write_item v) :: t2); auto.
    now rewrite <- H0.
    simpl; destruct (Nat.eq_dec tid tid); intuition.
  }

  apply in_split in H4.
  destruct H4 as [t1a [t1b T1]].
  subst.
  repeat rewrite <- app_assoc in *.
  repeat rewrite <- app_comm_cons in *.
  remember ((tid, lock_write_item) :: t1b ++ (tid, write_item v) :: t2) as tx.
  assert (locked_by tx 0 = tid). {
    rewrite Heqtx; now cbn.
  }
  assert (trace_tid_phase tid tx = 2). {
    assert (trace_tid_phase tid tx >= 2). {
      apply locked_phase; auto.
      now apply sto_trace_app with (t1:=t1a).
    }
    assert (2 >= trace_tid_phase tid tx). {
      rewrite <- H1.
      now apply phase_increase_app.
    }
    omega.
  }

  apply phase_2_preserves_lock; auto.
Qed.

Lemma seq_point_after t1 t2 tid action:
  sto_trace ((tid, action) :: t1 ++ (tid, commit_txn) :: t2)
  -> action = complete_write_item (S (trace_write_version t2))
     \/ action = commit_done_txn.
Proof.
  intros T.
  assert (trace_tid_phase tid (t1 ++ (tid, commit_txn) :: t2) = 4) as TG4. {
    apply sto_trace_cons in T.
    apply commit_phase_app; auto.
    simpl; destruct (Nat.eq_dec tid tid); congruence.
  }
  inversion T; try omega.
  2: now right.
  left.

  assert (trace_write_version (t1 ++ (tid, commit_txn) :: t2) =
          trace_write_version t2). {
    subst.
    clear TG4 val H2 H3 H4 H5.
    inversion T; subst; clear T H4 val.
    remember (t1 ++ (tid, commit_txn) :: t2) as t.
    clear H0.
    revert t1 t2 tid Heqt H2 H3.
    induction H5; intros t1 t2 tid T P L.
    all: destruct t1; simpl in T.
    1,2: congruence.
    all: inversion T.
    all: cbn in *.
    all: destruct (Nat.eq_dec tid tid0); try congruence.
    1-2,5,7,10,13: rewrite <- H3; apply (IHsto_trace _ _ _ H3); auto.
    1-2: rewrite <- H2; apply (IHsto_trace _ _ _ H2); auto.
    1: rewrite <- H4; apply (IHsto_trace _ _ _ H4); auto.

    assert (tid > 0). {
      apply (trace_phase_nonzero _ _ H5); omega.
    }
    omega.

    rewrite <- H3; apply (IHsto_trace _ _ _ H3); auto.
    rewrite H3; apply commit_phase_app.
    rewrite <- H3; auto.
    cbn; destruct (Nat.eq_dec tid tid); congruence.

    assert (tid > 0). {
      apply (tid_nonzero _ commit_txn _ H5).
      rewrite H4; apply in_or_app; right; now left.
    }
    omega.

    assert (tid > 0). {
      apply (tid_nonzero _ commit_txn _ H5).
      rewrite H4; apply in_or_app; right; now left.
    }
    omega.
  }

  now rewrite H6.
Qed.


From isla Require Import opsem.

Definition a80190 : isla_trace :=
  Smt (DeclareConst 46%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R1" [] (RegVal_Base (Val_Symbolic 46%Z)) Mk_annot :t:
  Smt (DefineConst 49%Z (Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Symbolic 46%Z) Mk_annot; Val (Val_Bits (BV 64%N 0xffffffff0000ffff%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0x3f210000%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R1" [] (RegVal_Base (Val_Symbolic 49%Z)) Mk_annot :t:
  Smt (DeclareConst 50%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 50%Z)) Mk_annot :t:
  Smt (DefineConst 51%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 50%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 51%Z)) Mk_annot :t:
  tnil
.


(**

 Ahrens, Lumsdaine, Voevodsky, 2015

 Contents:

  - Definition of a Display map category from Category with Families
    (requires Pullbacks to be hProps, e.g., as in a saturated precategory

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.Pullbacks.

Require Import TypeTheory.OtherDefs.CwF_Pitts.
Require Import TypeTheory.OtherDefs.DM.

(* Locally override the notation [ γ ♯ a ], at a higher level,
  to get more informative bracketing when pairing meets composition. *)
Local Notation "γ ## a" := (pairing γ a) (at level 75).

(** * Category with DM from Category with families

*)

Section DM_of_CwF.

(** assumption of [CC] being saturated is essential: we need pullbacks to be propositions *)
Context (CC : category) (C : cwf_struct CC) (H : is_univalent CC).

(** Being isomorphic to a dependent projection *)
Definition iso_to_dpr {Γ Γ'} (γ : Γ --> Γ') : UU
  := ∑ (A : C⟨Γ'⟩) (f : z_iso (Γ'∙A) Γ),
        π _ = f ;; γ .

Definition dm_sub_struct_of_CwF : dm_sub_struct CC.
Proof.
  unfold dm_sub_struct.
  intros Γ Γ' γ.
  exact (ishinh (iso_to_dpr γ)).
Defined.

Lemma dm_sub_closed_under_iso_of_CwF : dm_sub_closed_under_iso dm_sub_struct_of_CwF.
Proof.
  unfold dm_sub_closed_under_iso.
  intros Δ Γ γ Δ' δ h HT.
  unfold dm_sub_struct_of_CwF in γ.
  destruct γ as [γ A]. simpl in *. unfold DM_type in A.
  apply A.
  intro A'.
  apply hinhpr.
  clear A.
  destruct A' as [A [f TH]].
  unfold iso_to_dpr.
  exists A.
  set (T:= z_iso_comp f h).
  exists T.
  unfold T. simpl.
  rewrite TH; clear TH.
  rewrite <- assoc. apply maponpaths.
  sym. assumption.
Qed.

Definition pb_of_DM_of_CwF : pb_of_DM_struct dm_sub_struct_of_CwF.
Proof.
  unfold pb_of_DM_struct.
  intros Δ Γ γ Γ' f.
  destruct γ as [γ B]. simpl.
  match goal with | [ |- ?T ] => assert (X : isaprop T) end.
  { apply isofhleveltotal2.
    - apply isaprop_Pullback. assumption.
    - intros. apply isapropishinh.
  }
  unfold DM_type in B. simpl in *.
  unfold dm_sub_struct_of_CwF in B.
  set (T:= make_hProp _ X).
  set (T':= B T).
  apply T'.
  unfold T; simpl;
  clear X T T'.
  intro T.
  unfold iso_to_dpr in T.
  destruct T as [A [h e]].
  clear B.
  unshelve refine (tpair _ _ _ ).
  - unshelve refine (make_Pullback _ _).
    5: use postcomp_pb_with_z_iso.
    7: eapply is_pullback_reindx_cwf.
    + eassumption.
    + sym. assumption.
  - simpl.
    apply hinhpr.
    unfold iso_to_dpr.
    exists (A{{f}}).
    exists (identity_z_iso _ ).
    sym. apply id_left.
Defined.

Definition dm_sub_pb_of_CwF : dm_sub_pb CC.
Proof.
  exists dm_sub_struct_of_CwF.
  exact pb_of_DM_of_CwF.
Defined.

Definition  DM_structure_of_CwF :  DM_structure CC.
Proof.
  exists dm_sub_pb_of_CwF.
  exists dm_sub_closed_under_iso_of_CwF.
  intros. apply isapropishinh.
Defined.

End DM_of_CwF.


Require Import Rel.Definitions.
Require Import Rel.BasicFacts.
Require Import Rel.Compat_sub.
Require Import Rel.Compat_bind_EV.
Require Import Util.Subset.
Require Import Lang.BindingsFacts.
Require Import Lang.Static.
Require Import Lang.StaticFacts.
Set Implicit Arguments.

Section section_compat_tm_eapp.

Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (Γ : V → ty EV HV ∅).
Context (P : HV → F).
Context (T : ty (inc EV) HV ∅).
Context (𝓔 𝓕 : eff EV HV ∅).
Context (t₁ t₂ : tm EV HV V ∅).

Hint Resolve subset_trans st_reflexive postfix_is_subset postfix_refl.
Hint Rewrite lbl_V_map_hd.

Lemma compat_tm_eapp n :
n ⊨ ⟦ Ξ P Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : (ty_efun T) # 𝓕 ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ (tm_eapp t₁ 𝓔) ≼ˡᵒᵍ (tm_eapp t₂ 𝓔) : (EV_subst_ty 𝓔 T) # 𝓕 ⟧.
Proof.
intro Ht.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hρ ; iintro Hγ.
iespecialize Ht.
repeat (ispecialize Ht ; [ eassumption | ]).

simpl.
generalize Ht.
generalize (subst_tm δ₁ ρ₁ γ₁ t₁), (subst_tm δ₂ ρ₂ γ₂ t₂).
clear Ht t₁ t₂.
intros t₁ t₂ Ht.

bind_eapp.
eapply plug0 with (ξ₁ := ξ₁) (ξ₂ := ξ₂) ; [auto|auto| |auto|auto|exact Ht].

iintro ξ₁' ; iintro ξ₂' ; iintro v₁ ; iintro v₂ ; iintro Hξ₁' ; iintro Hξ₂' ; iintro Hv.
simpl in Hv |- *.
ispecialize Hv ξ₁' ; ispecialize Hv ξ₂'.
ispecialize Hv ; [auto 6|].
ispecialize Hv ; [auto 6|].
ispecialize Hv (subst_eff δ₁ ρ₁ 𝓔).
ispecialize Hv (subst_eff δ₂ ρ₂ 𝓔).
ispecialize Hv (𝓤⟦ Ξ ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ).
ispecialize Hv.
{ iintro ; iintro ; iintro ; iintro ; iintro ; iintro Xs₁ ; iintro Xs₂ ; iintro.
  iintro_prop ; assert (Xs₁ \c from_list ξ₁ ∧ Xs₂ \c from_list ξ₂) as HXs₁Xs₂.
  - eapply Xs_is_𝓤_bounded ; eauto.
  - clear - Hξ₁' Hξ₂' HXs₁Xs₂.
    destruct HXs₁Xs₂.
    split ; eauto.
}

change (
  λ _ _ _ _ _ _ _, (False)ᵢ
) with (
  𝓤⟦ (EV_shift_XEnv Ξ) ⊢ [] ⟧
  (env_ext δ₁ (subst_eff δ₁ ρ₁ 𝓔))
  (env_ext δ₂ (subst_eff δ₂ ρ₂ 𝓔))
  (env_ext δ (𝓤⟦ Ξ ⊢ 𝓔 ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ))
  ρ₁ ρ₂ ρ
) in Hv.

replace (subst_eff δ₁ (V_open_hd ∘ ρ₁) 𝓔) with (subst_eff δ₁ ρ₁ 𝓔) by
  (clear ; apply HV_bind_eff_eq ; crush).
replace (subst_eff δ₂ (V_open_hd ∘ ρ₂) 𝓔) with (subst_eff δ₂ ρ₂ 𝓔) by
  (clear ; apply HV_bind_eff_eq ; crush).
replace Ξ with (EV_bind_XEnv (EV_substfun 𝓔) (EV_shift_XEnv Ξ)) by
  (clear ; erewrite EV_bind_map_XEnv, EV_bind_XEnv_id, EV_map_XEnv_id ; crush).
apply ccompat_sub with (T := EV_subst_ty 𝓔 T) (𝓔 := EV_subst_eff 𝓔 []) ; [crush|crush|].
erewrite <- I_iff_elim_M ; [ exact Hv | apply EV_bind_𝓣 ; clear ].

{ intro α ; destruct α ; unfold compose ; simpl ; [ crush | ].
  rewrite app_nil_r.
  unshelve erewrite HV_bind_map_eff, HV_bind_eff_id, HV_map_eff_id ; crush.
}
{ intro α ; destruct α ; unfold compose ; simpl ; [ crush | ].
  rewrite app_nil_r.
  unshelve erewrite HV_bind_map_eff, HV_bind_eff_id, HV_map_eff_id ; crush.
}
{ iintro α ; repeat iintro.
  destruct α ; simpl.
  + erewrite EV_bind_map_XEnv, EV_bind_XEnv_id, EV_map_XEnv_id ;
    try apply auto_contr_id ; crush.
  + isplit ; iintro H ; [ ileft | idestruct H as H H ] ; crush.
}
Qed.

End section_compat_tm_eapp.


(** Interpretation of endpoints in 1-types *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Constant.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Whiskering.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import algebra.one_types_polynomials.

Local Open Scope cat.

Opaque comp_psfunctor.

Definition sem_endpoint_UU_natural
           {A P Q : poly_code}
           (e : endpoint A P Q)
           {X Y : UU}
           {cX : poly_act A X → X}
           {cY : poly_act A Y → Y}
           {f : X → Y}
           (ef : ((λ x, f (cX x)) ~ (λ x, cY (poly_map A f x))))
           (x : poly_act P X)
  : poly_map Q f (sem_endpoint_UU e cX x)
    =
    sem_endpoint_UU e cY (poly_map P f x).
Proof.
  induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                  | P Q | P Q | P Q | P Q
                  | P Q R e₁ IHe₁ e₂ IHe₂
                  | P T t | C₁ C₂ g | ].
  - (* Identity *)
    exact (idpath _).
  - (* Composition *)
    exact (IHe₂ (sem_endpoint_UU e₁ cX x)
           @ maponpaths (sem_endpoint_UU e₂ cY) (IHe₁ x)).
  - (* Left inclusion *)
    exact (idpath _).
  - (* Right inclusion *)
    exact (idpath _).
  - (* Left projection *)
    exact (idpath _).
  - (* Right projection *)
    exact (idpath _).
  - (* Pairing *)
    exact (pathsdirprod (IHe₁ x) (IHe₂ x)).
  - (* Constant *)
    exact (idpath _).
  - (* Constant map *)
    exact (idpath _).
  - (* Constructor *)
    exact (ef x).
Defined.

Definition sem_endpoint_one_types_data
           {A P Q : poly_code}
           (e : endpoint A P Q)
  : pstrans_data
      (comp_psfunctor (⟦ P ⟧) (pr1_psfunctor (disp_alg_bicat (⟦ A ⟧))))
      (comp_psfunctor (⟦ Q ⟧) (pr1_psfunctor (disp_alg_bicat (⟦ A ⟧)))).
Proof.
  use make_pstrans_data.
  - exact (λ X, sem_endpoint_UU e (pr2 X)).
  - intros X Y f.
    use make_invertible_2cell.
    + exact (λ x, sem_endpoint_UU_natural e (pr12 f) x).
    + apply one_type_2cell_iso.
Defined.

Definition sem_endpoint_UU_natural_natural
           {A P Q : poly_code}
           (e : endpoint A P Q)
           {X Y : UU}
           {cX : poly_act A X → X}
           {cY : poly_act A Y → Y}
           {f g : X → Y}
           {ef : ((λ x, f (cX x)) ~ (λ x, cY (poly_map A f x)))}
           {eg : ((λ x, g (cX x)) ~ (λ x, cY (poly_map A g x)))}
           {αp : f ~ g}
           (αh : (λ x : poly_act A X, αp (cX x) @ eg x)
                 =
                 (λ x : poly_act A X, ef x @ maponpaths cY (poly_homot A αp x)))
           (x : poly_act P X)
  : poly_homot Q αp (sem_endpoint_UU e cX x)
    @ sem_endpoint_UU_natural e eg x
    =
    sem_endpoint_UU_natural e ef x
    @ maponpaths (sem_endpoint_UU e cY) (poly_homot P αp x).
Proof.
  induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                  | P Q | P Q | P Q | P Q
                  | P Q R e₁ IHe₁ e₂ IHe₂
                  | P T t | C₁ C₂ h | ].
  - (* Identity *)
    exact (pathscomp0rid _ @ !(maponpathsidfun _)).
  - (* Composition *)
    exact (path_assoc _ _ _
           @ maponpaths (λ z, z @ _) (IHe₂ (sem_endpoint_UU e₁ cX x))
           @ !(path_assoc _ _ _)
           @ maponpaths
               (λ z, _ @ z)
               (!(maponpathscomp0 _ _ _)
                @ maponpaths
                    (maponpaths (sem_endpoint_UU e₂ cY))
                    (IHe₁ x)
                @ maponpathscomp0 _ _ _
                @ maponpaths
                    (λ z, _ @ z)
                    (maponpathscomp _ _ _))
           @ path_assoc _ _ _).
  - (* Left inclusion *)
    exact (pathscomp0rid _).
  - (* Right inclusion *)
    exact (pathscomp0rid _).
  - (* Left projection *)
    exact (pathscomp0rid _ @ !(maponpaths_pr1_pathsdirprod _ _)).
  - (* Right projection *)
    exact (pathscomp0rid _ @ !(maponpaths_pr2_pathsdirprod _ _)).
  - (* Pairing *)
    exact (pathsdirprod_concat _ _ _ _
           @ paths_pathsdirprod (IHe₁ x) (IHe₂ x)
           @ !(pathsdirprod_concat _ _ _ _)
           @ maponpaths
               (λ z, _ @ z)
               (!(maponpaths_prod_path _ _ _))).
  - (* Constant *)
    exact (!(maponpaths_for_constant_function _ _)).
  - (* Constant map *)
    exact (idpath _).
  - (* Constructor *)
    exact (eqtohomot αh x).
Qed.

Definition sem_endpoint_UU_natural_id
           {A P Q : poly_code}
           (e : endpoint A P Q)
           {X : one_type}
           (c : poly_act A X → X)
           (x : poly_act P X)
  : (poly_id Q X (sem_endpoint_UU e c x)
     @ poly_homot Q (λ z, idpath z) (sem_endpoint_UU e c x))
    @ sem_endpoint_UU_natural e (λ z, maponpaths c (poly_id A X z)) x
    =
    maponpaths
      (sem_endpoint_UU e c)
      (poly_id P X x @ poly_homot P (λ z, idpath z) x).
Proof.
  induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                  | P Q | P Q | P Q | P Q
                  | P Q R e₁ IHe₁ e₂ IHe₂
                  | P T t | C₁ C₂ h | ].
  - (* Identity *)
    exact (pathscomp0rid _ @ !(maponpathsidfun _)).
  - (* Composition *)
    exact (path_assoc _ _ _
           @ maponpaths (λ z, z @ _) (IHe₂ (sem_endpoint_UU e₁ c x))
           @ !(maponpathscomp0 _ _ _)
           @ maponpaths
               (maponpaths (sem_endpoint_UU e₂ c))
               (IHe₁ x)
           @ maponpathscomp _ _ _).
  - (* Left inclusion *)
    exact (pathscomp0rid _ @ !(maponpathscomp0 _ _ _)).
  - (* Right inclusion *)
    exact (pathscomp0rid _ @ !(maponpathscomp0 _ _ _)).
  - (* Left projection *)
    exact (pathscomp0rid _
           @ !(maponpaths_pr1_pathsdirprod _ _)
           @ maponpaths (maponpaths pr1) (!(pathsdirprod_concat _ _ _ _))).
  - (* Right projection *)
    exact (pathscomp0rid _
           @ !(maponpaths_pr2_pathsdirprod _ _)
           @ maponpaths (maponpaths dirprod_pr2) (!(pathsdirprod_concat _ _ _ _))).
  - (* Pairing *)
    exact (maponpaths
             (λ z, z @ _)
             (pathsdirprod_concat _ _ _ _)
           @ pathsdirprod_concat _ _ _ _
           @ paths_pathsdirprod (IHe₁ x) (IHe₂ x)
           @ !(maponpaths_prod_path _ _ _)).
  - (* Constant *)
    exact (!(maponpaths_for_constant_function _ _)).
  - (* Constant map *)
    exact (idpath _).
  - (* Constructor *)
    exact (maponpaths
             (maponpaths c)
             (!(pathscomp0rid _)
              @ maponpaths
                  (λ z, _ @ z)
                  (!(eqtohomot
                       (psfunctor_id2 (sem_poly_one_types A) (λ (x : X), x))
                       x)))).
Qed.

Definition sem_endpoint_UU_natural_comp
           {A P Q : poly_code}
           (e : endpoint A P Q)
           {X Y Z : total_bicat (disp_alg_bicat (⟦ A ⟧))}
           (f : X --> Y)
           (g : Y --> Z)
           (x : poly_act P (pr1 X : one_type))
  : (poly_comp Q (pr1 f) (pr1 g) (sem_endpoint_UU e (pr2 X) x)
    @ poly_homot Q (λ x0, idpath (pr1 g (pr1 f x0))) (sem_endpoint_UU e (pr2 X) x))
    @ sem_endpoint_UU_natural
        e
        (λ x0,
         (((maponpaths (pr1 g) (pr12 f x0)
            @ idpath (pr1 g (pr2 Y (poly_map A (pr1 f) x0))))
            @ (pr12 g) (poly_map A (pr1 f) x0))
            @ idpath (pr2 Z (poly_map A (pr1 g) (poly_map A (pr1 f) x0))))
            @ maponpaths (pr2 Z) (poly_comp A (pr1 f) (pr1 g) x0))
        x
    =
    (((maponpaths
         (poly_map Q (pr1 g))
         (sem_endpoint_UU_natural e (pr12 f) x)
    @ idpath (poly_map Q (pr1 g) (sem_endpoint_UU e (pr2 Y) (poly_map P (pr1 f) x))))
    @ sem_endpoint_UU_natural e (pr12 g) (poly_map P (pr1 f) x))
    @ idpath (sem_endpoint_UU e (pr2 Z) (poly_map P (pr1 g) (poly_map P (pr1 f) x))))
    @ maponpaths
        (sem_endpoint_UU e (pr2 Z))
        (poly_comp P (pr1 f) (pr1 g) x
         @ poly_homot P (λ x0, idpath (pr1 g (pr1 f x0))) x).
Proof.
  refine (!_).
  etrans.
  {
    apply maponpaths_2.
    etrans.
    {
      apply pathscomp0rid.
    }
    apply maponpaths_2.
    apply pathscomp0rid.
  }
  etrans.
  {
    do 2 apply maponpaths.
    etrans.
    {
      apply maponpaths.
      apply (eqtohomot (psfunctor_id2 (⟦ P ⟧) (λ z, pr1 g (pr1 f z)))).
    }
    apply pathscomp0rid.
  }
  refine (!_).
  etrans.
  {
    apply maponpaths_2.
    etrans.
    {
      apply maponpaths.
      apply (eqtohomot (psfunctor_id2 (⟦ Q ⟧) (λ z, pr1 g (pr1 f z)))).
    }
    apply pathscomp0rid.
  }
  induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                  | P Q | P Q | P Q | P Q
                  | P Q R e₁ IHe₁ e₂ IHe₂
                  | P T t | C₁ C₂ h | ].
  - (* Identity *)
    exact (pathscomp0rid _ @ !(maponpathsidfun _)).
  - (* Composition *)
    assert (poly_comp
              R (pr1 f) (pr1 g)
              (sem_endpoint_UU e₂ (pr2 X) (sem_endpoint_UU e₁ (pr2 X) x))
            @ sem_endpoint_UU_natural e₂
                (λ x0,
                 (((maponpaths (pr1 g) ((pr12 f) x0)
                    @ idpath (pr1 g (pr2 Y (poly_map A (pr1 f) x0))))
                    @ (pr12 g) (poly_map A (pr1 f) x0))
                    @ idpath (pr2 Z (poly_map A (pr1 g) (poly_map A (pr1 f) x0))))
            @ maponpaths
                (pr2 Z)
                (poly_comp A (pr1 f) (pr1 g) x0)) (sem_endpoint_UU e₁ (pr2 X) x)
            @ maponpaths
                (sem_endpoint_UU e₂ (pr2 Z))
                (sem_endpoint_UU_natural
                   e₁
                   (λ x0,
                    (((maponpaths (pr1 g) ((pr12 f) x0)
                       @ idpath (pr1 g (pr2 Y (poly_map A (pr1 f) x0))))
                       @ (pr12 g) (poly_map A (pr1 f) x0))
                       @ idpath _)
                      @ maponpaths (pr2 Z) (poly_comp A (pr1 f) (pr1 g) x0))
                   x)
            =
            (maponpaths
               (poly_map R (pr1 g))
               (sem_endpoint_UU_natural
                  e₂ (pr12 f)
                  (sem_endpoint_UU e₁ (pr2 X) x)
            @ maponpaths
                (sem_endpoint_UU e₂ (pr2 Y))
                (sem_endpoint_UU_natural e₁ (pr12 f) x))
            @ sem_endpoint_UU_natural
                e₂ (pr12 g)
                (sem_endpoint_UU e₁ (pr2 Y) (poly_map P (pr1 f) x))
            @ maponpaths
                (sem_endpoint_UU e₂ (pr2 Z))
                (sem_endpoint_UU_natural e₁ (pr12 g) (poly_map P (pr1 f) x)))
            @ maponpaths
                (λ x0, sem_endpoint_UU e₂ (pr2 Z) (sem_endpoint_UU e₁ (pr2 Z) x0))
                (poly_comp P (pr1 f) (pr1 g) x))
      as goal.
    {
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        apply IHe₂.
      }
      clear IHe₂.
      refine (!(path_assoc _ _ _) @ _ @ path_assoc _ _ _).
      refine (!(path_assoc _ _ _) @ _).
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        exact (maponpathscomp0 (poly_map R (pr1 g)) _ _).
      }
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          exact (!(maponpathscomp0 (sem_endpoint_UU e₂ (pr2 Z)) _ _)).
        }
        apply maponpaths.
        apply IHe₁.
      }
      clear IHe₁.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        refine (!(path_assoc _ _ _) @ _).
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          exact (!(maponpathscomp _ _ _)).
        }
        exact (!(maponpathscomp0 _ _ _)).
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          exact (!(path_assoc _ _ _)).
        }
        exact (maponpathscomp0 _ _ _).
      }
      refine (path_assoc _ _ _ @ _).
      refine (_ @ !(path_assoc _ _ _)).
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        apply maponpathscomp.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply maponpathscomp.
      }
      exact (homotsec_natural'
               (sem_endpoint_UU_natural e₂ (pr12 g))
               (sem_endpoint_UU_natural e₁ (pr12 f) x)).
    }
    exact goal.
  - (* Left inclusion *)
    exact (pathscomp0rid _).
  - (* Right inclusion *)
    exact (pathscomp0rid _).
  - (* Left projection *)
    refine (pathscomp0rid _ @ _).
    refine (!_).
    exact (maponpaths_pr1_pathsdirprod _ _).
  - (* Right projection *)
    refine (pathscomp0rid _ @ _).
    refine (!_).
    exact (maponpaths_pr2_pathsdirprod _ _).
  - (* Pairing *)
    refine (!_).
    etrans.
    {
      refine (maponpaths (λ z, _ @ z) _).
      apply maponpaths_prod_path.
    }
    etrans.
    {
      refine (maponpaths (λ z, z @ _) _).
      etrans.
      {
        refine (maponpaths (λ z, z @ _) _).
        refine (!_).
        apply maponpaths_pathsdirprod.
      }
      apply pathsdirprod_concat.
    }
    etrans.
    {
      apply pathsdirprod_concat.
    }
    refine (!_).
    etrans.
    {
      apply pathsdirprod_concat.
    }
    exact (paths_pathsdirprod (IHe₁ x) (IHe₂ x)).
  - (* Constant *)
    exact (!(maponpaths_for_constant_function _ _)).
  - (* Constant map *)
    apply idpath.
  - (* Constructor *)
    etrans.
    {
      refine (maponpaths (λ z, z @ maponpaths _ _) _).
      etrans.
      {
        apply pathscomp0rid.
      }
      apply maponpaths_2.
      apply pathscomp0rid.
    }
    apply idpath.
Qed.

Definition sem_endpoint_one_types_is_pstrans
           {A P Q : poly_code}
           (e : endpoint A P Q)
  : is_pstrans (sem_endpoint_one_types_data e).
Proof.
  repeat split.
  - intros X Y f g α.
    use funextsec.
    exact (sem_endpoint_UU_natural_natural e (pr2 α)).
  - intros X.
    use funextsec.
    exact (sem_endpoint_UU_natural_id e (pr2 X)).
  - intros X Y Z f g.
    use funextsec.
    exact (sem_endpoint_UU_natural_comp e f g).
Qed.

Definition sem_endpoint_one_types
           {A P Q : poly_code}
           (e : endpoint A P Q)
  : pstrans
      (comp_psfunctor (⟦ P ⟧) (pr1_psfunctor (disp_alg_bicat (⟦ A ⟧))))
      (comp_psfunctor (⟦ Q ⟧) (pr1_psfunctor (disp_alg_bicat (⟦ A ⟧)))).
Proof.
  use make_pstrans.
  - exact (sem_endpoint_one_types_data e).
  - exact (sem_endpoint_one_types_is_pstrans e).
Defined.


From Coq Require Import Bool ZArith Reals Lia.
From Flocq Require Import Core Digits Round 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 :=
  (Generic_fmt.round radix2 (FLT_exp d (Zpos p)) rdir) (only parsing).

Global Notation rounding_floatx rdir p :=
  (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 cexp.
apply monotone_exp...
now apply mag_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 cexp.
apply monotone_exp...
now apply mag_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 cexp.
destruct (Zle_or_lt (mag radix2 x) k) as [Hk1|Hk1].
apply monotone_exp...
destruct (Zle_or_lt (mag radix2 x) d) as [Hk2|Hk2].
unfold FLT_exp.
clear -Hk1 Hk2 ; zify ; lia.
elim Rlt_not_le with (1 := Hx) ; clear Hx.
apply Rle_trans with (bpow radix2 (Z.max k d)).
apply bpow_le.
apply Z.le_max_l.
apply abs_round_ge_generic...
apply generic_format_bpow.
unfold FLT_exp.
clear ; zify ; lia.
destruct (mag radix2 x) as (ex,Ex) ; simpl in *.
apply Rle_trans with (2 := proj1 (Ex Hx0)).
apply bpow_le.
clear -Hk1 Hk2 ; zify ; lia.
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 cexp.
apply monotone_exp...
destruct (Zle_or_lt (mag 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 ; lia.
destruct (mag radix2 x) as (ex,Ex) ; simpl in *.
apply Rle_trans with (2 := proj1 (Ex Hx0)).
apply bpow_le.
clear -Hk1 ; lia.
Qed.

Lemma Zmax_inf_l :
 forall m n : Z, (n <= m)%Z -> Z.max m n = m.
intros m n H.
generalize (Z.le_ge _ _ H).
unfold Z.max, Z.ge.
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 <> 0%R).
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 ; lia.
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 cexp.
apply Z.le_trans with (1 := H).
apply Z.le_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) (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 Z.lt_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) (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 Z.lt_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 (mag radix2 (F2R (Float radix2 m2 e2)) <= Zpos p2 + e2)%Z.
rewrite mag_F2R with (1 := Hm).
apply Zplus_le_compat_r.
apply Z.le_trans with (2 := H2).
apply bpow_lt_bpow with radix2.
destruct (mag radix2 (IZR m2)) as (n2, Hn).
simpl.
specialize (Hn (IZR_neq _ _ Hm)).
apply Rle_lt_trans with (1 := proj1 Hn).
rewrite <- abs_IZR.
now apply IZR_lt.
destruct (Zle_or_lt e1 e2) as [He|He].
(* *)
rewrite <- Hx3.
apply generic_format_F2R.
intros _ ; simpl.
apply Z.max_lub.
clear -H ; lia.
apply Z.le_trans with (1 := H1).
now apply Z.le_trans with e1.
(* *)
rewrite <- Hx1.
apply generic_format_F2R.
intros _ ; simpl.
apply Z.max_lub.
unfold float2R in Hx1. simpl in Hx1.
rewrite Hx1, <- Hx3.
unfold float2R. simpl.
lia.
now apply Z.le_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 cexp.
intros Hm ; simpl.
rewrite mag_F2R with (1 := Hm).
simpl.
unfold FLX_exp.
cut (mag radix2 (IZR m) <= Zpos p1)%Z.
clear -H1 ; lia.
apply bpow_lt_bpow with radix2.
destruct (mag radix2 (IZR m)) as [n Hn].
simpl.
specialize (Hn (IZR_neq _ _ Hm)).
apply Rle_lt_trans with (1 := proj1 Hn).
rewrite <- abs_IZR.
now apply IZR_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 IZR_lt.
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 0%R 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.
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 cexp, float2R.
rewrite mag_F2R with (1 := Hm0).
rewrite <- Zdigits_mag with (1 := Hm0).
simpl.
rewrite <- Zdigits_abs.
rewrite Zplus_comm.
destruct m as [|m|m] ; unfold Z.abs.
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 (Z.even 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 (Z.abs (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 Zdigits_abs, Zplus_comm.
rewrite <- mag_F2R_Zdigits with (1 := Zx).
destruct mag as (ex,Ex) ; simpl.
apply Rle_lt_trans with (1 := RRle_abs _).
apply Ex.
contradict Zx.
apply eq_0_F2R with (1 := Zx).
clear -Zx ; zify ; lia.
unfold float_ulp.
case Z.eq_dec ; intros Zx.
rewrite Zx.
unfold FLT_exp.
clear ; zify ; lia.
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 (Z.even 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.
assert (x = 0%R) as ->.
  rewrite float2_zero in Hx.
  apply Rabs_le_inv in Hx.
  apply Rle_antisym with (1 := proj2 Hx).
  now rewrite <- Ropp_0.
rewrite round_0...
rewrite Rminus_0_r.
rewrite Rabs_R0.
apply bpow_ge_0.
(* *)
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)).
lia.
destruct (Rle_or_lt (bpow radix2 (Fexp + Zpos (digits p0) - 1)) (Rabs x)).
(* . *)
rewrite float_absolute_ne_sym.
replace (rounding_float rndNE p d (Rabs x)) with (bpow radix2 (Fexp + Zpos (digits p0) - 1)).
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
apply Rle_trans with (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.
assert (Fexp + Zpos (digits p0) - Zpos p - 2 - (Fexp + Zpos (digits p0) - 1) = Zneg (p + 1))%Z as ->.
  rewrite <- Zneg_plus_distr.
  rewrite <- (Zopp_neg p).
  ring.
assert (Zpos (xI (shift_pos p 1)) - Zpos (shift_pos (p + 1) 1) = 1)%Z as ->.
  rewrite Zpos_xI.
  rewrite 2!shift_pos_correct.
  rewrite Zpower_pos_is_exp.
  change (Z.pow_pos 2 1) with 2%Z.
  ring.
unfold float2R.
rewrite F2R_bpow.
apply Rle_refl.
apply Rplus_le_reg_r with (Rabs x).
unfold Rminus.
now rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r, Rplus_0_l.
apply eq_sym, Rle_antisym.
(* .. *)
cut (bpow radix2 (Fexp + Zpos (digits p0) - 1) =
  Generic_fmt.round radix2 (FLT_exp d (Zpos p)) rndNE (F2R (Float radix2 (Zpos (xI (shift_pos p 1))) e)) :>R).
intros ->.
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.
cut (FLT_exp d (Zpos p) (e + Zpos (Pos.succ (digits (shift_pos p 1)))) = e + 2)%Z.
intros ->.
replace (e + 2 - e)%Z with 2%Z by ring.
unfold shr, shr_aux, shift_pos.
simpl.
rewrite iter_nat_of_P.
destruct (ZL4 p) as (p1,H3).
rewrite H3.
simpl.
rewrite H9.
replace (Fexp + Zpos (digits p0) - Zpos p - 2 + 2)%Z with (Fexp + Zpos (digits p0) - Zpos p)%Z by 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 (Pos.pred 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.
apply (f_equal (fun v => float2R (Float2 _ v))).
rewrite <- H4 at 2.
rewrite Zpos_succ_morphism.
unfold Z.succ.
ring.
rewrite H9.
rewrite Zpos_succ_morphism.
rewrite (digits2_digits (shift_pos p 1)).
rewrite shift_pos_correct, Zmult_1_r.
change (Z.pow_pos 2 p) with (Zpower 2 (Zpos p)).
rewrite Zdigits_Zpower by easy.
unfold Z.succ.
replace (Fexp + Zpos (digits p0) - Zpos p - 2 + (Zpos p + 1 + 1))%Z with (Fexp + Zpos (digits p0))%Z by ring.
unfold FLT_exp.
rewrite Zmax_inf_l.
ring.
generalize (Zgt_pos_0 (digits p0)).
lia.
(* .. *)
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).
lia.
generalize (Zgt_pos_0 (digits p0)).
lia.
(* . *)
replace e with (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 ; lia.
elim Rlt_not_le with (2 := Hx).
apply Rlt_le_trans with (Float2 0 Fexp).
now apply F2R_lt.
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 (Z.even 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 (Z.even 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 (Z.even 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 0%R.
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 Z.le_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 (Z.even 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.