Require Import msl.msl_standard.
Require Import NPeano.
Require Import share_dec_base.
Require Import base_properties.
Require Import share_equation_system.
Require Import share_dec_interface.
Require Import share_decompose_base.
Require Import share_correctness.

Module SAT_Decompose (sv : SV)
                     (Import es : EQUATION_SYSTEM sv with Module dom := Share_Domain)
                     (Import esf : SYSTEM_FEATURES sv es) <:
                     SAT_DECOMPOSE sv es esf.

 Module DB := Decompose_Base sv es esf.
 Import DB.

 Function SATdecompose (ses : sat_equation_system) {measure height ses} :=
  if is_height_zero ses then (ses::nil) else
   let (sesL,sesR) := decompose ses in
   (SATdecompose sesL)++(SATdecompose sesR).
 Proof with try tauto;try omega.
  repeat intro.
  apply height_nonzero in teq0.
  detach teq0...
  repeat intro.
  apply height_nonzero in teq0.
  detach teq0...
 Defined.

 Lemma SAT_decompose_not_nil: forall ses,
  SATdecompose ses <> nil.
 Proof with try tauto.
  do 1 intro.
  apply SATdecompose_ind; repeat intro. inv H.
  apply app_eq_nil in H1...
 Qed.

 Lemma SAT_decompose_height: forall ses ses',
  In ses' (SATdecompose ses) -> |ses'| = 0 .
 Proof with try tauto.
  do 1 intro.
  apply SATdecompose_ind . repeat intro.
  simpl in H. destruct H... subst...
  repeat intros.
  apply in_app_or in H1.
  destruct H1.
  apply H... apply H0...
 Qed.

 Lemma nSAT_decompose_eval: forall ses,
  nSAT ses <-> forall ses', In ses' (SATdecompose ses) -> nSAT ses'.
 Proof with try tauto.
  do 1 intro.
  apply SATdecompose_ind;repeat intros.
  split;intros.
  destruct H0...
  subst ses'...
  apply H. left...
  apply decompose_nSAT in e0.
  split;intros.
  rewrite in_app_iff in H2. destruct H2.
  apply H... apply H0...
  apply e0. split.
  apply H... intros. apply H1. rewrite in_app_iff...
  apply H0... intros. apply H1. rewrite in_app_iff...
 Qed.

 Lemma sSAT_decompose_eval: forall ses x,
  nSAT ses ->
  (sSAT ses x <-> (exists ses', In ses' (SATdecompose ses) /\ sSAT ses' x)).
 Proof with try tauto.
  do 2 intro.
  apply SATdecompose_ind;intros.
  split;intros.
  exists ses0. split... left...
  destruct H0 as [? [? ?]]...
  destruct H0... subst x0...
  generalize (decompose_sSAT _ _ _ x H1 e0);intro.
  rewrite H2.
  generalize (decompose_nSAT _ _ _ e0);intro.
  rewrite H3 in H1. destruct H1.
  spec H H1. spec H0 H4.
  split;intros.
  destruct H5.
  apply H in H5. destruct H5.
  exists x0. rewrite in_app_iff...
  apply H0 in H5. destruct H5.
  exists x0. rewrite in_app_iff...
  destruct H5 as [? [? ?]].
  rewrite in_app_iff in H5.
  destruct H5.
  left. apply H. exists x0...
  right. apply H0. exists x0...
 Qed.

End SAT_Decompose.

Module IMPL_Decompose (sv : SV)
                      (Import es : EQUATION_SYSTEM sv with Module dom := Share_Domain)
                      (Import esf : SYSTEM_FEATURES sv es) <:
                       IMPL_DECOMPOSE sv es esf.

 Module DB := Decompose_Base sv es esf.
 Import DB.
 Import ClassicalProps.

 Function IMPLdecompose (is : impl_system) {measure height is} :=
  if is_height_zero is then (is::nil) else
   let (isL,isR) := decompose is in
   (IMPLdecompose isL)++(IMPLdecompose isR).
 Proof with try tauto;try omega.
  repeat intro.
  apply height_nonzero in teq0.
  detach teq0...
  repeat intro.
  apply height_nonzero in teq0.
  detach teq0...
 Defined.

 Lemma IMPL_decompose_not_nil: forall is,
  IMPLdecompose is <> nil.
 Proof with try tauto.
  do 1 intro.
  apply IMPLdecompose_ind; repeat intro. inv H.
  apply app_eq_nil in H1...
 Qed.

 Lemma IMPL_decompose_height : forall (is is':impl_system),
  In is' (IMPLdecompose is) ->
  |is'| = 0.
 Proof with try tauto.
  do 1 intro.
  apply IMPLdecompose_ind;intros.
  simpl in H. destruct H... subst...
  rewrite in_app_iff in H1. destruct H1.
  apply H... apply H0...
 Qed.

 Lemma nIMPL_decompose_eval: forall (is:impl_system),
  nSAT (ies2ses (fst is)) ->
  (nIMPL is <-> forall (is':impl_system), In is' (IMPLdecompose is) -> nIMPL is').
 Proof with try tauto.
  do 1 intro.
  apply IMPLdecompose_ind ;intros.
  split;intros.
  destruct H1... subst...
  apply H0. left...

  assert (nSAT (ies2ses (fst isL)) /\ nSAT (ies2ses (fst isR))).
   rewrite<- decompose_nSAT with (ses:=ies2ses (fst is0))...
   rewrite decompose_is_rewrite in e0.
   destruct e0 as [H2 _].
   clear - H2.
   destruct (fst is0) as [l1 l2 l3 l4].
   destruct (fst isL) as [l1L l2L l3L l4L].
   destruct (fst isR) as [l1R l2R l3R l4R].
   simpl in *.
   unfold decompose_ses,decompose_ies,ies2ses in *;simpl in *.
   simpl.
   destruct (decompose_list l3).
   destruct (decompose_list l4).
   inv H2...
  destruct H2.
  apply H in H2.
  apply H0 in H3.
  rewrite decompose_nIMPL with (isL:=isL)(isR:=isR)...
  split;intros.
  rewrite in_app_iff in H5.
  destruct H5. apply H2... apply H3...
  split. apply H2. intros. apply H4.
  rewrite in_app_iff...
  apply H3. intros. apply H4.
  rewrite in_app_iff...
 Qed.

 Lemma zIMPL_decompose_eval: forall (is:impl_system) y,
  nSAT (ies2ses (fst is)) ->
  nIMPL is  ->
  (zIMPL is y <-> exists (is':impl_system), In is' (IMPLdecompose is) /\ zIMPL is' y).
 Proof with try tauto.
  do 1 intro.
  apply IMPLdecompose_ind ;intros.
  split;intros.
  exists is0.
  split... left...
  destruct H1 as [is'[H1 H2]].
  destruct H1...
  subst is'...

  assert (nSAT (ies2ses (fst isL)) /\ nSAT (ies2ses (fst isR))).
   rewrite<- decompose_nSAT with (ses:=ies2ses (fst is0))...
   rewrite decompose_is_rewrite in e0.
   destruct e0 as [H3 _].
   clear - H3.
   destruct (fst is0) as [l1 l2 l3 l4].
   destruct (fst isL) as [l1L l2L l3L l4L].
   destruct (fst isR) as [l1R l2R l3R l4R].
   simpl in *.
   unfold decompose_ses,decompose_ies,ies2ses in *;simpl in *.
   destruct (decompose_list l3).
   destruct (decompose_list l4).
   inv H3...
  destruct H3.
  assert (nIMPL isL /\ nIMPL isR).
   rewrite<- decompose_nIMPL with (is:=is0)...
  destruct H5.
  spec H y H3 H5.
  spec H0 y H4 H6.
  rewrite decompose_zIMPL with (isL:=isL)(isR:=isR)...
  split;intros.
  destruct H7.
  apply H in H7. destruct H7 as [is' H7].
  exists is'. rewrite in_app_iff...
  apply H0 in H7. destruct H7 as [is' H7].
  exists is'. rewrite in_app_iff...
  destruct H7 as [is' [H7 H8]].
  rewrite in_app_iff in H7.
  destruct H7.
  left. apply H. exists is'...
  right. apply H0. exists is'...
 Qed.

 Lemma sIMPL_decompose_eval: forall (is:impl_system) x y,
  nSAT (ies2ses (fst is)) ->
  nIMPL is ->
  ~zIMPL is y ->
  (sIMPL is x y <-> forall (is':impl_system), In is' (IMPLdecompose is) -> sIMPL is' x y).
 Proof with try tauto.
  do 1 intro.
  apply IMPLdecompose_ind ;intros.
  split;intros.
  destruct H3...
  subst is'...
  apply H2... left...

  assert (nSAT (ies2ses (fst isL)) /\ nSAT (ies2ses (fst isR))).
   rewrite<- decompose_nSAT with (ses:=ies2ses (fst is0))...
   rewrite decompose_is_rewrite in e0.
   destruct e0 as [H4 _].
   clear - H4.
   destruct (fst is0) as [l1 l2 l3 l4].
   destruct (fst isL) as [l1L l2L l3L l4L].
   destruct (fst isR) as [l1R l2R l3R l4R].
   simpl in *.
   unfold decompose_ses,decompose_ies,ies2ses in *;simpl in *.
   destruct (decompose_list l3).
   destruct (decompose_list l4).
   inv H4...
  destruct H4.
  assert (nIMPL isL /\ nIMPL isR).
   rewrite<- decompose_nIMPL with (is:=is0)...
  destruct H6.
  assert (~zIMPL isL y /\ ~zIMPL isR y).
   rewrite<-neg_or.
   rewrite<- decompose_zIMPL with (is:=is0)...
  destruct H8.
  spec H x y H4 H6 H8.
  spec H0 x y H5 H7 H9.
  rewrite decompose_sIMPL with (isL:=isL)(isR:=isR)...
  split;intros.
  rewrite in_app_iff in H11.
  destruct H11. apply H... apply H0...
  split. apply H. intros. apply H10. rewrite in_app_iff...
  apply H0. intros. apply H10. rewrite in_app_iff...
 Qed.

End IMPL_Decompose.


Require Export CatSem.CAT.NT.
Require Export CatSem.CAT.monic_epi.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Automatic Introduction.

Section Nat_Iso_def.

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.
Variables F G: Functor C D.

Section struct_def.

Variable alpha: NT F G.
(*
Class NISO_struct := {
  inv: forall c, morD (G c) (F c);
  inv_right: forall c, alpha c ;; inv c == id _;
  inv_left: forall c, inv c ;; alpha c == id _
}.
*)
Class NISO_struct := {
  NT_inv :> forall c, Invertible (alpha c)
}.

End struct_def.

Record NISO := {
  tra :> NT F G;
  niso_struct :> NISO_struct tra
}.

End Nat_Iso_def.

Existing Instance niso_struct.

Section Nat_Iso_gives_NT.

Notation "-- f" := (inverse f) (at level 30).

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.
Variables F G: Functor C D.

Variable alpha: NISO F G.

Program Definition NTinv: NT G F := Build_NT
    (trafo := fun c => -- (alpha c)) _ .
Next Obligation.
Proof.
  constructor.
  intros c d f.
  destruct alpha as [al NIS]. simpl.
  destruct NIS as [INV].
  simpl in *|-*.
  set (H := trafo_ax (NT_struct := al)).
  assert (H': --al c ;; (al c ;; #G f) ==
                  --al c ;; (#F f ;; al d)).
  apply praecomp. auto.
  assert (H'': (--al c ;; (al c ;; #G f)) ;; --al d ==
                  (--al c ;; (#F f ;; al d)) ;; --al d).
  apply postcomp. auto.
  repeat rewrite assoc in H''.
  rewrite inv_post in H''.
  repeat rewrite <- assoc in H''.
  rewrite inv_prae in H''.
  rewrite idl in H''.
  rewrite idr in H''.
  apply hom_sym. auto.
Qed.

(*
Program Definition NTinv: NT G F := Build_NT
     (trafo := @inv _ _ _ _ _ _ F G alpha (niso_struct alpha) ) _ .
Next Obligation.
Proof.
  apply Build_NatTrans.
  unfold trafo_comm, inv.
  intros c d f.
  destruct alpha as [al da]. simpl.
  destruct da as [invv r l]. simpl in *|-*.
  destruct al as [al H]. simpl in *|-*.
  destruct H as [H].
  unfold trafo_comm in H. simpl in H.
  assert (H': invv c ;; (al c ;; !G f) ==
                  invv c ;; (!F f ;; al d)).
  apply praecomp. auto.
  assert (H'': (invv c ;; (al c ;; !G f)) ;; invv d ==
                  (invv c ;; (!F f ;; al d)) ;; invv d).
  apply postcomp. auto.
  repeat rewrite assoc in H''.
  rewrite r in H''.
  repeat rewrite <- assoc in H''.
  rewrite l in H''.
  rewrite idl in H''.
  rewrite idr in H''.
  apply hom_sym. auto.
Qed.
*)
End Nat_Iso_gives_NT.

(*
Section ISO.

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat morC.
Variable D: Cat morD.
Variables F G: Functor C D.

Class

*)


Require Export prosa.analysis.facts.behavior.all.
Require Export prosa.analysis.facts.model.ideal_schedule.
Require Export prosa.analysis.definitions.job_properties.
Require Export prosa.model.schedule.nonpreemptive.

(** Furthermore, we assume the fully non-preemptive job model. *)
Require Import prosa.model.preemption.fully_nonpreemptive.

(** * Platform for Fully Non-Preemptive model *)
(** In this section, we prove that instantiation of predicate
    [job_preemptable] to the fully non-preemptive model indeed
    defines a valid preemption model. *)
Section FullyNonPreemptiveModel.

  (**  Consider any type of jobs. *)
  Context {Job : JobType}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any arrival sequence with consistent arrivals. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.

  (** Next, consider any non-preemptive ideal uniprocessor schedule of
      this arrival sequence ... *)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_nonpreemptive_sched : nonpreemptive_schedule  sched.

  (** ... where jobs do not execute before their arrival or after completion. *)
  Hypothesis H_jobs_must_arrive_to_execute : jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute : completed_jobs_dont_execute sched.

  (** For simplicity, let's define some local names. *)
  Let job_pending := pending sched.
  Let job_completed_by := completed_by sched.
  Let job_scheduled_at := scheduled_at sched.

  (** Then, we prove that fully_nonpreemptive_model is a valid preemption model. *)
  Lemma valid_fully_nonpreemptive_model:
    valid_preemption_model arr_seq sched.
  Proof.
    intros j; split; [by apply/orP; left | split; [by apply/orP; right | split]].
    - move => t; rewrite /job_preemptable /fully_nonpreemptive_model Bool.negb_orb -lt0n; move => /andP [POS NCOMPL].
      move: (incremental_service_during _ _ _ _ _ POS) => [ft [/andP [_ LT] [SCHED SERV]]].
      apply H_nonpreemptive_sched with ft.
      + by apply ltnW.
      + by done.
      + rewrite /completed_by -ltnNge.
        move: NCOMPL; rewrite neq_ltn; move => /orP [LE|GE]; [by done | exfalso].
        move: GE; rewrite ltnNge; move => /negP GE; apply: GE.
        apply completion.service_at_most_cost; eauto 2 with basic_facts.
    - intros t NSCHED SCHED.
      rewrite /job_preemptable /fully_nonpreemptive_model.
      apply/orP; left.
      apply/negP; intros CONTR; move: CONTR => /negP; rewrite -lt0n; intros POS.
      move: (incremental_service_during _ _ _ _ _ POS) => [ft [/andP [_ LT] [SCHEDn SERV]]].
      move: NSCHED => /negP NSCHED; apply: NSCHED.
      apply H_nonpreemptive_sched with ft.
      + by rewrite -ltnS.
      + by done.
      + rewrite /completed_by -ltnNge.
        apply leq_ltn_trans with (service sched j t.+1).
        * by rewrite /service /service_during big_nat_recr //= leq_addr.
        * rewrite -addn1; apply leq_trans with (service sched j t.+2).
          have <-: (service_at sched j t.+1) = 1.
          { by apply/eqP; rewrite eqb1 -scheduled_at_def. }
            by rewrite -big_nat_recr //=.
            by apply completion.service_at_most_cost; eauto 2 with basic_facts.
  Qed.

  (** We also prove that under the fully non-preemptive model
      [job_max_nonpreemptive_segment j] is equal to [job_cost j] ... *)
  Lemma job_max_nps_is_job_cost:
    forall j, job_max_nonpreemptive_segment j = job_cost j.
  Proof.
    intros.
    rewrite /job_max_nonpreemptive_segment /lengths_of_segments
            /job_preemption_points /job_preemptable /fully_nonpreemptive_model.
    case: (posnP (job_cost j)) => [ZERO|POS].
    { by rewrite ZERO; compute. }
    have ->: forall n, n>0 -> [seq ρ <- index_iota 0 n.+1 | (ρ == 0) || (ρ == n)] = [:: 0; n].
    { clear; simpl; intros.
      apply/eqP; rewrite eqseq_cons; apply/andP; split; first by done.
      have ->:  forall xs P1 P2, (forall x, x \in xs -> ~~ P1 x) -> [seq x <- xs | P1 x || P2 x] = [seq x <- xs | P2 x].
      { clear; intros.
        apply eq_in_filter.
        intros ? IN. specialize (H _ IN).
          by destruct (P1 x), (P2 x).
      }
      rewrite filter_pred1_uniq; first by done.
      - by apply iota_uniq.
      - by rewrite mem_iota; apply/andP; split; [done | rewrite add1n].
      - intros x; rewrite mem_iota; move => /andP [POS _].
          by rewrite -lt0n.
    }
    by rewrite /distances; simpl; rewrite subn0 /max0; simpl; rewrite max0n.
      by done.
  Qed.

  (** ... and [job_last_nonpreemptive_segment j] is equal to [job_cost j]. *)
  Lemma job_last_nps_is_job_cost:
    forall j, job_last_nonpreemptive_segment j = job_cost j.
  Proof.
    intros.
    rewrite /job_last_nonpreemptive_segment /lengths_of_segments
            /job_preemption_points /job_preemptable /fully_nonpreemptive_model.
    case: (posnP (job_cost j)) => [ZERO|POS].
    { by rewrite ZERO; compute. }
    have ->: forall n, n>0 -> [seq ρ <- index_iota 0 n.+1 | (ρ == 0) || (ρ == n)] = [:: 0; n].
    { clear; simpl; intros.
      apply/eqP; rewrite eqseq_cons; apply/andP; split; first by done.
      have ->:  forall xs P1 P2, (forall x, x \in xs -> ~~ P1 x) -> [seq x <- xs | P1 x || P2 x] = [seq x <- xs | P2 x].
      { clear; intros.
        apply eq_in_filter.
        intros ? IN. specialize (H _ IN).
          by destruct (P1 x), (P2 x).
      }
      rewrite filter_pred1_uniq; first by done.
      - by apply iota_uniq.
      - by rewrite mem_iota; apply/andP; split; [done | rewrite add1n].
      - intros x; rewrite mem_iota; move => /andP [POS _].
          by rewrite -lt0n.
    }
      by rewrite /distances; simpl; rewrite subn0 /last0; simpl.
      by done.
  Qed.

End FullyNonPreemptiveModel.
Hint Resolve valid_fully_nonpreemptive_model : basic_facts.


(** * Relations on indexed types *)

(* begin hide *)
From Coq Require Import
     Relations
     Setoid.

From ITree Require Import
     Basics.Basics.

Set Universe Polymorphism.
(* end hide *)

(** This is an indexed generalization of the standard [respectful]
    relation ([==>]). *)
Definition i_respectful {A B : Type -> Type}
           (RA : forall T, A T -> A T -> Prop)
           (RB : forall T, B T -> B T -> Prop)
           (f1 f2 : A ~> B)
  : Prop
  := forall T (a1 a2 : A T), RA T a1 a2 -> (RB T) (f1 T a1) (f2 T a2).

Definition i_pointwise {A B : Type -> Type}
           (RB : forall T, B T -> B T -> Prop)
           (f1 f2 : A ~> B)
  : Prop
  := forall T (a : A T), (RB T) (f1 T a) (f2 T a).

#[global]
Instance Reflexive_i_pointwise {A B : Type -> Type}
         (RB : forall T, B T -> B T -> Prop)
         {Reflexive_R : forall T, Reflexive (RB T)}
  : Reflexive (@i_pointwise A B RB).
Proof.
  repeat red; intros; red in Reflexive_R; eauto.
Qed.

#[global]
Instance Symmetric_i_pointwise {A B : Type -> Type}
         (RB : forall T, B T -> B T -> Prop)
         {Symmetric_R : forall T, Symmetric (RB T)}
  : Symmetric (@i_pointwise A B RB).
Proof.
  repeat red; intros; red in Symmetric_R; eauto.
Qed.

#[global]
Instance Transitive_i_pointwise {A B : Type -> Type}
         (RB : forall T, B T -> B T -> Prop)
         {Transitive_R : forall T, Transitive (RB T)}
  : Transitive (@i_pointwise A B RB).
Proof.
  repeat red; intros; red in Transitive_R; eauto.
Qed.

#[global]
Instance Equivalence_i_pointwise {A B : Type -> Type}
         (RB : forall T, B T -> B T -> Prop)
         {Equivalence_R : forall T, Equivalence (RB T)}
  : Equivalence (@i_pointwise A B RB).
Proof.
  split; try typeclasses eauto.
Qed.

#[global]
Instance subrelation_i_pointwise_i_respectful {A B : Type -> Type}
           (RB : forall T, B T -> B T -> Prop)
  : subrelation (i_pointwise RB) (i_respectful (fun T => @eq (A T)) RB).
Proof.
  repeat red; intros; subst; auto.
Qed.

(* This is not an instance, to avoid instance resolution loops. *)
Definition subrelation_i_respectful_i_pointwise {A B : Type -> Type}
           (RB : forall T, B T -> B T -> Prop)
  : subrelation (i_respectful (fun T => @eq (A T)) RB) (i_pointwise RB).
Proof.
  repeat red; auto.
Qed.


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

Copyright (C) 2011-2013 Sylvie Boldo
#<br />#
Copyright (C) 2011-2013 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.
*)

(** * IEEE-754 encoding of binary floating-point data *)
Require Import Fcore.
Require Import Fcore_digits.
Require Import Fcalc_digits.
Require Import Fappli_IEEE.

Section Binary_Bits.

Implicit Arguments exist [[A] [P]].
Implicit Arguments B754_zero [[prec] [emax]].
Implicit Arguments B754_infinity [[prec] [emax]].
Implicit Arguments B754_nan [[prec] [emax]].
Implicit Arguments B754_finite [[prec] [emax]].

(** Number of bits for the fraction and exponent *)
Variable mw ew : Z.
Hypothesis Hmw : (0 < mw)%Z.
Hypothesis Hew : (0 < ew)%Z.

Let emax := Zpower 2 (ew - 1).
Let prec := (mw + 1)%Z.
Let emin := (3 - emax - prec)%Z.
Let binary_float := binary_float prec emax.

Let Hprec : (0 < prec)%Z.
unfold prec.
apply Zle_lt_succ.
now apply Zlt_le_weak.
Qed.

Let Hm_gt_0 : (0 < 2^mw)%Z.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
Qed.

Let He_gt_0 : (0 < 2^ew)%Z.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
Qed.

Hypothesis Hmax : (prec < emax)%Z.

Definition join_bits (s : bool) m e :=
  (Z.shiftl ((if s then Zpower 2 ew else 0) + e) mw + m)%Z.

Lemma join_bits_range :
  forall s m e,
  (0 <= m < 2^mw)%Z ->
  (0 <= e < 2^ew)%Z ->
  (0 <= join_bits s m e < 2 ^ (mw + ew + 1))%Z.
Proof.
intros s m e Hm He.
unfold join_bits.
rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak.
split.
- apply (Zplus_le_compat 0 _ 0) with (2 := proj1 Hm).
  rewrite <- (Zmult_0_l (2^mw)).
  apply Zmult_le_compat_r.
  case s.
  clear -He ; omega.
  now rewrite Zmult_0_l.
  clear -Hm ; omega.
- apply Zlt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z.
  rewrite (Zmult_plus_distr_l _ 1).
  apply Zplus_lt_compat_l.
  now rewrite Zmult_1_l.
  rewrite <- (Zplus_assoc mw), (Zplus_comm mw), Zpower_plus.
  apply Zmult_le_compat_r.
  rewrite Zpower_plus.
  change (2^1)%Z with 2%Z.
  case s ; clear -He ; omega.
  now apply Zlt_le_weak.
  easy.
  clear -Hm ; omega.
  clear -Hew ; omega.
  now apply Zlt_le_weak.
Qed.

Definition split_bits x :=
  let mm := Zpower 2 mw in
  let em := Zpower 2 ew in
  (Zle_bool (mm * em) x, Zmod x mm, Zmod (Zdiv x mm) em)%Z.

Theorem split_join_bits :
  forall s m e,
  (0 <= m < Zpower 2 mw)%Z ->
  (0 <= e < Zpower 2 ew)%Z ->
  split_bits (join_bits s m e) = (s, m, e).
Proof.
intros s m e Hm He.
unfold split_bits, join_bits.
rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak.
apply f_equal2.
apply f_equal2.
(* *)
case s.
apply Zle_bool_true.
apply Zle_0_minus_le.
ring_simplify.
apply Zplus_le_0_compat.
apply Zmult_le_0_compat.
apply He.
now apply Zlt_le_weak.
apply Hm.
apply Zle_bool_false.
apply Zplus_lt_reg_l with (2^mw * (-e))%Z.
replace (2 ^ mw * - e + ((0 + e) * 2 ^ mw + m))%Z with (m * 1)%Z by ring.
rewrite <- Zmult_plus_distr_r.
apply Zlt_le_trans with (2^mw * 1)%Z.
now apply Zmult_lt_compat_r.
apply Zmult_le_compat_l.
clear -He. omega.
now apply Zlt_le_weak.
(* *)
rewrite Zplus_comm.
rewrite Z_mod_plus_full.
now apply Zmod_small.
(* *)
rewrite Z_div_plus_full_l.
rewrite Zdiv_small with (1 := Hm).
rewrite Zplus_0_r.
case s.
replace (2^ew + e)%Z with (e + 1 * 2^ew)%Z by ring.
rewrite Z_mod_plus_full.
now apply Zmod_small.
now apply Zmod_small.
now apply Zgt_not_eq.
Qed.

Theorem join_split_bits :
  forall x,
  (0 <= x < Zpower 2 (mw + ew + 1))%Z ->
  let '(s, m, e) := split_bits x in
  join_bits s m e = x.
Proof.
intros x Hx.
unfold split_bits, join_bits.
rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak.
pattern x at 4 ; rewrite Z_div_mod_eq_full with x (2^mw)%Z.
apply (f_equal (fun v => (v + _)%Z)).
rewrite Zmult_comm.
apply f_equal.
pattern (x / (2^mw))%Z at 2 ; rewrite Z_div_mod_eq_full with (x / (2^mw))%Z (2^ew)%Z.
apply (f_equal (fun v => (v + _)%Z)).
replace (x / 2 ^ mw / 2 ^ ew)%Z with (if Zle_bool (2 ^ mw * 2 ^ ew) x then 1 else 0)%Z.
case Zle_bool.
now rewrite Zmult_1_r.
now rewrite Zmult_0_r.
rewrite Zdiv_Zdiv.
apply sym_eq.
case Zle_bool_spec ; intros Hs.
apply Zle_antisym.
cut (x / (2^mw * 2^ew) < 2)%Z. clear ; omega.
apply Zdiv_lt_upper_bound.
try apply Hx. (* 8.2/8.3 compatibility *)
now apply Zmult_lt_0_compat.
rewrite <- Zpower_exp ; try ( apply Zle_ge ; apply Zlt_le_weak ; assumption ).
change 2%Z at 1 with (Zpower 2 1).
rewrite <- Zpower_exp.
now rewrite Zplus_comm.
discriminate.
apply Zle_ge.
now apply Zplus_le_0_compat ; apply Zlt_le_weak.
apply Zdiv_le_lower_bound.
try apply Hx. (* 8.2/8.3 compatibility *)
now apply Zmult_lt_0_compat.
now rewrite Zmult_1_l.
apply Zdiv_small.
now split.
now apply Zlt_le_weak.
now apply Zlt_le_weak.
now apply Zgt_not_eq.
now apply Zgt_not_eq.
Qed.

Theorem split_bits_inj :
  forall x y,
  (0 <= x < Zpower 2 (mw + ew + 1))%Z ->
  (0 <= y < Zpower 2 (mw + ew + 1))%Z ->
  split_bits x = split_bits y ->
  x = y.
Proof.
intros x y Hx Hy.
generalize (join_split_bits x Hx) (join_split_bits y Hy).
destruct (split_bits x) as ((sx, mx), ex).
destruct (split_bits y) as ((sy, my), ey).
intros Jx Jy H. revert Jx Jy.
inversion_clear H.
intros Jx Jy.
now rewrite <- Jx.
Qed.

Definition bits_of_binary_float (x : binary_float) :=
  match x with
  | B754_zero sx => join_bits sx 0 0
  | B754_infinity sx => join_bits sx 0 (Zpower 2 ew - 1)
  | B754_nan sx (exist plx _) => join_bits sx (Zpos plx) (Zpower 2 ew - 1)
  | B754_finite sx mx ex _ =>
    let m := (Zpos mx - Zpower 2 mw)%Z in
    if Zle_bool 0 m then
      join_bits sx m (ex - emin + 1)
    else
      join_bits sx (Zpos mx) 0
  end.

Definition split_bits_of_binary_float (x : binary_float) :=
  match x with
  | B754_zero sx => (sx, 0, 0)%Z
  | B754_infinity sx => (sx, 0, Zpower 2 ew - 1)%Z
  | B754_nan sx (exist plx _) => (sx, Zpos plx, Zpower 2 ew - 1)%Z
  | B754_finite sx mx ex _ =>
    let m := (Zpos mx - Zpower 2 mw)%Z in
    if Zle_bool 0 m then
      (sx, m, ex - emin + 1)%Z
    else
      (sx, Zpos mx, 0)%Z
  end.

Theorem split_bits_of_binary_float_correct :
  forall x,
  split_bits (bits_of_binary_float x) = split_bits_of_binary_float x.
Proof.
intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] ;
  try ( simpl ; apply split_join_bits ; split ; try apply Zle_refl ; try apply Zlt_pred ; trivial ; omega ).
simpl. apply split_join_bits; split; try (zify; omega).
destruct (digits2_Pnat_correct plx).
rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx.
rewrite Zpower_nat_Z in H0.
eapply Zlt_le_trans. apply H0.
change 2%Z with (radix_val radix2). apply Zpower_le.
rewrite Z.ltb_lt in Hplx.
unfold prec in *. zify; omega.
(* *)
unfold bits_of_binary_float, split_bits_of_binary_float.
assert (Hf: (emin <= ex /\ Zdigits radix2 (Zpos mx) <= prec)%Z).
destruct (andb_prop _ _ Hx) as (Hx', _).
unfold canonic_mantissa in Hx'.
rewrite Zpos_digits2_pos in Hx'.
generalize (Zeq_bool_eq _ _ Hx').
unfold FLT_exp.
unfold emin.
clear ; zify ; omega.
case Zle_bool_spec ; intros H ;
  [ apply -> Z.le_0_sub in H | apply -> Z.lt_sub_0 in H ] ;
  apply split_join_bits ; try now split.
(* *)
split.
clear -He_gt_0 H ; omega.
cut (Zpos mx < 2 * 2^mw)%Z. clear ; omega.
replace (2 * 2^mw)%Z with (2^prec)%Z.
apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)).
apply Hf.
unfold prec.
rewrite Zplus_comm.
apply Zpower_exp ; apply Zle_ge.
discriminate.
now apply Zlt_le_weak.
(* *)
split.
generalize (proj1 Hf).
clear ; omega.
destruct (andb_prop _ _ Hx) as (_, Hx').
unfold emin.
replace (2^ew)%Z with (2 * emax)%Z.
generalize (Zle_bool_imp_le _ _ Hx').
clear ; omega.
apply sym_eq.
rewrite (Zsucc_pred ew).
unfold Zsucc.
rewrite Zplus_comm.
apply Zpower_exp ; apply Zle_ge.
discriminate.
now apply Zlt_0_le_0_pred.
Qed.

Theorem bits_of_binary_float_range:
  forall x, (0 <= bits_of_binary_float x < 2^(mw+ew+1))%Z.
Proof.
unfold bits_of_binary_float.
intros [sx|sx|sx [pl pl_range]|sx mx ex H].
- apply join_bits_range ; now split.
- apply join_bits_range.
  now split.
  clear -He_gt_0 ; omega.
- apply Z.ltb_lt in pl_range.
  apply join_bits_range.
  split.
  easy.
  apply (Zpower_gt_Zdigits radix2 _ (Zpos pl)).
  apply Z.lt_succ_r.
  now rewrite <- Zdigits2_Zdigits.
  clear -He_gt_0 ; omega.
- unfold bounded in H.
  apply Bool.andb_true_iff in H ; destruct H as [A B].
  apply Z.leb_le in B.
  unfold canonic_mantissa, FLT_exp in A. apply Zeq_bool_eq in A.
  case Zle_bool_spec ; intros H.
  + apply join_bits_range.
    * split.
      clear -H ; omega.
      rewrite Zpos_digits2_pos in A.
      cut (Zpos mx < 2 ^ prec)%Z.
      unfold prec.
      rewrite Zpower_plus by (clear -Hmw ; omega).
      change (2^1)%Z with 2%Z.
      clear ; omega.
      apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)).
      clear -A ; zify ; omega.
    * split.
      unfold emin ; clear -A ; zify ; omega.
      replace ew with ((ew - 1) + 1)%Z by ring.
      rewrite Zpower_plus by (clear - Hew ; omega).
      unfold emin, emax in *.
      change (2^1)%Z with 2%Z.
      clear -B ; omega.
  + apply -> Z.lt_sub_0 in H.
    apply join_bits_range ; now split.
Qed.

Definition binary_float_of_bits_aux x :=
  let '(sx, mx, ex) := split_bits x in
  if Zeq_bool ex 0 then
    match mx with
    | Z0 => F754_zero sx
    | Zpos px => F754_finite sx px emin
    | Zneg _ => F754_nan false xH (* dummy *)
    end
  else if Zeq_bool ex (Zpower 2 ew - 1) then
    match mx with
      | Z0 => F754_infinity sx
      | Zpos plx => F754_nan sx plx
      | Zneg _ => F754_nan false xH (* dummy *)
    end
  else
    match (mx + Zpower 2 mw)%Z with
    | Zpos px => F754_finite sx px (ex + emin - 1)
    | _ => F754_nan false xH (* dummy *)
    end.

Lemma binary_float_of_bits_aux_correct :
  forall x,
  valid_binary prec emax (binary_float_of_bits_aux x) = true.
Proof.
intros x.
unfold binary_float_of_bits_aux, split_bits.
case Zeq_bool_spec ; intros He1.
case_eq (x mod 2^mw)%Z ; try easy.
(* subnormal *)
intros px Hm.
assert (Zdigits radix2 (Zpos px) <= mw)%Z.
apply Zdigits_le_Zpower.
simpl.
rewrite <- Hm.
eapply Z_mod_lt.
now apply Zlt_gt.
apply bounded_canonic_lt_emax ; try assumption.
unfold canonic, canonic_exp.
fold emin.
rewrite ln_beta_F2R_Zdigits. 2: discriminate.
unfold Fexp, FLT_exp.
apply sym_eq.
apply Zmax_right.
clear -H Hprec.
unfold prec ; omega.
apply Rnot_le_lt.
intros H0.
refine (_ (ln_beta_le radix2 _ _ _ H0)).
rewrite ln_beta_bpow.
rewrite ln_beta_F2R_Zdigits. 2: discriminate.
unfold emin, prec.
apply Zlt_not_le.
cut (0 < emax)%Z. clear -H Hew ; omega.
apply (Zpower_gt_0 radix2).
clear -Hew ; omega.
apply bpow_gt_0.
simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega.
case Zeq_bool_spec ; intros He2.
case_eq (x mod 2 ^ mw)%Z; try easy.
(* nan *)
intros plx Eqplx. apply Z.ltb_lt.
rewrite Zpos_digits2_pos.
assert (forall a b, a <= b -> a < b+1)%Z by (intros; omega). apply H. clear H.
apply Zdigits_le_Zpower. simpl.
rewrite <- Eqplx. edestruct Z_mod_lt; eauto.
change 2%Z with (radix_val radix2).
apply Z.lt_gt, Zpower_gt_0. omega.
simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega.
case_eq (x mod 2^mw + 2^mw)%Z ; try easy.
simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega.
(* normal *)
intros px Hm.
assert (prec = Zdigits radix2 (Zpos px)).
(* . *)
rewrite Zdigits_ln_beta. 2: discriminate.
apply sym_eq.
apply ln_beta_unique.
rewrite <- Z2R_abs.
unfold Zabs.
replace (prec - 1)%Z with mw by ( unfold prec ; ring ).
rewrite <- Z2R_Zpower with (1 := Zlt_le_weak _ _ Hmw).
rewrite <- Z2R_Zpower. 2: now apply Zlt_le_weak.
rewrite <- Hm.
split.
apply Z2R_le.
change (radix2^mw)%Z with (0 + 2^mw)%Z.
apply Zplus_le_compat_r.
eapply Z_mod_lt.
now apply Zlt_gt.
apply Z2R_lt.
unfold prec.
rewrite Zpower_exp. 2: now apply Zle_ge ; apply Zlt_le_weak. 2: discriminate.
rewrite <- Zplus_diag_eq_mult_2.
apply Zplus_lt_compat_r.
eapply Z_mod_lt.
now apply Zlt_gt.
(* . *)
apply bounded_canonic_lt_emax ; try assumption.
unfold canonic, canonic_exp.
rewrite ln_beta_F2R_Zdigits. 2: discriminate.
unfold Fexp, FLT_exp.
rewrite <- H.
set (ex := ((x / 2^mw) mod 2^ew)%Z).
replace (prec + (ex + emin - 1) - prec)%Z with (ex + emin - 1)%Z by ring.
apply sym_eq.
apply Zmax_left.
revert He1.
fold ex.
cut (0 <= ex)%Z.
unfold emin.
clear ; intros H1 H2 ; omega.
eapply Z_mod_lt.
apply Zlt_gt.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
apply Rnot_le_lt.
intros H0.
refine (_ (ln_beta_le radix2 _ _ _ H0)).
rewrite ln_beta_bpow.
rewrite ln_beta_F2R_Zdigits. 2: discriminate.
rewrite <- H.
apply Zlt_not_le.
unfold emin.
apply Zplus_lt_reg_r with (emax - 1)%Z.
ring_simplify.
revert He2.
set (ex := ((x / 2^mw) mod 2^ew)%Z).
cut (ex < 2^ew)%Z.
replace (2^ew)%Z with (2 * emax)%Z.
clear ; intros H1 H2 ; omega.
replace ew with (1 + (ew - 1))%Z by ring.
rewrite Zpower_exp.
apply refl_equal.
discriminate.
clear -Hew ; omega.
eapply Z_mod_lt.
apply Zlt_gt.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
apply bpow_gt_0.
simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega.
Qed.

Definition binary_float_of_bits x :=
  FF2B prec emax _ (binary_float_of_bits_aux_correct x).

Theorem binary_float_of_bits_of_binary_float :
  forall x,
  binary_float_of_bits (bits_of_binary_float x) = x.
Proof.
intros x.
apply B2FF_inj.
unfold binary_float_of_bits.
rewrite B2FF_FF2B.
unfold binary_float_of_bits_aux.
rewrite split_bits_of_binary_float_correct.
destruct x as [sx|sx|sx [plx Hplx]|sx mx ex Bx].
apply refl_equal.
(* *)
simpl.
rewrite Zeq_bool_false.
now rewrite Zeq_bool_true.
cut (1 < 2^ew)%Z. clear ; omega.
now apply (Zpower_gt_1 radix2).
(* *)
simpl.
rewrite Zeq_bool_false.
rewrite Zeq_bool_true; auto.
cut (1 < 2^ew)%Z. clear ; omega.
now apply (Zpower_gt_1 radix2).
(* *)
unfold split_bits_of_binary_float.
case Zle_bool_spec ; intros Hm.
(* . *)
rewrite Zeq_bool_false.
rewrite Zeq_bool_false.
now ring_simplify (Zpos mx - 2 ^ mw + 2 ^ mw)%Z (ex - emin + 1 + emin - 1)%Z.
destruct (andb_prop _ _ Bx) as (_, H1).
generalize (Zle_bool_imp_le _ _ H1).
unfold emin.
replace (2^ew)%Z with (2 * emax)%Z.
clear ; omega.
replace ew with (1 + (ew - 1))%Z by ring.
rewrite Zpower_exp.
apply refl_equal.
discriminate.
clear -Hew ; omega.
destruct (andb_prop _ _ Bx) as (H1, _).
generalize (Zeq_bool_eq _ _ H1).
rewrite Zpos_digits2_pos.
unfold FLT_exp, emin.
generalize (Zdigits radix2 (Zpos mx)).
clear.
intros ; zify ; omega.
(* . *)
rewrite Zeq_bool_true. 2: apply refl_equal.
simpl.
apply f_equal.
destruct (andb_prop _ _ Bx) as (H1, _).
generalize (Zeq_bool_eq _ _ H1).
rewrite Zpos_digits2_pos.
unfold FLT_exp, emin, prec.
apply -> Z.lt_sub_0 in Hm.
generalize (Zdigits_le_Zpower radix2 _ (Zpos mx) Hm).
generalize (Zdigits radix2 (Zpos mx)).
clear.
intros ; zify ; omega.
Qed.

Theorem bits_of_binary_float_of_bits :
  forall x,
  (0 <= x < 2^(mw+ew+1))%Z ->
  bits_of_binary_float (binary_float_of_bits x) = x.
Proof.
intros x Hx.
unfold binary_float_of_bits, bits_of_binary_float.
set (Cx := binary_float_of_bits_aux_correct x).
clearbody Cx.
rewrite match_FF2B.
revert Cx.
generalize (join_split_bits x Hx).
unfold binary_float_of_bits_aux.
case_eq (split_bits x).
intros (sx, mx) ex Sx.
assert (Bm: (0 <= mx < 2^mw)%Z).
inversion_clear Sx.
apply Z_mod_lt.
now apply Zlt_gt.
case Zeq_bool_spec ; intros He1.
(* subnormal *)
case_eq mx.
intros Hm Jx _.
now rewrite He1 in Jx.
intros px Hm Jx _.
rewrite Zle_bool_false.
now rewrite <- He1.
apply <- Z.lt_sub_0.
now rewrite <- Hm.
intros px Hm _ _.
apply False_ind.
apply Zle_not_lt with (1 := proj1 Bm).
now rewrite Hm.
case Zeq_bool_spec ; intros He2.
(* infinity/nan *)
case_eq mx; intros Hm.
now rewrite He2.
now rewrite He2.
intros. zify; omega.
(* normal *)
case_eq (mx + 2 ^ mw)%Z.
intros Hm.
apply False_ind.
clear -Bm Hm ; omega.
intros p Hm Jx Cx.
rewrite <- Hm.
rewrite Zle_bool_true.
now ring_simplify (mx + 2^mw - 2^mw)%Z (ex + emin - 1 - emin + 1)%Z.
now ring_simplify.
intros p Hm.
apply False_ind.
clear -Bm Hm ; zify ; omega.
Qed.

End Binary_Bits.

(** Specialization for IEEE single precision operations *)
Section B32_Bits.

Implicit Arguments B754_nan [[prec] [emax]].

Definition binary32 := binary_float 24 128.

Let Hprec : (0 < 24)%Z.
apply refl_equal.
Qed.

Let Hprec_emax : (24 < 128)%Z.
apply refl_equal.
Qed.

Definition default_nan_pl32 : bool * nan_pl 24 :=
  (false, exist _ (iter_nat 22 _ xO xH) (refl_equal true)).

Definition unop_nan_pl32 (f : binary32) : bool * nan_pl 24 :=
  match f with
  | B754_nan s pl => (s, pl)
  | _ => default_nan_pl32
  end.

Definition binop_nan_pl32 (f1 f2 : binary32) : bool * nan_pl 24 :=
  match f1, f2 with
  | B754_nan s1 pl1, _ => (s1, pl1)
  | _, B754_nan s2 pl2 => (s2, pl2)
  | _, _ => default_nan_pl32
  end.

Definition b32_opp := Bopp 24 128 pair.
Definition b32_plus := Bplus _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_minus := Bminus _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_mult := Bmult _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_div := Bdiv _ _ Hprec Hprec_emax binop_nan_pl32.
Definition b32_sqrt := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32.

Definition b32_of_bits : Z -> binary32 := binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _).
Definition bits_of_b32 : binary32 -> Z := bits_of_binary_float 23 8.

End B32_Bits.

(** Specialization for IEEE double precision operations *)
Section B64_Bits.

Implicit Arguments B754_nan [[prec] [emax]].

Definition binary64 := binary_float 53 1024.

Let Hprec : (0 < 53)%Z.
apply refl_equal.
Qed.

Let Hprec_emax : (53 < 1024)%Z.
apply refl_equal.
Qed.

Definition default_nan_pl64 : bool * nan_pl 53 :=
  (false, exist _ (iter_nat 51 _ xO xH) (refl_equal true)).

Definition unop_nan_pl64 (f : binary64) : bool * nan_pl 53 :=
  match f with
  | B754_nan s pl => (s, pl)
  | _ => default_nan_pl64
  end.

Definition binop_nan_pl64 (pl1 pl2 : binary64) : bool * nan_pl 53 :=
  match pl1, pl2 with
  | B754_nan s1 pl1, _ => (s1, pl1)
  | _, B754_nan s2 pl2 => (s2, pl2)
  | _, _ => default_nan_pl64
  end.

Definition b64_opp := Bopp 53 1024 pair.
Definition b64_plus := Bplus _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_minus := Bminus _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_mult := Bmult _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_div := Bdiv _ _ Hprec Hprec_emax binop_nan_pl64.
Definition b64_sqrt := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64.

Definition b64_of_bits : Z -> binary64 := binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _).
Definition bits_of_b64 : binary64 -> Z := bits_of_binary_float 52 11.

End B64_Bits.


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

(** printing Max %\ensuremath{\max}% *)
(** printing Min %\ensuremath{\min}% *)

Require Export CoRN.reals.Q_in_CReals.
Require Import Coq.QArith.Qabs.
Require Export CoRN.reals.CauchySeq.

Section Maximum.

Section Max_function.
(**
** Maximum, Minimum and Absolute Value

%\begin{convention}%
Let [x] and [y] be reals
(we will define the maximum of [x] and [y]).
%\end{convention}%
*)

Variables x y : IR.

Definition Max_seq : nat -> IR.
Proof.
 intro i.
 elim (less_cotransitive_unfolded IR [0] (one_div_succ i)) with (x[-]y).
   3: apply one_div_succ_pos.
  intro H; apply x.
 intro H; apply y.
Defined.

Lemma Max_seq_char : forall n,
 [0] [<] x[-]y and Max_seq n [=] x or x[-]y [<] one_div_succ n and Max_seq n [=] y.
Proof.
 intros.
 unfold Max_seq in |- *.
 elim less_cotransitive_unfolded; intro H; simpl in |- *.
  left; split; algebra.
 right; split; algebra.
Qed.

Lemma Cauchy_Max_seq : Cauchy_prop Max_seq.
Proof.
 apply Cauchy_prop1_prop.
 intro k.
 exists k; intros m H.
 unfold Max_seq in |- *.
 elim less_cotransitive_unfolded; intro Hm; simpl in |- *;
   elim less_cotransitive_unfolded; intro Hk; simpl in |- *.
    astepr ZeroR; split; apply less_leEq.
     astepr ( [--]ZeroR); apply inv_resp_less; apply one_div_succ_pos.
    apply one_div_succ_pos.
   apply leEq_imp_AbsSmall; apply less_leEq; auto.
  apply AbsSmall_minus.
  apply leEq_imp_AbsSmall; apply less_leEq; auto.
  apply less_leEq_trans with (one_div_succ (R:=IR) m); auto.
  apply one_div_succ_resp_leEq; auto.
 astepr ZeroR; split; apply less_leEq.
  astepr ( [--]ZeroR); apply inv_resp_less; apply one_div_succ_pos.
 apply one_div_succ_pos.
Qed.

Definition Max_CauchySeq : CauchySeqR.
Proof.
 unfold CauchySeqR in |- *.
 apply Build_CauchySeq with Max_seq.
 exact Cauchy_Max_seq.
Defined.

Definition MAX : IR.
Proof.
 apply Lim.
 exact Max_CauchySeq.
Defined.

(**
Constructively, the elementary properties of the maximum function are:
- [x [<=] Max (x,y)],
- [x [<=] Max (y,x)],
- [z [<] Max(x,y) -> z [<] x or z [<] y].

(This can be more concisely expressed as
[z [<] Max(x,y) Iff z [<] x or z [<] y]).
From these elementary properties we can prove all other properties, including
strong extensionality.
With strong extensionality, we can make the binary operation [Max].
(So [Max] is [MAX] coupled with some proofs.)
*)

Lemma lft_leEq_MAX : x [<=] MAX.
Proof.
 astepr ([0][+]MAX); apply shift_leEq_plus.
 apply approach_zero_weak.
 intros e He.
 apply leEq_wdl with (Lim (Cauchy_const x) [-]MAX).
  2: apply cg_minus_wd; [ apply eq_symmetric_unfolded; apply Lim_const | algebra ].
 unfold MAX in |- *.
 eapply leEq_wdl.
  2: apply Lim_minus.
 simpl in |- *.
 elim (Archimedes ([1][/] e[//]pos_ap_zero _ _ He)); intros n Hn.
 cut ([0] [<] nring (R:=IR) n).
  intro posn.
  apply str_seq_leEq_so_Lim_leEq.
  exists n; intros i Hi.
  simpl in |- *.
  unfold Max_seq in |- *.
  elim less_cotransitive_unfolded; intro H; simpl in |- *.
   astepl ZeroR; apply less_leEq; auto.
  apply less_leEq; eapply less_transitive_unfolded.
   apply H.
  unfold one_div_succ, Snring in |- *; apply shift_div_less.
   apply pos_nring_S.
  apply shift_less_mult' with (pos_ap_zero _ _ He).
   auto.
  eapply leEq_less_trans.
   apply Hn.
  apply nring_less; auto with arith.
 eapply less_leEq_trans.
  2: apply Hn.
 apply recip_resp_pos; auto.
Qed.

Lemma rht_leEq_MAX : y [<=] MAX.
Proof.
 unfold MAX in |- *.
 apply leEq_seq_so_leEq_Lim.
 intro i; simpl in |- *.
 unfold Max_seq in |- *.
 elim less_cotransitive_unfolded; intro H; simpl in |- *.
  2: apply leEq_reflexive.
 apply less_leEq; astepl ([0][+]y).
 apply shift_plus_less; auto.
Qed.

Lemma less_MAX_imp : forall z : IR, z [<] MAX -> z [<] x or z [<] y.
Proof.
 intros z H.
 unfold MAX in H.
 elim (less_Lim_so_less_seq _ _ H).
 intros N HN.
 simpl in HN.
 elim (Max_seq_char N); intro Hseq; inversion_clear Hseq; [ left | right ];
   astepr (Max_seq N); auto with arith.
Qed.

End Max_function.

Lemma MAX_strext : bin_op_strext _ MAX.
Proof.
 unfold bin_op_strext in |- *.
 unfold bin_fun_strext in |- *.
 intros x1 x2 y1 y2 H.
 generalize (ap_imp_less _ _ _ H); intro H0.
 elim H0; intro H1.
  generalize (less_MAX_imp _ _ _ H1); intro H2.
  elim H2; intro H3.
   left.
   apply less_imp_ap.
   apply leEq_less_trans with (MAX x1 y1); auto.
   apply lft_leEq_MAX.
  right.
  apply less_imp_ap.
  apply leEq_less_trans with (MAX x1 y1); auto.
  apply rht_leEq_MAX.
 generalize (less_MAX_imp _ _ _ H1); intro H2.
 elim H2; intro.
  left.
  apply Greater_imp_ap.
  apply leEq_less_trans with (MAX x2 y2); auto.
  apply lft_leEq_MAX.
 right.
 apply Greater_imp_ap.
 apply leEq_less_trans with (MAX x2 y2); auto.
 apply rht_leEq_MAX.
Qed.

Lemma MAX_wd : bin_op_wd IR MAX.
Proof.
 unfold bin_op_wd in |- *.
 apply bin_fun_strext_imp_wd.
 exact MAX_strext.
Qed.

Section properties_of_Max.

(**
*** Maximum *)

Definition Max := Build_CSetoid_bin_op _ MAX MAX_strext.

Lemma Max_wd_unfolded : forall x y x' y',
 x [=] x' -> y [=] y' -> Max x y [=] Max x' y'.
Proof.
 cut (bin_op_wd _ MAX); [ intro | apply MAX_wd ].
 red in H.
 red in H.
 intros; apply H; assumption.
Qed.

Lemma lft_leEq_Max : forall x y : IR, x [<=] Max x y.
Proof.
 unfold Max in |- *.
 simpl in |- *.
 exact lft_leEq_MAX.
Qed.

Lemma rht_leEq_Max : forall x y : IR, y [<=] Max x y.
Proof.
 unfold Max in |- *.
 simpl in |- *.
 exact rht_leEq_MAX.
Qed.

Lemma less_Max_imp : forall x y z : IR, z [<] Max x y -> z [<] x or z [<] y.
Proof.
 unfold Max in |- *.
 simpl in |- *.
 exact less_MAX_imp.
Qed.

Lemma Max_leEq : forall x y z : IR, x [<=] z -> y [<=] z -> Max x y [<=] z.
Proof.
 unfold Max in |- *.
 simpl in |- *.
 intros.
 rewrite -> leEq_def in |- *.
 intro H1.
 generalize (less_MAX_imp _ _ _ H1); intro H2.
 elim H2; intros.
  rewrite -> leEq_def in H; elim H.
  assumption.
 rewrite -> leEq_def in H0; elim H0.
 assumption.
Qed.

Lemma Max_less : forall x y z : IR, x [<] z -> y [<] z -> Max x y [<] z.
Proof.
 intros.
 elim (smaller _ (z[-]x) (z[-]y)). intro e. intros H1 H2. elim H2. clear H2. intros H2 H3.
   cut (z[-]e [/]TwoNZ [<] z). intro H4.
    elim (less_cotransitive_unfolded _ _ _ H4 (Max x y)); intros H5.
     elim (less_Max_imp _ _ _ H5); intros H6.
      cut (Not (e [/]TwoNZ [<] z[-]x)). intro H7. elim H7.
       apply less_leEq_trans with e; auto.
       apply pos_div_two'; auto.
      apply less_antisymmetric_unfolded.
      apply shift_minus_less. apply shift_less_plus'. auto.
      cut (Not (e [/]TwoNZ [<] z[-]y)). intro H7. elim H7.
      apply less_leEq_trans with e; auto.
      apply pos_div_two'; auto.
     apply less_antisymmetric_unfolded.
     apply shift_minus_less. apply shift_less_plus'. auto.
     auto.
   apply shift_minus_less. astepl (z[+][0]).
   apply plus_resp_less_lft. apply pos_div_two. auto.
   apply shift_less_minus. astepl x. auto.
  apply shift_less_minus. astepl y. auto.
Qed.

Lemma equiv_imp_eq_max : forall x x' m, (forall y, x [<=] y -> x' [<=] y -> m [<=] y) ->
 (forall y, m [<=] y -> x [<=] y) -> (forall y, m [<=] y -> x' [<=] y) -> Max x x' [=] m.
Proof.
 intros.
 apply not_ap_imp_eq.
 intros X.
 destruct (ap_imp_less _ _ _ X) as [X0|X0].
  apply (less_irreflexive_unfolded _ (Max x x')).
  apply less_leEq_trans with m.
   assumption.
  apply H.
   apply lft_leEq_Max.
  apply rht_leEq_Max.
 case (less_Max_imp _ _ _ X0).
  change (Not (m[<]x)).
  rewrite <- (leEq_def).
  apply H0.
  apply leEq_reflexive.
 change (Not (m[<]x')).
 rewrite <- (leEq_def).
 apply H1.
 apply leEq_reflexive.
Qed.

Lemma Max_id : forall x : IR, Max x x [=] x.
Proof.
 intros.
 apply equiv_imp_eq_max; auto.
Qed.

Lemma Max_comm : forall x y : IR, Max x y [=] Max y x.
Proof.
 cut (forall x y : IR, Max x y [<=] Max y x).
  intros.
  apply leEq_imp_eq.
   apply H.
  apply H.
 intros.
 apply Max_leEq.
  apply rht_leEq_Max.
 apply lft_leEq_Max.
Qed.

Lemma leEq_imp_Max_is_rht : forall x y : IR, x [<=] y -> Max x y [=] y.
Proof.
 intros.
 apply leEq_imp_eq.
  apply Max_leEq.
   assumption.
  apply leEq_reflexive.
 apply rht_leEq_Max.
Qed.

Lemma Max_is_rht_imp_leEq : forall x y : IR, Max x y [=] y -> x [<=] y.
Proof.
 intros.
 rewrite -> leEq_def in |- *.
 intro H0.
 generalize (less_leEq _ _ _ H0); intro H1.
 generalize (leEq_imp_Max_is_rht _ _ H1); intro.
 cut (y [=] x).
  intro.
  elim (less_irreflexive_unfolded _ x).
  astepl y.
  assumption.
 astepl (Max x y).
 astepr (Max y x).
 apply Max_comm.
Qed.

Lemma Max_minus_eps_leEq : forall x y e,
 [0] [<] e -> {Max x y[-]e [<=] x} + {Max x y[-]e [<=] y}.
Proof.
 intros.
 cut (Max x y[-]e [<] x or Max x y[-]e [<] y).
  intro H0; elim H0; intros; clear H0.
   left; apply less_leEq; assumption.
  right; apply less_leEq; assumption.
 apply less_Max_imp.
 apply shift_minus_less.
 apply shift_less_plus'.
 astepl ZeroR; assumption.
Qed.

Lemma max_one_ap_zero : forall x : IR, Max x [1] [#] [0].
Proof.
 intros.
 apply ap_symmetric_unfolded.
 apply less_imp_ap.
 apply less_leEq_trans with OneR.
  apply pos_one.
 apply rht_leEq_Max.
Qed.

Lemma pos_max_one : forall x : IR, [0] [<] Max x [1].
Proof.
 intro.
 apply less_leEq_trans with OneR; [ apply pos_one | apply rht_leEq_Max ].
Qed.

Lemma x_div_Max_leEq_x :
 forall x y : IR, [0] [<] x -> (x[/] Max y [1][//]max_one_ap_zero _) [<=] x.
Proof.
 intros.
 apply shift_div_leEq'.
  apply pos_max_one.
 astepl ([1][*]x).
 apply mult_resp_leEq_rht; [ apply rht_leEq_Max | apply less_leEq; assumption ].
Qed.

Lemma max_plus : forall (a b c : IR),
Max (a[+]c) (b[+]c) [=] Max a b [+] c.
Proof.
 intros.
 apply equiv_imp_eq_max; intros.
   apply shift_plus_leEq.
   apply Max_leEq; apply shift_leEq_minus; auto.
  apply leEq_transitive with (Max a b [+]c); auto.
  apply plus_resp_leEq.
  apply lft_leEq_Max.
 apply leEq_transitive with (Max a b [+]c); auto.
 apply plus_resp_leEq.
 apply rht_leEq_Max.
Qed.

Lemma max_mult : forall (a b c : IR), [0] [<=] c ->
(Max (c[*]a) (c[*]b)) [=] c[*](Max a b).
Proof.
 intros a b c H.
 apply leEq_imp_eq.
  apply Max_leEq; apply mult_resp_leEq_lft.
     apply lft_leEq_Max.
    assumption.
   apply rht_leEq_Max.
  assumption.
 rewrite -> leEq_def in *.
 intros Z.
 assert (Not (Not ([0][<]c or [0][=]c))).
  intros X.
  apply X.
  right.
  apply not_ap_imp_eq.
  intros Y.
  destruct (ap_imp_less _ _ _ Y) as [Y0|Y0].
   auto.
  auto.
 apply H0.
 intros X.
 generalize Z.
 clear H H0 Z.
 change (Not (Max (c[*]a) (c[*]b)[<]c[*]Max a b)).
 rewrite <- leEq_def.
 destruct X as [c0|c0].
  assert (X:c[#][0]).
   apply ap_symmetric; apply less_imp_ap; assumption.
  apply shift_mult_leEq' with X.
   assumption.
  apply Max_leEq;(apply shift_leEq_div;[assumption|]).
   rstepl (c[*]a); apply lft_leEq_Max.
  rstepl (c[*]b); apply rht_leEq_Max.
 stepl (c[*]a).
  apply lft_leEq_Max.
 csetoid_rewrite_rev c0.
 rational.
Qed.

End properties_of_Max.

End Maximum.

#[global]
Hint Resolve Max_id: algebra.

Section Minimum.

(**
*** Mininum

The minimum is defined by the formula
[Min(x,y) [=] [--]Max( [--]x,[--]y)].
*)

Definition MIN (x y : IR) : IR := [--] (Max [--]x [--]y).

Lemma MIN_wd : bin_op_wd _ MIN.
Proof.
 intros x1 x2 y1 y2.
 unfold MIN in |- *; algebra.
Qed.

Lemma MIN_strext : bin_op_strext _ MIN.
Proof.
 intros x1 x2 y1 y2 H.
 unfold MIN in H.
 assert (H':=(un_op_strext_unfolded _ _ _ _ H)).
 elim (bin_op_strext_unfolded _ _ _ _ _ _ H');
   intro H1; [left | right]; exact (un_op_strext_unfolded _ _ _ _ H1).
Qed.

Definition Min : CSetoid_bin_op IR := Build_CSetoid_bin_op _ MIN MIN_strext.

Lemma Min_wd_unfolded : forall x y a b,
 x [=] a /\ y [=] b -> (Min x y) [=] (Min a b).
Proof.
 intros; inversion H.
 apply MIN_wd; auto.
Qed.

Lemma Min_strext_unfolded : forall x y a b,
 (Min x y) [#] (Min a b) -> x [#] a or y [#] b.
Proof.
 intros.
 apply MIN_strext; auto.
Qed.

Lemma Min_leEq_lft : forall x y : IR, Min x y [<=] x.
Proof.
 intros.
 simpl in |- *; unfold MIN.
 rstepr ( [--][--]x).
 apply inv_resp_leEq.
 apply lft_leEq_Max.
Qed.

Lemma Min_leEq_rht : forall x y : IR, Min x y [<=] y.
Proof.
 intros.
 simpl; unfold MIN.
 rstepr ( [--][--]y).
 apply inv_resp_leEq.
 apply rht_leEq_Max.
Qed.

Lemma Min_less_imp : forall x y z : IR, Min x y [<] z -> x [<] z or y [<] z.
Proof.
 simpl; unfold MIN.
 intros.
 cut ( [--]z [<] [--]x or [--]z [<] [--]y).
  intros H0.
  elim H0; intro.
   left.
   apply inv_cancel_less; assumption.
  right.
  apply inv_cancel_less; assumption.
 apply less_Max_imp.
 apply inv_cancel_less.
 apply less_wdr with z.
  assumption.
 algebra.
Qed.

Lemma leEq_Min : forall x y z : IR, z [<=] x -> z [<=] y -> z [<=] Min x y.
Proof.
 intros.
 simpl; unfold MIN.
 rstepl ( [--][--]z).
 apply inv_resp_leEq.
 apply Max_leEq; apply inv_resp_leEq; assumption.
Qed.

Lemma less_Min : forall x y z : IR, z [<] x -> z [<] y -> z [<] Min x y.
Proof.
 intros.
 simpl; unfold MIN.
 rstepl ( [--][--]z).
 apply inv_resp_less.
 apply Max_less; apply inv_resp_less; assumption.
Qed.

Lemma equiv_imp_eq_min : forall x x' m, (forall y, y [<=] x -> y [<=] x' -> y [<=] m) ->
 (forall y, y [<=] m -> y [<=] x) -> (forall y, y [<=] m -> y [<=] x') -> Min x x' [=] m.
Proof.
 intros x x' m X X0 X1.
 simpl; unfold MIN.
 astepr ( [--][--]m).
 apply un_op_wd_unfolded.
 apply equiv_imp_eq_max.
   intros.
   rstepr ( [--][--]y).
   apply inv_resp_leEq.
   apply X.
    rstepr ( [--][--]x).
    apply inv_resp_leEq.
    assumption.
   rstepr ( [--][--]x').
   apply inv_resp_leEq.
   assumption.
  intros.
  rstepr ( [--][--]y).
  apply inv_resp_leEq.
  apply X0.
  rstepr ( [--][--]m).
  apply inv_resp_leEq.
  assumption.
 intros.
 rstepr ( [--][--]y).
 apply inv_resp_leEq.
 apply X1.
 rstepr ( [--][--]m).
 apply inv_resp_leEq.
 assumption.
Qed.

Lemma Min_id : forall x : IR, Min x x [=] x.
Proof.
 intro.
 simpl; unfold MIN.
 astepr ( [--][--]x).
 apply un_op_wd_unfolded; apply Max_id.
Qed.

Lemma Min_comm : forall x y : IR, Min x y [=] Min y x.
Proof.
 intros.
 simpl; unfold MIN.
 apply un_op_wd_unfolded; apply Max_comm.
Qed.

Lemma leEq_imp_Min_is_lft : forall x y : IR, x [<=] y -> Min x y [=] x.
Proof.
 intros.
 simpl; unfold MIN.
 astepr ( [--][--]x).
 apply un_op_wd_unfolded.
 apply eq_transitive_unfolded with (Max [--]y [--]x).
  apply Max_comm.
 apply leEq_imp_Max_is_rht.
 apply inv_resp_leEq.
 assumption.
Qed.

Lemma Min_is_lft_imp_leEq : forall x y : IR, Min x y [=] x -> x [<=] y.
Proof.
 simpl; unfold MIN.
 intros.
 rstepl ( [--][--]x).
 rstepr ( [--][--]y).
 apply inv_resp_leEq.
 apply Max_is_rht_imp_leEq.
 astepl ( [--][--] (Max [--]y [--]x)).
 apply eq_transitive_unfolded with ( [--][--] (Max [--]x [--]y)).
  apply un_op_wd_unfolded; apply un_op_wd_unfolded; apply Max_comm.
 apply un_op_wd_unfolded; assumption.
Qed.

Lemma leEq_Min_plus_eps : forall x y e,
 [0] [<] e -> {x [<=] Min x y[+]e} + {y [<=] Min x y[+]e}.
Proof.
 intros.
 cut (x [<] Min x y[+]e or y [<] Min x y[+]e).
  intro H0; elim H0; intros; clear H0.
   left; apply less_leEq; assumption.
  right; apply less_leEq; assumption.
 apply Min_less_imp.
 apply shift_less_plus'.
 astepl ZeroR; assumption.
Qed.

Variables a b : IR.

Lemma Min_leEq_Max : Min a b [<=] Max a b.
Proof.
 intros.
 apply leEq_transitive with a; [ apply Min_leEq_lft | apply lft_leEq_Max ].
Qed.

Lemma Min_leEq_Max' : forall z : IR, Min a z [<=] Max b z.
Proof.
 intros; apply leEq_transitive with z.
  apply Min_leEq_rht.
 apply rht_leEq_Max.
Qed.

Lemma Min3_leEq_Max3 : forall c : IR, Min (Min a b) c [<=] Max (Max a b) c.
Proof.
 intros; eapply leEq_transitive.
  apply Min_leEq_rht.
 apply rht_leEq_Max.
Qed.

Lemma Min_less_Max : forall c d : IR, a [<] b -> Min a c [<] Max b d.
Proof.
 intros.
 apply leEq_less_trans with a.
  apply Min_leEq_lft.
 apply less_leEq_trans with b.
  assumption.
 apply lft_leEq_Max.
Qed.

Lemma ap_imp_Min_less_Max : a [#] b -> Min a b [<] Max a b.
Proof.
 intro Hap; elim (ap_imp_less _ _ _ Hap); (intro H; [ eapply leEq_less_trans;
   [ idtac | eapply less_leEq_trans; [ apply H | idtac ] ] ]).
    apply Min_leEq_lft.
   apply rht_leEq_Max.
  apply Min_leEq_rht.
 apply lft_leEq_Max.
Qed.

Lemma Min_less_Max_imp_ap : Min a b [<] Max a b -> a [#] b.
Proof.
 intro H.
 elim (Min_less_imp _ _ _ H); clear H; intro H; elim (less_Max_imp _ _ _ H); intro H0.
    exfalso; exact (less_irreflexive _ _ H0).
   apply less_imp_ap; auto.
  apply Greater_imp_ap; auto.
 exfalso; exact (less_irreflexive _ _ H0).
Qed.

Lemma Max_monotone : forall (f: PartIR),
 (forall (x y:IR) Hx Hy, (Min a b)[<=]x -> x[<=]y -> y[<=](Max a b) ->
   (f x Hx)[<=](f y Hy)) ->
forall Ha Hb Hc, (Max (f a Ha) (f b Hb)) [=] f (Max a b) Hc.
Proof.
 intros f H Ha Hb Hc.
 apply leEq_imp_eq.
  apply Max_leEq; apply H; (apply leEq_reflexive || apply Min_leEq_lft || apply Min_leEq_rht ||
    apply lft_leEq_Max || apply rht_leEq_Max).
 rewrite -> leEq_def.
 intros X.
 apply (leEq_or_leEq IR a b).
 intros H0.
 generalize X; clear X.
 change (Not (Max (f a Ha) (f b Hb)[<]f (Max a b) Hc)).
 rewrite <- leEq_def.
 destruct H0.
  stepl (f b Hb).
   apply rht_leEq_Max.
  apply pfwdef.
  apply eq_symmetric; apply leEq_imp_Max_is_rht.
  assumption.
 stepl (f a Ha).
  apply lft_leEq_Max.
 apply pfwdef.
 stepr (Max b a).
  apply eq_symmetric; apply leEq_imp_Max_is_rht.
  assumption.
 now apply Max_comm.
Qed.

Lemma Min_monotone : forall (f: PartIR),
 (forall (x y:IR) Hx Hy, (Min a b)[<=]x -> x[<=]y -> y[<=](Max a b) ->
   (f x Hx)[<=](f y Hy)) ->
forall Ha Hb Hc, (Min (f a Ha) (f b Hb)) [=] f (Min a b) Hc.
Proof.
 intros f H Ha Hb Hc.
 apply leEq_imp_eq;[| apply leEq_Min; apply H; (apply leEq_reflexive || apply Min_leEq_lft ||
   apply Min_leEq_rht || apply lft_leEq_Max || apply rht_leEq_Max)].
 rewrite -> leEq_def.
 intros X.
 apply (leEq_or_leEq IR a b).
 intros H0.
 generalize X; clear X.
 change (Not (f (Min a b) Hc[<]Min (f a Ha) (f b Hb))).
 rewrite <- leEq_def.
 destruct H0.
  stepr (f a Ha).
   apply Min_leEq_lft.
  apply pfwdef.
  apply eq_symmetric; apply leEq_imp_Min_is_lft.
  assumption.
 stepr (f b Hb).
  apply Min_leEq_rht.
 apply pfwdef.
 stepr (Min b a).
  apply eq_symmetric; apply leEq_imp_Min_is_lft.
  assumption.
 apply Min_comm.
Qed.

End Minimum.

(*---------------------------------*)
Section Absolute.
(*---------------------------------*)

(**
*** Absolute value *)

Definition ABSIR (x : IR) : IR := Max x [--]x.

Lemma ABSIR_strext : un_op_strext _ ABSIR.
Proof.
 unfold un_op_strext in |- *.
 unfold fun_strext in |- *.
 unfold ABSIR in |- *.
 intros.
 generalize (csbf_strext _ _ _ Max); intro H0.
 unfold bin_fun_strext in H0.
 generalize (H0 _ _ _ _ X); intro H1.
 elim H1.
  intro H2.
  assumption.
 intro H2.
 apply zero_minus_apart.
 generalize (minus_ap_zero _ _ _ H2); intro H3.
 generalize (inv_resp_ap_zero _ _ H3); intro H4.
 cut (x[-]y [=] [--] ( [--]x[-][--]y)).
  intro.
  astepl ( [--] ( [--]x[-][--]y)). auto.
  rational.
Qed.

Lemma ABSIR_wd : un_op_wd _ ABSIR.
Proof.
 unfold un_op_wd in |- *.
 apply fun_strext_imp_wd.
 exact ABSIR_strext.
Qed.

Definition AbsIR : CSetoid_un_op IR := Build_CSetoid_un_op _ ABSIR ABSIR_strext.

Lemma AbsIR_wd : forall x y : IR, x [=] y -> AbsIR x [=] AbsIR y.
Proof.
 algebra.
Qed.

Lemma AbsIR_wdl : forall x y e, x [=] y -> AbsIR x [<] e -> AbsIR y [<] e.
Proof.
 intros.
 apply less_wdl with (AbsIR x).
  assumption.
 algebra.
Qed.

Lemma AbsIR_wdr : forall x y e, x [=] y -> e [<] AbsIR x -> e [<] AbsIR y.
Proof.
 intros.
 apply less_wdr with (AbsIR x).
  assumption.
 algebra.
Qed.

Lemma AbsIRz_isz : AbsIR [0] [=] [0].
Proof.
 intros. unfold AbsIR in |- *. simpl in |- *. unfold ABSIR in |- *.
 Step_final (Max [0] [0]).
Qed.

Lemma AbsIR_nonneg : forall x : IR, [0] [<=] AbsIR x.
Proof.
 intro x; rewrite -> leEq_def; intro H.
 cut ([0] [<] ZeroR).
  apply less_irreflexive.
 apply less_wdl with (AbsIR x); auto.
 eapply eq_transitive_unfolded.
  2: apply AbsIRz_isz.
 apply AbsIR_wd.
 unfold AbsIR in H; simpl in H; unfold ABSIR in H.
 apply leEq_imp_eq; apply less_leEq.
  apply leEq_less_trans with (Max x [--]x).
   apply lft_leEq_Max.
  assumption.
 apply inv_cancel_less.
 apply leEq_less_trans with (Max x [--]x).
  apply rht_leEq_Max.
 astepr ZeroR; auto.
Qed.

Lemma AbsIR_pos : forall x : IR, x [#] [0] -> [0] [<] AbsIR x.
Proof.
 intros.
 cut (x [<] [0] or [0] [<] x).
  2: apply ap_imp_less; assumption.
 intros H0.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *.
 elim H0.
  intro.
  apply less_leEq_trans with ( [--]x).
   astepl ( [--]ZeroR).
   apply inv_resp_less.
   assumption.
  apply rht_leEq_Max.
 intro.
 apply less_leEq_trans with x.
  assumption.
 apply lft_leEq_Max.
Qed.

Lemma AbsIR_cancel_ap_zero : forall x : IR, AbsIR x [#] [0] -> x [#] [0].
Proof.
 intros.
 apply un_op_strext_unfolded with AbsIR.
 apply ap_wdr_unfolded with ZeroR.
  assumption.
 apply eq_symmetric_unfolded; apply AbsIRz_isz.
Qed.

Lemma AbsIR_resp_ap_zero : forall x : IR, x [#] [0] -> AbsIR x [#] [0].
Proof.
 intros.
 apply ap_symmetric_unfolded; apply less_imp_ap.
 apply AbsIR_pos; assumption.
Qed.

Lemma leEq_AbsIR : forall x : IR, x [<=] AbsIR x.
Proof.
 intros.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *; apply lft_leEq_Max.
Qed.

Lemma inv_leEq_AbsIR : forall x : IR, [--]x [<=] AbsIR x.
Proof.
 intros.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *; apply rht_leEq_Max.
Qed.

Lemma AbsSmall_e : forall e x : IR, AbsSmall e x -> [0] [<=] e.
Proof.
 intros.
 red in H.
 cut ( [--]e [<=] e).
  2: inversion_clear H; apply leEq_transitive with x; assumption.
 intro.
 apply mult_cancel_leEq with (Two:IR); astepl ZeroR.
  apply pos_two.
 rstepr (e[+]e).
 apply shift_leEq_plus; astepl ( [--]e).
 assumption.
Qed.

Lemma AbsSmall_imp_AbsIR : forall x y : IR, AbsSmall y x -> AbsIR x [<=] y.
Proof.
 intros.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *.
 inversion_clear H.
 apply Max_leEq.
  assumption.
 apply inv_cancel_leEq.
 astepr x; auto.
Qed.

Lemma AbsIR_eq_AbsSmall : forall x e : IR, [--]e [<=] x -> x [<=] e -> AbsSmall e x.
Proof.
 intros.
 unfold AbsSmall in |- *.
 auto.
Qed.

Lemma AbsIR_imp_AbsSmall : forall x y : IR, AbsIR x [<=] y -> AbsSmall y x.
Proof.
 intros.
 unfold AbsSmall in |- *.
 simpl in H.
 unfold ABSIR in H.
 simpl in H.
 split.
  generalize (rht_leEq_Max x [--]x).
  intro H1.
  generalize (leEq_transitive _ _ (MAX x [--]x) _ H1 H).
  intro H2.
  rstepr ( [--][--]x).
  apply inv_resp_leEq.
  assumption.
 generalize (lft_leEq_Max x [--]x).
 intro H1.
 generalize (leEq_transitive _ _ (MAX x [--]x) _ H1 H).
 auto.
Qed.

Lemma AbsSmall_transitive : forall e x y : IR,
 AbsSmall e x -> AbsIR y [<=] AbsIR x -> AbsSmall e y.
Proof.
 intros.
 apply AbsIR_imp_AbsSmall.
 eapply leEq_transitive.
  apply H0.
 apply AbsSmall_imp_AbsIR; assumption.
Qed.

Lemma zero_less_AbsIR_plus_one : forall q : IR, [0] [<] AbsIR q[+][1].
Proof.
 intros.
 apply less_leEq_trans with ([0][+]OneR).
  rstepr OneR; apply pos_one.
 apply plus_resp_leEq; apply AbsIR_nonneg.
Qed.

Lemma AbsIR_inv : forall x : IR, AbsIR x [=] AbsIR [--]x.
Proof.
 intros.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *.
 apply eq_transitive_unfolded with (Max [--][--]x [--]x).
  apply bin_op_wd_unfolded; algebra.
 apply Max_comm.
Qed.

Lemma AbsIR_minus : forall x y : IR, AbsIR (x[-]y) [=] AbsIR (y[-]x).
Proof.
 intros.
 eapply eq_transitive_unfolded.
  apply AbsIR_inv.
 apply AbsIR_wd; rational.
Qed.

Lemma AbsIR_mult : forall (x c: IR) (H : [0] [<=]c),
c[*] AbsIR (x) [=] AbsIR (c[*]x).
Proof.
 intros.
 unfold AbsIR.
 simpl.
 unfold ABSIR.
 rstepr (Max (c[*]x) (c[*]([--]x))).
 apply eq_symmetric_unfolded.
 apply max_mult; auto.
Qed.

Lemma AbsIR_eq_x : forall x : IR, [0] [<=] x -> AbsIR x [=] x.
Proof.
 intros.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *.
 apply eq_transitive_unfolded with (Max [--]x x).
  apply Max_comm.
 apply leEq_imp_Max_is_rht.
 apply leEq_transitive with ZeroR.
  2: assumption.
 astepr ( [--]ZeroR).
 apply inv_resp_leEq.
 assumption.
Qed.

Lemma AbsIR_eq_inv_x : forall x : IR, x [<=] [0] -> AbsIR x [=] [--]x.
Proof.
 intros.
 apply eq_transitive_unfolded with (AbsIR [--]x).
  apply AbsIR_inv.
 apply AbsIR_eq_x.
 astepl ( [--]ZeroR).
 apply inv_resp_leEq.
 assumption.
Qed.

Lemma less_AbsIR : forall x y, [0] [<] x -> x [<] AbsIR y -> x [<] y or y [<] [--]x.
Proof.
 intros x y H H0.
 simpl in H0.
 unfold ABSIR in H0.
 cut (x [<] y or x [<] [--]y).
  intro H1; inversion_clear H1.
   left; assumption.
  right; astepl ( [--][--]y); apply inv_resp_less; assumption.
 apply less_Max_imp; assumption.
Qed.

Lemma leEq_distr_AbsIR : forall x y : IR,
 [0] [<] x -> x [<=] AbsIR y -> {x [<=] y} + {y [<=] [--]x}.
Proof.
 intros.
 cut (x[*]Three [/]FourNZ [<] AbsIR y); intros.
  elim (less_AbsIR (x[*]Three [/]FourNZ) y); intros; [ left | right | idtac | auto ].
    astepr ([0][+]y); apply shift_leEq_plus.
    apply approach_zero.
    cut (forall e : IR, [0] [<] e -> e [<] x [/]TwoNZ -> x[-]y [<] e); intros.
     cut (x [/]FourNZ [<] x [/]TwoNZ); intros.
      2: rstepl ((x [/]TwoNZ) [/]TwoNZ); apply pos_div_two'; apply pos_div_two; auto.
     rename X3 into H4.
     elim (less_cotransitive_unfolded _ _ _ H4 e); intro.
      apply leEq_less_trans with (x [/]FourNZ); auto.
      apply less_leEq.
      apply shift_minus_less; apply shift_less_plus'.
      rstepl (x[*]Three [/]FourNZ); auto.
     rename X1 into H2. apply H2; auto.
     apply shift_minus_less; apply shift_less_plus'.
    cut (x[-]e [<] AbsIR y); intros.
     2: apply less_leEq_trans with x; auto.
     2: apply shift_minus_less; apply shift_less_plus'; astepl ZeroR; auto.
    elim (less_AbsIR (x[-]e) y); auto.
     intro; exfalso.
     apply (less_irreflexive_unfolded _ y).
     eapply leEq_less_trans.
      2: apply a.
     apply less_leEq; eapply less_transitive_unfolded.
      apply b.
     astepl ([0][-] (x[-]e)).
     apply shift_minus_less.
     astepr (x[*]Three [/]FourNZ[+]x[-]e).
     apply shift_less_minus; astepl e.
     eapply less_leEq_trans.
      rename X2 into H3. apply H3.
      apply less_leEq.
     rstepl (x[*] ([0][+][0][+][1] [/]TwoNZ)); rstepr (x[*] ([1][+][1] [/]FourNZ[+][1] [/]TwoNZ)).
     apply mult_resp_less_lft; auto.
     apply plus_resp_less_rht; apply plus_resp_less_leEq.
      apply pos_one.
     apply less_leEq; apply pos_div_four; apply pos_one.
    apply shift_less_minus; astepl e.
    eapply less_leEq_trans.
     rename X2 into H3. apply H3.
     apply less_leEq; apply pos_div_two'; auto.
   astepr ([0][+][--]x); apply shift_leEq_plus.
   apply leEq_wdl with (y[+]x).
    2: unfold cg_minus in |- *; algebra.
   apply approach_zero.
   cut (forall e : IR, [0] [<] e -> e [<] x [/]TwoNZ -> y[+]x [<] e); intros.
    cut (x [/]FourNZ [<] x [/]TwoNZ); intros.
     2: rstepl ((x [/]TwoNZ) [/]TwoNZ); apply pos_div_two'; apply pos_div_two; auto.
    rename X3 into H4.
    elim (less_cotransitive_unfolded _ _ _ H4 e); intro.
     apply leEq_less_trans with (x [/]FourNZ); auto.
     apply less_leEq; apply shift_plus_less.
     rstepr ( [--] (x[*]Three [/]FourNZ)); auto.
    rename X1 into H2. apply H2; auto.
    cut (x[-]e [<] AbsIR y); intros.
    2: apply less_leEq_trans with x; auto.
    2: apply shift_minus_less; apply shift_less_plus'; astepl ZeroR; auto.
   elim (less_AbsIR (x[-]e) y); auto.
     intro; exfalso.
     apply (less_irreflexive_unfolded _ y).
     eapply leEq_less_trans.
      2: apply a.
     apply less_leEq; eapply less_transitive_unfolded.
      apply b.
     apply shift_less_minus; apply shift_plus_less'.
     eapply less_transitive_unfolded.
      rename X2 into H3. apply H3.
      rstepl (x[*] ([0][+][0][+][1] [/]TwoNZ)); rstepr (x[*] ([1][+][1] [/]FourNZ[+][1] [/]TwoNZ)).
     apply mult_resp_less_lft; auto.
     apply plus_resp_less_rht; apply plus_resp_less_leEq.
      apply pos_one.
     apply less_leEq; apply pos_div_four; apply pos_one.
    intro.
    rstepl (y[-][--]x).
    apply shift_minus_less.
    rstepr ( [--] (x[-]e)); auto.
   apply shift_less_minus; astepl e.
   eapply less_leEq_trans.
    rename X2 into H3. apply H3.
    apply less_leEq; apply pos_div_two'; auto.
  astepl (ZeroR[*]Three [/]FourNZ).
  apply mult_resp_less; auto.
  apply pos_div_four; apply pos_three.
 apply less_leEq_trans with x; auto.
 astepr (x[*][1]).
 astepr (x[*]Four [/]FourNZ).
 apply mult_resp_less_lft; auto.
 apply div_resp_less.
  apply pos_four.
 apply three_less_four.
Qed.

Lemma AbsIR_approach_zero : forall x, (forall e, [0] [<] e -> AbsIR x [<=] e) -> x [=] [0].
Proof.
 intros.
 apply leEq_imp_eq.
  apply approach_zero_weak.
  intros e H0.
  eapply leEq_transitive; [ apply leEq_AbsIR | exact (H e H0) ].
 astepl ( [--]ZeroR); astepr ( [--][--]x); apply inv_resp_leEq.
 apply approach_zero_weak.
 intros e H0.
 eapply leEq_transitive; [ apply inv_leEq_AbsIR | exact (H e H0) ].
Qed.

Lemma AbsSmall_approach :
forall (a b : IR),
  (forall (e : IR), [0][<]e -> AbsSmall (a[+]e) b) -> AbsSmall a b.
Proof.
 unfold AbsSmall.
 intros a b H.
 split.
  assert (forall e : IR, [0][<]e -> [--]a[-]b[<=]e).
   intros.
   assert ([--](a[+]e)[<=]b /\ b[<=]a[+]e).
    apply H; auto. destruct H0.
   apply shift_minus_leEq.
   apply shift_leEq_plus'.
   astepl ([--]a[+][--]e).
   astepl ([--](a[+]e)).
   auto.
  astepr (b[+][0]).
  apply shift_leEq_plus'.
  apply approach_zero_weak; auto.
 assert (forall e : IR, [0][<]e -> b[-]a[<=]e).
  intros.
  assert ([--](a[+]e)[<=]b /\ b[<=]a[+]e).
   apply H; auto. destruct H0.
  apply shift_minus_leEq.
  astepr (a[+]e).
  auto.
 astepr (a[+][0]).
 apply shift_leEq_plus'.
 apply approach_zero_weak; auto.
Qed.

Lemma AbsIR_eq_zero : forall x : IR, AbsIR x [=] [0] -> x [=] [0].
Proof.
 intros.
 apply AbsIR_approach_zero; intros.
 astepl ZeroR; apply less_leEq; auto.
Qed.

Lemma Abs_Max : forall a b : IR, AbsIR (a[-]b) [=] Max a b[-]Min a b.
Proof.
 intros.
 apply leEq_imp_eq.
  apply leEq_wdl with (Max (a[-]b) (b[-]a)).
   2: simpl in |- *; unfold ABSIR in |- *.
   2: apply Max_wd_unfolded; rational.
  apply Max_leEq.
   unfold cg_minus in |- *; apply plus_resp_leEq_both.
    apply lft_leEq_Max.
   apply inv_resp_leEq; apply Min_leEq_rht.
  unfold cg_minus in |- *; apply plus_resp_leEq_both.
   apply rht_leEq_Max.
  apply inv_resp_leEq; apply Min_leEq_lft.
 astepr ([0][+]AbsIR (a[-]b)).
 apply shift_leEq_plus.
 apply approach_zero_weak.
 intros.
 do 2 apply shift_minus_leEq.
 eapply leEq_wdr.
  2: apply CSemiGroups.plus_assoc.
 apply shift_leEq_plus'.
 rename X into H.
 elim (Max_minus_eps_leEq a b e H); intro.
  apply leEq_transitive with a.
   assumption.
  apply shift_leEq_plus'.
  apply leEq_Min.
   apply shift_minus_leEq; apply shift_leEq_plus'.
   astepl ZeroR; apply AbsIR_nonneg.
  apply shift_minus_leEq; apply shift_leEq_plus'.
  apply leEq_AbsIR.
 apply leEq_transitive with b.
  assumption.
 apply shift_leEq_plus'.
 apply leEq_Min.
  apply shift_minus_leEq; apply shift_leEq_plus'.
  rstepl ( [--] (a[-]b)); apply inv_leEq_AbsIR.
 apply shift_minus_leEq; apply shift_leEq_plus'.
 astepl ZeroR; apply AbsIR_nonneg.
Qed.

Lemma AbsIR_str_bnd : forall a b e : IR, AbsIR (a[-]b) [<] e -> b [<] a[+]e.
Proof.
 intros.
 apply shift_less_plus'.
 apply leEq_less_trans with (AbsIR (a[-]b)); auto.
 eapply leEq_wdr; [ apply leEq_AbsIR | apply AbsIR_minus ].
Qed.

Lemma AbsIR_bnd : forall a b e : IR, AbsIR (a[-]b) [<=] e -> b [<=] a[+]e.
Proof.
 intros.
 apply shift_leEq_plus'.
 apply leEq_transitive with (AbsIR (a[-]b)); auto.
 eapply leEq_wdr; [ apply leEq_AbsIR | apply AbsIR_minus ].
Qed.

Lemma AbsIR_less : forall a b, a[<]b -> [--]b[<]a -> AbsIR a[<]b.
Proof.
 intros a b H0 H1.
 destruct (smaller _ _ _ (shift_zero_less_minus _ _ _ H0) (shift_zero_less_minus _ _ _ H1)) as
   [z Hz0 [Hz1 Hz2]].
 apply shift_zero_less_minus'.
 eapply less_leEq_trans.
  apply Hz0.
 apply shift_leEq_minus.
 apply shift_plus_leEq'.
 apply AbsSmall_imp_AbsIR.
 split.
  rstepl (z[-]b).
  apply shift_minus_leEq.
  rstepr (a[-][--]b).
  assumption.
 apply shift_leEq_minus.
 apply shift_plus_leEq'.
 assumption.
Qed.

Lemma AbsIR_Qabs : forall (a:Q), AbsIR (inj_Q IR a)[=]inj_Q IR (Qabs a).
Proof.
 intros a.
 apply Qabs_case; intros H.
  apply AbsIR_eq_x.
  stepl (inj_Q IR [0]).
   apply inj_Q_leEq.
   assumption.
  now apply (inj_Q_nring IR 0).
 stepr ([--](inj_Q IR a)).
  apply AbsIR_eq_inv_x.
  stepr (inj_Q IR [0]).
   apply inj_Q_leEq.
   assumption.
  now apply (inj_Q_nring IR 0).
 apply eq_symmetric. apply inj_Q_inv.
Qed.

End Absolute.

#[global]
Hint Resolve AbsIRz_isz: algebra.

Section SeqMax.

(**
*** Bound of sequence *)

Variable seq : nat -> IR.

Fixpoint SeqBound0 (n : nat) : IR :=
    match n with
     | O => [0]
     | S m => Max (AbsIR (seq m)) (SeqBound0 m)
    end.

Lemma SeqBound0_greater : forall (m n : nat),
  (m < n)%nat -> AbsIR (seq m) [<=] SeqBound0 n.
Proof.
 intros.
 elim H.
  simpl. apply lft_leEq_MAX.
  intros. simpl.
 apply leEq_transitive with (SeqBound0 m0); auto.
 apply rht_leEq_MAX.
Qed.

End SeqMax.

Section Part_Function_Max.

(**
*** Functional Operators

The existence of these operators allows us to lift them to functions.  We will define the maximum, minimum and absolute value of two partial functions.

%\begin{convention}%
Let [F,G:PartIR] and denote by [P] and [Q] their respective domains.
%\end{convention}%
*)

Variables F G : PartIR.

(* begin hide *)
Let P := Dom F.
Let Q := Dom G.
(* end hide *)

Lemma part_function_Max_strext : forall x y (Hx : Conj P Q x) (Hy : Conj P Q y),
 Max (F x (Prj1 Hx)) (G x (Prj2 Hx)) [#] Max (F y (Prj1 Hy)) (G y (Prj2 Hy)) ->
 x [#] y.
Proof.
 intros. rename X into H.
 elim (cs_bin_op_strext _ _ _ _ _ _ H).
  exact (pfstrx _ F _ _ _ _).
 exact (pfstrx _ G _ _ _ _).
Qed.

Definition FMax := Build_PartFunct IR _ (conj_wd (dom_wd _ _) (dom_wd _ _))
 (fun x Hx => Max (F x (Prj1 Hx)) (G x (Prj2 Hx))) part_function_Max_strext.

End Part_Function_Max.

Section Part_Function_Abs.

Variables F G : PartIR.

(* begin hide *)
Let P := Dom F.
Let Q := Dom G.
(* end hide *)

Definition FMin := {--} (FMax {--}F {--}G).
Definition FAbs := FMax F {--}F.

Lemma FMin_char : forall x Hx Hx' Hx'', FMin x Hx [=] Min (F x Hx') (G x Hx'').
Proof.
 intros.
 Opaque Max.
 simpl in |- *; unfold MIN; algebra.
Qed.

Transparent Max.

Lemma FAbs_char : forall x Hx Hx', FAbs x Hx [=] AbsIR (F x Hx').
Proof.
 intros.
 simpl in |- *; unfold ABSIR in |- *; apply MAX_wd; algebra.
Qed.

End Part_Function_Abs.

#[global]
Hint Resolve FAbs_char: algebra.

Lemma FAbs_char' : forall F x Hx, AbsIR (FAbs F x Hx) [=] AbsIR (F x (ProjIR1 Hx)).
Proof.
 intros.
 eapply eq_transitive_unfolded.
  apply AbsIR_eq_x.
  2: apply FAbs_char.
 eapply leEq_wdr.
  2: apply eq_symmetric_unfolded; apply FAbs_char with (Hx' := ProjIR1 Hx).
 apply AbsIR_nonneg.
Qed.

Lemma FAbs_nonneg : forall F x Hx, [0] [<=] FAbs F x Hx.
Proof.
 intros.
 eapply leEq_wdr.
  2: apply eq_symmetric_unfolded; apply FAbs_char with (Hx' := ProjIR1 Hx).
 apply AbsIR_nonneg.
Qed.

#[global]
Hint Resolve FAbs_char': algebra.

Section Inclusion.

Variables F G : PartIR.

(* begin hide *)
Let P := Dom F.
Let Q := Dom G.
(* end hide *)

(**
%\begin{convention}% Let [R:IR->CProp].
%\end{convention}%
*)

Variable R : IR -> CProp.

Lemma included_FMax : included R P -> included R Q -> included R (Dom (FMax F G)).
Proof.
 intros; simpl in |- *; apply included_conj; assumption.
Qed.

Lemma included_FMax' : included R (Dom (FMax F G)) -> included R P.
Proof.
 intro H; simpl in H; eapply included_conj_lft; apply H.
Qed.

Lemma included_FMax'' : included R (Dom (FMax F G)) -> included R Q.
Proof.
 intro H; simpl in H; eapply included_conj_rht; apply H.
Qed.

Lemma included_FMin : included R P -> included R Q -> included R (Dom (FMin F G)).
Proof.
 intros; simpl in |- *; apply included_conj; assumption.
Qed.

Lemma included_FMin' : included R (Dom (FMin F G)) -> included R P.
Proof.
 intro H; simpl in H; eapply included_conj_lft; apply H.
Qed.

Lemma included_FMin'' : included R (Dom (FMin F G)) -> included R Q.
Proof.
 intro H; simpl in H; eapply included_conj_rht; apply H.
Qed.

Lemma included_FAbs : included R P -> included R (Dom (FAbs F)).
Proof.
 intros; simpl in |- *; apply included_conj; assumption.
Qed.

Lemma included_FAbs' : included R (Dom (FAbs F)) -> included R P.
Proof.
 intro H; simpl in H; eapply included_conj_lft; apply H.
Qed.

End Inclusion.

#[global]
Hint Resolve included_FMax included_FMin included_FAbs : included.

#[global]
Hint Immediate included_FMax' included_FMin' included_FAbs'
  included_FMax'' included_FMin'' : included.