(** Author: Alexander Anisimov *)
From mathcomp Require Import ssreflect ssrbool eqtype seq choice.
From libs Require Import edone bcase base fset.

Set Implicit Arguments.
(*Unset Strict Implicit.*)

(** * Automation for finite Sets *)

Section TabRules.

  Variable T: choiceType.

  (** Simplification rules **)

  (** composite set operations and relations **)
  Lemma properSub (A B : {fset T}): A `<` B = (A `<=` B) && ~~ (B `<=` A).
  Proof. rewrite properEneq eqEsub. by case (A`<=`B), (B`<=`A). Qed.
  Lemma sepI (A B : {fset T}) : A `&` B = [fset x in A | x \in B].
  Proof. by rewrite /fsetI. Qed.
  Lemma sepD (A B : {fset T}) : A `\` B = [fset x in A | x \notin B].
  Proof. by rewrite /fsetD. Qed.

  Definition compSetOps := (sepI, sepD, properSub).

  (** ** Tableau rules **)

  (** nonbranching *)

  (** one premise*)
  Lemma prop_dn s : ~~ ~~ s -> s. (*P7*)
  Proof. exact (@ negbNE s). Qed.

  Lemma prop_conj s t : s && t -> s /\ t. (*P1*)
  Proof. apply: andP. Qed.

  Lemma prop_negDisj s t : ~~ (s || t) -> ~~ s /\ ~~ t. (*P5*)
  Proof. rewrite negb_or. apply: andP. Qed.

  Lemma prop_negImpl s t : ~~ (s ==> t) -> s /\ ~~ t. (*P6*)
  Proof. rewrite negb_imply. apply: andP. Qed.

  Lemma satr_eqSym (a b : T) : a == b -> b == a. (*S8*)
  Proof. by rewrite eq_sym. Qed.

  Lemma satr_memSgt (a b : T) : a \in [fset b] -> a == b. (*S9*)
  Proof. by rewrite in_fset1. Qed.

  Lemma satr_nmemSgt (a b : T) : a \notin [fset b] -> a != b. (*S10*)
  Proof. by rewrite in_fset1. Qed.

  Lemma satr_sgtSub (a:T) (A : {fset T}) : [fset a] `<=` A -> a \in A. (*S11*)
  Proof. by rewrite fsub1. Qed.

  Lemma satr_eqP (A B : {fset T}) : A == B -> (A `<=` B) /\ (B `<=` A). (*S4*)
  Proof. rewrite eqEsub. apply: andP. Qed.

  Lemma satr_nmemU (a:T) (A B : {fset T}) : a \notin A `|` B -> a \notin A /\ a \notin B. (*S13*)
  Proof. rewrite in_fsetU negb_or. apply: andP. Qed.

  Lemma pow_mem (A B : {fset T}) : A \in (powerset B) -> A `<=` B. (*Q1*)
  Proof. by rewrite powersetE. Qed.

  (** several premises *)
  Lemma satr_memSub (a:T) (A B : {fset T}) : a \in A -> A `<=` B -> a \in B. (*S1*)
  Proof. move => P Q. apply: (@subP T A) => //. Qed.

  Lemma satr_nmemSup (a:T) (A B : {fset T}) : a \notin A -> B `<=` A -> a \notin B. (*S2*)
  Proof. move => P Q. case R: (a \in B) => //. by rewrite (subP Q) in P. Qed.

  Lemma satr_eqMem (a b : T) (A : {fset T}) : a == b -> b \in A -> a \in A. (*S6*)
  Proof. intros P Q. by rewrite -(eqP P) in Q. Qed.

  Lemma satr_eqTrans (a b c : T) : a == b -> b == c -> a == c. (*S7*)
  Proof. intros P Q. by rewrite -(eqP P) in Q. Qed.

  (** fresh variable generation *)
  Lemma satr_notSub (A B : {fset T}) : ~~ (A `<=` B) -> exists a, (a \in A) /\ (a \notin B). (*S3*)
  Proof. move => P. move: (subPn A B P) => {P} [a P Q]. by exists a. Qed.

  Lemma pow_nmem (A B : {fset T}) : A \notin (powerset B) -> exists x, (x \in A) /\ (x \notin B). (*Q2*)
  Proof. rewrite powersetE => P. apply (satr_notSub A B P). Qed.

  (** branching *)

  Lemma prop_disj s t : s || t -> s \/ t. (*P2*)
  Proof. apply: orP. Qed.

  Lemma prop_impl s t : s ==> t -> ~~ s \/ t. (*P3*)
  Proof. rewrite implybE. apply: orP. Qed.

  Lemma prop_negConj s t : ~~ (s && t) -> ~~ s \/ ~~ t. (*P4*)
  Proof. rewrite negb_and. apply: orP. Qed.

  Lemma satr_memU (a:T) (A B : {fset T}) : a \in A `|` B -> a \in A \/ a \in B. (*S12*)
  Proof. rewrite in_fsetU. apply: orP. Qed.

  Lemma satr_neqP (A B : {fset T}) :
    A != B -> exists x, (x \in A /\ x \notin B) \/ (x \in B /\ x \notin A). (*S5*)
  Proof.
    rewrite eqEsub negb_and => P. move: (orP P) => {P} [P|P].
    - move: (satr_notSub A B P) => {P} [x [P Q]]. exists x; by left.
    - move: (satr_notSub B A P) => {P} [x [P Q]]. exists x; by right.
  Qed.

  (** branch closing *)

  Lemma clos_posNeg (s : bool) : s -> ~~ s -> False. (*D1*)
  Proof. by case s. Qed.

  Lemma clos_neqxx (a : T) : a != a -> False. (*D2*)
  Proof. by rewrite eqxx. Qed.

  Lemma clos_memEmp (a : T) : a \in fset0 -> False. (*D3*)
  Proof. by rewrite in_fset0. Qed.

  (** substitution *)

  Lemma subst_memSep (y:T) (A : {fset T}) (p : T -> bool) : y \in sep A p -> (y \in A) /\ (p y). (*R1*)
  Proof. rewrite in_sep. apply: andP. Qed.

  Lemma subst_nmemSep (y:T) (A : {fset T}) (p : T -> bool):
    y \notin [ fset x in A | p x] -> y \notin A \/ ~~ p y. (*R2*)
  Proof. rewrite in_sep => P . apply: orP. by rewrite -negb_and. Qed.

  (** cut *)

  Lemma cut_eq (a b : T) : a == b \/ a != b.
  Proof. case (a == b); first by left. right. by apply negbT. Qed. (*C1*)

  Lemma cut_mem a (A: {fset T}) : a \in A \/ a \notin A. (*C2*)
  Proof. case (a \in A); first by left. right. by apply negbT. Qed.

  Lemma cut_sub (A B : {fset T}) : A `<=` B \/ ~~ (A `<=` B). (*C3*)
  Proof. case (A `<=` B); first by left. right. by apply negbT. Qed.

End TabRules.

(** ** Implementation of the Tactic *)

(** adding conclusions of diffrerent rule types *)

Ltac extend X PX :=
  let V := fresh "H" in
  let X := constr:(is_true X) in
  match goal with
    | _:  X |- _ => fail 1
    | _ => have V: X by apply PX
  end.

Ltac extend_conj A B PX :=
  let U := fresh "H" in
  let V := fresh "H" in
  let A := (eval simpl in (is_true A)) in
  let B := (eval simpl in (is_true B)) in
  match goal with
    | _: A, _: B |- _ => fail 1
    | _ => have [U V]: A /\ B by apply PX
  end.

Ltac extend_disj A B PX :=
  let V := fresh "H" in
  let A := (eval simpl in (is_true A)) in
  let B := (eval simpl in (is_true B)) in
  match goal with
    | _: A |- _ => fail 1
    | _: B |- _ => fail 1
    | _ => have [V | V]: A \/ B by apply PX
  end.

Ltac extend_conj_ex A B PX :=
  let X := fresh "x" in
  let U := fresh "H" in
  let V := fresh "H" in
  match goal with
    | _: is_true(?x \in A), _: is_true (?x \notin B) |- _ => fail 1
    | _ => have [X [U V]]: exists x, (x \in A) /\ (x \notin B) by apply PX
  end.

Ltac extend_disconj_ex A B PX :=
  let X := fresh "x" in
  let U := fresh "H" in
  let V := fresh "H" in
  match goal with
    | _: is_true(?x \in A), _: is_true(?x \notin B) |- _ => fail 1
    | _: is_true(?x \in B), _: is_true(?x \notin A) |- _ => fail 1
    | _ => have [X [[U V] | [U V]]]:
             exists x, (x \in A /\ x \notin B) \/ (x \in B /\ x \notin A)
               by apply PX
  end.

(** saturation *)

Ltac closebranch :=
  match goal with
  | H0: is_true (?s), H1: is_true(~~ ?s) |- _ => apply (@ clos_posNeg s); first exact H0; exact H1
  | H0: is_true (?a != ?a)               |- _ => apply (@ clos_neqxx _ a); exact H0
  | H0: is_true (?a \in fset0)           |- _ => apply (@ clos_memEmp _ a); exact H0
  end.

Ltac nonbranching :=
  match goal with
  (* one premiss *)
  | _: is_true(~~ ~~ ?s)             |- _ => extend s (prop_dn s)
  | _: is_true(?s && ?t)             |- _ => extend_conj s t (prop_conj s t)
  | _: is_true(~~ (?s || ?t))        |- _ => extend_conj (~~ s) (~~ t) (prop_negDisj s t)
  | _: is_true(~~ (?s ==> ?t))       |- _ => extend_conj s (~~ t) (prop_negImpl s t)
  | _: is_true(?a == ?b)             |- _ => extend (b == a) (satr_eqSym a b)
  | _: is_true(?a \in [fset ?b])     |- _ => extend (a == b) (satr_memSgt _ a b)
  | _: is_true(?a \notin [fset ?b])  |- _ => extend (a != b) (satr_nmemSgt _ a b)
  | _: is_true([fset ?a] `<=` ?A)    |- _ => extend (a \in A) (satr_sgtSub a A)
  | _: is_true(?A == ?B)             |- _ => extend_conj (A `<=` B) (B `<=` A) (satr_eqP A B)
  | _: is_true(?a \notin ?A `|` ?B)  |- _ => extend_conj (a \notin A) (a \notin B) (satr_nmemU a A B)
  | _: is_true(?A \in (powerset ?B)) |- _ => extend (A `<=` B) (pow_mem A B)
  (* several premises *)
  | _: is_true(?a \in ?A), _: is_true(?A `<=` ?B)    |- _ => extend (a \in B) (satr_memSub a A B)
  | _: is_true(?a \notin ?A), _: is_true(?B `<=` ?A) |- _ => extend (a \notin B) (satr_nmemSup a A B)
  | _: is_true(?a == ?b), _: is_true(?b \in ?A)      |- _ => extend (a \in A) (satr_eqMem a b A)
  | _: is_true(?a == ?b), _: is_true(?b == ?c)       |- _ => extend (a == c) (satr_eqTrans _ a b c)
  (* freshvar *)
  | _: is_true(~~ (?A `<=` ?B))         |- _ => extend_conj_ex A B (satr_notSub A B)
  | _: is_true(?A \notin (powerset ?B)) |- _ => extend_conj_ex A B (pow_nmem A B)
  (* substitution *)
  | _: is_true(?a \in sep ?A ?p) |- _ => extend_conj (a \in A) (p a) (subst_memSep a A p)
  end.

Ltac branching :=
  match goal with
  | _: is_true(?s || ?t)            |- _ => extend_disj s t (prop_disj s t)
  | _: is_true(?s ==> ?t)           |- _ => extend_disj (~~ s) t (prop_impl s t)
  | _: is_true(~~ (?s && ?t))       |- _ => extend_disj (~~ s) (~~ t) (prop_negConj s t)
  (* basic saturation *)
  | _: is_true(?a \in ?A `|` ?B)    |- _ => extend_disj (a \in A) (a \in B) (satr_memU a A B)
  | _: is_true(?A != ?B)            |- _ => extend_disconj_ex A B (satr_neqP A B)
  (*substitution *)
  | _: is_true(?a \notin sep ?A ?p) |- _ => extend_disj (a \notin A) (~~ (p a)) (subst_nmemSep a A p)
  end.

Ltac cutrules :=
  match goal with
  | _: context[?a], _: context[?A] |- _ => extend_disj (a \in A) (a \notin A) (cut_mem a A)
  | _: context[?A], _: context[?B] |- _ => extend_disj (A `<=` B) (~~(A `<=` B)) (cut_sub A B)
  | _: context[?A], _: context[?B] |- _ => extend_disj (A == B) (A != B) (cut_eq _ A B)
  end.

(** form control *)

Ltac reverywhere X :=
  repeat rewrite X;
  repeat match goal with
           | H: _ |- _ => rewrite X in H
         end.

Ltac genSubst :=
  repeat (
      let V := fresh "su" in
      match goal with
        | H: is_true(?x == ?y) |- _ =>
          match goal with
            | _: x = y |- _ => fail 1
            | _ => move: (eqP H) => V
          end
        | x := _ |- _ => subst x
      end
    ); subst.

Ltac clearNonbools :=
  repeat(
      match goal with
      | H : _ |- _ =>
        match type of H with
        | is_true _ => fail 1
        | _ = _ => fail 1
        | _ => clear H
        end
      end
    ).

(** preprocessing *)

Lemma semiDN (b:bool) : ~ ~~ b -> b.
Proof. case: b => _ //. Qed.

Lemma eq2bool (T : eqType) (a b : T) : a = b -> a == b.
Proof. move => H. by rewrite H. Qed.

Ltac oDN :=
  let V := fresh "H" in
  match goal with
  | |- is_true _ => apply semiDN; hnf => V
  | |- _ = _ => apply:eqP; apply semiDN; hnf => V
  | |- False => idtac
  end.

Ltac eq2bool :=
  let V := fresh "H" in
  match goal with
  | H: _ = _ |- _ => move:(eq2bool _ H) => V
  | _ => idtac
  end.

Ltac preproc :=
  repeat (let V := fresh "H" in move => V);
  oDN;
  eq2bool;
  reverywhere compSetOps;
  clearNonbools.

(** automated saturation without cuts *)

Ltac core :=
  repeat(
      genSubst;
      repeat nonbranching;
      try closebranch;
      genSubst;
      try branching;
      try closebranch
    ).

(** ** User-level Tactics *)

Ltac fset_dec :=
  preproc;
  repeat(
      try closebranch;
      core;
      try cutrules
    ).

(** omits cut rules *)
Ltac fset_nocut := preproc; try closebranch; core.

Ltac invert X :=
  match X with
    | (?x, ?y) =>
      match x with
        | (?x0, ?x1) => let z := invert (x0, (x1, y)) in constr:(z)
      end
    | _ => constr:(X)
  end.

(** unfolds all definitions given in a tuple before applying fset_dec *)
Ltac fset_decu X :=
  let Y := invert X in
  match Y with
    | (?x, ?xs) => unfold x in *; fset_decu xs
    | ?x => unfold x in *; fset_dec
  end.

(** omits cut rules and unfolds definitions *)
Ltac fset_nocutu X :=
  let Y := invert X in
  match Y with
    | (?x, ?xs) => unfold x in *; fset_nocutu xs
    | ?x => unfold x in *; fset_nocut
  end.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*               Typed LambdaFactor Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus  from Project Coq                                  *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                      Unstar.v                                      *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import List.
Require Import Max.
Require Import Test.
Require Import General.
Require Import LamSF_Terms.
Require Import LamSF_Substitution_term.
Require Import LamSF_Tactics.
Require Import Components.
Require Import Compounds.
Require Import LamSF_reduction.
Require Import LamSF_Normal.
Require Import LamSF_Closed.
Require Import LamSF_Eval.
Require Import type_derivation.
Require Import type_derivation_resi.
Require Import operator_types.
Require Import subject_reduction.
Require Import Equal.

Definition id_type := Abs (funty (Ref 0) (Ref 0)).

Definition ref := Ref.
Definition ap := App .
Definition abs := Abs.
Definition abs_S := (abs (abs (abs (ap (ap (ref 2) (ref 0)) (ap (ref 1) (ref 0)))))) .
Definition abs_K := (abs (abs (ref 1))).
Definition abs_I := (abs (ref 0)).
Definition abs_KI := (abs (abs (ref 0))).

Lemma abs_S_type : derivation nil abs_S (opty Sop).
Proof.
unfold abs_S; unfold_opty; unfold abs, ap.
repeat eapply derive_gen1.  simpl.
repeat eapply derive_abs.
repeat eapply derive_app; var_tac.
Qed.

Lemma abs_K_type : derivation nil abs_K (opty Kop).
Proof.
unfold abs_K; unfold_opty; unfold abs, ap.
repeat eapply derive_gen1.  simpl.
repeat eapply derive_abs.
repeat eapply derive_app; var_tac.
Qed.

Definition abs_A u := Abs (Abs (App u (App (Ref 1) (Ref 0)))).

Lemma abs_A_type : derivation (cons id_type nil) (abs_A (Ref 2)) (opty Aop).
Proof.
unfold abs_A; unfold_opty.
repeat eapply derive_gen1.
unfold lift; simpl; repeat rewrite lift_rec_closed; try (split_all; omega).
unfold relocate; simpl.
repeat eapply derive_abs.
repeat eapply derive_app.
eapply derive_instance.
derive_tac.
eapply succ_red. eapply instance_rule.
2: wfcs_tac. instantiate(1:= varty 1).
wfcs_tac.
unfold subst; simpl. insert_Ref_out.
repeat rewrite lift_rec_null. eapply2 zero_red. derive_tac. derive_tac.
Qed.

(* unstar *)

Definition unstar_fn :=
Abs (App g_op
(App (App (Op DAop) (abs_A (Ref 2)))
(App (App (Op DKop) abs_K)
(App g_op (App (App (Op DSop) abs_S) i_op)))))
.

Definition unstar := App (App a_op y_op) unstar_fn.

(*
Definition unstar_fn :=
Abs (Abs (App (App (App is_abs (Ref 0))
                   (App (Abs (Abs (App (Ref 3) (App (Ref 1) (Ref 0))))) (Ref 0)))
              (App (App (App f_op (Ref 0)) (Ref 0))
                   (Abs (Abs (App (App (App f_op (Ref 1))
                                       (App (App d_op (Ref 1)) (Ref 0)))
                                   (Abs (Abs (App (App (App d_op (Ref 1))
                                                       (App (Ref 5) (Ref 0)))
                                                  (App (Ref 5) (Ref 2)))))))))))
.

Definition unstar := App (App a_op y_op) unstar_fn.
*)

Proposition unstar_type: derivation nil unstar (Abs (funty (varty 0) (varty 0))).
Proof.
unfold unstar.
eapply derive_app.
eapply derive_app.
eapply derive_A.
wfcs_tac.
2: wfcs_tac.
2: eapply derive_Y.
wfcs_tac.
wfcs_tac.
wfcs_tac.
unfold unstar_fn.
eapply derive_abs.
eapply derive_gen1.
unfold lift; simpl. relocate_lt.
eapply derive_app.
eapply derive_G.
wfcs_tac.
wfcs_tac.
wfcs_tac.
eapply derive_gen1.
unfold lift; simpl. relocate_lt. simpl.
eapply derive_app.
eapply derive_app.
eapply derive_DA.
wfcs_tac.
wfcs_tac.
eapply abs_A_type.
eapply derive_app.
eapply derive_app.
eapply derive_DK.
wfcs_tac.
wfcs_tac.
eapply derive_nil.
eapply abs_K_type.
wfcs_tac.
eapply derive_app.
eapply derive_G.
wfcs_tac. wfcs_tac. wfcs_tac.
eapply derive_gen1.
unfold lift; simpl. relocate_lt; simpl.
eapply derive_app.
eapply derive_app.
eapply derive_DS.
wfcs_tac.
wfcs_tac.
eapply derive_nil.
eapply abs_S_type.
wfcs_tac.
eapply2 derive_I; wfcs_tac.
Qed.

Theorem unstar_star : forall M, normal M -> lamSF_red (App unstar (star M)) (Abs M).
Proof.
rank_tac.
induction M; split_all.
(* 4 *)
case n; split_all.
(* 5 *)
unfold unstar. eval_lamSF.
eapply transitive_red.
eapply preserves_app_lamSF_red.
red; one_step.
eauto.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply da_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
eapply succ_red.
eapply dk_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply ds_s_lamSF_red.
eauto.
eauto.
eval_lamSF.
eauto.
eauto.
eval_lamSF.
eapply preserves_abs_lamSF_red.
eval_lamSF.
(* 4 *)
unfold unstar. eval_lamSF.
eapply transitive_red.
eapply preserves_app_lamSF_red.
red; one_step.
eauto.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply da_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
eapply succ_red.
eapply dk_k_lamSF_red.
unfold factorable; simpl in *; auto 20.
eauto.
eval_lamSF.
eapply preserves_abs_lamSF_red.
relocate_lt. simpl; auto.
unfold lift; split_all. relocate_lt. auto.
(* 3 *)
unfold unstar. eval_lamSF.
eapply transitive_red.
eapply preserves_app_lamSF_red.
red; one_step.
eauto.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply da_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
eapply succ_red.
eapply dk_k_lamSF_red.
eauto.
eauto.
eval_lamSF.
auto.
(* 2 *)
unfold unstar. eval_lamSF. eval_lamSF.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply2 succ_red.
auto.
eval_lamSF.
eapply preserves_abs_lamSF_red.
eapply transitive_red.
eapply preserves_app_lamSF_red.
instantiate(1:= unstar). auto.
unfold lift; simpl. eval_lamSF.
rewrite subst_rec_lift_rec2.
eapply2 IHp.
omega.
inversion H0; auto.
(* 1 *)
unfold unstar. eval_lamSF.
eapply transitive_red.
eapply preserves_app_lamSF_red.
red; one_step.
eauto.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply da_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
eapply succ_red.
eapply dk_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
g_tac.
unfold factorable; simpl in *; auto 20.
eapply transitive_red.
eapply preserves_app_lamSF_red.
simpl. eapply succ_red.
eapply ds_s_lamSF_red.
eauto.
simpl. eauto. eval_lamSF.
eauto. eauto. eval_lamSF.
eapply preserves_abs_lamSF_red.
rewrite subst_rec_lift_rec; try omega.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eval_lamSF.
unfold lift; simpl. eval_lamSF.
repeat rewrite subst_rec_lift_rec2.
auto.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive datatype  :=
  | Tint : datatype
  | Tbool : datatype .

(* Why3 assumption *)
Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator .

(* Why3 assumption *)
Definition ident  := Z.

(* Why3 assumption *)
Inductive term  :=
  | Tconst : Z -> term
  | Tvar : Z -> term
  | Tderef : Z -> term
  | Tbin : term -> operator -> term -> term .

(* Why3 assumption *)
Inductive fmla  :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla
  | Flet : Z -> term -> fmla -> fmla
  | Fforall : Z -> datatype -> fmla -> fmla .

(* Why3 assumption *)
Inductive value  :=
  | Vint : Z -> value
  | Vbool : bool -> value .

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall (a:Type) (b:Type), (map a b) -> a -> b.
Implicit Arguments get.

Parameter set: forall (a:Type) (b:Type), (map a b) -> a -> b -> (map a b).
Implicit Arguments set.

Axiom Select_eq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall (a:Type) (b:Type), b -> (map a b).
Set Contextual Implicit.
Implicit Arguments const.
Unset Contextual Implicit.

Axiom Const : forall (a:Type) (b:Type), forall (b1:b) (a1:a),
  ((get (const b1:(map a b)) a1) = b1).

(* Why3 assumption *)
Definition env  := (map Z value).

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = (Vbool false))
  end.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint eval_term(sigma:(map Z value)) (pi:(map Z value))
  (t:term) {struct t}: value :=
  match t with
  | (Tconst n) => (Vint n)
  | (Tvar id) => (get pi id)
  | (Tderef id) => (get sigma id)
  | (Tbin t1 op t2) => (eval_bin (eval_term sigma pi t1) op (eval_term sigma
      pi t2))
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint eval_fmla(sigma:(map Z value)) (pi:(map Z value))
  (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term sigma pi t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla sigma pi f1) /\ (eval_fmla sigma pi f2)
  | (Fnot f1) => ~ (eval_fmla sigma pi f1)
  | (Fimplies f1 f2) => (eval_fmla sigma pi f1) -> (eval_fmla sigma pi f2)
  | (Flet x t f1) => (eval_fmla sigma (set pi x (eval_term sigma pi t)) f1)
  | (Fforall x Tint f1) => forall (n:Z), (eval_fmla sigma (set pi x (Vint n))
      f1)
  | (Fforall x Tbool f1) => forall (b:bool), (eval_fmla sigma (set pi x
      (Vbool b)) f1)
  end.
Unset Implicit Arguments.

Parameter subst_term: term -> Z -> Z -> term.

Axiom subst_term_def : forall (e:term) (r:Z) (v:Z),
  match e with
  | (Tconst _) => ((subst_term e r v) = e)
  | (Tvar _) => ((subst_term e r v) = e)
  | (Tderef x) => ((r = x) -> ((subst_term e r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((subst_term e r v) = e))
  | (Tbin e1 op e2) => ((subst_term e r v) = (Tbin (subst_term e1 r v) op
      (subst_term e2 r v)))
  end.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint fresh_in_term(id:Z) (t:term) {struct t}: Prop :=
  match t with
  | (Tconst _) => True
  | (Tvar v) => ~ (id = v)
  | (Tderef _) => True
  | (Tbin t1 _ t2) => (fresh_in_term id t1) /\ (fresh_in_term id t2)
  end.
Unset Implicit Arguments.

Axiom eval_subst_term : forall (sigma:(map Z value)) (pi:(map Z value))
  (e:term) (x:Z) (v:Z), (fresh_in_term v e) -> ((eval_term sigma pi
  (subst_term e x v)) = (eval_term (set sigma x (get pi v)) pi e)).

Axiom eval_term_change_free : forall (t:term) (sigma:(map Z value)) (pi:(map
  Z value)) (id:Z) (v:value), (fresh_in_term id t) -> ((eval_term sigma
  (set pi id v) t) = (eval_term sigma pi t)).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint fresh_in_fmla(id:Z) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => (fresh_in_term id e)
  | ((Fand f1 f2)|(Fimplies f1 f2)) => (fresh_in_fmla id f1) /\
      (fresh_in_fmla id f2)
  | (Fnot f1) => (fresh_in_fmla id f1)
  | (Flet y t f1) => (~ (id = y)) /\ ((fresh_in_term id t) /\
      (fresh_in_fmla id f1))
  | (Fforall y ty f1) => (~ (id = y)) /\ (fresh_in_fmla id f1)
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint subst(f:fmla) (x:Z) (v:Z) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x v))
  | (Fand f1 f2) => (Fand (subst f1 x v) (subst f2 x v))
  | (Fnot f1) => (Fnot (subst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x v) (subst f2 x v))
  | (Flet y t f1) => (Flet y (subst_term t x v) (subst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (subst f1 x v))
  end.
Unset Implicit Arguments.

Axiom eval_subst : forall (f:fmla) (sigma:(map Z value)) (pi:(map Z value))
  (x:Z) (v:Z), (fresh_in_fmla v f) -> ((eval_fmla sigma pi (subst f x v)) <->
  (eval_fmla (set sigma x (get pi v)) pi f)).

Axiom eval_swap : forall (f:fmla) (sigma:(map Z value)) (pi:(map Z value))
  (id1:Z) (id2:Z) (v1:value) (v2:value), (~ (id1 = id2)) -> ((eval_fmla sigma
  (set (set pi id1 v1) id2 v2) f) <-> (eval_fmla sigma (set (set pi id2 v2)
  id1 v1) f)).

Axiom eval_change_free : forall (f:fmla) (sigma:(map Z value)) (pi:(map Z
  value)) (id:Z) (v:value), (fresh_in_fmla id f) -> ((eval_fmla sigma (set pi
  id v) f) <-> (eval_fmla sigma pi f)).

(* Why3 assumption *)
Inductive stmt  :=
  | Sskip : stmt
  | Sassign : Z -> term -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : term -> stmt -> stmt -> stmt
  | Sassert : fmla -> stmt
  | Swhile : term -> fmla -> stmt -> stmt .

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

(* Why3 assumption *)
Inductive one_step : (map Z value) -> (map Z value) -> stmt -> (map Z value)
  -> (map Z value) -> stmt -> Prop :=
  | one_step_assign : forall (sigma:(map Z value)) (pi:(map Z value)) (x:Z)
      (e:term), (one_step sigma pi (Sassign x e) (set sigma x
      (eval_term sigma pi e)) pi Sskip)
  | one_step_seq : forall (sigma:(map Z value)) (pi:(map Z value))
      (sigma':(map Z value)) (pi':(map Z value)) (i1:stmt) (i1':stmt)
      (i2:stmt), (one_step sigma pi i1 sigma' pi' i1') -> (one_step sigma pi
      (Sseq i1 i2) sigma' pi' (Sseq i1' i2))
  | one_step_seq_skip : forall (sigma:(map Z value)) (pi:(map Z value))
      (i:stmt), (one_step sigma pi (Sseq Sskip i) sigma pi i)
  | one_step_if_true : forall (sigma:(map Z value)) (pi:(map Z value))
      (e:term) (i1:stmt) (i2:stmt), ((eval_term sigma pi
      e) = (Vbool true)) -> (one_step sigma pi (Sif e i1 i2) sigma pi i1)
  | one_step_if_false : forall (sigma:(map Z value)) (pi:(map Z value))
      (e:term) (i1:stmt) (i2:stmt), ((eval_term sigma pi
      e) = (Vbool false)) -> (one_step sigma pi (Sif e i1 i2) sigma pi i2)
  | one_step_assert : forall (sigma:(map Z value)) (pi:(map Z value))
      (f:fmla), (eval_fmla sigma pi f) -> (one_step sigma pi (Sassert f)
      sigma pi Sskip)
  | one_step_while_true : forall (sigma:(map Z value)) (pi:(map Z value))
      (e:term) (inv:fmla) (i:stmt), (eval_fmla sigma pi inv) ->
      (((eval_term sigma pi e) = (Vbool true)) -> (one_step sigma pi
      (Swhile e inv i) sigma pi (Sseq i (Swhile e inv i))))
  | one_step_while_false : forall (sigma:(map Z value)) (pi:(map Z value))
      (e:term) (inv:fmla) (i:stmt), (eval_fmla sigma pi inv) ->
      (((eval_term sigma pi e) = (Vbool false)) -> (one_step sigma pi
      (Swhile e inv i) sigma pi Sskip)).

(* Why3 assumption *)
Inductive many_steps : (map Z value) -> (map Z value) -> stmt -> (map Z
  value) -> (map Z value) -> stmt -> Z -> Prop :=
  | many_steps_refl : forall (sigma:(map Z value)) (pi:(map Z value))
      (i:stmt), (many_steps sigma pi i sigma pi i 0%Z)
  | many_steps_trans : forall (sigma1:(map Z value)) (pi1:(map Z value))
      (sigma2:(map Z value)) (pi2:(map Z value)) (sigma3:(map Z value))
      (pi3:(map Z value)) (i1:stmt) (i2:stmt) (i3:stmt) (n:Z),
      (one_step sigma1 pi1 i1 sigma2 pi2 i2) -> ((many_steps sigma2 pi2 i2
      sigma3 pi3 i3 n) -> (many_steps sigma1 pi1 i1 sigma3 pi3 i3
      (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (sigma1:(map Z value)) (pi1:(map Z value))
  (sigma2:(map Z value)) (pi2:(map Z value)) (i1:stmt) (i2:stmt) (n:Z),
  (many_steps sigma1 pi1 i1 sigma2 pi2 i2 n) -> (0%Z <= n)%Z.

Axiom many_steps_seq : forall (sigma1:(map Z value)) (pi1:(map Z value))
  (sigma3:(map Z value)) (pi3:(map Z value)) (i1:stmt) (i2:stmt) (n:Z),
  (many_steps sigma1 pi1 (Sseq i1 i2) sigma3 pi3 Sskip n) ->
  exists sigma2:(map Z value), exists pi2:(map Z value), exists n1:Z,
  exists n2:Z, (many_steps sigma1 pi1 i1 sigma2 pi2 Sskip n1) /\
  ((many_steps sigma2 pi2 i2 sigma3 pi3 Sskip n2) /\
  (n = ((1%Z + n1)%Z + n2)%Z)).

(* Why3 assumption *)
Definition valid_fmla(p:fmla): Prop := forall (sigma:(map Z value)) (pi:(map
  Z value)), (eval_fmla sigma pi p).

(* Why3 assumption *)
Definition valid_triple(p:fmla) (i:stmt) (q:fmla): Prop := forall (sigma:(map
  Z value)) (pi:(map Z value)), (eval_fmla sigma pi p) -> forall (sigma':(map
  Z value)) (pi':(map Z value)) (n:Z), (many_steps sigma pi i sigma' pi'
  Sskip n) -> (eval_fmla sigma' pi' q).

Parameter set1 : forall (a:Type), Type.

Parameter mem: forall (a:Type), a -> (set1 a) -> Prop.
Implicit Arguments mem.

(* Why3 assumption *)
Definition infix_eqeq (a:Type)(s1:(set1 a)) (s2:(set1 a)): Prop :=
  forall (x:a), (mem x s1) <-> (mem x s2).
Implicit Arguments infix_eqeq.

Axiom extensionality : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)),
  (infix_eqeq s1 s2) -> (s1 = s2).

(* Why3 assumption *)
Definition subset (a:Type)(s1:(set1 a)) (s2:(set1 a)): Prop := forall (x:a),
  (mem x s1) -> (mem x s2).
Implicit Arguments subset.

Axiom subset_trans : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a))
  (s3:(set1 a)), (subset s1 s2) -> ((subset s2 s3) -> (subset s1 s3)).

Parameter empty: forall (a:Type), (set1 a).
Set Contextual Implicit.
Implicit Arguments empty.
Unset Contextual Implicit.

(* Why3 assumption *)
Definition is_empty (a:Type)(s:(set1 a)): Prop := forall (x:a), ~ (mem x s).
Implicit Arguments is_empty.

Axiom empty_def1 : forall (a:Type), (is_empty (empty :(set1 a))).

Parameter add: forall (a:Type), a -> (set1 a) -> (set1 a).
Implicit Arguments add.

Axiom add_def1 : forall (a:Type), forall (x:a) (y:a), forall (s:(set1 a)),
  (mem x (add y s)) <-> ((x = y) \/ (mem x s)).

Parameter remove: forall (a:Type), a -> (set1 a) -> (set1 a).
Implicit Arguments remove.

Axiom remove_def1 : forall (a:Type), forall (x:a) (y:a) (s:(set1 a)), (mem x
  (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).

Axiom subset_remove : forall (a:Type), forall (x:a) (s:(set1 a)),
  (subset (remove x s) s).

Parameter union: forall (a:Type), (set1 a) -> (set1 a) -> (set1 a).
Implicit Arguments union.

Axiom union_def1 : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)) (x:a),
  (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).

Parameter inter: forall (a:Type), (set1 a) -> (set1 a) -> (set1 a).
Implicit Arguments inter.

Axiom inter_def1 : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)) (x:a),
  (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).

Parameter diff: forall (a:Type), (set1 a) -> (set1 a) -> (set1 a).
Implicit Arguments diff.

Axiom diff_def1 : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)) (x:a),
  (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).

Axiom subset_diff : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)),
  (subset (diff s1 s2) s1).

Parameter choose: forall (a:Type), (set1 a) -> a.
Implicit Arguments choose.

Axiom choose_def : forall (a:Type), forall (s:(set1 a)), (~ (is_empty s)) ->
  (mem (choose s) s).

Parameter all: forall (a:Type), (set1 a).
Set Contextual Implicit.
Implicit Arguments all.
Unset Contextual Implicit.

Axiom all_def : forall (a:Type), forall (x:a), (mem x (all :(set1 a))).

(* Why3 assumption *)
Definition assigns(sigma:(map Z value)) (a:(set1 Z)) (sigma':(map Z
  value)): Prop := forall (i:Z), (~ (mem i a)) -> ((get sigma
  i) = (get sigma' i)).

Axiom assigns_refl : forall (sigma:(map Z value)) (a:(set1 Z)),
  (assigns sigma a sigma).

Axiom assigns_trans : forall (sigma1:(map Z value)) (sigma2:(map Z value))
  (sigma3:(map Z value)) (a:(set1 Z)), ((assigns sigma1 a sigma2) /\
  (assigns sigma2 a sigma3)) -> (assigns sigma1 a sigma3).

Axiom assigns_union_left : forall (sigma:(map Z value)) (sigma':(map Z
  value)) (s1:(set1 Z)) (s2:(set1 Z)), (assigns sigma s1 sigma') ->
  (assigns sigma (union s1 s2) sigma').

Axiom assigns_union_right : forall (sigma:(map Z value)) (sigma':(map Z
  value)) (s1:(set1 Z)) (s2:(set1 Z)), (assigns sigma s2 sigma') ->
  (assigns sigma (union s1 s2) sigma').

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint stmt_writes(i:stmt) (w:(set1 Z)) {struct i}: Prop :=
  match i with
  | (Sskip|(Sassert _)) => True
  | (Sassign id _) => (mem id w)
  | ((Sseq s1 s2)|(Sif _ s1 s2)) => (stmt_writes s1 w) /\ (stmt_writes s2 w)
  | (Swhile _ _ s) => (stmt_writes s w)
  end.
Unset Implicit Arguments.

(* Why3 goal *)
Theorem WP_parameter_compute_writes : forall (s:stmt),
  match s with
  | Sskip => True
  | (Sassign i _) => True
  | (Sseq s1 s2) => True
  | (Sif _ s1 s2) => forall (o:(set1 Z)), (forall (sigma:(map Z value))
      (pi:(map Z value)) (sigma':(map Z value)) (pi':(map Z value)) (n:Z),
      (many_steps sigma pi s2 sigma' pi' Sskip n) -> (assigns sigma o
      sigma')) -> forall (o1:(set1 Z)), (forall (sigma:(map Z value))
      (pi:(map Z value)) (sigma':(map Z value)) (pi':(map Z value)) (n:Z),
      (many_steps sigma pi s1 sigma' pi' Sskip n) -> (assigns sigma o1
      sigma')) -> forall (sigma:(map Z value)) (pi:(map Z value))
      (sigma':(map Z value)) (pi':(map Z value)) (n:Z), (many_steps sigma pi
      s sigma' pi' Sskip n) -> (assigns sigma (union o1 o) sigma')
  | (Swhile _ _ s1) => True
  | (Sassert _) => True
  end.
destruct s; intuition.
inversion H1; subst; clear H1.
inversion H2; subst; clear H2.
apply assigns_union_left.
eapply H0; eauto.
apply assigns_union_right.
eapply H; eauto.
Qed.


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

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

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

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

(** * Rounding to nearest, ties to even: existence, unicity... *)

From Coq Require Import ZArith Reals Lia.

Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop Ulp.

Notation ZnearestE := (Znearest (fun x => negb (Z.even x))).

Section Fcore_rnd_NE.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { valid_exp : Valid_exp fexp }.

Notation format := (generic_format beta fexp).
Notation canonical := (canonical beta fexp).

Definition NE_prop (_ : R) f :=
  exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = true.

Definition Rnd_NE_pt :=
  Rnd_NG_pt format NE_prop.

Definition DN_UP_parity_pos_prop :=
  forall x xd xu,
  (0 < x)%R ->
  ~ format x ->
  canonical xd ->
  canonical xu ->
  F2R xd = round beta fexp Zfloor x ->
  F2R xu = round beta fexp Zceil x ->
  Z.even (Fnum xu) = negb (Z.even (Fnum xd)).

Definition DN_UP_parity_prop :=
  forall x xd xu,
  ~ format x ->
  canonical xd ->
  canonical xu ->
  F2R xd = round beta fexp Zfloor x ->
  F2R xu = round beta fexp Zceil x ->
  Z.even (Fnum xu) = negb (Z.even (Fnum xd)).

Lemma DN_UP_parity_aux :
  DN_UP_parity_pos_prop ->
  DN_UP_parity_prop.
Proof.
intros Hpos x xd xu Hfx Hd Hu Hxd Hxu.
destruct (total_order_T 0 x) as [[Hx|Hx]|Hx].
(* . *)
exact (Hpos x xd xu Hx Hfx Hd Hu Hxd Hxu).
elim Hfx.
rewrite <- Hx.
apply generic_format_0.
(* . *)
assert (Hx': (0 < -x)%R).
apply Ropp_lt_cancel.
now rewrite Ropp_involutive, Ropp_0.
destruct xd as (md, ed).
destruct xu as (mu, eu).
simpl.
rewrite <- (Bool.negb_involutive (Z.even mu)).
apply f_equal.
apply sym_eq.
rewrite <- (Z.even_opp mu), <- (Z.even_opp md).
change (Z.even (Fnum (Float beta (-md) ed)) = negb (Z.even (Fnum (Float beta (-mu) eu)))).
apply (Hpos (-x)%R _ _ Hx').
intros H.
apply Hfx.
rewrite <- Ropp_involutive.
now apply generic_format_opp.
now apply canonical_opp.
now apply canonical_opp.
rewrite round_DN_opp, F2R_Zopp.
now apply f_equal.
rewrite round_UP_opp, F2R_Zopp.
now apply f_equal.
Qed.

Class Exists_NE :=
  exists_NE : Z.even beta = false \/ forall e,
  ((fexp e < e)%Z -> (fexp (e + 1) < e)%Z) /\ ((e <= fexp e)%Z -> fexp (fexp e + 1) = fexp e).

Context { exists_NE_ : Exists_NE }.

Theorem DN_UP_parity_generic_pos :
  DN_UP_parity_pos_prop.
Proof with auto with typeclass_instances.
intros x xd xu H0x Hfx Hd Hu Hxd Hxu.
destruct (mag beta x) as (ex, Hexa).
specialize (Hexa (Rgt_not_eq _ _ H0x)).
generalize Hexa. intros Hex.
rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0x)) in Hex.
destruct (Zle_or_lt ex (fexp ex)) as [Hxe|Hxe].
(* small x *)
assert (Hd3 : Fnum xd = Z0).
apply eq_0_F2R with beta (Fexp xd).
change (F2R xd = R0).
rewrite Hxd.
apply round_DN_small_pos with (1 := Hex) (2 := Hxe).
assert (Hu3 : xu = Float beta (1 * Zpower beta (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))).
apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- F2R_change_exp.
rewrite F2R_bpow.
apply sym_eq.
rewrite Hxu.
apply sym_eq.
apply round_UP_small_pos with (1 := Hex) (2 := Hxe).
now apply valid_exp.
rewrite Hd3, Hu3.
rewrite Zmult_1_l.
simpl.
destruct exists_NE_ as [H|H].
apply Zeven_Zpower_odd with (2 := H).
apply Zle_minus_le_0.
now apply valid_exp.
rewrite (proj2 (H ex)).
now rewrite Zminus_diag.
exact Hxe.
(* large x *)
assert (Hd4: (bpow (ex - 1) <= Rabs (F2R xd) < bpow ex)%R).
rewrite Rabs_pos_eq.
rewrite Hxd.
split.
apply (round_DN_pt beta fexp x).
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
lia.
apply Hex.
apply Rle_lt_trans with (2 := proj2 Hex).
apply (round_DN_pt beta fexp x).
rewrite Hxd.
apply (round_DN_pt beta fexp x).
apply generic_format_0.
now apply Rlt_le.
assert (Hxe2 : (fexp (ex + 1) <= ex)%Z) by now apply valid_exp.
assert (Hud: (F2R xu = F2R xd + ulp beta fexp x)%R).
rewrite Hxu, Hxd.
now apply round_UP_DN_ulp.
destruct (total_order_T (bpow ex) (F2R xu)) as [[Hu2|Hu2]|Hu2].
(* - xu > bpow ex  *)
elim (Rlt_not_le _ _ Hu2).
rewrite Hxu.
apply round_bounded_large_pos...
(* - xu = bpow ex *)
assert (Hu3: xu = Float beta (1 * Zpower beta (ex - fexp (ex + 1))) (fexp (ex + 1))).
apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- Hu2.
apply sym_eq.
rewrite <- F2R_change_exp.
apply F2R_bpow.
exact Hxe2.
assert (Hd3: xd = Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex)).
assert (H: F2R xd = F2R (Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex))).
unfold F2R. simpl.
rewrite minus_IZR.
unfold Rminus.
rewrite Rmult_plus_distr_r.
rewrite IZR_Zpower, <- bpow_plus.
ring_simplify (ex - fexp ex + fexp ex)%Z.
rewrite Hu2, Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold cexp.
rewrite mag_unique with beta x ex.
unfold F2R.
simpl. ring.
rewrite Rabs_pos_eq.
exact Hex.
now apply Rlt_le.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
apply canonical_unique with (1 := Hd) (3 := H).
apply (f_equal fexp).
rewrite <- H.
apply sym_eq.
now apply mag_unique.
rewrite Hd3, Hu3.
unfold Fnum.
rewrite Z.even_mul. simpl.
unfold Zminus at 2.
rewrite Z.even_add.
rewrite eqb_sym. simpl.
fold (negb (Z.even (beta ^ (ex - fexp ex)))).
rewrite Bool.negb_involutive.
rewrite (Z.even_pow beta (ex - fexp ex)) by lia.
destruct exists_NE_.
rewrite H.
apply Zeven_Zpower_odd with (2 := H).
now apply Zle_minus_le_0.
apply Z.even_pow.
specialize (H ex).
lia.
(* - xu < bpow ex *)
revert Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold F2R.
rewrite Hd, Hu.
unfold cexp.
rewrite mag_unique with beta (F2R xu) ex.
rewrite mag_unique with (1 := Hd4).
rewrite mag_unique with (1 := Hexa).
intros H.
replace (Fnum xu) with (Fnum xd + 1)%Z.
rewrite Z.even_add.
now apply eqb_sym.
apply sym_eq.
apply eq_IZR.
rewrite plus_IZR.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
rewrite H.
simpl. ring.
apply Rgt_not_eq.
apply bpow_gt_0.
rewrite Rabs_pos_eq.
split.
apply Rle_trans with (1 := proj1 Hex).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
exact Hu2.
apply Rlt_le.
apply Rlt_le_trans with (1 := H0x).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
Qed.

Theorem DN_UP_parity_generic :
  DN_UP_parity_prop.
Proof.
apply DN_UP_parity_aux.
apply DN_UP_parity_generic_pos.
Qed.

Theorem Rnd_NE_pt_total :
  round_pred_total Rnd_NE_pt.
Proof.
apply satisfies_any_imp_NG.
now apply generic_format_satisfies_any.
intros x d u Hf Hd Hu.
generalize (proj1 Hd).
unfold generic_format.
set (ed := cexp beta fexp d).
set (md := Ztrunc (scaled_mantissa beta fexp d)).
intros Hd1.
case_eq (Z.even md) ; [ intros He | intros Ho ].
right.
exists (Float beta md ed).
unfold Generic_fmt.canonical.
rewrite <- Hd1.
now repeat split.
left.
generalize (proj1 Hu).
unfold generic_format.
set (eu := cexp beta fexp u).
set (mu := Ztrunc (scaled_mantissa beta fexp u)).
intros Hu1.
rewrite Hu1.
eexists ; repeat split.
unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite (DN_UP_parity_generic x (Float beta md ed) (Float beta mu eu)).
simpl.
now rewrite Ho.
exact Hf.
unfold Generic_fmt.canonical.
now rewrite <- Hd1.
unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite <- Hd1.
apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_monotone :
  round_pred_monotone Rnd_NE_pt.
Proof.
apply Rnd_NG_pt_monotone.
intros x d u Hd Hdn Hu Hun (cd, (Hd1, Hd2)) (cu, (Hu1, Hu2)).
destruct (Req_dec x d) as [Hx|Hx].
rewrite <- Hx.
apply sym_eq.
apply Rnd_UP_pt_idempotent with (1 := Hu).
rewrite Hx.
apply Hd.
rewrite (DN_UP_parity_aux DN_UP_parity_generic_pos x cd cu) in Hu2 ; try easy.
now rewrite (proj2 Hd2) in Hu2.
intros Hf.
apply Hx.
apply sym_eq.
now apply Rnd_DN_pt_idempotent with (1 := Hd).
rewrite <- Hd1.
apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_round :
  round_pred Rnd_NE_pt.
Proof.
split.
apply Rnd_NE_pt_total.
apply Rnd_NE_pt_monotone.
Qed.

Lemma round_NE_pt_pos :
  forall x,
  (0 < x)%R ->
  Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x Hx.
split.
now apply round_N_pt.
unfold NE_prop.
set (mx := scaled_mantissa beta fexp x).
set (xr := round beta fexp ZnearestE x).
destruct (Req_dec (mx - IZR (Zfloor mx)) (/2)) as [Hm|Hm].
(* midpoint *)
left.
exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (cexp beta fexp xr)).
split.
apply round_N_pt...
split.
unfold Generic_fmt.canonical. simpl.
apply f_equal.
apply round_N_pt...
simpl.
unfold xr, round, Znearest.
fold mx.
rewrite Hm.
rewrite Rcompare_Eq. 2: apply refl_equal.
case_eq (Z.even (Zfloor mx)) ; intros Hmx.
(* . even floor *)
change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true).
destruct (Rle_or_lt (round beta fexp Zfloor x) 0) as [Hr|Hr].
rewrite (Rle_antisym _ _ Hr).
unfold scaled_mantissa.
rewrite Rmult_0_l.
now rewrite Ztrunc_IZR.
rewrite <- (round_0 beta fexp Zfloor).
apply round_le...
now apply Rlt_le.
rewrite scaled_mantissa_DN...
now rewrite Ztrunc_IZR.
(* . odd floor *)
change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true).
destruct (mag beta x) as (ex, Hex).
specialize (Hex (Rgt_not_eq _ _ Hx)).
rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hx)) in Hex.
destruct (Z_lt_le_dec (fexp ex) ex) as [He|He].
(* .. large pos *)
assert (Hu := round_bounded_large_pos _ _ Zceil _ _ He Hex).
assert (Hfc: Zceil mx = (Zfloor mx + 1)%Z).
apply Zceil_floor_neq.
intros H.
rewrite H in Hm.
unfold Rminus in Hm.
rewrite Rplus_opp_r in Hm.
elim (Rlt_irrefl 0).
rewrite Hm at 2.
apply Rinv_0_lt_compat.
now apply IZR_lt.
destruct (proj2 Hu) as [Hu'|Hu'].
(* ... u <> bpow *)
unfold scaled_mantissa.
rewrite cexp_fexp_pos with (1 := conj (proj1 Hu) Hu').
unfold round, F2R. simpl.
rewrite cexp_fexp_pos with (1 := Hex).
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
rewrite Ztrunc_IZR.
fold mx.
rewrite Hfc.
now rewrite Z.even_add, Hmx.
(* ... u = bpow *)
rewrite Hu'.
unfold scaled_mantissa, cexp.
rewrite mag_bpow.
rewrite <- bpow_plus, <- IZR_Zpower.
rewrite Ztrunc_IZR.
case_eq (Z.even beta) ; intros Hr.
destruct exists_NE_ as [Hs|Hs].
now rewrite Hs in Hr.
destruct (Hs ex) as (H,_).
rewrite Z.even_pow.
exact Hr.
lia.
assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
replace (Zfloor mx) with (Zceil mx + -1)%Z by lia.
rewrite Z.even_add.
apply eqb_true.
unfold mx.
replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)).
rewrite Zeven_Zpower_odd with (2 := Hr).
easy.
lia.
apply eq_IZR.
rewrite IZR_Zpower by lia.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
unfold Zminus.
rewrite bpow_plus.
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l, Rmult_1_r.
pattern (fexp ex) ; rewrite <- cexp_fexp_pos with (1 := Hex).
now apply sym_eq.
apply Rgt_not_eq.
apply bpow_gt_0.
generalize (proj1 (valid_exp ex) He).
lia.
(* .. small pos *)
assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
unfold mx, scaled_mantissa.
rewrite cexp_fexp_pos with (1 := Hex).
now rewrite mantissa_DN_small_pos.
(* not midpoint *)
right.
intros g Hg.
destruct (Req_dec x g) as [Hxg|Hxg].
rewrite <- Hxg.
apply sym_eq.
apply round_generic...
rewrite Hxg.
apply Hg.
set (d := round beta fexp Zfloor x).
set (u := round beta fexp Zceil x).
apply Rnd_N_pt_unique with (d := d) (u := u) (4 := Hg).
now apply round_DN_pt.
now apply round_UP_pt.
2: now apply round_N_pt.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
unfold d, u, round, F2R. simpl. fold mx.
rewrite <- 2!Rmult_minus_distr_r.
intros H.
apply Rmult_eq_reg_r in H.
apply Hm.
apply Rcompare_Eq_inv.
rewrite Rcompare_floor_ceil_middle.
now apply Rcompare_Eq.
contradict Hxg.
apply sym_eq.
apply Rnd_N_pt_idempotent with (1 := Hg).
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
fold mx.
rewrite <- Hxg.
change (IZR (Zfloor mx) * bpow (cexp beta fexp x))%R with d.
now eapply round_DN_pt.
apply Rgt_not_eq.
apply bpow_gt_0.
Qed.

Theorem round_NE_opp :
  forall x,
  round beta fexp ZnearestE (-x) = (- round beta fexp ZnearestE x)%R.
Proof.
intros x.
unfold round. simpl.
rewrite scaled_mantissa_opp, cexp_opp.
rewrite Znearest_opp.
rewrite <- F2R_Zopp.
apply (f_equal (fun v => F2R (Float beta (-v) _))).
set (m := scaled_mantissa beta fexp x).
unfold Znearest.
case Rcompare ; trivial.
apply (f_equal (fun (b : bool) => if b then Zceil m else Zfloor m)).
rewrite Bool.negb_involutive.
rewrite Z.even_opp.
rewrite Z.even_add.
now rewrite eqb_sym.
Qed.

Lemma round_NE_abs:
  forall x : R,
  round beta fexp ZnearestE (Rabs x) = Rabs (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x.
apply sym_eq.
unfold Rabs at 2.
destruct (Rcase_abs x) as [Hx|Hx].
rewrite round_NE_opp.
apply Rabs_left1.
rewrite <- (round_0 beta fexp ZnearestE).
apply round_le...
now apply Rlt_le.
apply Rabs_pos_eq.
rewrite <- (round_0 beta fexp ZnearestE).
apply round_le...
now apply Rge_le.
Qed.

Theorem round_NE_pt :
  forall x,
  Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x.
destruct (total_order_T x 0) as [[Hx|Hx]|Hx].
apply Rnd_NG_pt_opp_inv.
apply generic_format_opp.
unfold NE_prop.
intros _ f ((mg,eg),(H1,(H2,H3))).
exists (Float beta (- mg) eg).
repeat split.
rewrite H1.
now rewrite F2R_Zopp.
now apply canonical_opp.
simpl.
now rewrite Z.even_opp.
rewrite <- round_NE_opp.
apply round_NE_pt_pos.
now apply Ropp_0_gt_lt_contravar.
rewrite Hx, round_0...
apply Rnd_NG_pt_refl.
apply generic_format_0.
now apply round_NE_pt_pos.
Qed.

End Fcore_rnd_NE.

(** Notations for backward-compatibility with Flocq 1.4. *)
Notation rndNE := ZnearestE (only parsing).