(* ***************************************************************** *)
(* Types.v                                                           *)
(*                                                                   *)
(* 2019 Xuan Huang                                                   *)
(* ***************************************************************** *)

(* ################################################################# *)
(** * Types *)

(* It's interesting that if we use

     Require Export Int.
     Require Export Float.

   Here, we will later hit errors in [Execution.v] saying:

     (cannot unify "I32.t" and "Values.I32.t").

   This might be a bug or intentional of Coq.
   Issue posted: https://github.com/coq/coq/issues/10869
 *)

From Wasm Require Import Int.
From Wasm Require Import Float.
From Wasm Require Export Commons.

(* ----------------------------------------------------------------- *)
(** *** Value Types *)

Inductive valtype :=
  | T_i32
  | T_i64
  | T_f32
  | T_f64.

Definition eqb_valtype (ty1 ty2: valtype) : bool :=
  match ty1, ty2 with
  | T_i32, T_i32 => true
  | T_i64, T_i64 => true
  | T_f32, T_f32 => true
  | T_f64, T_f64 => true
  | _, _ => false
  end.

Definition all_valtype (ts: list valtype) (t': valtype) :=
  forallb (fun t => eqb_valtype t t') ts.

Lemma eqb_valtype_refl : forall (ty: valtype),
  eqb_valtype ty ty = true.
Proof.
  destruct ty; auto.
Qed.

Lemma eqb_valtype_eq : forall (ty1 ty2: valtype),
  eqb_valtype ty1 ty2 = true -> ty1 = ty2.
Proof with eauto.
  intro ty1.
  destruct ty1;
    intros ty2 Heqb;
    destruct ty2; inversion Heqb...
Qed.

(** Having eq_dec is equivalent to having eqb and its spec
    How? https://coq.inria.fr/library/Coq.Structures.Equalities.html
  *)
Lemma valtype_eq_dec: forall (ty1 ty2: valtype), {ty1 = ty2} + {ty1 <> ty2}.
Proof.
  decide equality.
Qed.

Module TestValtypeEq.

  Example ex1 : all_valtype [T_i32] T_i32 = true. auto. Qed.

End TestValtypeEq.

(* ----------------------------------------------------------------- *)
(** *** Result Types *)

(** the current spec use optional occurence such as

      Definition resulttype : Type := option valtype.

    while we moved to the "multi-value" proposal where

      resulttype ::= [vec(valtype)]

    See option valtype section below.
 *)

Notation resulttype := (list valtype).

(* ----------------------------------------------------------------- *)
(** *** Function Types *)

Inductive functype := FT (_ _: resulttype).
(*
Record functype :=
  {
    FT_ins  : resulttype;
    FT_outs : resulttype;
  }.
*)

Module FunctypeNotations.

  (* Notation "ts1 --> ts2" := *)
  (*   ({| FT_ins := ts1; FT_outs := ts2|}) *)

  Notation "ts1 --> ts2" := (FT ts1 ts2)
    (at level 30, right associativity) : wasm_scope.
  Open Scope wasm_scope.

End FunctypeNotations.

(** Testing *)

Module TypesTest.

  Example ex_res1: resulttype := [].
  Example ex_res2: resulttype := [T_i32].
  Example ex_fun: functype := FT [T_i32] [T_i32].

  (* Func Notation Testing *)

  Import FunctypeNotations.

  Example ex_fun_nu : functype := [] --> [T_i32].

  Example ex_fun_un : functype := [T_i32] --> [T_i32].

  Example ex_fun_bin : functype := [T_i32; T_i32] --> [T_i32].

  (* cannot looser than ++ *)
  Example ex_fun_loose : functype := ([T_i32] ++ [T_i32]) --> [T_i32].

End TypesTest.

(* ----------------------------------------------------------------- *)
(** *** Limits *)

(* techinically the spec use [u32], which mean we should interpter
   this [I32.t] as unsigned integers. *)

Record limits :=
  {
    L_min: Int.I32.t;
    L_max: option Int.I32.t;
  }.

(* ----------------------------------------------------------------- *)
(** *** Memory Types *)

Definition memtype := limits.

(* ----------------------------------------------------------------- *)
(** *** Table Types *)

(* according to spec:

   > The element type [funcref] is the infinite union of all function types.
     A table of that type thus contains references to functions of
     heterogeneous type.

   the [Call_indirect] will fetch index into this table,
   and the type of function is **checked dynamically**

   combined it can represent *function pointer* and dynamic linking.
 *)

(* We don't need ET since [funcref] is a unique name. *)
Inductive elemtype := funcref.

Definition tabletype : Type := limits * elemtype.

(* ----------------------------------------------------------------- *)
(** *** Global Types *)

Inductive mut :=
  | GT_const
  | GT_var.

Definition globaltype : Type := mut * valtype.

(* ----------------------------------------------------------------- *)
(** *** External Types *)

Inductive externtype :=
  | ET_func (ft: functype)
  | ET_table (tt: tabletype)
  | ET_mem (mt: memtype)
  | ET_global (gt: globaltype).

(* ----------------------------------------------------------------- *)
(** *** Option ValType Occurence *)

(* Not currently used in favor of plain [option value]
   Potential uses would be [blocktype] and module [M_return].
 *)

Definition opt_valtype := (option valtype).

Definition opt_to_rt (opt : opt_valtype) : resulttype :=
  match opt with
  | Some valtype => [valtype]
  | None => []
  end.

Coercion opt_to_rt : opt_valtype >-> resulttype.

Module OptionValTyTest.

  Import FunctypeNotations.

  Example valtype1 : opt_valtype := Some T_i32.
  Example valtype2 : opt_valtype := None.

  Example ft_some := [] --> opt_to_rt valtype1.
  Example ft_some2 := [] --> valtype1.

End OptionValTyTest.


From coqutil Require Import sanity.
From coqutil Require Import HList.
From coqutil Require List.
From coqutil Require Import Datatypes.PropSet.

Module map.
  Class map {key value} := mk {
    rep : Type;

    (* fundamental operation, all others are axiomatized in terms of this one *)
    get: rep -> key -> option value;

    empty : rep;
    put : rep -> key -> value -> rep;
    remove : rep -> key -> rep;
    fold{R: Type}: (R -> key -> value -> R) -> R -> rep -> R;
  }.
  Arguments map : clear implicits.
  Global Coercion rep : map >-> Sortclass.
  Global Hint Mode map + + : typeclass_instances.
  Local Hint Mode map - - : typeclass_instances.

  Class ok {key value : Type} {map : map key value}: Prop := {
    map_ext : forall m1 m2, (forall k, get m1 k = get m2 k) -> m1 = m2;
    get_empty : forall k, get empty k = None;
    get_put_same : forall m k v, get (put m k v) k = Some v;
    get_put_diff : forall m k v k', k <> k' -> get (put m k' v) k = get m k;
    get_remove_same : forall m k, get (remove m k) k = None;
    get_remove_diff : forall m k k', k <> k' -> get (remove m k') k = get m k;
    fold_spec{R: Type} : forall (P: rep -> R -> Prop) (f: R -> key -> value -> R) r0,
        P empty r0 ->
        (forall k v m r, get m k = None -> P m r -> P (put m k v) (f r k v)) ->
        forall m, P m (fold f r0 m);
    (* Folding over a map preserves relations: *)
    fold_parametricity: forall {A B : Type} (R : A -> B -> Prop)
                               (fa: A -> key -> value -> A) (fb: B -> key -> value -> B),
        (forall a b k v, R a b -> R (fa a k v) (fb b k v)) ->
        forall a0 b0, R a0 b0 -> forall m, R (fold fa a0 m) (fold fb b0 m);

  }.
  Arguments ok {_ _} _.

  Section WithMap. Local Set Default Proof Using "All".
    Context {key value : Type} {map : map key value} {map_ok : ok map}.

    Definition update (m : map) (k : key) (ov : option value) :=
      match ov with
      | None => remove m k
      | Some v => put m k v
      end.
    Definition putmany: map -> map -> map := fold put.
    Definition extends (m1 m2 : map) := forall x w, get m2 x = Some w -> get m1 x = Some w.
    Definition agree_on (P : set key) m1 m2 := forall k, elem_of k P -> get m1 k = get m2 k.
    Definition only_differ(m1: map)(ks: set key)(s2: map) :=
      forall x, elem_of x ks \/ get m1 x = get s2 x.
    Definition undef_on m P := agree_on P m empty.
    Definition injective(m: map): Prop :=
      forall k1 k2 v,
        map.get m k1 = Some v -> map.get m k2 = Some v -> k1 = k2.
    Definition not_in_range(m: map)(l: list value): Prop :=
      List.Forall (fun v => forall k, map.get m k <> Some v) l.
    Definition disjoint (a b : map) :=
      forall k v1 v2, get a k = Some v1 -> get b k = Some v2 -> False.
    Definition sub_domain(m1 m2: map): Prop :=
      forall k v1, map.get m1 k = Some v1 -> exists v2, map.get m2 k = Some v2.
    Definition same_domain(m1 m2: map): Prop := sub_domain m1 m2 /\ sub_domain m2 m1.
    Definition forall_keys(P : key -> Prop)(m : map): Prop :=
      forall k v, map.get m k = Some v -> P k.
    Definition forall_values(P: value -> Prop)(m: map): Prop :=
      forall k v, map.get m k = Some v -> P v.
    Definition forallb(f: key -> value -> bool): map -> bool :=
      map.fold (fun res k v => andb res (f k v)) true.
    Definition singleton(k: key)(v: value): map := map.put map.empty k v.

    Definition split m m1 m2 := m = (putmany m1 m2) /\ disjoint m1 m2.

    Definition getmany_of_list (m : map) (keys : list key) : option (list value) :=
      List.option_all (List.map (get m) keys).

    Fixpoint putmany_of_list (l : list (key*value)) (init : rep) {struct l} : map :=
      match l with
      | nil => init
      | cons (k,v) l =>
        putmany_of_list l (put init k v)
      end.
    Fixpoint of_list (l : list (key * value)) : rep :=
      match l with
      | nil => map.empty
      | cons (k,v) l => put (of_list l) k v
      end.

    Definition keys(m : map): list key := fold (fun acc k v => cons k acc) nil m.

    Definition tuples(m: map): list (key * value) := fold (fun l k v => cons (k, v) l) nil m.

    Fixpoint putmany_of_list_zip (keys : list key) (values : list value) (init : rep) {struct keys} : option map :=
      match keys, values with
      | nil, nil => Some init
      | cons k keys, cons v values =>
        putmany_of_list_zip keys values (put init k v)
      | _, _ => None
      end.
    Definition of_list_zip keys values := putmany_of_list_zip keys values empty.

    Fixpoint putmany_of_disjoint_list_zip (keys : list key) (values : list value) (init : rep)
             {struct keys} : option map :=
      match keys, values with
      | nil, nil => Some init
      | cons k keys, cons v values =>
        match putmany_of_disjoint_list_zip keys values init with
        | Some m => match get m k with
                    | Some _ => None
                    | None => Some (put m k v)
                    end
        | None => None
        end
      | _, _ => None
      end.
    Definition of_disjoint_list_zip keys values := putmany_of_disjoint_list_zip keys values empty.

    Import PrimitivePair.

    Definition getmany_of_tuple(m: map){sz: nat}(keys: tuple key sz): option (tuple value sz) :=
      tuple.option_all (tuple.map (get m) keys).

    Fixpoint putmany_of_tuple {sz : nat} : tuple key sz -> tuple value sz -> map -> map :=
      match sz with
      | O => fun keys values init => init
      | S sz' => fun '(pair.mk k ks) '(pair.mk v vs) init =>
                   put (putmany_of_tuple ks vs init) k v
      end.
    Definition of_tuple {sz : nat} (keys: tuple key sz) (values: tuple value sz) :=
      putmany_of_tuple keys values empty.
  End WithMap.
End map. Local Notation map := map.map.
Global Coercion map.rep : map >-> Sortclass.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Ranalysis2.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import Ranalysis1.
Open Local Scope R_scope.

(**********)
Lemma formule :
  forall (x h l1 l2:R) (f1 f2:R -> R),
    h <> 0 ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (f1 (x + h) / f2 (x + h) - f1 x / f2 x) / h -
    (l1 * f2 x - l2 * f1 x) / Rsqr (f2 x) =
    / f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1) +
    l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h)) -
    f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) +
    l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x).
Proof.
  intros; unfold Rdiv, Rminus, Rsqr in |- *.
  repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
    repeat rewrite Rinv_mult_distr; try assumption.
  replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x));
  [ idtac | ring ].
  replace (l1 * (/ f2 x * / f2 (x + h)) * f2 x) with
  (l1 * / f2 (x + h) * (f2 x * / f2 x)); [ idtac | ring ].
  replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with
  (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ].
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with
  (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h)));
  [ idtac | ring ].
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with
  (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x)));
  [ idtac | ring ].
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with
  (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h)));
  [ idtac | ring ].
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with
  (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x)));
  [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try assumption || ring.
  apply prod_neq_R0; assumption.
Qed.

(* begin hide *)
Notation Rmin_pos := Rmin_pos (only parsing). (* compat *)
(* end hide *)

Lemma maj_term1 :
  forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall h:R,
      h <> 0 ->
      Rabs h < alp_f1d ->
      Rabs ((f1 (x + h) - f1 x) / h - l1) < Rabs (eps * f2 x / 8)) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f1d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) < eps / 4.
Proof.
  intros.
  assert (H7 := H3 h H6).
  assert (H8 := H2 h H4 H5).
  apply Rle_lt_trans with
    (2 / Rabs (f2 x) * Rabs ((f1 (x + h) - f1 x) / h - l1)).
  rewrite Rabs_mult.
  apply Rmult_le_compat_r.
  apply Rabs_pos.
  rewrite Rabs_Rinv; [ left; exact H7 | assumption ].
  apply Rlt_le_trans with (2 / Rabs (f2 x) * Rabs (eps * f2 x / 8)).
  apply Rmult_lt_compat_l.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ prove_sup0 | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
  exact H8.
  right; unfold Rdiv in |- *.
  repeat rewrite Rabs_mult.
  rewrite Rabs_Rinv; discrR.
  replace (Rabs 8) with 8.
  replace 8 with 8; [ idtac | ring ].
  rewrite Rinv_mult_distr; [ idtac | discrR | discrR ].
  replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with
  (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x)));
  [ idtac | ring ].
  replace (Rabs eps) with eps.
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry  in |- *; apply Rabs_right; left; assumption.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
Qed.

Lemma maj_term2 :
  forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal)
    (f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall a:R,
      Rabs a < alp_f2t2 ->
      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2t2 ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    l1 <> 0 -> Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) < eps / 4.
Proof.
  intros.
  assert (H8 := H3 h H6).
  assert (H9 := H2 h H5).
  apply Rle_lt_trans with
    (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  rewrite Rabs_mult; apply Rmult_le_compat_l.
  apply Rabs_pos.
  rewrite <- (Rabs_Ropp (f2 x - f2 (x + h))); rewrite Ropp_minus_distr.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
    try assumption || discrR.
  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR.
  unfold Rdiv in |- *.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  rewrite (Rmult_comm 2).
  replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
  (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
  repeat rewrite Rabs_Rinv; try assumption.
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H8; exact H8.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  right.
  unfold Rsqr, Rdiv in |- *.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * (Rabs l1 * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (eps * (Rabs (f2 x) * Rabs (f2 x)) * (/ 4 * / 2 * / Rabs l1))) with
  (eps * / 4 * (Rabs l1 * / Rabs l1) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try (apply Rabs_no_R0; assumption) || discrR.
  ring.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
  symmetry  in |- *; apply Rabs_right; left; assumption.
Qed.

Lemma maj_term3 :
  forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall h:R,
      h <> 0 ->
      Rabs h < alp_f2d ->
      Rabs ((f2 (x + h) - f2 x) / h - l2) <
      Rabs (Rsqr (f2 x) * eps / (8 * f1 x))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> 0 ->
    Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) <
    eps / 4.
Proof.
  intros.
  assert (H8 := H2 h H4 H5).
  assert (H9 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H8.
  apply Rlt_le_trans with
    (Rabs (2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
    try assumption.
  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption.
  unfold Rdiv in |- *.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  rewrite (Rmult_comm 2).
  replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
  (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
  repeat rewrite Rabs_Rinv; assumption || idtac.
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H9; exact H9.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  right.
  unfold Rsqr, Rdiv in |- *.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * eps * (/ 4 * / 2 * / Rabs (f1 x)))) with
  (eps * / 4 * (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f1 x) * / Rabs (f1 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
  symmetry  in |- *; apply Rabs_right; left; assumption.
Qed.

Lemma maj_term4 :
  forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall a:R,
      Rabs a < alp_f2c ->
      Rabs (f2 (x + a) - f2 x) <
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2c ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> 0 ->
    l2 <> 0 ->
    Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x)) <
    eps / 4.
Proof.
  intros.
  assert (H9 := H2 h H5).
  assert (H10 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (2 * l2 * (f1 x / (Rsqr (f2 x) * f2 x))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
    assumption || idtac.
  red in |- *; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0.
  apply prod_neq_R0.
  discrR.
  assumption.
  assumption.
  unfold Rdiv in |- *.
  repeat rewrite Rinv_mult_distr;
    try assumption || (unfold Rsqr in |- *; apply prod_neq_R0; assumption).
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  replace
  (2 * Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 x)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * (Rabs (/ f2 x) * 2))));
  [ idtac | ring ].
  replace
  (Rabs l2 * Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr in |- *;
    apply prod_neq_R0; assumption.
  repeat rewrite Rabs_Rinv; [ idtac | assumption | assumption ].
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H10; exact H10.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  right; unfold Rsqr, Rdiv in |- *.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * Rabs l2 *
    (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * Rabs (f2 x) * eps *
      (/ 4 * / 2 * / Rabs (f1 x) * / Rabs l2))) with
  (eps * / 4 * (Rabs l2 * / Rabs l2) * (Rabs (f1 x) * / Rabs (f1 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
  symmetry  in |- *; apply Rabs_right; left; assumption.
  apply prod_neq_R0; assumption || discrR.
  apply prod_neq_R0; assumption.
Qed.

Lemma D_x_no_cond : forall x a:R, a <> 0 -> D_x no_cond x (x + a).
Proof.
  intros.
  unfold D_x, no_cond in |- *.
  split.
  trivial.
  apply Rminus_not_eq.
  unfold Rminus in |- *.
  rewrite Ropp_plus_distr.
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  apply Ropp_neq_0_compat; assumption.
Qed.

Lemma Rabs_4 :
  forall a b c d:R, Rabs (a + b + c + d) <= Rabs a + Rabs b + Rabs c + Rabs d.
Proof.
  intros.
  apply Rle_trans with (Rabs (a + b) + Rabs (c + d)).
  replace (a + b + c + d) with (a + b + (c + d)); [ apply Rabs_triang | ring ].
  apply Rle_trans with (Rabs a + Rabs b + Rabs (c + d)).
  apply Rplus_le_compat_r.
  apply Rabs_triang.
  repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
  apply Rabs_triang.
Qed.

Lemma Rlt_4 :
  forall a b c d e f g h:R,
    a < b -> c < d -> e < f -> g < h -> a + c + e + g < b + d + f + h.
Proof.
  intros; apply Rlt_trans with (b + c + e + g).
  repeat apply Rplus_lt_compat_r; assumption.
  repeat rewrite Rplus_assoc; apply Rplus_lt_compat_l.
  apply Rlt_trans with (d + e + g).
  rewrite Rplus_assoc; apply Rplus_lt_compat_r; assumption.
  rewrite Rplus_assoc; apply Rplus_lt_compat_l; apply Rlt_trans with (f + g).
  apply Rplus_lt_compat_r; assumption.
  apply Rplus_lt_compat_l; assumption.
Qed.

(* begin hide *)
Notation Rmin_2 := Rmin_glb_lt (only parsing).
(* end hide *)

Lemma quadruple : forall x:R, 4 * x = x + x + x + x.
Proof.
  intro; ring.
Qed.

Lemma quadruple_var : forall x:R, x = x / 4 + x / 4 + x / 4 + x / 4.
Proof.
  intro; rewrite <- quadruple.
  unfold Rdiv in |- *; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
  reflexivity.
Qed.

(**********)
Lemma continuous_neq_0 :
  forall (f:R -> R) (x0:R),
    continuity_pt f x0 ->
    f x0 <> 0 ->
    exists eps : posreal, (forall h:R, Rabs h < eps -> f (x0 + h) <> 0).
Proof.
  intros; unfold continuity_pt in H; unfold continue_in in H;
    unfold limit1_in in H; unfold limit_in in H; elim (H (Rabs (f x0 / 2))).
  intros; elim H1; intros.
  exists (mkposreal x H2).
  intros; assert (H5 := H3 (x0 + h)).
  cut
    (dist R_met (x0 + h) x0 < x ->
      dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / 2)).
  unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
    replace (x0 + h - x0) with h.
  intros; assert (H7 := H6 H4).
  red in |- *; intro.
  rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7;
    rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7;
      pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7.
  cut (0 < Rabs (f x0)).
  intro; assert (H10 := Rmult_lt_reg_l _ _ _ H9 H7).
  cut (Rabs (/ 2) = / 2).
  assert (Hyp : 0 < 2).
  prove_sup0.
  intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10);
    rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12;
      [ idtac | discrR ].
  cut (IZR 1 < IZR 2).
  unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro;
    elim (Rlt_irrefl 1 (Rlt_trans _ _ _ H13 H12)).
  apply IZR_lt; omega.
  unfold Rabs in |- *; case (Rcase_abs (/ 2)); intro.
  assert (Hyp : 0 < 2).
  prove_sup0.
  assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp r); rewrite Rmult_0_r in H11;
    rewrite <- Rinv_r_sym in H11; [ idtac | discrR ].
  elim (Rlt_irrefl 0 (Rlt_trans _ _ _ Rlt_0_1 H11)).
  reflexivity.
  apply (Rabs_pos_lt _ H0).
  ring.
  assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
  intro; rewrite <- H7; unfold dist, R_met in |- *; unfold R_dist in |- *;
    unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
      apply Rabs_pos_lt.
  unfold Rdiv in |- *; apply prod_neq_R0;
    [ assumption | apply Rinv_neq_0_compat; discrR ].
  intro; apply H5.
  split.
  unfold D_x, no_cond in |- *.
  split; trivial || assumption.
  assumption.
  change (0 < Rabs (f x0 / 2)) in |- *.
  apply Rabs_pos_lt; unfold Rdiv in |- *; apply prod_neq_R0.
  assumption.
  apply Rinv_neq_0_compat; discrR.
Qed.


(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)
(*                                                                     *)
(*  Frobenius theorem                                                  *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)

Require Import ssreflect ssrbool ssrfun ssrnat.
Require Import eqtype fintype div ssralg bigops prime finset.
Require Import groups morphisms action normal cyclic center pgroups.

(* Require Import seq paths connect zp. *)

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

Import GroupScope.

Definition Ldiv (gT : finGroupType) n := [set z : gT | z ^+ n == 1].

Notation "''Ldiv_' n ()" := (Ldiv _ n)
  (at level 8, n at level 2, format "''Ldiv_' n ()") : group_scope.

Notation "''Ldiv_' n ( G )" := (G :&: 'Ldiv_n())
  (at level 8, n at level 2, format "''Ldiv_' n ( G )") : group_scope.

Theorem Frobenius_Ldiv : forall (gT : finGroupType) (G : {group gT}) n,
  n %| #|G| -> n %| #|'Ldiv_n(G)|.
Proof.
move=> gT G n nG; move: {2}_.+1 (ltnSn (#|G| %/ n)) => mq.
elim: mq => // mq IHm in gT G n nG *; case/dvdnP: nG => q oG.
have [q_pos n_pos] : 0 < q /\ 0 < n by apply/andP; rewrite -ltn_0mul -oG.
rewrite ltnS oG mulnK // => leqm.
have:= q_pos; rewrite leq_eqVlt; case/predU1P=> [q1 | lt1q].
  rewrite -(mul1n n) q1 -oG (setIidPl _) //.
  by apply/subsetP=> x Gx; rewrite inE -order_dvd order_dvd_g.
pose p := pdiv q; have pr_p: prime p by exact: prime_pdiv.
have lt1p: 1 < p := prime_gt1 pr_p; have p_pos := ltnW lt1p.
have{leqm} lt_qp_mq: q %/ p < mq by apply: leq_trans leqm; rewrite ltn_Pdiv.
have: n %| #|'Ldiv_(p * n)(G)|.
  have: p * n %| #|G| by rewrite oG dvdn_pmul2r ?dvdn_pdiv.
  move/IHm=> IH; apply: dvdn_trans (IH _); first exact: dvdn_mull.
  by rewrite oG divn_pmul2r.
rewrite -(cardsID 'Ldiv_n()) dvdn_addl.
  rewrite -setIA ['Ldiv_n(_)](setIidPr _) //.
  apply/subsetP=> x; rewrite !inE -!order_dvd; exact: dvdn_mull.
rewrite setDE -setIA -setDE; set A := _ :\: _.
have pA: forall x, x \in A -> #[x]`_p = (n`_p * p)%N.
  move=> x; rewrite !inE -!order_dvd; case/andP=> xn xnp.
  rewrite !p_part // -expnSr; congr (p ^ _)%N; apply/eqP.
  rewrite eqn_leq -{1}addn1 -(pfactorK 1 pr_p) -logn_mul ?expn1 // mulnC.
  rewrite dvdn_leq_log ?ltn_0mul ?p_pos //= ltnNge; apply: contra xn => xn.
  move: xnp; rewrite -[#[x]](partnC p) //.
  rewrite !gauss_inv ?coprime_partC //; case/andP=> _.
  rewrite p_part ?pfactor_dvdn // xn gauss // coprime_sym.
  exact: pnat_coprime (pnat_id _) (pnat_part _ _).
rewrite -(partnC p n_pos) gauss_inv ?coprime_partC //; apply/andP; split.
  rewrite -sum1_card (partition_big_imset (@cycle _)) /=.
  apply: dvdn_sum => X; case/imsetP=> x; case/setIP=> Gx Ax ->{X}.
  rewrite (eq_bigl (generator <[x]>)) => [|y].
    rewrite sum1_card -phi_gen -[#[x]](partnC p) // phi_mult ?coprime_partC //.
    rewrite dvdn_mulr // (pA x Ax) p_part // -expnSr.
    by rewrite phi_prime_k // expnS dvdn_sub ?dvdn_mull.
  rewrite /generator eq_sym andbC; case xy: {+}(_ == _) => //.
  rewrite !inE -!order_dvd in Ax *.
  by rewrite -cycle_subG /order -(eqP xy) cycle_subG Gx.
rewrite -sum1_card (partition_big_imset (fun x => x.`_p ^: G)) /=.
apply: dvdn_sum => X; case/imsetP=> x; case/setIP=> Gx Ax ->{X}.
set y := x.`_p; have oy: #[y] = (n`_p * p)%N by rewrite order_constt pA.
rewrite (partition_big (fun x => x.`_p) (mem (y ^: G))) /= => [|z]; last first.
  by case/andP=> _; move/eqP <-; rewrite /= class_refl.
pose G' := ('C_G[y] / <[y]>)%G; pose n' := gcdn #|G'| n`_p^'.
have n'_pos: 0 < n' by rewrite ltn_0gcd ltn_0group.
rewrite (eq_bigr (fun _ => #|'Ldiv_n'(G')|)) => [|ya].
  rewrite sum_nat_const -index_cent1 indexgI.
  rewrite -(dvdn_pmul2l (ltn_0group 'C_G[y])) mulnA LaGrangeI.
  have oCy: #|'C_G[y]| = (#[y] * #|G'|)%N.
    rewrite card_quotient ?subcent1_cycle_norm // LaGrange //.
    by rewrite subcent1_cycle_sub ?groupX.
  rewrite oCy -mulnA -(muln_lcm_gcd #|G'|) -/n' mulnA dvdn_mul //.
    rewrite muln_lcmr -oCy order_constt pA // mulnAC partnC // dvdn_lcm.
    by rewrite cardSg ?subsetIl // mulnC oG dvdn_pmul2r ?dvdn_pdiv.
  apply: IHm; [exact: dvdn_gcdl | apply: leq_ltn_trans lt_qp_mq].
  rewrite -(@divn_pmul2r n`_p^') // -muln_lcm_gcd mulnC divn_pmul2l //.
  rewrite leq_divr // divn_mulAC ?leq_divl ?dvdn_mulr ?dvdn_lcmr //.
  rewrite dvdn_leq ?ltn_0mul ?q_pos //= mulnC muln_lcmr dvdn_lcm.
  rewrite -(@dvdn_pmul2l n`_p) // mulnA -oy -oCy mulnCA partnC // -oG.
  by rewrite cardSg ?subsetIl // dvdn_mul ?dvdn_pdiv.
case/imsetP=> a Ga ->{ya}.
pose h := [fun z => coset <[y]> (z ^ a^-1)].
pose h' := [fun Z : coset_of <[y]> => (y * (repr Z).`_p^') ^ a].
rewrite -sum1_card (reindex_onto h h') /= => [|Z]; last first.
  rewrite conjgK coset_kerl ?cycle_id ?morph_constt ?repr_coset_norm //.
  rewrite /= coset_reprK 2!inE -order_dvd dvdn_gcd; case/and3P=> _ _ p'Z.
  apply: constt_p_elt (pnat_dvd p'Z _); exact: pnat_part.
apply: eq_bigl => z; apply/andP/andP=> [[]|[]].
  rewrite inE -andbA; case/and3P=> Gz Az _; move/eqP=> zp_ya.
  have czy: z ^ a^-1 \in 'C[y].
    rewrite -mem_conjg -normJ conjg_set1 -zp_ya.
    by apply/cent1P; exact: commuteX.
  have Nz:  z ^ a^-1 \in 'N(<[y]>) by apply: subsetP czy; exact: norm_gen.
  have G'z: h z \in G' by rewrite mem_morphim //= inE groupJ // groupV.
  rewrite inE G'z inE -order_dvd dvdn_gcd order_dvd_g //=.
  rewrite /order -morphim_cycle // -quotientE card_quotient ?cycle_subG //.
  rewrite -(@dvdn_pmul2l #[y]) // LaGrange; last first.
    by rewrite /= cycleJ cycle_subG mem_conjgV -zp_ya mem_cycle.
  rewrite oy mulnAC partnC // [#|_|]orderJ; split.
    by rewrite !inE -!order_dvd mulnC in Az; case/andP: Az.
  set Z := coset _ _; have NZ := repr_coset_norm Z; have:= coset_reprK Z.
  case/kercoset_rcoset=> {NZ}// yi; case/cycleP=> i <- -> {yi Z}.
  rewrite consttM; last by apply commute_sym; apply: commuteX; apply/cent1P.
  rewrite (constt1P _) ?p_eltNK 1?p_eltX ?p_elt_constt // mul1g.
  by rewrite conjMg consttJ conjgKV -zp_ya consttC.
rewrite 2!inE -order_dvd; set Z := coset _ _.
case/andP=> Cz n'Z; move/eqP=> def_z.
have Nz: z ^ a^-1 \in 'N(<[y]>).
  rewrite -def_z conjgK groupMr; first by rewrite -(cycle_subG y) normG.
  by rewrite groupX ?repr_coset_norm.
have{Cz}: z ^ a^-1 \in 'C_G[y]; last case/setIP=> Gz Cz.
  case/morphimP: Cz => u Nu Cu.
  case/kercoset_rcoset=> // yi; case/cycleP=> i <-{yi} ->.
  by rewrite groupMr // groupX // inE groupX //; exact/cent1P.
have{def_z} zp_ya: z.`_p = y ^ a.
  rewrite -def_z consttJ consttM.
    rewrite constt_p_elt ?p_elt_constt //.
    by rewrite (constt1P _) ?p_eltNK ?p_elt_constt ?mulg1.
  apply: commute_sym; apply/cent1P.
  rewrite -def_z conjgK groupMl // in Cz; exact/cent1P.
have ozp: #[z ^ a^-1]`_p = #[y].
  by rewrite -order_constt consttJ zp_ya conjgK.
split; rewrite zp_ya // -class_lcoset lcoset_id // eqxx andbT.
rewrite -(conjgKV a z) !inE groupJ //= -!order_dvd orderJ; apply/andP; split.
  apply/negP; move/(partn_dvd p n_pos); apply/negP.
  by rewrite ozp -(muln1 n`_p) oy dvdn_pmul2l // dvdn1 neq_ltn lt1p orbT.
rewrite -(partnC p n_pos) mulnCA mulnA -oy -(@partnC p #[_]) // ozp.
apply dvdn_mul => //; apply: dvdn_trans (dvdn_trans n'Z (dvdn_gcdr _ _)).
rewrite {2}/order -morphim_cycle // -quotientE card_quotient ?cycle_subG //.
rewrite -(@dvdn_pmul2l #|<[z ^ a^-1]> :&: <[y]>|) ?ltn_0group // LaGrangeI.
rewrite -[#|<[_]>|](partnC p) ?ltn_0order // dvdn_pmul2r // ozp.
by rewrite cardSg ?subsetIr.
Qed.


(* 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                                                     *)

(********************************************************)
(* Une  axiomatisation en coq de la norme IEEE 754 	*)
(* Module Diadic.v 				   	*)
(* un plan d'ensemble se trouve dans le fichier README 	*)
(* Patrick Loiseleur, avril 1997			*)
(********************************************************)

Require Import Omega.
Require Import Zcomplements.
Require Import Zpower.
Require Import Zlogarithm.
Require Import ZArithRing.

Section definitions.

(* The type diadic represents the set of numbers who can be written:  	*)
(* x = n*2^p with  n and p in Z. (diadic numbers)			*)
(* n = Dnum and p = Dexp 						*)

Record diadic : Set := Diadic {Dnum : Z; Dexp : Z}.

Definition Dshift (n : Z) (x : diadic) := Diadic (Dnum x) (Dexp x + n).

Definition Dzero (x : Z) := Diadic 0 x.

Definition is_Dzero (x : diadic) := Dnum x = 0%Z.

(**
Fixpoint Dnormalize[x:diadic] : diadic :=
  Cases (Dnum x) of
    (POS (xO y)) => (Dnormalize (Diadic (POS y) `(Dexp x)+1`))
  | (NEG (xO y)) => (Dnormalize (Diadic (NEG y) `(Dexp x)+1`))
  | _ => x
  end.
**)
Inductive rounding_mode : Set :=
  | Rounding_sup : rounding_mode
  | Rounding_inf : rounding_mode
  | Rounding_nearest : rounding_mode
  | Rounding_zero : rounding_mode.

Definition Rounding_mode_opp (m : rounding_mode) :=
  match m with
  | Rounding_sup => Rounding_inf
  | Rounding_inf => Rounding_sup
  | Rounding_nearest => Rounding_nearest
  | Rounding_zero => Rounding_zero
  end.

(* This inductive set, equal to {-infty}+Z+Z (disjoint union) is
  the set of results of function DLog. *)

(****
Inductive DLog_result : Set :=
  M_infty : DLog_result
| Log_of_pos : Z -> DLog_result
| Log_of_neg : Z -> DLog_result.
****)

End definitions.

Section comparisons.

(* Fist a function Qcompare is defined, who takes two diadic numbers	*)
(* and answers SUPERIEUR, EGAL or INFERIEUR.				*)
(* Qcompare is similary to Zcompare from the omega library		*)
(* Then the usual predicates "less or equal", "less than", "greater	*)
(* or equal" and "greater than" are defined. Since these predicates	*)
(* are deterministic, the boolean equivalents are also defined	*)
(* Be careful ! Two diadic numbers x, y are equal iff the predicate	*)
(* (Deq x y) is true, that is (Dcompare x y)=EGAL			*)
(* That's not equivalent to : (eq D x y)				*)

Definition Dcompare (x y : diadic) : Datatypes.comparison :=
  let nx := Dnum x in
  let ny := Dnum y in
  let ex := Dexp x in
  let ey := Dexp y in
  (two_p (ex - Zmin ex ey) * nx ?= two_p (ey - Zmin ex ey) * ny)%Z.

(* Inductive relation := EGAL | INFERIEUR | SUPERIEUR *)
Definition Deq (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => True
  | Datatypes.Lt => False
  | Datatypes.Gt => False
  end.
Definition Dneq (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => False
  | Datatypes.Lt => True
  | Datatypes.Gt => True
  end.
Definition Dle (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => True
  | Datatypes.Lt => True
  | Datatypes.Gt => False
  end.
Definition Dlt (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => False
  | Datatypes.Lt => True
  | Datatypes.Gt => False
  end.
Definition Dge (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => True
  | Datatypes.Lt => False
  | Datatypes.Gt => True
  end.
Definition Dgt (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => False
  | Datatypes.Lt => False
  | Datatypes.Gt => True
  end.

Definition Deq_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => true
  | Datatypes.Lt => false
  | Datatypes.Gt => false
  end.
Definition Dneq_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => false
  | Datatypes.Lt => true
  | Datatypes.Gt => true
  end.
Definition Dle_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => true
  | Datatypes.Lt => true
  | Datatypes.Gt => false
  end.
Definition Dlt_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => false
  | Datatypes.Lt => true
  | Datatypes.Gt => false
  end.
Definition Dge_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => true
  | Datatypes.Lt => false
  | Datatypes.Gt => true
  end.
Definition Dgt_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => false
  | Datatypes.Lt => false
  | Datatypes.Gt => true
  end.

Lemma Dcompare_shift :
 forall (x y : diadic) (n : Z),
 Dcompare (Dshift n x) (Dshift n y) = Dcompare x y.
unfold Dcompare in |- *; simpl in |- *; intros;
 rewrite (Zmin.Zmin_plus (Dexp x) (Dexp y) n).
do 2 rewrite BinInt.Zminus_plus_simpl_r.
reflexivity.
Qed.

Lemma eq_Deq : forall x y : diadic, x = y -> Deq x y.
intros; rewrite H; unfold Deq in |- *; unfold Dcompare in |- *;
 apply Zcompare.Zcompare_eq_case; trivial.
Qed.

(* Links between Zcompare and Dcompare, Zle and Dle *)

Lemma Dcompare_zero :
 forall (x : diadic) (n : Z), Dcompare x (Dzero n) = (Dnum x ?= 0)%Z.
intros (nx, ex) n.
unfold Dcompare in |- *; simpl in |- *.
symmetry  in |- *.
replace (two_p (n - Zmin ex n) * 0)%Z with (two_p (ex - Zmin ex n) * 0)%Z.
apply Zmult_compare_compat_l.
apply two_p_gt_ZERO.
generalize (Zle_min_l ex n); generalize (Zmin ex n); intro; omega.
do 2 rewrite Zmult_0_r; reflexivity.
Qed.

Lemma Deq_shift :
 forall (x y : diadic) (n : Z), Deq x y -> Deq (Dshift n x) (Dshift n y).
unfold Deq in |- *; intros; rewrite (Dcompare_shift x y n); trivial.
Qed.

Lemma Deq_x_shift_x :
 forall (x : diadic) (n : Z),
 (0 <= n)%Z -> Deq x (Diadic (Dnum x * two_p n) (Dexp x - n)).
intros (nx, ex) n Hn; unfold Deq in |- *; unfold Dcompare in |- *;
 simpl in |- *.
cut
 ((two_p (ex - Zmin ex (ex - n)) * nx)%Z =
  (two_p (ex - n - Zmin ex (ex - n)) * (nx * two_p n))%Z).
intro H; rewrite H.
generalize (two_p (ex - n - Zmin ex (ex - n)) * (nx * two_p n))%Z.
intros. generalize (Zcompare.Zcompare_refl z).
elim (z ?= z)%Z; discriminate || trivial.
rewrite (Zmult_comm nx (two_p n)).
rewrite <- Zmult_assoc_reverse.
rewrite <- two_p_is_exp.
ring_simplify (ex - n - Zmin ex (ex - n) + n)%Z (ex - Zmin ex (ex - n))%Z.
reflexivity.
generalize (Zle_min_l ex (ex - n)) (Zle_min_r ex (ex - n)).
omega.
assumption.
Qed.

Lemma Dle_Zle :
 forall n1 n2 d : Z, (n1 <= n2)%Z -> Dle (Diadic n1 d) (Diadic n2 d).
intros; unfold Dle in |- *; unfold Dcompare in |- *; simpl in |- *.
rewrite (Zmin_n_n d).
rewrite <- (Zminus_diag_reverse d).
unfold two_p in |- *.
rewrite (Zcompare_mult_compat 1 n1 n2).
apply Zcompare.Zle_compare; assumption.
Qed.

Lemma Dlt_Zlt :
 forall n1 n2 d : Z, (n1 < n2)%Z -> Dlt (Diadic n1 d) (Diadic n2 d).
intros; unfold Dlt in |- *; unfold Dcompare in |- *; simpl in |- *.
rewrite (Zmin_n_n d).
rewrite <- (Zminus_diag_reverse d).
unfold two_p in |- *.
rewrite (Zcompare_mult_compat 1 n1 n2).
apply Zcompare.Zlt_compare; assumption.
Qed.

Lemma Dge_Zge :
 forall n1 n2 d : Z, (n1 >= n2)%Z -> Dge (Diadic n1 d) (Diadic n2 d).
intros; unfold Dge in |- *; unfold Dcompare in |- *; simpl in |- *.
rewrite (Zmin_n_n d).
rewrite <- (Zminus_diag_reverse d).
unfold two_p in |- *.
rewrite (Zcompare_mult_compat 1 n1 n2).
apply Zcompare.Zge_compare; assumption.
Qed.

Lemma Dgt_Zgt :
 forall n1 n2 d : Z, (n1 > n2)%Z -> Dgt (Diadic n1 d) (Diadic n2 d).
intros; unfold Dgt in |- *; unfold Dcompare in |- *; simpl in |- *.
rewrite (Zmin_n_n d).
rewrite <- (Zminus_diag_reverse d).
unfold two_p in |- *.
rewrite (Zcompare_mult_compat 1 n1 n2).
apply Zcompare.Zgt_compare; assumption.
Qed.

(* Arithmetic properties on D : Dle is reflexive, transitive, antisymmetric *)
Lemma Dle_refl : forall x y : diadic, Deq x y -> Dle x y.
unfold Deq in |- *; unfold Dle in |- *; intros x y; elim (Dcompare x y);
 trivial.
Qed.

(***
Lemma Dle_trans : (x,y,z:diadic) (Dle x y)->(Dle y z)->(Dle x z).
Intros x y z; Unfold Dle;

Lemma Dle_antisym :

Lemma Dle_lt_or_eq : (Dle x y) -> (Dlt x y)\/(Deq x y)
Lemma Dlt_not_refl :
Lemma Dlt_trans :
Lemma Dle_lt_trans : x<=y -> y<z -> x < z
Lemma Dlt_le_trans :

Lemma Dgt_lt :
Lemma Dge_le :
***)

End comparisons.

Section operations.

(* Now the 4 arithmetic operations and the square root 			*)
(* can be defined on D.				 			*)
(* Addition, negation, difference and multiplication are exact.		*)
(* Since D is non closed by inverse and square root, these operations	*)
(* are defined with a precision 2^p for a given p > 0.			*)
(* So, there is at this step of the work no function Dinv, but a	*)
(* predicates Dinv who takes 4 arguments : rounding mode, x, y, p.	*)
(* (Dinv MODE x y p) says that y is an approximation of 1/x with	*)
(* p digits, according to the rounding mode MODE			*)
(* That means (in the field R of real numbers):				*)
(*  (Dnum y) has p digits and : 					*)
(*									*)
(* -For MODE=Roundig_sup :  y <= 1/x < Dsucc y				*)
(* -For MODE=Roundig_inf :  Dpred y < 1/x <= y				*)
(* -For MODE=Rounding_nearest : 					*)
(*  	as Rounding_sup if nearer than Rounding_inf			*)
(*      as Rounding_inf in the other case				*)
(* -For MODE=Roundig_zero : as Rounding_sup if x>0,			*)
(*   	       	       	      as Rounding_inf if x<=0.			*)
(*	 					          __		*)
(* (Dsqr MODE x y p) says that y is an approximation of \/ x 		*)
(*   with p digits, according to the rounding mode MODE.		*)
(* That means : 							*)
(* -For MODE=Roundig_sup :  y^2 <= x < (Dsucc y)^2			*)
(* -For MODE=Roundig_inf :  (Dpred y)^2 < x <= y^2			*)
(* -For MODE=Rounding_nearest : 					*)
(*  	as Rounding_sup if nearer than Rounding_inf			*)
(*      as Rounding_inf in the other case				*)
(* -For MODE=Roundig_zero : as Rounding_sup since x>0			*)
(*									*)
(* The square root of a negative number does not exist : 		*)
(* (Dsrq MODE x y p) is alwas false when x <= 0				*)

Definition Dsucc (x : diadic) := Diadic (Dnum x + 1) (Dexp x).
Definition Dpred (x : diadic) := Diadic (Dnum x - 1) (Dexp x).

Definition Dadd (x y : diadic) :=
  let nx := Dnum x in
  let ny := Dnum y in
  let ex := Dexp x in
  let ey := Dexp y in
  Diadic (two_p (ex - Zmin ex ey) * nx + two_p (ey - Zmin ex ey) * ny)
    (Zmin ex ey).

Definition Dopp (x : diadic) := Diadic (- Dnum x) (Dexp x).

Definition Dabs (x : diadic) := Diadic (Zabs (Dnum x)) (Dexp x).

Definition Dminus (x y : diadic) := Dadd x (Dopp y).

Definition Dmult (x y : diadic) := Diadic (Dnum x * Dnum y) (Dexp x + Dexp y).

(* DLog 0 is -infty.
   When n<>0,
     (DLog n)= (Log_of_pos m) iff +2^m is the nearest power of two
   of n, according to the choosen rounding mode.
     (DLog n) = (Log_of_neg m) iff -2^m is the nearest power of two
   of n, according to the choosen rounding mode.
*)
(*** ON S'en FOUT
Definition DLog :=
  [m:rounding_mode][x:diadic]Cases (Dnum x) of
    (POS n) => (Log_of_pos (Cases m of
      	       	  Rounding_sup => `(Log_sup_pos n)-(Dexp x)`
      	       	| Rounding_inf => `(Log_inf_pos n)-(Dexp x)`
      	        | Rounding_nearest => `(Log_nearest n)-(Dexp x)`
      	        | Rounding_zero => `(Log_inf n)-(Dexp x)) end)`
  | (NEG n) =>  (Log_of_neg (Cases m of
      	       	  Rounding_sup => `(Log_inf n)-(Dexp x)`
      	       	| Rounding_inf => `(Log_sup n)-(Dexp x)`
      	        | Rounding_nearest => `(Log_nearest n)-(Dexp x)`
      	        | Rounding_zero => `(Log_inf n)-(Dexp x)) end)`
  | ZERO => M_infty
  end.
*****************)

(* (Dproj m x P y) is true when y is the projection of x onto the subset
  of integers who satisfy P, acording to the rounding mode m *)

Definition Dproj (m : rounding_mode) (x : diadic) (P : diadic -> Prop)
  (y : diadic) :=
  P y /\
  match m with
  | Rounding_sup => forall z : diadic, P z -> Dle x z -> Dle y z
  | Rounding_inf => forall z : diadic, P z -> Dle z x -> Dle z y
  | Rounding_nearest =>
      forall z : diadic, P z -> Dle (Dabs (Dminus x y)) (Dabs (Dminus x z))
  | Rounding_zero =>
      forall z : diadic,
      P z ->
      IF Dle (Dzero 0) x then Dle z x -> Dle z y else Dle z x -> Dle z y
  end.

(* ZROUND "forgets" p digits of n, but with respect to the rounding
  mode m.
  In few cases, ZROUND may have one digit more than (N_digits n)-p.
  Examples :

  (ZROUND inf 4 #1111111) = #111 but (ZROUND sup 4 #1111111) = #1000
  (ZROUND inf 4 #-1111111) = #-1000 but (ZROUND sup 4 #-1111111) = #-111

*)

Lemma ZROUND_inf_spec :
 forall (p : positive) (x : Z),
 {y : Z | (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z}.
intros; elim (Zdiv_rest_correct x p); intros q r Hx Hr1 Hr2; exists q;
 rewrite (Zplus_0_r_reverse (q * two_power_pos p));
 rewrite Hx; split;
 [ apply Zplus_le_compat_l; assumption
 | unfold Zsucc in |- *; rewrite Zmult_plus_distr_l; apply Zplus_lt_compat_l;
    rewrite Zmult_1_l; assumption ].
Qed.

Definition ZROUND_inf (p : positive) (x : Z) :=
  let (x', p) := ZROUND_inf_spec p x in x'.

Lemma ZROUND_sup_spec :
 forall (p : positive) (x : Z),
 {y : Z | (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z}.
intros; elim (Zdiv_rest_correct x p); intros q r; elim r;
 [ intros Hx Hr; exists q; rewrite Hx; rewrite <- Zplus_0_r_reverse; split;
    [ apply Zmult_gt_0_lt_compat_r;
       [ compute in |- *; reflexivity | apply Zlt_pred ]
    | apply Zle_refl ]
 | intros p0 Hx Hr1 Hr2; exists (Zsucc q); rewrite Hx; split;
    [ replace (Zpred (Zsucc q) * two_power_pos p)%Z with
       (q * two_power_pos p + 0)%Z;
       [ apply Zplus_lt_compat_l; compute in |- *; reflexivity
       | rewrite <- Zpred_succ; rewrite <- Zplus_0_r_reverse; reflexivity ]
    | unfold Zsucc in |- *; rewrite Zmult_plus_distr_l;
       apply Zplus_le_compat_l; rewrite Zmult_1_l;
       apply Zlt_le_weak; assumption ]
 | intros p0 Hx Hr1 Hr2; absurd (Datatypes.Gt = Datatypes.Gt);
    [ exact Hr1 | reflexivity ] ].
Qed.

Definition ZROUND_sup (p : positive) (x : Z) :=
  let (x', p) := ZROUND_sup_spec p x in x'.

Lemma ZROUND_correct :
 forall (m : rounding_mode) (p : positive) (x : Z),
 {y : Z |
 match m with
 | Rounding_inf => (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z
 | Rounding_sup => (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z
 | Rounding_nearest =>
     match (x - ZROUND_inf p x ?= ZROUND_sup p x - x)%Z with
     | Datatypes.Eq =>
         if Zeven.Zeven_bool (ZROUND_inf p x)
         then (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z
         else (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z
     | Datatypes.Gt =>
         (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z
     | Datatypes.Lt =>
         (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z
     end
 | Rounding_zero =>
     match x with
     | Zpos _ => (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z
     | Z0 => y = 0%Z
     | Zneg _ => (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z
     end
 end}.
simple destruct m;
 [ exact ZROUND_sup_spec
 | exact ZROUND_inf_spec
 | intros p x; elim (x - ZROUND_inf p x ?= ZROUND_sup p x - x)%Z;
    [ elim (Zeven.Zeven_bool (ZROUND_inf p x));
       [ apply ZROUND_inf_spec | apply ZROUND_sup_spec ]
    | apply ZROUND_inf_spec
    | apply ZROUND_sup_spec ]
 | simple induction x;
    [  (* ZERO *) exists 0%Z; reflexivity
    |  (* POS *) intro; apply ZROUND_inf_spec
    |  (* NEG *) intro; apply ZROUND_sup_spec ] ].
Qed.

Definition ZROUND (m : rounding_mode) (p : positive)
  (x : Z) := let (x', p) := ZROUND_correct m p x in x'.

Definition POS_ROUND (m : rounding_mode) (p n : positive) :=
  BinInt.Zabs_N (ZROUND m p (Zpos n)).

Definition NEG_ROUND (m : rounding_mode) (p n : positive) :=
  BinInt.Zabs_N (- ZROUND m p (Zneg n)).

(* (ROUND m p x) does verify :
   (Dproj m x {y:Z | (N_digits (Dexp x))=p \/ (Dexp x)=`0`} (ROUND m p x))

  (At least, I hope so). *)

(* If p < 0 then (ROUND m p x)=(ROUND m -p x) *)
(* p is choosen of type Z (and not positive) only to avoid some
  further conversions *)

(* The case when (ZROUND m q nx) has p+1 digits occurs only when
  (ZROUND m q nx) = 1000...000. It is correctly matched *)
Definition Ddouble (d : diadic) := Dshift 1 d.

Axiom
  ROUND_spec :
    forall (m : rounding_mode) (p : Z) (x : diadic),
    {y : diadic |
    N_digits (Dexp y) = p /\
    match m with
    | Rounding_inf => Dle y x /\ Dlt x (Dsucc y)
    | Rounding_sup => Dlt (Dpred y) x /\ Dle x y
    | Rounding_nearest =>
        Dle (Dpred (Ddouble y)) (Ddouble x) /\
        Dle (Ddouble x) (Dsucc (Ddouble y))
    | Rounding_zero =>
        IF Dlt (Dzero 0) x then Dle y x /\ Dlt x (Dsucc y)
        else Dlt (Dpred y) x /\ Dle x y
    end}.

Definition ROUND (m : rounding_mode) (p : Z) (d : diadic) :=
  let (x, _) := ROUND_spec m p d in x.

(* Le jeu inverse : on fixe l'exposant, et on ajuste la mantisse    *)
(* (ANTIROUND m p x) rend l'entier k tel que la projection de x
   (selon le mode m) sur l'ensemble des diadiques dont l'exposant
    vaut p (cad l'ensemble des multiples entiers de 2^p) est k.2^p *)

Definition ANTIROUND (m : rounding_mode) (p : Z) (x : diadic) :=
  let nx := Dnum x in
  let ex := Dexp x in
  match (p - ex)%Z with
  | Zpos q => ZROUND m q nx
  | Zneg q => (nx * two_power_pos q)%Z
  | Z0 => nx
  end.

(********
Definition Dinv :=
  [x,y:diadic m:rounding_mode; p:positive]
  [nx=(POS px)][ny=(POS py)][ex=(Dexp x)][ey=(Dexp y)]
  Cases nx ny m  of
    (POS px) (POS py) Rounding_sup =>
      	`(Log_inf nx) - ex = -(Log_sup ny) + ey`
	/\`(Log_inf ny) >= p`
        /\` nx*ny <= (two_power_Z (ex+ey)) < nx*(ny+1)`
    (POS px) (POS py) Rounding_inf =>
      	`(Log_sup nx) - ex = -(Log_inf ny) + ey`
	/\`(Log_inf ny) >= p`
        /\` nx*(ny-1) <= (two_power_Z (ex+ey)) <= nx*ny`
    (POS px) (POS py) Rounding_nearest =>
      	`(Log_nearest nx) - ex = -(Log_nearest ny) + ey`
	/\`(Log_inf ny) >= p`
        /\` nx*ny <= (two_power_Z (ex+ey)) < (nx+1)*ny`

  | Rounding_sup (Log_of_neg e) =>
  | Rounding_inf =>
  | Rounding_nearest =>
  | Rounding_zero =>
  end.
************)

(* (Ddiv m p x y) is the correct approximation with p digits of the
  division (in the field R of real numebers) x/y
  Unspecified if p <= 0 *)

Parameter Ddiv : rounding_mode -> Z -> diadic -> diadic -> diadic.

(* Dsqrt m p n e) is the correct approximation with p digits of the
  division (in the field R of real numebers) sqrt(n*2^e) *)

Parameter Dsqrt : rounding_mode -> Z -> positive -> Z -> diadic.

End operations.


Require Import Bool Arith List Query.
Set Implicit Arguments.

(**
  IMP syntax
**)

(*
    Nameholders for variables.
    Currently, there are two types:
    1. Result: a special variable to initialize/update the return value of the program.
    (Note: at this point, the result cannot be read. Only new tuples can be added to the current result)
    2. Heap variables: special indexed variables that initialize/update global data. Currently, there are 2 heap variables:
        a. 0 => Special index reserved for the tuple bound to each iteration of the outer ForAll loop (alternatively the only ForAll loop in the program, if applicable).
        b. 1 => Special index reserved for the tuple bound to each iteration of the inner ForAll loop. Only valid for programs with multiple loops (e.g., Jo)
*)
Inductive VarName : Set :=
  | ResultName : VarName
  | IndexedVarName : nat -> VarName.

(*
    Boolean expressions.
    Currenty, there are two ways to construct a boolean expression:
    1. BoolBExp: For the predicates true and false
    2. Pred1Exp: true if the first attribute == 1
*)
Inductive BExp : Set :=
  | BoolBExp : Bool -> BExp
  | Pred1Exp : BExp.

(*
    Expressions. Current values are:
    1. InputRelation1: First input relation to the program. This is also the relation for one-relation programs (e.g., SELECT)
    2. InputRelation2: Second input relation to the program. Only valid for programs that need a second relation (e.g., JOIN)
    3. RelationExp: Constructor to wrap the input relation to an expression.
    4. NatExp: Constructor to wrap the input natural number to an expression.
    5. BoolExp: Constructor to wrap the input boolean expression to an expression.
*)
Inductive Exp : Set :=
  | InputRelation1 : Exp
  | InputRelation2 : Exp
  | RelationExp : relation -> Exp
  | NatExp : nat -> Exp
  | BoolExp : BExp -> Exp.

(*
    Statements. Current values are:
    1. Assign: Execute the statement and assign the result to the input expression.
    2. ForAll: Iterate over the relation specified by the input expression, bind each tuple in this relation to the input variable name and execute the input statement for each of these tuples.
        Simulates the following loop.
        for (Tuple tuple: relation.getTuples()) {
            runStatement(statement, tuple);
        }
    3. ProjectTuple: For each tuple of the input relation, projects the element located at the specified index (NatExp) of the input expression, wraps it into a new tuple, and appends it to the result.
        Note: The second argument (IndexedVarName) is not used at this point but is kept for extensibility.
        Previously ProjectTuple was an expression (instead of statement) where the result of this projection needed to be stored in the heap. In future, this IndexedVarName will represent this heap variable.
    4. SelectTuple: Retrieves the tuple located at the specified index (NatExp) of the input relation and appends it to the result.
        Note: The second argument (IndexedVarName) is not used at this point but is kept for extensibility.
        Previously ProjectTuple was an expression (instead of statement) where the result of this projection needed to be stored in the heap. In future, this IndexedVarName will represent this heap variable.
    5. MatchTuples: Matches two tuples by an attribute (attribute hardcoded, so no syntax for specifying which)
*)
Inductive Statement : Set :=
  | Assign : VarName -> Exp -> Statement
  | ForAll : VarName -> Exp -> Statement -> Statement
  | ProjectTuple : Exp -> VarName -> Statement
  | SelectTuple : Exp -> VarName -> Statement
  | MatchTuples : VarName -> VarName -> Statement.

(*
    Imperative program representation.
    We decided to differentiate Seq from other statements, so that Coq can immediately know that imperative programs nest Sequence over the second argument.
    An imperative program is basically a list (Seq) of statements that end with a special program called Skip.
*)
Inductive ImpProgram : Set :=
  | Seq : Statement -> ImpProgram -> ImpProgram
  | Skip.

(**
   end (IMP syntx
**)

(* Converts the input query to an imperative program. *)
Definition queryToImp (q : Query) : option ImpProgram :=
  (* All imperative programs begin by assigning the result to nil (e.g., Result = nil;). This method reduces that clutter. *)
  let structure (inner : Statement) :=
    Some (Seq
      (Assign ResultName (RelationExp nil))
      (Seq
        (ForAll (IndexedVarName 0) InputRelation1 inner)
        Skip))
  in match q with
     | Select b => match b with
                   (* Select True => Result = Input; *)
                   | BTrue => Some (Seq (Assign ResultName InputRelation1) Skip)
                   (* Select False => Result = Nil; *)
                   | BFalse => Some (Seq (Assign ResultName (RelationExp nil)) Skip)
                   end
     | Project index => structure (ProjectTuple (NatExp index) (IndexedVarName 0))
     | SelectIf pr => match pr with
                      | PredBool b => structure (SelectTuple (BoolExp (BoolBExp b)) (IndexedVarName 0))
                      | PredFirst1 => structure (SelectTuple (BoolExp Pred1Exp) (IndexedVarName 0))
                      end
     | JoinFirst => structure (ForAll (IndexedVarName 1) InputRelation2
                              (MatchTuples (IndexedVarName 0) (IndexedVarName 1)))
     end.

(*
    Runs the input statement on input relations, updating the heap and producing a relation (actually a tuple), if necessary.
    Note that to simplify representation, the heap is represented as a pair of tuples. These tuples represent the tuples bound to the
    outer and inner loops in the program. The second tuple (of the heap) and the second input relation (input2) are only used by Join.
*)
Fixpoint runStatement (s: Statement) (input1: relation) (input2: relation) (heap: tuple * tuple) (nested: bool) : option relation :=
  match s with
  | Assign ResultName e => match e with
                           | InputRelation1 => Some input1
                           | RelationExp rexp => Some rexp
                           | _ => None
                           end
  | Assign _ _ => None
  | ProjectTuple (NatExp index) (IndexedVarName vnIndex) =>
          match projectTuple (fst heap) index with
          | Some tup => Some (tup :: nil)
          | None => None
          end
  | ProjectTuple _ _ => None
  | SelectTuple (BoolExp bexp) (IndexedVarName vnIndex) =>
      match bexp with
        | BoolBExp b => match b with
                          | BTrue => Some ((fst heap) :: nil)
                          | BFalse => Some nil
                        end
        | Pred1Exp => match (fst heap) with
                        | 1 :: _ => Some ((fst heap) :: nil)
                        | _ => Some nil
                      end
      end
  | SelectTuple _ _ => None
  | ForAll (IndexedVarName index) _ s' =>
      let fix helper (rel: relation) (nested' : bool) :=
        match rel with
        | nil => Some nil
        | t :: rem =>
          let heap' := if nested' then pair (fst heap) t else pair t nil in
          match (runStatement s' input1 input2 heap' true) with
          | None => None
          | Some res => match (helper rem nested') with
                        | Some rem' => Some (res ++ rem')
                        | None => None
                        end
          end
        end
      in if nested then helper input2 true else helper input1 false
  | ForAll _ _ _ => None
  | MatchTuples (IndexedVarName vn1) (IndexedVarName vn2) =>
       let (t1, t2) := ((fst heap), (snd heap)) in
       if joineq t1 t2 then Some ((t1 ++ t2) :: nil) else Some nil
  | MatchTuples _ _ => None
  end.

(*
    Runs the input imperative program on the input relations and returns the result.
    It turns out that we do not (and should not) have runImpSmall (small step semantics). Otherwise Coq cannot
    figure out that our function is structurally recursive. Special thanks go to Eric Mullen and Zach Tatlock.
*)
Definition runImp (p : ImpProgram) (input1 : relation) (input2 : relation) : option relation :=
  let fix helper (p : ImpProgram) (result: relation) : option relation :=
    match p with
    | Skip => Some result
    | Seq s p' => match (runStatement s input1 input2 (pair nil nil) false) with
                    | Some res => helper p' (result ++ res)
                    | None => None
                  end
    end
  in helper p nil.

(*
    Runs the input imperative program on the input relations and returns the result.
    Non-tail recursive version.
*)
Fixpoint runImp' (p: ImpProgram) (input1: relation) (input2 : relation) : option relation :=
  match p with
    | Skip => Some nil
    | Seq s p' => match (runStatement s input1 input2 (pair nil nil) false) with
                    | Some res => match runImp' p' input1 input2 with
                                    | Some remres => Some (res ++ remres)
                                    | None => None
                                      end
                    | None => None
                      end
end.

(**
  Test cases
**)
Eval compute in let p := queryToImp (Project 0) in
                        match p with
                          | None => None
                          | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3 :: 4 :: nil) :: nil) nil
end.
(* = Some [(1),(3)] *)

Eval compute in let p := queryToImp (Project 2) in
                        match p with
                          | None => None
                          | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3::4::nil) :: nil) nil
end.
(* = None *)

Eval compute in let p := queryToImp (Project 1) in
                        match p with
                          | None => None
                          | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3::4::nil) :: nil) nil
end.
(* = Some [(2),(4)] *)

Eval compute in let p := queryToImp (SelectIf (PredBool BTrue)) in
                          match p with
                            | None => None
                            | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3::4::nil) :: nil) nil
end.
(* = Some [(1,2),(3,4)] *)

Eval compute in let p := queryToImp (SelectIf (PredBool BFalse)) in
                          match p with
                            | None => None
                            | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3::4::nil) :: nil) nil
end.
(* = Some [] *)

Eval compute in let p := queryToImp (SelectIf PredFirst1) in
                        match p with
                          | None => None
                          | Some p' => runImp' p' ((1::2::nil) :: (3::4::nil) :: (0::1::nil) :: (1::6::nil) :: nil) nil
end.
(* = Some [(1,2),(1,6)] *)

Eval compute in let p := queryToImp JoinFirst in
  match p with
    | None => None
    | Some p' => runImp' p' ((1::2::nil) :: (2::3::nil) :: nil) ((3::4::nil) :: (1::10::nil) :: (1::12::nil) :: nil)
end.
(* = Some [(1,2,1,10), (1,2,1,12)] *)

(**
   end (Test cases)
**)


From Coq Require Import String Bool Datatypes Relations Program.Equality Classes.RelationClasses.
From SymEx Require Import Expr Maps.
Import BasicExpr BasicMaps.

Inductive trace (A : Type) : Type :=
| Tnil : trace A
| Tcons : trace A -> A -> trace A.

Arguments Tnil {A}.
Arguments Tcons {A} a l.

Declare Scope trace_scope.
Infix "::" := Tcons (at level 60, right associativity) : trace_scope.
Notation "[ ]" := Tnil (format "[ ]") : trace_scope.
Notation "[ x ]" := (Tcons Tnil x) : trace_scope.
Notation "[ x ; .. ; y ; z ]" := (Tcons (Tcons .. (Tcons Tnil x) .. y) z)
  (format "[ '[' x ; '/' .. ; '/' y ; '/' z ']' ]") : trace_scope.

Open Scope trace_scope.

Lemma cons_eq {A:Type} (x y:trace A) : forall a b, x::a = y::b -> x = y /\ a = b.
Proof. intros. induction x; inversion H; subst; split; reflexivity. Qed.

Fixpoint app {A:Type} (xs ys:trace A) : trace A :=
  match ys with
  | [] => xs
  | ys :: y => (app xs ys) :: y
  end.

Notation "x '++' y" := (app x y) : trace_scope.

Theorem app_nil_l {A:Type} (x:trace A) : [] ++ x = x.
Proof. induction x. reflexivity. simpl. rewrite IHx. reflexivity. Qed.

Theorem app_nil_r {A:Type} (x:trace A) : x ++ [] = x.
Proof. reflexivity. Qed.

Theorem app_comm_cons {A:Type} (a:A) (x y:trace A) : (x ++ y) :: a = x ++ (y :: a).
Proof. reflexivity. Qed.

Theorem app_assoc {A:Type} (x y z:trace A) : x ++ y ++ z = (x ++ y) ++ z.
Proof.
  induction z.
  - reflexivity.
  - simpl. rewrite IHz. reflexivity.
Qed.

Lemma cons_not_empty {A:Type} (a:A) (t:trace A) : t :: a <> [].
Proof.
  intros. induction t.
  - discriminate.
  - discriminate.
Qed.

Lemma not_empty_cons {A:Type} (t:trace A) : t <> [] -> exists a t', t = t'::a.
Proof.
  intros. destruct t.
  - exfalso. apply H. reflexivity.
  - exists a. exists t. reflexivity.
Qed.

Theorem app_eq_nil {A:Type} (x y:trace A) : x ++ y = [] -> x = [] /\ y = [].
Proof.
  induction y; induction x; intro; split;
    try (rewrite app_nil_r in H);
    try (rewrite app_nil_l in H);
    try reflexivity;
    try assumption;
    discriminate.
Qed.

Theorem cons_neq {A:Type} (x:trace A) (y:A) : x::y <> x.
Proof. induction x.
       - apply cons_not_empty.
       - intro. inversion H; subst. exact (IHx H1).
Qed.

Theorem cons_neq' {A:Type} (x:trace A) (y:A) : x <> x::y.
Proof. intro. symmetry in H. exact (cons_neq _ _  H). Qed.

Lemma peel_off' {A:Type} (t:trace A) (a:A) : exists x t', t::a = [x] ++ t'.
Proof.
  intros. induction t.
  - exists a. exists []. reflexivity.
  - destruct IHt as [x [t' IH]]. destruct t'; inversion IH; subst.
    + exists a0. exists [x]. reflexivity.
    + exists x. exists ((t' :: a0 ):: a1). reflexivity.
Qed.

Theorem peel_off {A:Type} (t:trace A) : t <> [] -> exists x t', t = [x] ++ t'.
Proof.
  intros. destruct (not_empty_cons _ H) as [x [t' H']].
  rewrite H'. apply peel_off'.
Qed.

(* generic equivalence stuff *)
Inductive permute_events {X: Type} (IF: relation X): relation (trace X) :=
  | pe_refl: forall t, permute_events IF t t
  | pe_sym: forall t t', permute_events IF t t' -> permute_events IF t' t
  | pe_trans: forall t1 t2 t3,
      permute_events IF t1 t2 -> permute_events IF t2 t3 -> permute_events IF t1 t3
  | pe_interference_free: forall t t' e1 e2,
      IF e1 e2 ->
      permute_events IF ((((t :: e1) :: e2)) ++ t') ((((t :: e2) :: e1)) ++ t')
.

Global Instance trace_eq_refl {X: Type} {r: relation X}: Reflexive (permute_events r).
Proof. intro. apply pe_refl. Qed.

Global Instance trace_eq_sym {X: Type} {r: relation X}: Symmetric (permute_events r).
Proof. intro. apply pe_sym. Qed.

Global Instance trace_eq_trans {X: Type} {r: relation X}: Transitive (permute_events r).
Proof. intro. apply pe_trans. Qed.

Lemma path_equiv_extend {X:Type}: forall r t t' (x: X),
    permute_events r t t' -> permute_events r (t :: x) (t' :: x).
Proof.
  intros. induction H.
  - reflexivity.
  - symmetry. assumption.
  - transitivity (t2::x); assumption.
  - rewrite 2 app_comm_cons. apply pe_interference_free. assumption.
Qed.

Module TraceSemantics.
  (** Symbolic *)
  Definition Var: Type := string.

  Inductive trace_step__S : Type :=
  | Asgn__S (x:Var) (e:Aexpr)
  | Cond (b:Bexpr).

  Definition trace__S := trace trace_step__S.

  Fixpoint acc_subst (s0:sub) (t:trace__S) : sub :=
    match t with
    | [] => s0
    | t :: Asgn__S x e => let s := acc_subst s0 t in
                      (x !-> Aapply s e ; s)
    | t :: _ => acc_subst s0 t
    end.

  Definition Aapply_t (t:trace__S) (e:Aexpr) : Aexpr :=
    Aapply (acc_subst id_sub t) e.

  Definition Bapply_t (t:trace__S) (e:Bexpr) : Bexpr :=
    Bapply (acc_subst id_sub t) e.

  Fixpoint pc (t:trace__S) : Bexpr :=
    match t with
    | [] => BTrue
    | t :: Cond b => BAnd (Bapply_t t b) (pc t)
    | t :: _ => pc t
    end.

  (** Concrete *)
  Definition trace__C := trace (Var * Aexpr).

  Fixpoint acc_val (V0:Valuation) (t:trace__C) : Valuation :=
    match t with
    | [] => V0
    | t :: (x, e) => let V := acc_val V0 t in
                   (x !-> Aeval V e ; V)
    end.

  Definition Aeval_t (V0:Valuation) (t:trace__C) (e:Aexpr) : nat :=
    Aeval (acc_val V0 t) e.

  Definition Beval_t (V0:Valuation) (t:trace__C) (e:Bexpr) : bool :=
    Beval (acc_val V0 t) e.

  Definition is_abstraction (V0:Valuation) (t:trace__C) (t':trace__S) : Prop :=
    Beval V0 (pc t') = true /\ Comp V0 (acc_subst id_sub t') = acc_val V0 t.

  Fixpoint Apply_t (s: sub) (t: trace__S) : trace__S :=
    match t with
    | [] => []
    | xs :: Asgn__S x e => Apply_t s xs :: Asgn__S x (Aapply s e)
    | xs :: Cond e => Apply_t s xs :: Cond (Bapply s e)
    end.

  (* Path Equivalence Conditions *)
  Definition sim_subst (r: relation trace_step__S) :=
    forall s x x' e e',
        r (Asgn__S x e) (Asgn__S x' e') ->
        (x' !-> Aapply (x !-> Aapply s e; s) e'; x !-> Aapply s e; s)
      = (x !-> Aapply (x' !-> Aapply s e'; s) e; x' !-> Aapply s e'; s).

  Definition subst_bapply (r: relation trace_step__S) :=
    forall x e b s, r (Asgn__S x e) (Cond b) ->
      Bapply (x !-> Aapply s e; s) b = Bapply s b.

  (* if r allows simultaneous substitution, then equiv_acc_subst *)
  Theorem equiv_acc_subst_generic (r: relation trace_step__S) (sim_subst: sim_subst r):
    forall s t t',
      permute_events r t t' -> acc_subst s t = acc_subst s t'.
  Proof.
    intros s t t' equiv. induction equiv;
      try auto.
    - rewrite IHequiv1. apply IHequiv2.
    - induction t'.
      + destruct e1, e2;
          try reflexivity.
        apply sim_subst. apply H.
      + destruct a; simpl;
          rewrite IHt'; auto.
  Qed.

  (* if r additionally respects subst_bapply we get equiv_pc*)
  Theorem equiv_pc_generic (r: relation trace_step__S) (sym: Symmetric r) (sim_subst: sim_subst r) (subst_bapply: subst_bapply r):
    forall V t t', permute_events r t t' -> Beval V (pc t) = true <-> Beval V (pc t') = true.
  Proof.
    intros.
    induction H.
    - reflexivity.
    - symmetry. apply IHpermute_events.
    - rewrite IHpermute_events1. apply IHpermute_events2.
    - induction t'.
      + destruct e1, e2.
        * reflexivity.
        * simpl. unfold Bapply_t. simpl.
          rewrite (subst_bapply _ _ _ _ H). reflexivity.
        * simpl. unfold Bapply_t. simpl. symmetry in H.
          rewrite (subst_bapply _ _ _ _ H). reflexivity.
        * simpl. unfold Bapply_t. simpl.
          rewrite 2 andb_assoc.
          rewrite (andb_comm (Beval V (Bapply (acc_subst id_sub t) b0))).
          reflexivity.
      + destruct a; simpl.
        * apply IHt'.
        * unfold Bapply_t.
          assert (IHequiv: permute_events r (((t :: e1) :: e2) ++ t') (((t :: e2) :: e1) ++ t'))
            by (apply pe_interference_free; assumption).
          rewrite (equiv_acc_subst_generic r sim_subst _ _ _ IHequiv).
          rewrite 2 andb_true_iff. rewrite IHt'. reflexivity.
  Qed.

  Definition sim_subst__C (r: relation (Var * Aexpr)) :=
    forall V x x' e e',
        r (x, e) (x', e') ->
        (x' !-> Aeval (x !-> Aeval V e ; V) e'; x !-> Aeval V e; V)
      = (x !-> Aeval (x' !-> Aeval V e'; V) e; x' !-> Aeval V e'; V).

  Theorem equiv_acc_val_generic (r: relation (Var * Aexpr)) (sim_subst: sim_subst__C r):
    forall V t t', permute_events r t t' -> acc_val V t = acc_val V t'.
  Proof.
    intros. induction H;
      try auto.
    - rewrite IHpermute_events1. apply IHpermute_events2.
    - induction t'.
      + destruct e1, e2; simpl.
        apply sim_subst. apply H.
      + destruct a; simpl. rewrite IHt'. reflexivity.
  Qed.

End TraceSemantics.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QposMinMax.
Require Export CoRN.reals.fast.CRFieldOps.
Require Export CoRN.model.ordfields.CRordfield.
Require Export CoRN.reals.CReals.
Require Import CoRN.reals.fast.CRcorrect.
Require Import CoRN.model.metric2.Qmetric.
Require Import CoRN.tactics.CornTac.

Opaque CR.

Local Open Scope uc_scope.

(**
** Example of a real number structure: $\langle$#⟨#[CR]$\rangle$#⟩#
*)

Lemma CRAbsSmall_ball : forall (x y:CR) (e:Q),
    AbsSmall (R:=CRasCOrdField) (inject_Q_CR e) ((x:CRasCOrdField)[-]y) <->
 ball e x y.
Proof.
 intros x y e.
 split.
 - intros [H1 H2].
  rewrite <- (doubleSpeed_Eq x).
  rewrite <- (doubleSpeed_Eq (doubleSpeed x)).
  rewrite <- (doubleSpeed_Eq y).
  rewrite <- (doubleSpeed_Eq (doubleSpeed y)).
  apply: regFunBall_e.
  intros d.
  assert (H1':=H1 d).
  assert (H2':=H2 d).
  clear H1 H2.
  simpl.
  set (x':=approximate x ((1#2)*((1#2)*d))%Qpos).
  set (y':=approximate y ((1#2)*((1#2)*d))%Qpos).
  change (-proj1_sig d <= x' - y' + - - e) in H1'.
  change (-proj1_sig d <= e + - (x' - y')) in H2'.
  rewrite -> Qle_minus_iff in *.
  apply: ball_weak. apply Qpos_nonneg.
  split; simpl; rewrite -> Qle_minus_iff.
  rewrite Qopp_involutive. do 2 rewrite Qopp_involutive in H1'.
  rewrite (Qplus_comm (proj1_sig d)).
  rewrite Qplus_assoc. exact H1'.
  rewrite <- Qplus_assoc, Qplus_comm. rewrite Qopp_involutive in H2'.
  exact H2'.
 - intros H.
 rewrite <- (doubleSpeed_Eq x) in H.
 rewrite <- (doubleSpeed_Eq y) in H.
 split; intros d; destruct (H ((1#2)*d)%Qpos ((1#2)*d)%Qpos) as [H1 H2]; clear H;
   set (x':=(approximate (doubleSpeed x) ((1 # 2) * d)%Qpos)) in *;
     set (y':=(approximate (doubleSpeed y) ((1 # 2) * d)%Qpos)) in *.
  autorewrite with QposElim in H1.
  change (- ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)<=x' - y') in H1.
  change (-proj1_sig d <= x' - y' + - - e).
  rewrite -> Qle_minus_iff.
  rewrite -> Qle_minus_iff in H1.
  replace RHS with (x' - y' + - - ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)) by ring.
  assumption.
 autorewrite with QposElim in H2.
 change (x' - y'<=((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)) in H2.
 change (-proj1_sig d <= e + - (x' - y')).
 rewrite -> Qle_minus_iff.
 rewrite -> Qle_minus_iff in H2.
 replace RHS with ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d + - (x' - y'))
   by ring.
 assumption.
Qed.

Lemma CRlt_Qlt : forall a b, (a < b)%Q -> ((' a%Q) < (' b))%CR.
Proof.
 intros a b H.
 destruct (Qpos_sub _ _ H) as [c Hc].
 exists c.
 intros d.
 change (-proj1_sig d <= b + - a + - proj1_sig c).
 rewrite -> Hc.
 rewrite -> Qle_minus_iff.
 ring_simplify.
 apply Qpos_nonneg.
Qed.

Definition CRlim (s:CauchySeq CRasCOrdField) : CR.
Proof.
 revert s.
 intros [f Hf].
 apply (ucFun (@Cjoin Q_as_MetricSpace)).
 exists (fun e:QposInf => match e with | QposInfinity => 0%CR
   | Qpos2QposInf e => let (n,_) := Hf (inject_Q_CR (proj1_sig e)) (CRlt_Qlt _ _ (Qpos_ispos e)) in f n end).
 abstract ( intros e1 e2; destruct (Hf (inject_Q_CR (proj1_sig e1)) (CRlt_Qlt _ _ (Qpos_ispos e1))) as [n1 Hn1];
   destruct (Hf (inject_Q_CR (proj1_sig e2)) (CRlt_Qlt _ _ (Qpos_ispos e2))) as [n2 Hn2];
     eapply ball_triangle;[apply ball_sym|];rewrite <- CRAbsSmall_ball; [apply Hn1;apply le_max_l|
       apply Hn2;apply le_max_r]) using Rlim_subproof0.
Defined.

Lemma CRisCReals : is_CReals CRasCOrdField CRlim.
Proof.
 split.
  intros [f Hf] e [d Hed].
  destruct (Hf _ (CRlt_Qlt _ _ (Qpos_ispos ((1#2)*d)%Qpos))) as [n Hn].
  exists n.
  intros m Hm.
  apply AbsSmall_leEq_trans with (inject_Q_CR (proj1_sig d));
    [rstepr (e[-][0]);assumption|].
  rewrite -> CRAbsSmall_ball.
  change (nat -> Complete Q_as_MetricSpace) in f.
  change (ball (proj1_sig d) (f m) (CRlim (Build_CauchySeq CRasCOrdField f Hf))).
  rewrite <- (MonadLaw5 (f m)).
  change (ball (proj1_sig d) (Cjoin (Cunit (f m))) (CRlim (Build_CauchySeq CRasCOrdField f Hf))).
  unfold CRlim.
  apply uc_prf.
  change (ball (proj1_sig d) (Cunit (f m)) (Build_RegularFunction (Rlim_subproof0 f Hf))).
  intros e1 e2.
  simpl.
  destruct (Hf (' proj1_sig e2)%CR (CRlt_Qlt _ _ (Qpos_ispos e2))) as [a Ha].
  change (ball (proj1_sig (e1+d+e2)%Qpos) (f m) (f a)).
  destruct (le_ge_dec a m).
   rewrite <- CRAbsSmall_ball.
   eapply AbsSmall_leEq_trans;[|apply Ha;assumption].
   intros x.
   autorewrite with QposElim.
   change (-proj1_sig x <= proj1_sig e1 + proj1_sig d + proj1_sig e2 - proj1_sig e2).
   rewrite -> Qle_minus_iff.
   ring_simplify.
   change (0<= proj1_sig (e1+d+x)%Qpos).
   apply Qpos_nonneg.
  apply ball_weak_le with (proj1_sig ((1#2)*d+(1#2)*d)%Qpos).
   rewrite -> Qle_minus_iff.
   simpl. ring_simplify.
   change (0<= proj1_sig (e1+e2)%Qpos).
   apply Qpos_nonneg.
  apply ball_triangle with (f n);[|apply ball_sym]; rewrite <- CRAbsSmall_ball; apply Hn.
   auto.
  apply le_trans with m; auto.
 (*Archimedean*)
 intros x.
 assert (X:=(CR_b_upperBound (1#1) x)).
 destruct (CR_b (1 # 1) x) as [[n d] qpos].
 destruct n as [|n|n]. inversion qpos. 2: inversion qpos.
 rewrite (anti_convert_pred_convert n) in X.
 exists (nat_of_P n)%nat.
 eapply leEq_transitive.
  apply X.
 clear X.
 intros z.
 simpl.
 unfold Cap_raw.
 simpl.
 apply Qle_trans with 0.
  rewrite -> Qle_minus_iff.
  ring_simplify.
  apply Qpos_nonneg.
 destruct (ZL4 n) as [a Ha].
 rewrite Ha.
 clear Ha.
 simpl.
 unfold Cap_raw.
 simpl.
 rewrite <- Qle_minus_iff.
 remember ((1 # 2) * ((1 # 2) * z))%Qpos as q.
 simpl in Heqq. rewrite <- Heqq. clear Heqq.
 revert q.
 induction a; intro q.
  simpl.
  ring_simplify.
  unfold Qle.
  simpl.
  apply Zle_1_POS.
 simpl.
 unfold Cap_raw.
 simpl.
 rewrite -> Qle_minus_iff.
 rewrite <- Qplus_assoc.
 setoid_replace (1 + - (Pos.succ (Pos.of_succ_nat a) # d))
   with (-((Pos.succ (Pos.of_succ_nat a) # d) - 1)) by ring.
 rewrite<- Qle_minus_iff.
 apply (Qle_trans _ (Pos.of_succ_nat a # d)).
 2: apply IHa.
 generalize (P_of_succ_nat a).
 intros p.
 rewrite -> Qle_minus_iff.
 autorewrite with QposElim.
 replace RHS with (((p#d) + 1) + - (Pos.succ p # d)) by ring.
 rewrite <- Qle_minus_iff.
 unfold Qle.
 simpl.
 repeat rewrite Pmult_1_r.
 rewrite Pplus_one_succ_r.
 repeat rewrite Zpos_mult_morphism.
 apply Zmult_lt_0_le_compat_r.
  auto with *.
 repeat rewrite Zpos_plus_distr.
 auto with *.
Qed.

Definition CRasCReals : CReals :=
Build_CReals _ _ CRisCReals.

Canonical Structure CRasCReals.