Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Require Import util.
Require Import Le.
Require Import Lt.
Require Import Rbase.
Require Import Plus.
Require Import Mult.
Require Import Arith.
Require Import Omega.
Require Import Div2.
Require Import Recdef.
Require Import Rbase.
Require Import Morphisms.

(* nat misc *)

Definition ltb (x y: nat): bool := negb (leb y x).
Definition geb (x y: nat): bool := leb y x.

Ltac subst_tac x y z := (* todo: rename *)
  match z with
  | x => y
  | ?l + ?r =>
      let l' := subst_tac x y l in
      let r' := subst_tac x y r in
        constr: (l' + r')
  | ?l * ?r =>
      let l' := subst_tac x y l in
      let r' := subst_tac x y r in
        constr: (l' * r')
  | _ => z
  end.

Ltac deep_le_trans h :=
  match type of h with
  | ?n <= ?u =>
    match goal with
    | |- ?l <= _ =>
      let q := subst_tac n u l
      in apply le_trans with q
    end
  end.

Instance Transitive_le: Transitive le := le_trans.

Lemma minus_plus_same (y x: nat): x <= x - y + y.
Proof. intros. omega. Qed.

Lemma ltb_complete m n: ltb m n = true -> m < n.
Proof with auto.
  unfold ltb.
  intros.
  apply leb_complete_conv.
  apply negb_inv...
Qed.

Lemma ltb_complete_conv m n: ltb m n = false -> n <= m.
Proof. unfold ltb. intros. apply leb_complete. apply negb_inv; auto. Qed.

Lemma lt_0_mult x y: 0 < x -> 0 < y -> 0 < x * y.
Proof with auto.
  destruct x.
    intros.
    inversion H.
  simpl.
  intros.
  apply lt_plus_trans...
Qed.

Lemma mult_ne_0 a b: (a <> 0 -> b <> 0 -> mult a b <> 0)%nat.
Proof with auto with arith.
  destruct a... destruct b...
  intros. simpl. discriminate.
Qed.

Lemma weak_lt_S_n n m: S n < m -> n < m.
Proof with auto with arith.
  intros.
  apply lt_S_n.
  apply lt_trans with m...
Qed.

Lemma le_exists_plus (x y: nat) (p: x <= y): exists d, y = x + d.
Proof with auto.
  induction p.
    exists 0...
  destruct IHp.
  exists (S x0).
  subst...
Qed.

Lemma lt_exists_plus (x y: nat) (p: x < y): exists d, y = S (x + d).
Proof.
  unfold lt in p.
  destruct (le_exists_plus p).
  exists x0.
  assumption.
Qed.

Lemma n_lt_n_plus_Sm n m: n < n + S m.
Proof. intros. omega. Qed.

Lemma ne_le_impl_lt x y: x <> y -> x <= y -> x < y.
Proof. auto with *. Qed.

Hint Rewrite plus_0_r : arith_norm.
Hint Rewrite mult_plus_distr_r mult_plus_distr_l plus_assoc : arith_norm.

Lemma beq_nat_false x y: x <> y -> beq_nat x y = false.
Proof with auto.
  intros.
  case_eq (beq_nat x y)...
  intros.
  elimtype False.
  apply H.
  apply beq_nat_eq...
Qed.

Lemma minus_lt_compat_l x y z: (y <= x -> z < y -> x - y < x - z)%nat.
Proof with auto.
  intros.
  omega.
Qed.

Lemma minus_eq_inv_r d x y: (x <= d -> y <= d -> (d - x = d - y) -> x = y)%nat.
Proof with auto with arith.
  revert x y.
  induction d.
    simpl.
    intros.
    destruct x...
    inversion H.
  simpl.
  intros.
  destruct x.
    destruct y...
    elimtype False.
    apply le_Sn_n with d...
    rewrite H1.
    apply le_minus.
  destruct y.
    elimtype False.
    apply le_Sn_n with d.
    rewrite <- H1.
    apply le_minus.
  apply eq_S.
  apply IHd...
Qed.

Lemma le_ne_lt x y: x <= y -> x <> y -> x < y.
Proof. intros. omega. Qed.

Lemma ne_nlt_lt x y: x <> y -> ~ x < y -> y < x.
Proof with auto.
  intros.
  destruct (le_gt_dec x y)...
  destruct (le_lt_eq_dec _ _ l)...
    elimtype False...
  elimtype False...
Qed.

Lemma lt_not_eq x y: (x < y -> x <> y)%nat.
Proof. intros. omega. Qed.

Lemma lt_not_eq_sym x y: (y < x -> x <> y)%nat.
Proof. intros. omega. Qed.

Hint Resolve lt_not_eq.
Hint Resolve lt_not_eq_sym.

(* sqrd *)

Definition sqrd n := n * n.

Lemma sqrd_S n: sqrd (S n) = sqrd n + n + n + 1.
Proof with auto with arith.
  induction n...
  rewrite IHn.
  clear IHn.
  unfold sqrd.
  ring.
Qed.

Lemma sqrd_plus x y: sqrd x + sqrd y <= sqrd (x + y).
Proof with auto with arith.
  intros.
  unfold sqrd.
  autorewrite with arith_norm...
Qed.

Lemma sqrd_le x y: x <= y -> sqrd x <= sqrd y.
  intros.
  unfold sqrd.
  apply mult_le_compat; auto.
Qed.

Hint Resolve sqrd_plus sqrd_le.

(* div2 properties *)

Lemma div2_preserves_le x y: x <= y -> div2 x <= div2 y.
Proof.
  rewrite !Nat.div2_div. now apply Nat.div_le_mono.
Qed.

Lemma Sdiv2_eq_div2SS x: S (div2 x) = div2 (S (S x)).
Proof. reflexivity. Qed.

Lemma div2S_le_Sdiv2 x: div2 (S x) <= S (div2 x).
Proof with auto with arith.
  destruct x...
  rewrite <- Sdiv2_eq_div2SS.
  apply -> Nat.succ_le_mono. apply div2_preserves_le...
Qed.

Lemma div2_x_plus_Sx b: div2 (b + S b) = b.
Proof with auto with arith.
  induction b...
  rewrite plus_Sn_m.
  rewrite <- plus_Snm_nSm.
  rewrite plus_Sn_m.
  simpl...
Qed.

Lemma div2_x_plus_2y a b: div2 (a + 2 * b) = div2 a + b.
Proof.
  rewrite !Nat.div2_div, Nat.mul_comm. now apply Nat.div_add.
Qed.

Lemma div2_sqrdSn n: div2 (sqrd n) + n <= div2 (sqrd (S n)).
Proof with auto with arith.
  intros.
  unfold sqrd.
  replace (S n * S n) with (n * n + 2 * n + 1) by ring.
  replace (div2 (n * n) + n) with (div2 (n * n + 2 * n)).
    apply div2_preserves_le...
  rewrite div2_x_plus_2y...
Qed.

Lemma le_div2 n: div2 n <= n.
Proof. apply Nat.div2_decr; auto with arith. Qed.

Lemma div2_lt_inv0 x y: div2 x < div2 y -> x < y.
Proof.
  rewrite !Nat.lt_nge. intros H H'. contradict H. now apply div2_preserves_le.
Qed.

Lemma div2_lt_inv x y: div2 x < div2 y -> x <= y.
Proof.
  intros. now apply Nat.lt_le_incl, div2_lt_inv0.
Qed.

Lemma div2_le_div2_inv x y: div2 x <= div2 y -> x <= S y.
Proof with auto with arith.
 destruct x as [|[|x]]...
 simpl. intros H. apply div2_lt_inv0 in H...
Qed.

Lemma div2_cancel n: div2 (2 * n) = n.
Proof with auto.
  induction n...
  simpl mult.
  rewrite <- plus_n_Sm.
  simpl in *...
Qed.

Lemma div2_le_inv x n: div2 x <= n -> x <= S (2 * n).
Proof. intros. rewrite <- (div2_cancel n) in H. apply (div2_le_div2_inv _ _ H). Qed.

(* pow *)

Fixpoint pow (b e: nat) {struct e}: nat :=
  match e with
  | 0 => 1
  | S e' => b * pow b e'
  end.

Lemma pow_S x y: pow x (S y) = x * pow x y.
Proof. auto. Qed.

Lemma pow_min x: x <> 0%nat -> forall y, 0 < pow x y.
Proof with auto with arith.
  intros H.
  induction y...
  simpl.
  apply lt_0_mult...
  destruct x...
Qed.

(* log2 *)

Function ceil_log2_S (n: nat) {wf lt n}: nat :=
  match n with
  | 0 => 0
  | S _ => S (ceil_log2_S (div2 n))
  end.
Proof.
  intros.
  apply lt_div2; auto with arith.
  apply lt_wf.
Defined.

Lemma ceil_log2_S_def n: ceil_log2_S n =
  match n with
  | 0 => 0
  | S _ => S (ceil_log2_S (div2 n))
  end.
Proof. functional induction (ceil_log2_S n); auto. Qed.

Definition log2ceil (n: nat): nat :=
  match n with
  | 0 => 0
  | S n' => ceil_log2_S n'
  end.

Function floor_log2_S (n: nat) {wf lt n}: nat :=
  match n with
  | 0 => 0
  | S n' => S (floor_log2_S (div2 n'))
  end.
Proof.
  intros.
  apply le_lt_trans with n'; auto with arith.
  apply le_div2.
  apply lt_wf.
Defined.

Lemma pow2_ceil_log2: forall n, S n <= pow 2 (ceil_log2_S n).
Proof with auto.
  intro.
  functional induction (ceil_log2_S n).
    simpl...
  rewrite pow_S.
  cset' (pow 2 (ceil_log2_S (div2 (S _x)))).
  destruct H.
    inversion IHn0.
  cset (le_S_n _ _ IHn0).
  cset (div2_le_inv (S _x) H0).
  omega.
Qed.

Lemma ceil_log2_Sn_le_n: forall n, ceil_log2_S n <= n.
Proof with auto with arith.
  intro.
  functional induction (ceil_log2_S n)...
  apply le_n_S.
  apply le_trans with (div2 (S _x))...
  apply lt_n_Sm_le.
  apply lt_div2...
Qed.

Lemma log2ceil_lt: forall n, 0 < n -> log2ceil n < n.
Proof with auto.
  destruct n...
  simpl.
  unfold lt.
  intros.
  apply le_n_S.
  apply ceil_log2_Sn_le_n.
Qed.

Lemma log2ceil_le: forall n, log2ceil n <= n.
Proof with auto with arith.
  destruct n...
  apply lt_le_weak.
  apply log2ceil_lt...
Qed.

Lemma log2ceil_S_preserves_le x y: x <= y -> ceil_log2_S x <= ceil_log2_S y.
Proof with auto with arith.
  revert y.
  functional induction (ceil_log2_S x)...
  intros.
  destruct y.
    inversion H.
  apply le_trans with (S (ceil_log2_S (div2 (S y)))).
    apply le_n_S...
    apply IHn.
    apply div2_preserves_le...
  rewrite (ceil_log2_S_def (S y))...
Qed.

Lemma log2ceil_preserves_le x y: x <= y -> log2ceil x <= log2ceil y.
Proof with auto with arith.
  destruct x.
    destruct y...
  destruct y.
    intros.
    inversion H.
  simpl.
  intros.
  apply log2ceil_S_preserves_le...
Qed.

(* INR comparisons *)

Lemma INR_S_ne_0 n: INR (S n) <> 0%R.
Proof. apply not_O_INR. discriminate. Qed.

Hint Resolve INR_S_ne_0.

Lemma O_le_inv_INR_S n: (0 <= / INR (S n))%R.
Proof. intros. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_INR_0. auto with arith. Qed.

Hint Resolve O_le_inv_INR_S.

Lemma INR_0_inv n: INR n = 0%R -> n = 0.
Proof with auto.
  destruct n...
  intros.
  elimtype False.
  apply (INR_S_ne_0 _ H).
Qed.

Lemma O_lt_INR_S n: (0 < INR (S n))%R.
Proof. intros. apply lt_INR_0. auto with arith. Qed.

Hint Resolve O_lt_INR_S.

Require Import Fourier.

(* R misc *)

Ltac deep_Rle_trans h :=
  match type of h with
  | ?n <= ?u =>
    match goal with
    | |- (?l <= _)%R =>
      let q := subst_tac n u l
      in apply Rle_trans with q
    | _ => assert (False)
    end
  end.

Lemma Rmult_eq_compat_r (r r1 r2: R): (r1 = r2 -> r1 * r = r2 * r)%R.
Proof. intros. subst. reflexivity. Qed.

Lemma Rle_eq_trans x y z: (x <= y -> y = z -> x <= z)%R.
Proof. intros. fourier. Qed.

Lemma Req_ne_dec (x y: R): { x = y } + { x <> y }.
Proof with auto.
  intros.
  destruct (Rlt_le_dec x y).
    right. intro. subst. apply (Rlt_irrefl y)...
  destruct (Rle_lt_or_eq_dec _ _ r); [right | left]...
  intro. subst. apply (Rlt_irrefl y)...
Qed.

Lemma Rmult_0_inv (a b: R): (a * b)%R = 0%R -> (a = 0%R \/ b = 0%R).
Proof with auto with real.
  intros.
  destruct (Req_ne_dec a 0%R)...
    destruct (Req_ne_dec b 0%R).
    right...
  elimtype False.
  apply (prod_neq_R0 a b)...
Qed.

Lemma Req_le_trans x y z: x = y -> y <= z -> x <= z.
Proof. intros. subst. assumption. Qed.

Lemma Rle_plus_trans_l r a b c: a <= r -> r + b <= c -> a + b <= c.
Proof. intros. apply Rle_trans with (r + b); auto with real. Qed.

Lemma Rne_nlt_lt x y: x <> y -> ~ x < y -> y < x.
Proof with auto with real.
  intros.
  destruct (Rlt_le_dec x y)...
    elimtype False...
  destruct (Rle_lt_or_eq_dec y x r)...
  elimtype False...
Qed.

Lemma Rdiv_le_1 a b: 0 < a -> a <= b -> 1 <= b / a.
Proof with auto with real.
  intros.
  unfold Rdiv.
  rewrite <- (Rinv_r a)...
Qed.

Lemma Rdiv_lt_1 n m: 0 <= n -> n < m -> n / m < 1.
Proof with auto with real.
  unfold Rdiv.
  intros.
  rewrite <- (Rinv_r m)...
    apply Rmult_lt_compat_r...
    apply Rinv_0_lt_compat...
    fourier.
  intro.
  subst.
  apply (Rlt_not_le _ _ H0 H).
Qed.

Lemma zero_le_2_div_Sn n: 0 <= (2 * / INR (S n))%R.
Proof with auto with real.
  intros.
  unfold Rdiv...
  apply Rle_mult_inv_pos...
Qed.

Hint Resolve zero_le_2_div_Sn.

Definition bigO (f g: nat -> R): Prop := exists c, exists n, forall x, (n <= x)%nat -> f x <= c * g x.

Definition measured_bigO (X: Set) (m: X -> nat) (f: X -> R) (g: nat -> R): Prop
  := exists c, exists n, forall x, (n <= m x)%nat -> f x <= c * g (m x).

Notation "'over' m , f =O( g )" := (measured_bigO m f g).


(********** Translating Expressions in Time **********)

(* This module defines the operation [translateExp] on expressions,
which corresponds to the [Translate] constructs on contracts. In
contrast to [Translate], however, [translateExp] works on [Z] instead of
only on [nat]. *)

Require Import Denotational.
Require Import Tactics.
Require Import Typing.
Require Import FunctionalExtensionality.

Fixpoint translateExp (d : Z) (e : Exp) : Exp :=
  match e with
    | OpE op args => OpE op (map (translateExp d) args)
    | Obs l i => Obs l (d + i)
    | VarE a => VarE a
    | Acc f n z => Acc (translateExp d f) n (translateExp d z)
  end.

Lemma translateExp_ope d op args : translateExp d (OpE op args) = OpE op (map (translateExp d) args).
reflexivity. Qed.

Ltac rewr_assumption := idtac; match goal with
                          | [R:  _ |- _ ] => rewrite R
                        end.

Lemma translateExp_ext (env : Env) d (e : Exp) ext :
  E[|translateExp d e|] env ext = E[|e|] env (adv_ext d ext).
Proof.
  generalize dependent ext.   generalize dependent env.
  induction e using Exp_ind';intros;
  try solve [simpl; repeat rewr_assumption; reflexivity].
  rewrite translateExp_ope. simpl. rewrite map_map.
  eapply all_apply with (p:= env) in H.
  eapply all_apply with (p:= ext) in H.
  apply map_rewrite in H. rewrite H. reflexivity.

  generalize dependent ext.   generalize dependent env.
  simpl. unfold Fsem in *. induction d0; intros.
  - simpl. apply IHe2.
  - repeat rewrite adv_ext_step. simpl. rewrite IHd0.
    repeat rewrite adv_ext_iter. apply bind_equals.
    f_equal; try (f_equal; omega). f_equal.
    f_equal; try (f_equal;f_equal; omega). do 2 (apply functional_extensionality; intro).
    do 3 f_equal. apply functional_extensionality. intros. do 3 f_equal. omega. do 2 f_equal. omega.
    intros.    rewrite IHe1.
    repeat rewrite Zpos_P_of_succ_nat. do 2 f_equal. omega. rewrite <- adv_ext_0. f_equal.
    omega.
Qed.

Open Scope Z.

Lemma translateExp_ext_opp (env : Env) (d d' : Z) (e : Exp) (ext : ExtEnv):
  d' + d = 0 -> E[|translateExp d e|] env (adv_ext d' ext) = E[|e|] env ext.
Proof.
  intro H. rewrite translateExp_ext. rewrite adv_ext_opp; auto.
Qed.

Lemma translateExp_type g d e t : g |-E e ∶ t -> g |-E translateExp d e ∶ t.
Proof.
  intro T. generalize dependent g.  generalize dependent t.
  induction e using Exp_ind'; intros; simpl; inversion T; subst; auto.
  - econstructor. eassumption. eapply all_apply' in H. apply all_zip; eauto.
Qed.


Require Import QArith_base.
Require Import Qcanon.
Require Import Equalities.
Require Import Orders.
Require Import OrdersTac.

Local Open Scope Qc_scope.

Module Qc_as_DT <: DecidableTypeFull.
  Lemma  Qc_eq_bool_iff : forall x y, Qc_eq_bool x y = true <-> x = y.
  Proof.
  intros. split.
    apply Qc_eq_bool_correct.
    intro. unfold Qc_eq_bool. destruct (Qc_eq_dec x y). reflexivity. contradiction.
  Qed.

  Definition t := Qc.
  Definition eq := @eq Qc.
  Definition eq_equiv := @eq_equivalence Qc.
  Definition eqb := Qc_eq_bool.
  Definition eqb_eq := Qc_eq_bool_iff.

  Include BackportEq.
  Include HasEqBool2Dec.

End Qc_as_DT.

Module Qc_as_OT <: OrderedTypeFull.
  Lemma Qccompare_spec (x y : Qc) : CompareSpec (x=y) (x<y) (x>y) (x ?= y).
  Proof. now case_eq (x ?= y); constructor; [rewrite Qceq_alt | rewrite Qclt_alt | rewrite Qcgt_alt]. Qed.

  Include Qc_as_DT.
  Definition lt := Qclt.
  Definition le := Qcle.
  Definition compare := Qccompare.

  Instance lt_strorder : StrictOrder Qclt.
  Proof. split.
    intro. apply Qlt_irrefl.
    intros x y z. apply Qlt_trans.
  Qed.

  Instance lt_compat : Proper (eq==>eq==>iff) Qclt.
  Proof. intros x y Hxy z t Hzt. now rewrite Hxy, Hzt. Qed.

  Theorem le_lteq : forall x y : t, le x y <-> lt x y \/ eq x y.
  Proof.
  intros x y. unfold le,lt,eq. split; intro H.
    destruct (Qcle_lt_or_eq _ _ H). now left. right. assumption.
    destruct H. now apply Qlt_le_weak. subst. now apply Qcle_refl.
  Qed.
  Definition compare_spec (x y : Qc) := Qccompare_spec x y.

End Qc_as_OT.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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 2.1 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 GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Section Sets.
  Variable U : Type.

  Definition set := U -> Prop.

  Definition In (A:set) x : Prop := A x.

  Definition Set_included A B := forall x, In A x -> In B x.

  Inductive Set_inter (A B:set) : set :=
    Set_inter_intro : forall x, In A x -> In B x -> In (Set_inter A B) x.

  Inductive Set_union (A B:set) : set :=
    | Set_union_intro_l : forall x, In A x -> In (Set_union A B) x
    | Set_union_intro_r : forall x, In B x -> In (Set_union A B) x.

  Inductive Set_empty : set :=.

  Inductive Set_full : set :=
    | Set_full_intro : forall x, In Set_full x.

  Inductive Set_singleton (x:U) : set :=
    Set_singleton_intro : In (Set_singleton x) x.

  Inductive Set_couple (x y:U) : set :=
    | Set_couple_l : In (Set_couple x y) x
    | Set_couple_r : In (Set_couple x y) y.

  Inductive Set_triple (x y z:U) : set :=
    | Set_triple_l : In (Set_triple x y z) x
    | Set_triple_m : In (Set_triple x y z) y
    | Set_triple_r : In (Set_triple x y z) z.

  Definition Set_complement (A:set) : set := fun x:U => ~ In A x.

  Definition Set_minus (B C:set) : set := fun x:U => In B x /\ ~ In C x.

  Definition Set_subtract (B:set) (x:U) : set := Set_minus B (Set_singleton x).

  Inductive Set_disjoint (B C:set) : Prop :=
    Set_disjoint_intro : (forall x:U, ~ In (Set_inter B C) x) -> Set_disjoint B C.

  Inductive Set_inhabited (B:set) : Prop :=
    Inhabited_intro : forall x:U, In B x -> Set_inhabited B.

  Definition Set_strict_included (B C:set) : Prop := Set_included B C /\ B <> C.

  Definition Set_same (B C:set) : Prop := Set_included B C /\ Set_included C B.

  Axiom Set_Extensionality : forall A B:set, Set_same A B -> A = B.
End Sets.

Arguments set {U}.
Arguments In {U} A x.
Arguments Set_included {U} A B.
Arguments Set_inter {U} A B _.
Arguments Set_union {U} A B _.
Arguments Set_empty {U} _.
Arguments Set_full {U} _.
Arguments Set_singleton {U} x _.
Arguments Set_couple {U} x y _.
Arguments Set_triple {U} x y z _.
Arguments Set_complement {U} A _.
Arguments Set_minus {U} B C _.
Arguments Set_subtract {U} B x _.
Arguments Set_disjoint {U} B C.
Arguments Set_inhabited {U} B.
Arguments Set_strict_included {U} B C.
Arguments Set_same {U} B C.
Arguments Set_Extensionality {U} A B _.


(*I will introduce you to how to operate with Coq
in the very basic steps

 Coq as a language is very raw and with not many
 in built structures.

 Instead, Coq allows for more control by the user
 (even the equalities are defined by the user!)

 Coq works with Inductive, Module, Definition and a
 proof mode.

 Already implemented Types are: nat naturals, bool booleans,
 Prop propositions, Set set.

 Let us work first on Prop.
*)

Check Prop. Check 2 = 1. Check True -> True.

Check False -> False. Eval compute in 10 + 10.

Eval compute in true. Compute false. Compute True -> True.

(* We enter proof mode by defining a goal/theorem
 about a proposition. the followint is the structure of a
 well written proof.*)

Goal forall (A:Prop), A -> A. (* Goal, definition of A, Prop.*)
Proof. (*Start of your proof.*)
  intros A. (*Introduces A as a given fact.*)
  intros Hypoth. (*Same as above*)
  (*We now know that A is a given fact because of Hypoth,
   and that we want to prove A.*)
  exact Hypoth. (* "Same as Hypoth"*)
  (*Now we can close our proof with Qed.*)
Qed.

Goal forall A B : Prop, (A -> A) /\ (B -> B).
Proof.
  intros. (*This command introduces everything automatically.*)
  (*Well, we met this: (A -> A) /\ (B -> B) which is "And".*)
  refine(conj _ _). (*This separates 1 goal into 2.*)
  (*In Coq, we always prove the topmost subgoals first.
  If you want to skip any of them for the time being, you
  can call the "admit." command, and it eliminates the
  topmost goal.*)
  admit.
  intro H.
  exact H.
  (*At this point, the following message displays:
  No more subgoals, but there are some goals you gave up:

  A -> A

  You need to go back and solve them.
  Let us end our proof and do it the right way.*)
  Admitted.
  (*The command Admitted. closes an entire proof under
  the assumption that it is an axiom/unfinished proof.*)

Goal forall A B : Prop, (A -> A) /\ (B -> B).
Proof.
  intros.
  refine(conj _ _).
  trivial.
  auto.
Qed.

Theorem n_equals_n : forall n:nat, n = n.
Proof.
  (*Whenever we have "forall", it is a good idea to
  introduce the variables/facts.*)
  intros.
  (*To prove this, you can use auto/trivial/intuition etc.
  The ideal argument instead is "reflexivity.". Let us use
  that.*)
  reflexivity.
Qed.

Goal forall n m:nat, n = n /\ m = m.
Proof.
  intros.
  refine(conj _ _).
  (*We can use flexibility again, but let use our recently
  proven theorem/lemma.*)
  apply n_equals_n.
  (*Or, we can introduce our lemma for later.*)
  pose proof n_equals_n as theorem.
  (* pose [args]. takes some arguments and generates a new
  fact object which we can use later.*)
  apply theorem.
Qed.

Goal true = true.
Proof.
  (*We could just use reflex. or apply a previous theorem,
  but let me show you another strategy.*)

  pose(x := true). (*Declares "obj" defined as "true".*)
  (*We can create facts which will be added as a subgoal,
  and we will need to prove such fact.*)
  assert(x = true). trivial.
  (*Now, we can rewrite our goal.*)
  rewrite <- H.
  pose proof n_equals_n as T.
  trivial.
Qed.

Goal 5 < 6.
Proof.
  intuition.
Qed.

Goal 5 <> 6. (* 5 not equal 6*)
Proof.
  (*reflexivity here fails. lets try unfolding this.*)
  unfold not. (*you can try autounfold.*)
  intro H.
  (*We ended up in false. It means one of our Props is
  false by nature, and we need to check which one.
  Thankfully, since the statement H is simple enough,
  we use discriminate.*)
  discriminate.
Qed.

Goal False -> False.
Proof.
  intro.
  (*One of our facts is false, let us use that.*)
  exact H.
Qed.

Goal forall a b:Prop, a -> b \/ a.
Proof.
  intros.
  pose (H0 := or_intror H : b \/ a).
  Check H0.
  (*We created a fact "b \/ a" with the argument H. Only
  demanding part was "or_intro(l/r)".*)
  exact H0.
Qed.

(*Here is a nice exercise:*)
Goal (forall A B : Prop, A -> (A->B) -> B).
Proof.
 intros A.
 intros B.
 intros proof_of_A.
 intros A_implies_B.
 pose (proof_of_B := A_implies_B proof_of_A).
 (*pose (proof_of_B := proof_of_A A_implies_B).
  this is the incorrect order.*)
 exact proof_of_B.
Qed.

Goal (forall A B : Prop, A\/B -> B\/A).
Proof.
  intros.
  case H.

    intro.
    refine(or_intror _).
    exact H0.

    intro.
    refine(or_introl _). (*this one is different from above*)
    exact H0.
Qed.

Goal forall (a b:Prop), exists x:Prop, x -> (a->b) -> b.
Proof.
  intros.
  (*We have an existence question. we can either prove it,
  with an example, prove it in a shady way, or disprove it.*)
  pose(example := a).
  (*We have our example, let us substitute in our goal.*)
  refine(ex_intro _ example _).
  (*refine(ex_intro function example _). more on documentation*)

  (*We eliminated the existencial condition. we proceed.*)
  intros.
  pose(H1 := H0 H).
  exact H1.
Qed.

(*We will need the following knowledge.*)
Goal True.
Proof. exact I. Qed.

(*Let us make a tiny exercise.*)
Lemma x_not_false_and_x_true : forall x:Prop, x <> False /\ x -> True.
Proof.
  intros.
  destruct H as [].
  exact I.
Qed.

(*Little challenge for you.*)
Theorem a_true_false : forall a:Prop, ((a->True)/\(a->False))->False.
Proof.
  (*Write proof here*)
Admitted.

Goal ~exists x:Prop,
  x <> False /\ x -> False.
Proof.
  intros.

  (*It may not tell you, but the negation of existence is
  for all. Let us use that.*)

  pose proof x_not_false_and_x_true as H.
  unfold not.

  intro.
  case H0.
  unfold not in H.
  (*Okay, now our lemma comes in place to help us.
  we will use the last two lemmas.*)

  intros.

  pose proof a_true_false as T. (*challenge lemma*)

  pose(s := ((x = False) -> False) /\ x). (*lets make a
  variable substitution.*)
  assert(s = (((x = False) -> False) /\ x)). intuition.
  (*do not forget that we need to prove both are equal.*)
  (*we are rewriting so that we get the shape that
  lemma T requires.*)

  rewrite <- H2 in H1.
  (*since our prior lemma is for all x, we need to specify
  one x.*)
  assert((((x = False) -> False) /\ x) -> True). apply H.

  rewrite <- H2 in H3.
  (*we make more asserts to finish with T*)
  assert((s -> True) /\ (s -> False)). intuition.
  assert(((s -> True) /\ (s -> False))->False). apply T.

  pose(finale := H5 H4).
  exact finale.
Qed.

(*Since the last proof was on the heavy end of a simple
  proof, we shall have a break to explore the nat set.*)

Print nat.

(*Inductive nat : Set :=
| O : nat
| S : nat -> nat.*)

(*We define nat as an inductive type, which constructors
  are O and S (uppercase O, not zero.*)

Eval compute in 5 - 3.

(*Every simple natural operation except division is defined.
  With subtraction there is a catch, 3 - 5 = 0.*)

Eval  compute in 3 - 5.

Lemma sub_in_nat_is_weird : 3 - 5 = 0.
Proof.
  simpl. (*This simplifies an expression.*)
  reflexivity.
Qed.

(*Proving in naturals function the same way as we did
  before.*)

(*We define 3 as S(S(S(O))).*)

Goal S(S(S(0))) = 3.
Proof.
  reflexivity. Qed.

(*let us define a function that detects a zero.*)

Definition is_zero (n:nat) := (*parameters*)
match n with (*works in a similar fashion of switch case*)
| O => true (*if base constructor (aka 0), then true*)
| S n' => false (* if it is a sucessor of any number, false*)
end.

Eval compute in is_zero 0. Compute is_zero 11.

(*Let us create a definition*)
Definition n_not_0 : forall n:nat, is_zero n = false -> n > 0.
Admitted.

Goal is_zero 0 = true.
Proof.
  simpl.
  reflexivity.
Qed.

(*We can define recursive functions.*)

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Eval compute in evenb 2. Compute evenb 4.

(*Let us define some facts.*)

Definition a0 : forall b:bool, negb b <> b.
Proof.
  intro b.
  autounfold.
  case b.
    simpl. intro. discriminate.
    simpl. intro. discriminate.
Qed.

Definition a0_1 : forall b:bool, b <> negb b.
Proof.
  intro b.
  autounfold.
  case b.
    simpl. intro. discriminate.
    simpl. intro. discriminate.
Qed.

Definition a1 : forall (n:nat),
  evenb n = evenb (n+2).
Proof.
  (*Can you prove it?*)
Admitted.

Definition a2 : forall (n:nat),
  evenb n = negb (evenb(n+1)).
Proof.
  (*Yet again another challenge.*)
Admitted.

Definition a2_1 : forall (n:nat), evenb n <> evenb(n+1).
Proof.
  intro.
  pose proof a2 as a2.
  rewrite a2.
  pose proof a0 as a0.
  apply a0.
Qed.

Definition a2_2 : forall n:nat,
evenb n = negb (evenb (n + 1)) <-> evenb n <> evenb(n+1).
Proof.
  intro.
  unfold iff.
  refine(conj _ _).

    intro.
    rewrite H.
    pose proof a0 as a0.
    apply a0.

    intro.
    autounfold in H.
    (*                    did not work for me.
    destruct H as [].
    pose proof a2 as a2.
    rewrite a2.
    pose proof a0 as a0.

    pose(x := evenb(n+1)).
    assert(x = evenb(n+1)).
    auto.
    rewrite <- H.
    case x.
      simpl.
      assert(false <> true). intuition. discriminate.*)
    pose proof a2.
    apply H0.
Qed.

Goal 6 = 6.
Proof.
  assert(forall x:nat, x = x). reflexivity.
  pose(x := 6).
  assert(6 = x). trivial.
  rewrite H0.
  apply H.
Qed.

Goal evenb 4 = evenb 6.
Proof.
  pose proof a1 as hyp_1.
  apply hyp_1.
Qed.

Goal evenb 4 = evenb 820.
Proof.
  pose proof a1 as hyp_1.
  apply hyp_1.
Qed.

Goal evenb 4 <> evenb 5.
Proof.
  pose proof a2_1 as hyp_2.
  apply hyp_2.
Qed.

Goal evenb 7 = false.
Proof.
  simpl.
  reflexivity.
Qed.

(*Here we start the real theorems!*)
Theorem two_n_is_even : forall n:nat, evenb(2*n) = true.
Proof.
  intro.
  elim n. simpl. reflexivity.
    intros.
    pose proof a1.
    rewrite H0 in H.
    assert(2* S n0 = 2*n0 + 2). auto.
    rewrite H1.
    exact H.
Qed.

(*This one will be really complicated to follow through.*)
Theorem a3_1 : forall n:nat, evenb(2*n + 1) = false.
Proof.
  intro.
  pose proof two_n_is_even as lem1.
  pose proof a2 as lem2.

  assert(forall n : nat,
      evenb (2*n) = negb (evenb (2*n + 1))).
    intro.
    pose(x:=2*n0).
    assert(2*n0 = x). auto.
    rewrite H.
    apply lem2.

    assert(negb(evenb (2 * n + 1)) = true).
    rewrite <- H.
    apply lem1.

    assert(forall b:bool, negb b = true -> b = false).
    intro b.
    case b.
      auto.
      auto.

    pose(x:=2 * n + 1). assert(x = 2 * n + 1). auto.
    rewrite <- H2.
    assert(negb(evenb(x)) = true).
    rewrite H2.
    exact H0.
    apply H1.
    exact H3.
Qed.

(*If you could figure out what was happening there, please
  tell me!!*)

(*Let us stray away from evenb functions.*)

Require Import Arith.
(*We imported a library!*)

Compute 5 mod 3.

(*Now we can talk about notations. Let us define a notation.*)

Notation "x ! y" := (y mod x =0) (at level 35).

Compute 3 ! 7.

Goal 3 ! 6.
Proof.
  simpl.
  reflexivity.
Qed.

Goal ~ (3 ! 7).
Proof.
  simpl.
  unfold not.
  intro.
  discriminate.
Qed.

Goal forall (x:nat) (k:nat), x ! (k * x).
Proof.
  intros.
  elim k. simpl.
    assert(x * 0 = 0). intuition. admit.
    intros. simpl.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Export Iterator.
Require Import ZArith.
Require Export UList.
Open Scope Z_scope.

Theorem next_n_Z: forall n m,  next_n Z.succ n m = n + Z_of_nat m.
intros n m; generalize n; elim m; clear n m.
intros n; simpl; auto with zarith.
intros m H n.
replace (n + Z_of_nat (S m)) with (Z.succ n + Z_of_nat m); auto with zarith.
rewrite <- H; auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprogression_end:
 forall n m,
  progression Z.succ n (S m) =
  app (progression Z.succ n m) (cons (n + Z_of_nat m) nil).
intros n m; generalize n; elim m; clear n m.
simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith.
intros m1 Hm1 n1.
apply trans_equal with (cons n1 (progression Z.succ (Z.succ n1) (S m1))); auto.
rewrite Hm1.
replace (Z.succ n1 + Z_of_nat m1) with (n1 + Z_of_nat (S m1)); auto with zarith.
replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1); auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprogression_pred_end:
 forall n m,
  progression Z.pred n (S m) =
  app (progression Z.pred n m) (cons (n - Z_of_nat m) nil).
intros n m; generalize n; elim m; clear n m.
simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith.
intros m1 Hm1 n1.
apply trans_equal with (cons n1 (progression Z.pred (Z.pred n1) (S m1))); auto.
rewrite Hm1.
replace (Z.pred n1 - Z_of_nat m1) with (n1 - Z_of_nat (S m1)); auto with zarith.
replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1); auto with zarith.
rewrite inj_S; auto with zarith.
Qed.

Theorem Zprogression_opp:
 forall n m,
  rev (progression Z.succ n m) = progression Z.pred (n + Z_of_nat (pred m)) m.
intros n m; generalize n; elim m; clear n m.
simpl; auto.
intros m Hm n.
rewrite (Zprogression_end n); auto.
rewrite distr_rev.
rewrite Hm; simpl; auto.
case m.
simpl; auto.
intros m1;
 replace (n + Z_of_nat (pred (S m1))) with (Z.pred (n + Z_of_nat (S m1))); auto.
rewrite inj_S; simpl; (unfold Z.pred; unfold Z.succ); auto with zarith.
Qed.

Theorem Zprogression_le_init:
 forall n m p, In p (progression Z.succ n m) ->  (n <= p).
intros n m; generalize n; elim m; clear n m; simpl; auto.
intros; contradiction.
intros m H n p [H1|H1]; auto with zarith.
generalize (H _ _ H1); auto with zarith.
Qed.

Theorem Zprogression_le_end:
 forall n m p, In p (progression Z.succ n m) ->  (p < n + Z_of_nat m).
intros n m; generalize n; elim m; clear n m; auto.
intros; contradiction.
intros m H n p H1; simpl in H1 |-; case H1; clear H1; intros H1;
 auto with zarith.
subst n; auto with zarith.
apply Z.le_lt_trans  with (p + 0); auto with zarith.
apply Zplus_lt_compat_l; red; simpl; auto with zarith.
apply Z.lt_le_trans with (Z.succ n + Z_of_nat m); auto with zarith.
rewrite inj_S; rewrite Zplus_succ_comm; auto with zarith.
Qed.

Theorem ulist_Zprogression: forall a n,  ulist (progression Z.succ a n).
intros a n; generalize a; elim n; clear a n; simpl; auto with zarith.
intros n H1 a; apply ulist_cons; auto.
intros H2; absurd (Z.succ a <= a); auto with zarith.
apply Zprogression_le_init with ( 1 := H2 ).
Qed.

Theorem in_Zprogression:
 forall a b n, ( a <= b < a + Z_of_nat n ) ->  In b (progression Z.succ a n).
intros a b n; generalize a b; elim n; clear a b n; auto with zarith.
simpl; auto with zarith.
intros n H a b.
replace (a + Z_of_nat (S n)) with (Z.succ a + Z_of_nat n); auto with zarith.
intros [H1 H2]; simpl; auto with zarith.
case (Zle_lt_or_eq _ _ H1); auto with zarith.
rewrite inj_S; auto with zarith.
Qed.


(* -*- mode: coq; mode: visual-line -*-  *)
(** * H-Sets *)

Require Import Basics.
Require Import Types.
Require Import HProp.

Local Open Scope path_scope.

(** A type is a set if and only if it satisfies Axiom K. *)

Definition axiomK A := forall (x : A) (p : x = x), p = idpath x.

Definition axiomK_hset {A} : IsHSet A -> axiomK A.
Proof.
  intros H x p.
  apply (H x x p (idpath x)).
Defined.

Definition hset_axiomK {A} `{axiomK A} : IsHSet A.
Proof.
  intros x y H.
  apply @hprop_allpath.
  intros p q.
  by induction p.
Defined.

Section AssumeFunext.
Context `{Funext}.

Theorem equiv_hset_axiomK {A} : IsHSet A <~> axiomK A.
Proof.
  apply (equiv_adjointify (@axiomK_hset A) (@hset_axiomK A)).
  - intros K. by_extensionality x. by_extensionality x'.
    cut (Contr (x=x)).
    + intro. eapply path_contr.
    + exists 1. intros. symmetry; apply K.
  - intro K. by_extensionality x. by_extensionality x'.
    eapply path_ishprop.
Defined.

Global Instance axiomK_isprop A : IsHProp (axiomK A) | 0.
Proof.
  apply (trunc_equiv _ equiv_hset_axiomK).
Defined.

Theorem hset_path2 {A} `{IsHSet A} {x y : A} (p q : x = y):
  p = q.
Proof.
  induction q.
  apply axiomK_hset; assumption.
Defined.

(** Recall that axiom K says that any self-path is homotopic to the
   identity path.  In particular, the identity path is homotopic to
   itself.  The following lemma says that the endo-homotopy of the
   identity path thus specified is in fact (homotopic to) its identity
   homotopy (whew!).  *)
(* TODO: What was the purpose of this lemma?  Do we need it at all?  It's actually fairly trivial. *)
Lemma axiomK_idpath {A} (x : A) (K : axiomK A) :
  K x (idpath x) = idpath (idpath x).
Proof.
  pose (T1A := @trunc_succ _ A (@hset_axiomK A K)).
  exact (@hset_path2 (x=x) (T1A x x) _ _ _ _).
Defined.

End AssumeFunext.

(** We prove that if [R] is a reflexive mere relation on [X] implying identity, then [X] is an hSet, and hence [R x y] is equivalent to [x = y]. *)
Lemma ishset_hrel_subpaths
      {X R}
      `{Reflexive X R}
      `{forall x y, IsHProp (R x y)}
      (f : forall x y, R x y -> x = y)
: IsHSet X.
Proof.
  apply @hset_axiomK.
  intros x p.
  refine (_ @ concat_Vp (f x x (transport (R x) p^ (reflexivity _)))).
  apply moveL_Vp.
  refine ((transport_paths_r _ _)^ @ _).
  refine ((transport_arrow _ _ _)^ @ _).
  refine ((ap10 (apD (f x) p) (@reflexivity X R _ x)) @ _).
  apply ap.
  apply path_ishprop.
Defined.

Global Instance isequiv_hrel_subpaths
       X R
       `{Reflexive X R}
       `{forall x y, IsHProp (R x y)}
       (f : forall x y, R x y -> x = y)
       x y
: IsEquiv (f x y) | 10000.
Proof.
  pose proof (ishset_hrel_subpaths f).
  refine (isequiv_adjointify
            (f x y)
            (fun p => transport (R x) p (reflexivity x))
            _
            _);
  intro;
  apply path_ishprop.
Defined.

(** We will now prove that for sets, monos and injections are equivalent.*)
Definition ismono {X Y} (f : X -> Y)
  := forall (Z : hSet),
     forall g h : Z -> X, f o g = f o h -> g = h.

Definition isinj {X Y} (f : X -> Y)
  := forall x0 x1 : X,
       f x0 = f x1 -> x0 = x1.

Lemma isinj_embedding {A B : Type} (m : A -> B) : IsEmbedding m -> isinj m.
Proof.
  intros ise x y p.
  pose (ise (m y)).
  assert (q : (x;p) = (y;1) :> hfiber m (m y)) by apply path_ishprop.
  exact (ap pr1 q).
Defined.

Lemma isembedding_isinj_hset {A B : Type} `{IsHSet B} (m : A -> B)
: isinj m -> IsEmbedding m.
Proof.
  intros isi b.
  apply hprop_allpath; intros [x p] [y q].
  apply path_sigma_hprop; simpl.
  exact (isi x y (p @ q^)).
Defined.

Lemma ismono_isinj `{Funext} {X Y} (f : X -> Y) : isinj f -> ismono f.
Proof.
  intros ? ? ? ? H'.
  apply path_forall.
  apply ap10 in H'.
  hnf in *.
  eauto.
Qed.

Definition isinj_ismono {X Y} (f : X -> Y)
           (H : ismono f)
: isinj f
  := fun x0 x1 H' =>
       ap10 (H (BuildhSet Unit)
               (fun _ => x0)
               (fun _ => x1)
               (ap (fun x => unit_name x) H'))
            tt.

Lemma ismono_isequiv `{Funext} X Y (f : X -> Y) `{IsEquiv _ _ f}
: ismono f.
Proof.
  intros ? g h H'.
  apply ap10 in H'.
  apply path_forall.
  intro x.
  transitivity (f^-1 (f (g x))).
  - by rewrite eissect.
  - transitivity (f^-1 (f (h x))).
    * apply ap. apply H'.
    * by rewrite eissect.
Qed.


Require Import While String.
Require Import ZArith.
Open Scope Z_scope.

Definition fac :=
  Seq
    (Assign "res" (Const 1))
    (Seq
       (While (Lt (Const 0) (Var "n"))
              (Seq
                 (Assign "res" (Binop Bmul (Var "res") (Var "n")))
                 (Assign "n" (Binop Bsub (Var "n") (Const 1)))
              )
       )
       (Output (Var "res"))
    ).


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Reals Psatz.

Require Import Xreal.
Require Import Basic.
Require Import Sig.
Require Import Interval.
Require Import Float.
Require Import Transcend.

Module FloatIntervalFull (F : FloatOps with Definition even_radix := true) <: IntervalOps.

Module F' := FloatExt F.
Module T := TranscendentalFloatFast F.
Include FloatInterval F.

Definition s1 := F.ZtoS 1.
Definition s2 := F.ZtoS 2.
Definition s3 := F.ZtoS 3.
Definition sm1 := F.ZtoS (-1).
Definition c1 := F.fromZ 1.
Definition cm1 := F.fromZ (-1).
Definition c3 := F.fromZ 3.

Definition pi prec :=
  scale2 (T.pi4 prec) s2.

Lemma pi_correct :
  forall prec, contains (convert (pi prec)) (Xreal PI).
Proof.
intros prec.
unfold pi.
replace (Xreal PI) with (Xmul (Xreal (PI/4)) (Xreal (Raux.bpow radix2 2))).
  apply scale2_correct, T.pi4_correct.
change (Raux.bpow _ _) with 4%R.
simpl.
apply f_equal.
field.
Qed.

(* accurate only for |xi| <= 2 * pi *)
Definition cos prec xi :=
  match abs xi with
  | Ibnd xl xu =>
    if F'.le xu xl then T.cos_fast prec xl else
    let pi4 := T.pi4 prec in
    if F'.le xu (F.scale2 (lower pi4) s2) then
      bnd (lower (T.cos_fast prec xu)) (upper (T.cos_fast prec xl))
    else
      if F'.le xu (F.scale2 (lower pi4) s3) then
        if F'.le (F.scale2 (upper pi4) s2) xl then
          bnd (lower (T.cos_fast prec xl)) (upper (T.cos_fast prec xu))
        else
          bnd cm1 (F.max (upper (T.cos_fast prec xl)) (upper (T.cos_fast prec xu)))
      else
        let d := F.sub_exact xu xl in
        if F'.le d c3 then
          let m := F.scale2 (F.add_exact xl xu) sm1 in
          let d := F.scale2 d sm1 in
          let c := T.cos_fast prec m in
          meet (bnd cm1 c1) (add prec c (bnd (F.neg d) d))
        else bnd cm1 c1
  | Inan => Inan
  end.

Lemma cos_correct :
  forall prec, extension Xcos (cos prec).
Proof.
intros prec xi x Hx.
unfold cos.
generalize (abs_correct xi x Hx) (abs_ge_0' xi).
destruct (abs xi) as [|xl xu].
easy.
intros Ha Hal.
simpl in Hal.
destruct x as [|x] ; try easy.
unfold Xbind.
replace (Rtrigo_def.cos x) with (Rtrigo_def.cos (Rabs x)).
2: unfold Rabs ; case Rcase_abs ; intros _ ; try easy ; apply cos_neg.
clear Hx.
assert (Hcxl := T.cos_fast_correct prec xl).
assert (Hcxu := T.cos_fast_correct prec xu).
case_eq (F'.le xu xl).
  intros Hl.
  apply F'.le_correct in Hl.
  simpl in Ha.
  destruct (F.toX xu) as [|xur] ; try easy.
  destruct (F.toX xl) as [|xlr] ; try easy.
  replace (Rabs x) with xlr.
  exact Hcxl.
  apply Rle_antisym.
  apply Ha.
  now apply Rle_trans with (2 := Hl).
intros _.
unfold cm1, c1, c3, sm1, s2, s3.
case_eq (F'.le xu (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 2))).
  intros Hu.
  apply F'.le_correct in Hu.
  simpl in Ha.
  destruct (F.toX xu) as [|xur] ; try easy.
  assert (Hxur: (xur <= PI)%R).
    revert Hu.
    rewrite F.scale2_correct by easy.
    change (Raux.bpow _ _) with 4%R.
    generalize (T.pi4_correct prec).
    destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
    now rewrite F.nan_correct.
    intros [H _] Hu.
    destruct (F.toX pi4l) as [|pi4r] ; try easy.
    apply Rle_trans with (1 := Hu).
    lra.
  clear Hu.
  split.
    apply proj2 in Ha.
    destruct (T.cos_fast prec xu) as [|cu cu'] ; simpl.
      now rewrite F.nan_correct.
    destruct Hcxu as [Hcu _].
    destruct (F.toX cu) as [|cur] ; try easy.
    apply Rle_trans with (1 := Hcu).
    apply cos_decr_1 with (4 := Hxur) (5 := Ha).
    apply Rabs_pos.
    now apply Rle_trans with xur.
    apply Rle_trans with (2 := Ha).
    apply Rabs_pos.
  generalize (T.cos_fast_correct prec xl).
  destruct (T.cos_fast prec xl) as [|cl' cl] ; simpl.
    intros _.
    now rewrite F.nan_correct.
  destruct (F.toX xl) as [|xlr] ; try easy.
  intros [_ Hl].
  destruct (F.toX cl) as [|clr] ; try easy.
  apply Rle_trans with (2 := Hl).
  apply cos_decr_1 with (1 := Hal).
  apply Rle_trans with (2 := Hxur).
  now apply Rle_trans with (Rabs x).
  apply Rabs_pos.
  now apply Rle_trans with xur.
  apply Ha.
intros _.
case_eq (F'.le xu (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 3))).
  intros Hu.
  apply F'.le_correct in Hu.
  simpl in Ha.
  destruct (F.toX xu) as [|xur] ; try easy.
  assert (Hxur: (xur <= 2 * PI)%R).
    revert Hu.
    rewrite F.scale2_correct by easy.
    change (Raux.bpow _ _) with 8%R.
    generalize (T.pi4_correct prec).
    destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
    now rewrite F.nan_correct.
    intros [H _] Hu.
    destruct (F.toX pi4l) as [|pi4r] ; try easy.
    apply Rle_trans with (1 := Hu).
    lra.
  clear Hu.
  case_eq (F'.le (F.scale2 (upper (T.pi4 prec)) (F.ZtoS 2)) xl).
    intros Hl.
    apply F'.le_correct in Hl.
    destruct (F.toX xl) as [|xlr].
    now destruct (F.toX (F.scale2 (upper (T.pi4 prec)) (F.ZtoS 2))).
    assert (Hxlr: (PI <= xlr)%R).
      revert Hl.
      rewrite F.scale2_correct by easy.
      change (Raux.bpow _ _) with 4%R.
      generalize (T.pi4_correct prec).
      destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
      now rewrite F.nan_correct.
      intros [_ H] Hl.
      destruct(F.toX pi4u) as [|pi4r] ; try easy.
      apply Rle_trans with (2 := Hl).
      lra.
    clear Hl.
    split.
      destruct (T.cos_fast prec xl) as [|cl cl'] ; simpl.
        now rewrite F.nan_correct.
      destruct Hcxl as [Hcl _].
      destruct (F.toX cl) as [|clr] ; try easy.
      apply Rle_trans with (1 := Hcl).
      apply cos_incr_1 with (1 := Hxlr) (5 := proj1 Ha).
      apply Rle_trans with (2 := Hxur).
      apply Rle_trans with (1 := proj1 Ha) (2 := proj2 Ha).
      apply Rle_trans with (1 := Hxlr) (2 := proj1 Ha).
      apply Rle_trans with (1 := proj2 Ha) (2 := Hxur).
    destruct (T.cos_fast prec xu) as [|cu' cu] ; simpl.
      now rewrite F.nan_correct.
    destruct Hcxu as [_ Hcu].
    destruct (F.toX cu) as [|cur] ; try easy.
    apply Rle_trans with (2 := Hcu).
    apply cos_incr_1 with (4 := Hxur) (5 := proj2 Ha).
    apply Rle_trans with (1 := Hxlr) (2 := proj1 Ha).
    apply Rle_trans with (1 := proj2 Ha) (2 := Hxur).
    apply Rle_trans with (1 := Hxlr).
    apply Rle_trans with (1 := proj1 Ha) (2 := proj2 Ha).
  intros _.
  split.
    rewrite F.fromZ_correct.
    apply COS_bound.
  rewrite F.max_correct.
  destruct (T.cos_fast prec xl) as [|cl' cl] ; simpl.
    now rewrite F.nan_correct.
  destruct (F.toX xl) as [|xlr] ; try easy.
  destruct Hcxl as [_ Hcl].
  destruct (F.toX cl) as [|clr] ; try easy.
  destruct (T.cos_fast prec xu) as [|cu' cu] ; simpl.
    now rewrite F.nan_correct.
  destruct Hcxu as [_ Hcu].
  destruct (F.toX cu) as [|cur] ; try easy.
  destruct (Rle_dec (Rabs x) PI) as [Hx|Hx].
    apply Rle_trans with (2 := Rmax_l _ _).
    apply Rle_trans with (2 := Hcl).
    apply cos_decr_1 with (1 := Hal) (3 := Rabs_pos _) (4 := Hx) (5 := proj1 Ha).
    apply Rle_trans with (1 := proj1 Ha) (2 := Hx).
  apply Rle_trans with (2 := Rmax_r _ _).
  apply Rle_trans with (2 := Hcu).
  apply Rnot_le_lt, Rlt_le in Hx.
  apply cos_incr_1 with (1 := Hx) (4 := Hxur) (5 := proj2 Ha).
  apply Rle_trans with (1 := proj2 Ha) (2 := Hxur).
  apply Rle_trans with (1 := Hx) (2 := proj2 Ha).
intros _.
case_eq (F'.le (F.sub_exact xu xl) (F.fromZ 3)).
  intros Hd.
  apply F'.le_correct in Hd.
  revert Hd.
  rewrite F.sub_exact_correct, F.fromZ_correct.
  case_eq (F.toX xu) ; try easy ; intros xur Hur.
  case_eq (F.toX xl) ; try easy ; intros xlr Hlr.
  intros _.
  apply meet_correct.
    unfold convert, bnd.
    rewrite 2!F.fromZ_correct.
    apply COS_bound.
  set (m := ((xlr + xur) / 2)%R).
  replace (Xreal (Rtrigo_def.cos (Rabs x)))
      with (Xadd (Xcos (Xreal m)) (Xreal (Rtrigo_def.cos (Rabs x) - Rtrigo_def.cos m)))
      by (apply (f_equal Xreal) ; ring).
  apply add_correct.
    replace (Xreal m) with (F.toX (F.scale2 (F.add_exact xl xu) (F.ZtoS (-1)))).
      apply T.cos_fast_correct.
    unfold m, T.toR.
    rewrite F.scale2_correct, F.add_exact_correct by easy.
    now rewrite Hlr, Hur.
  simpl.
  rewrite F.neg_correct, F.scale2_correct by easy.
  rewrite F.sub_exact_correct, Hlr, Hur.
  simpl.
  apply Raux.Rabs_le_inv.
  destruct (MVT_abs Rtrigo_def.cos (fun t => Ropp (sin t)) m (Rabs x)) as [v [-> _]].
  intros c _.
  apply derivable_pt_lim_cos.
  apply Rle_trans with (1 * Rabs (Rabs x - m))%R.
  apply Rmult_le_compat_r.
  apply Rabs_pos.
  rewrite Rabs_Ropp.
  apply Rabs_le, SIN_bound.
  rewrite Rmult_1_l.
  apply Rabs_le.
  revert Ha.
  simpl.
  rewrite Hlr, Hur.
  unfold m.
  change (Z.pow_pos 2 1) with 2%Z.
  lra.
intros _.
unfold convert, bnd.
rewrite 2!F.fromZ_correct.
apply COS_bound.
Qed.

(* accurate only for |xi| <= 5/2*pi *)
Definition sin prec xi :=
  match xi with
  | Ibnd xl xu =>
    if F'.le xu xl then T.sin_fast prec xl else
    let pi4 := T.pi4 prec in
    let pi2 := F.scale2 (lower pi4) s1 in
    match F'.le (F.neg pi2) xl, F'.le xu pi2 with
    | true, true =>
      bnd (lower (T.sin_fast prec xl)) (upper (T.sin_fast prec xu))
    | true, false =>
      cos prec (sub prec (scale2 pi4 s1) xi)
    | _, _ =>
      neg (cos prec (add prec xi (scale2 pi4 s1)))
    end
  | Inan => Inan
  end.

Theorem sin_correct :
  forall prec, extension Xsin (sin prec).
Proof.
intros prec [|xl xu] [|x] Hx ; try easy.
generalize Hx.
intros [Hxl Hxu].
simpl.
case_eq (F'.le xu xl).
  intros Hl.
  apply F'.le_correct in Hl.
  assert (Hsxl := T.sin_fast_correct prec xl).
  destruct (F.toX xu) as [|xur] ; try easy.
  destruct (F.toX xl) as [|xlr] ; try easy.
  replace x with xlr.
  exact Hsxl.
  apply Rle_antisym with (1 := Hxl).
  now apply Rle_trans with (2 := Hl).
intros _.
unfold s1.
set (pi2 := F.scale2 (lower (T.pi4 prec)) (F.ZtoS 1)).
case_eq (F'.le (F.neg pi2) xl).
  intros Hpl.
  generalize (F'.le_correct _ _ Hpl).
  xreal_tac xl.
    now case (F.toX (F.neg pi2)).
  clear Hpl. intros Hpl.
  case_eq (F'.le xu pi2).
    intros Hpu.
    generalize (F'.le_correct _ _ Hpu).
    xreal_tac xu. easy.
    xreal_tac pi2. easy.
    clear Hpu. intros Hpu.
    revert Hpl.
    rewrite F.neg_correct, X1.
    simpl.
    intros Hpl.
    generalize (F.scale2_correct (lower (T.pi4 prec)) 1 (refl_equal _)).
    intros X2.
    change (F.toX pi2 = Xmul (F.toX (lower (T.pi4 prec))) (Xreal 2)) in X2.
    rewrite X1 in X2. clear X1.
    revert X2.
    generalize (T.pi4_correct prec).
    case (T.pi4 prec) ; simpl.
      now rewrite F.nan_correct.
    intros p.
    xreal_tac p. easy.
    intros _ [Hp _] H.
    injection H.
    clear H X1. intros H.
    assert (Hpl': (-(PI/2) <= r)%R).
      apply Rle_trans with (2 := Hpl).
      apply Ropp_le_contravar.
      rewrite H.
      replace (PI / 2)%R with (PI / 4 * 2)%R by field.
      apply Rmult_le_compat_r with (2 := Hp).
      now apply IZR_le.
    assert (Hpu': (r0 <= PI/2)%R).
      apply Rle_trans with (1 := Hpu).
      rewrite H.
      replace (PI / 2)%R with (PI / 4 * 2)%R by field.
      apply Rmult_le_compat_r with (2 := Hp).
      now apply IZR_le.
    split.
      generalize (T.sin_fast_correct prec xl).
      destruct (T.sin_fast prec xl) as [|yl yu].
        simpl.
        now rewrite F.nan_correct.
      rewrite X.
      simpl.
      xreal_tac yl. easy.
      intros [Hy _].
      apply Rle_trans with (1 := Hy).
      assert (H' := Rle_trans _ _ _ Hxu Hpu').
      apply sin_incr_1 ; try easy.
      now apply Rle_trans with x.
      now apply Rle_trans with r.
    generalize (T.sin_fast_correct prec xu).
    destruct (T.sin_fast prec xu) as [|yl yu].
      simpl.
      now rewrite F.nan_correct.
    rewrite X0.
    simpl.
    xreal_tac yu. easy.
    intros [_ Hy].
    apply Rle_trans with (2 := Hy).
    assert (H' := Rle_trans _ _ _ Hpl' Hxl).
    apply sin_incr_1 ; try easy.
    now apply Rle_trans with r0.
    now apply Rle_trans with x.
  intros _.
  rewrite <- cos_shift.
  change (Xreal (Rtrigo_def.cos (PI / 2 - x))) with (Xcos (Xsub (Xreal (PI / 2)) (Xreal x))).
  apply cos_correct.
  apply sub_correct with (2 := Hx).
  replace (PI / 2)%R with (PI / 4 * 2)%R by field.
  apply (scale2_correct _ (Xreal (PI / 4)) 1%Z).
  apply T.pi4_correct.
intros _.
rewrite <- (Ropp_involutive x).
rewrite sin_neg.
apply (neg_correct _ (Xreal _)).
rewrite <- cos_shift.
replace (PI / 2 - - x)%R with (x + PI / 2)%R by ring.
change (Xreal (Rtrigo_def.cos (x + PI / 2))) with (Xcos (Xadd (Xreal x) (Xreal (PI / 2)))).
apply cos_correct.
apply (add_correct _ _ _ _ _ Hx).
replace (PI / 2)%R with (PI / 4 * 2)%R by field.
apply (scale2_correct _ (Xreal (PI / 4)) 1%Z).
apply T.pi4_correct.
Qed.

(* meaningful only for |xi| <= pi/2 *)
Definition tan prec xi :=
  match xi with
  | Ibnd xl xu =>
    if F'.le xu xl then T.tan_fast prec xl else
    let pi2 := F.scale2 (lower (T.pi4 prec)) s1 in
    match F'.lt (F.neg pi2) xl, F'.lt xu pi2 with
    | true, true =>
      bnd (lower (T.tan_fast prec xl)) (upper (T.tan_fast prec xu))
    | _, _ => Inan
    end
  | Inan => Inan
  end.

Lemma tan_correct :
  forall prec, extension Xtan (tan prec).
Proof.
intros prec [|xl xu] [|x] Hx ; try easy.
unfold tan.
case_eq (F'.le xu xl).
  intros Hl.
  apply F'.le_correct in Hl.
  assert (Htxl := T.tan_fast_correct prec xl).
  unfold convert in Hx, Hl.
  destruct (F.toX xu) as [|xur] ; try easy.
  destruct (F.toX xl) as [|xlr] ; try easy.
  replace x with xlr.
  exact Htxl.
  apply Rle_antisym with (1 := proj1 Hx).
  apply Rle_trans with (2 := Hl).
  apply Hx.
unfold s1.
intros _.
case_eq (F'.lt (F.neg (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 1))) xl) ; try easy.
intros Hlt1.
apply F'.lt_correct in Hlt1.
case_eq (F'.lt xu (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 1))) ; try easy.
intros Hlt2.
apply F'.lt_correct in Hlt2.
generalize (T.tan_correct prec xl) (T.tan_correct prec xu).
simpl in Hx.
destruct (F.toX xl) as [|rl].
now destruct (F.toX (F.neg (F.scale2 (lower (T.pi4 prec)) (F.ZtoS 1)))).
destruct (F.toX xu) as [|ru] ; try easy.
intros Hl Hu.
rewrite bnd_correct.
rewrite F.neg_correct in Hlt1.
rewrite F.scale2_correct in Hlt1, Hlt2 by easy.
generalize (T.pi4_correct prec).
destruct (T.pi4 prec) as [|pi4l pi4u].
simpl in Hlt1.
now rewrite F.nan_correct in Hlt1.
intros [Hpil _].
simpl in Hlt1, Hlt2.
destruct (F.toX pi4l) as [|pi4r] ; try easy.
simpl in Hlt1, Hlt2.
apply (Rmult_le_compat_r 2) in Hpil.
2: now apply IZR_le.
unfold Rdiv in Hpil.
replace (PI * /4 * 2)%R with (PI / 2)%R in Hpil by field.
assert (H1: (- PI / 2 < rl)%R).
  apply Rle_lt_trans with (2 := Hlt1).
  unfold Rdiv.
  rewrite Ropp_mult_distr_l_reverse.
  now apply Ropp_le_contravar.
assert (H2: (ru < PI / 2)%R).
  now apply Rlt_le_trans with (pi4r * 2)%R.
unfold Xtan'.
simpl.
case is_zero_spec.
simpl in Hx.
apply Rgt_not_eq, cos_gt_0.
apply Rlt_le_trans with (2 := proj1 Hx).
unfold Rdiv.
now rewrite <- Ropp_mult_distr_l_reverse.
now apply Rle_lt_trans with ru.
unfold Xtan' in Hl, Hu.
intros _.
split.
- destruct (T.tan_fast prec xl) as [|tl tu].
  simpl.
  now rewrite F.nan_correct.
  revert Hl.
  simpl.
  case is_zero_spec ; try easy.
  intros _ [H _].
  destruct (F.toX tl) as [|rtl] ; try easy.
  apply Rle_trans with (1 := H).
  destruct (proj1 Hx) as [Hx'|Hx'].
  apply Rlt_le.
  apply tan_increasing ; try easy.
  now apply Rle_lt_trans with ru.
  rewrite Hx'.
  apply Rle_refl.
- destruct (T.tan_fast prec xu) as [|tl tu].
  simpl.
  now rewrite F.nan_correct.
  revert Hu.
  simpl.
  case is_zero_spec ; try easy.
  intros _ [_ H].
  destruct (F.toX tu) as [|rtu] ; try easy.
  apply Rle_trans with (2 := H).
  destruct (proj2 Hx) as [Hx'|Hx'].
  apply Rlt_le.
  apply tan_increasing ; try easy.
  now apply Rlt_le_trans with rl.
  rewrite Hx'.
  apply Rle_refl.
Qed.

Definition atan prec xi :=
  match xi with
  | Ibnd xl xu =>
    Ibnd
     (if F.real xl then lower (T.atan_fast prec xl)
      else F.neg (F.scale2 (upper (T.pi4 prec)) s1))
     (if F.real xu then upper (T.atan_fast prec xu)
      else F.scale2 (upper (T.pi4 prec)) s1)
  | Inan => Inan
  end.

Lemma atan_correct :
  forall prec, extension Xatan (atan prec).
Proof.
intros prec [|xl xu] [|x] Hx ; try easy.
assert (Hpi := T.pi4_correct prec).
simpl.
rewrite 2!F.real_correct.
simpl in Hx.
unfold s1.
split.
- generalize (proj1 Hx). clear Hx.
  case_eq (F.toX xl).
  intros _ _.
  rewrite F.neg_correct.
  rewrite F.scale2_correct by easy.
  destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
  now rewrite F.nan_correct.
  simpl in Hpi.
  destruct (F.toX pi4u) as [|rpi4] ; try easy.
  apply Rlt_le.
  apply Rle_lt_trans with (2 := proj1 (atan_bound x)).
  replace (- PI / 2)%R with (-(PI / 4 * 2))%R by field.
  apply Ropp_le_contravar.
  apply Rmult_le_compat_r with (2 := proj2 Hpi).
  now apply IZR_le.
  intros rl Hl Hx.
  generalize (T.atan_correct prec xl).
  destruct (T.atan_fast prec xl) as [|al au].
  intros _.
  simpl.
  now rewrite F.nan_correct.
  simpl.
  rewrite Hl.
  destruct (F.toX al) as [|ral] ; try easy.
  intros [H _].
  apply Rle_trans with (1 := H).
  destruct Hx as [Hx|Hx].
  now apply Rlt_le, atan_increasing.
  rewrite Hx.
  apply Rle_refl.
- generalize (proj2 Hx). clear Hx.
  case_eq (F.toX xu).
  intros _ _.
  rewrite F.scale2_correct by easy.
  destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl.
  now rewrite F.nan_correct.
  simpl in Hpi.
  destruct (F.toX pi4u) as [|rpi4] ; try easy.
  apply Rlt_le.
  apply Rlt_le_trans with (1 := proj2 (atan_bound x)).
  replace (PI / 2)%R with (PI / 4 * 2)%R by field.
  apply Rmult_le_compat_r with (2 := proj2 Hpi).
  now apply IZR_le.
  intros rl Hl Hx.
  generalize (T.atan_correct prec xu).
  destruct (T.atan_fast prec xu) as [|al au].
  intros _.
  simpl.
  now rewrite F.nan_correct.
  simpl.
  rewrite Hl.
  destruct (F.toX au) as [|rau] ; try easy.
  intros [_ H].
  apply Rle_trans with (2 := H).
  destruct Hx as [Hx|Hx].
  now apply Rlt_le, atan_increasing.
  rewrite Hx.
  apply Rle_refl.
Qed.

Definition exp prec xi :=
  match xi with
  | Ibnd xl xu =>
    Ibnd
     (if F.real xl then lower (T.exp_fast prec xl) else F.zero)
     (if F.real xu then upper (T.exp_fast prec xu) else F.nan)
  | Inan => Inan
  end.

Theorem exp_correct :
  forall prec, extension Xexp (exp prec).
Proof.
intros prec [|xl xu].
trivial.
intros [|x].
trivial.
intros (Hxl, Hxu).
split.
(* lower *)
clear Hxu.
rewrite F.real_correct.
xreal_tac xl.
rewrite F.zero_correct.
simpl.
apply Rlt_le.
apply exp_pos.
generalize (T.exp_fast_correct prec xl).
destruct (T.exp_fast prec xl) as [|yl yu].
unfold lower.
now rewrite F.nan_correct.
rewrite X.
intros (H, _).
simpl.
xreal_tac2.
apply Rle_trans with (1 := H).
now apply Raux.exp_le.
(* upper *)
clear Hxl.
rewrite F.real_correct.
xreal_tac xu.
now rewrite F.nan_correct.
generalize (T.exp_fast_correct prec xu).
destruct (T.exp_fast prec xu) as [|yl yu].
unfold upper.
now rewrite F.nan_correct.
rewrite X.
intros (_, H).
simpl.
xreal_tac2.
apply Rle_trans with (2 := H).
now apply Raux.exp_le.
Qed.

Definition ln prec xi :=
  match xi with
  | Ibnd xl xu =>
    if F'.lt F.zero xl then
      Ibnd
        (lower (T.ln_fast prec xl))
        (if F.real xu then upper (T.ln_fast prec xu) else F.nan)
    else Inan
  | Inan => Inan
  end.

Theorem ln_correct :
  forall prec, extension Xln (ln prec).
Proof.
intros prec [|xl xu].
easy.
unfold Xln'.
intros [|x].
easy.
simpl.
intros [Hl Hu].
case_eq (F'.lt F.zero xl) ; intros Hlt ; try easy.
apply F'.lt_correct in Hlt.
rewrite F.zero_correct in Hlt.
simpl in Hlt.
case is_positive_spec.
intros Hx.
split.
generalize (T.ln_fast_correct prec xl).
case T.ln_fast.
intros _.
simpl.
now rewrite F.nan_correct.
intros l u.
simpl.
case_eq (Xln (F.toX xl)).
easy.
intros lnx Hlnx.
intros [H _].
destruct (F.toX l) as [|lr].
easy.
apply Rle_trans with (1 := H).
destruct (F.toX xl) as [|xlr].
easy.
revert Hlnx.
unfold Xln'.
simpl.
case is_positive_spec.
intros _ H'.
injection H'.
intros <-.
destruct Hl as [Hl|Hl].
now apply Rlt_le, ln_increasing.
rewrite Hl.
apply Rle_refl.
easy.
rewrite F.real_correct.
case_eq (F.toX xu).
now rewrite F.nan_correct.
intros xur Hxu.
rewrite Hxu in Hu.
generalize (T.ln_fast_correct prec xu).
case T.ln_fast.
intros _.
simpl.
now rewrite F.nan_correct.
intros l u.
simpl.
rewrite Hxu.
unfold Xln'.
simpl.
case is_positive_spec.
intros _.
intros [_ H].
destruct (F.toX u) as [|ur].
easy.
apply Rle_trans with (2 := H).
destruct Hu as [Hu|Hu].
now apply Rlt_le, ln_increasing.
rewrite Hu.
apply Rle_refl.
easy.
intros Hx.
destruct (F.toX xl) as [|xlr].
easy.
elim Rle_not_lt with (1 := Hx).
now apply Rlt_le_trans with xlr.
Qed.

End FloatIntervalFull.


Require Import ZArith.
Require Import Reals.
Require Import RPolS.
Require Import PolSBase.
Require Import PolFBase.
Require Import PolAux.
Require Import PolAuxList.
Require Import RSignTac.

Definition Rfactor :=
  factor Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Definition Rfactor_minus :=
  factor_sub Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Ltac Rfactor_term term1 term2 :=
let term := constr:(Rminus term1 term2) in
let rfv := FV RCst Rplus Rmult Rminus Ropp term (@nil R) in
let fv := Trev rfv in
let expr1 := mkPolexpr Z RCst Rplus Rmult Rminus Ropp term1 fv in
let expr2 := mkPolexpr Z RCst Rplus Rmult Rminus Ropp term2 fv in
let re := eval vm_compute in (Rfactor_minus (PEsub expr1 expr2)) in
let factor := match re with (PEmul ?X1 _) => X1 end in
let expr3 := match re with (PEmul _ (PEsub ?X1 _)) => X1 end in
let expr4 := match re with (PEmul _ (PEsub _ ?X1 )) => X1 end in
let
 re1' :=
  eval
     unfold
      Rconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl, Z2R, P2R in (Rconvert_back (PEmul factor expr3) fv) in
let re1'' := eval lazy beta in re1' in
let
 re2' :=
  eval
     unfold
      Rconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl, Z2R, P2R in (Rconvert_back (PEmul factor expr4) fv) in
let re2'' := eval lazy beta in re2' in
replace2_tac term1 term2 re1'' re2''; [idtac| ring | ring].

Ltac rpolf :=
progress (
(try
match goal with
| |- (?X1 = ?X2)%R =>  Rfactor_term X1 X2
| |- (?X1 <> ?X2)%R =>  Rfactor_term X1 X2
| |- Rlt ?X1 ?X2 => Rfactor_term X1 X2
| |- Rgt ?X1 ?X2 =>Rfactor_term X1 X2
| |- Rle ?X1 ?X2 => Rfactor_term X1 X2
| |- Rge ?X1 ?X2 =>Rfactor_term X1 X2
| _ => fail end)); try (rsign_tac); try repeat (rewrite Rmult_1_l || rewrite Rmult_1_r).

Ltac hyp_rpolf H :=
progress (
generalize H;
(try
match type of H with
  (?X1 = ?X2)%R =>  Rfactor_term X1 X2
| (?X1 <> ?X2)%R =>  Rfactor_term X1 X2
| Rlt ?X1 ?X2 => Rfactor_term X1 X2
| Rgt ?X1 ?X2 =>Rfactor_term X1 X2
| Rle ?X1 ?X2 => Rfactor_term X1 X2
| Rge ?X1 ?X2 =>Rfactor_term X1 X2
| _ => fail end)); clear H; intros H; try (hyp_rsign_tac H); try repeat rewrite Rmult_1_l in H.


(* Función de búsqueda *)
Fixpoint lookup1 (key: N) (t: binTrie1) : option nat :=
match t with
| empty1 => None
| leaf1 x => Some x
| trie1 t1 t2 => if (N.even key) then lookup1 (N.div2 key) t1
                else lookup1 (N.div2 key) t2
end.


(** Coq coding by choukh, Aug 2020 **)

Require Import ZFC.Lib.Natural.

(* 以ω为指标集的集族的并 *)
Definition IFUnion : (set → set) → set :=
  λ F, ⋃{F n | n ∊ ω}.
Notation "'⋃ᵢ' F" := (IFUnion F)
  (at level 9, right associativity).

Lemma IFUnionI : ∀ F : set → set, ∀n ∈ ω, F n ⊆ ⋃ᵢ F.
Proof.
  intros F n Hn. unfold Sub. now apply FUnionI.
Qed.

Lemma IFUnionE : ∀ F : set → set, ∀x ∈ ⋃ᵢ F, ∃n ∈ ω, x ∈ F n.
Proof.
  intros F x Hx. apply FUnionE in Hx as [n [Hn H]].
  exists n. split; auto.
Qed.

Lemma nat_IFUnionI : ∀ F : nat → set, ∀ n : nat, F n ⊆ ⋃ᵢ F.
Proof.
  intros * x Hx. eapply FUnionI. apply (embed_ran n).
  rewrite proj_embed_id. apply Hx.
Qed.

Lemma nat_IFUnionE : ∀ F : nat → set, ∀x ∈ ⋃ᵢ F, ∃ n, x ∈ F n.
Proof.
  intros F x Hx. apply FUnionE in Hx as [n [Hn H]].
  exists n. apply H.
Qed.


Require Export Iron.Language.SystemF2r.TyEnv.
Require Export Iron.Language.SystemF2r.Ty.
Require Export Iron.Language.SystemF2r.Ki.

(* Expressions *)
Inductive exp : Type :=
 | XVar  : nat -> exp
 | XLAM  : exp -> exp
 | XAPP  : exp -> ty  -> exp
 | XLam  : ty  -> exp -> exp
 | XApp  : exp -> exp -> exp.
Hint Constructors exp.

(* Weak normal forms cannot be reduced further by
   call-by-value evaluation. *)
Inductive wnfX : exp -> Prop :=
 | Wnf_XVar
   : forall i
   , wnfX (XVar i)

 | Wnf_XLAM
   : forall x1
   , wnfX (XLAM x1)

 | Wnf_XLam
   : forall t1 x2
   , wnfX (XLam t1 x2).
Hint Constructors wnfX.

(* A well formed expression is closed under the given environments *)
Fixpoint wfX (kn: nat) (tn: nat) (xx: exp) : Prop :=
 match xx with
 | XVar ti    => ti < tn
 | XLAM x     => wfX (S kn) tn x
 | XAPP x t   => wfX kn tn x  /\ wfT kn t
 | XLam t x   => wfT kn t     /\ wfX kn (S tn) x
 | XApp x1 x2 => wfX kn tn x1 /\ wfX kn tn x2
 end.
Hint Unfold wfX.

(* A closed expression is well formed under an empty environment. *)
Definition closedX (xx: exp) : Prop
 := wfX O O xx.
Hint Unfold closedX.

(* Values are closed expressions that cannot be reduced further *)
Inductive value : exp -> Prop :=
 | Value
   :  forall xx
   ,  wnfX xx -> closedX xx
   -> value xx.
Hint Constructors value.

Lemma value_wnfX
 : forall xx, value xx -> wnfX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_wnfX.

Lemma value_closedX
 : forall xx, value xx -> closedX xx.
 Proof. intros. inverts H. auto. Qed.
Hint Resolve value_closedX.

(********************************************************************)
(* Lift type indices in expressions. *)
Fixpoint liftTX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar _     => xx

  |  XLAM x
  => XLAM (liftTX (S d) x)

  |  XAPP x t
  => XAPP (liftTX d x)   (liftTT 1 d t)

  |  XLam t x
  => XLam (liftTT 1 d t) (liftTX d x)

  |  XApp x1 x2
  => XApp (liftTX d x1)  (liftTX d x2)
 end.

(* Lift value indices in expressions. *)
Fixpoint liftXX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar ix
  => if le_gt_dec d ix
      then XVar (S ix)
      else xx

  |  XLAM x
  => XLAM (liftXX d x)

  |  XAPP x t
  => XAPP (liftXX d x) t

  |  XLam t x
  => XLam t (liftXX (S d) x)

  |  XApp x1 x2
  => XApp (liftXX d x1) (liftXX d x2)
 end.

(********************************************************************)
(* Substitution of Types in Exps *)
Fixpoint substTX (d: nat) (u: ty) (xx: exp) : exp :=
  match xx with
  | XVar _     => xx

  |  XLAM x
  => XLAM (substTX (S d) (liftTT 1 0 u) x)

  |  XAPP x t
  => XAPP (substTX d u x)  (substTT d u t)

  |  XLam t x
  => XLam (substTT d u t)  (substTX d u x)

  |  XApp x1 x2
  => XApp (substTX d u x1) (substTX d u x2)
 end.

(* Substitution of Exps in Exps *)
Fixpoint substXX (d: nat) (u: exp) (xx: exp) : exp :=
  match xx with
  | XVar ix
  => match nat_compare ix d with
     | Eq => u
     | Gt => XVar (ix - 1)
     | _  => XVar  ix
     end

  |  XLAM x
  => XLAM (substXX d (liftTX 0 u) x)

  |  XAPP x t
  => XAPP (substXX d u x) t

  |  XLam t x
  => XLam t (substXX (S d) (liftXX 0 u) x)

  |  XApp x1 x2
  => XApp (substXX d u x1) (substXX d u x2)
  end.


Require Import List.

Section NoetherianImplStreamless.
  Variable A : Set.

  Fixpoint existsLi (P:A->Prop) (l:list A) : Prop :=
    match l with
      | nil => False
      | h::tail => (P h \/ (existsLi P tail))
    end.

  Fixpoint goodLi (R:A-> A->Prop) (l:list A) : Prop :=
    match l with
      | nil => False
      | a::tail => (existsLi (R a) tail \/ goodLi R tail)
    end.

  Inductive accessible (P: list A->Prop) (l:list A): Prop:=
  | accessibleBase: P l -> accessible P l
  | accessibleInd: (forall x : A, accessible P (x :: l)) -> accessible P l.

  Fixpoint Initials (n:nat) (f: nat -> A) : list A :=
    match n with
      | 0 => nil
      | S n => (f n) :: (Initials n f)
    end.

  Definition Noetherian (R: A -> A ->Prop) : Prop := accessible (goodLi R) nil.
  Definition Streamless  (R: A -> A ->Prop) : Prop := forall f:nat -> A,exists n:nat, (goodLi R) (Initials n f).

  Definition goodLiImplGoodF (R:A-> A->Prop)  (f:nat -> A) (l:list A) : Prop :=  goodLi R l -> goodLi R (Initials (length l) f).
  Definition raListImpliesRaF (R:A->A->Prop)  (f:nat -> A) (l:list A) : Prop :=  forall a:A, existsLi (R a) l -> existsLi (R a) (Initials (length l) f).

  (* This version is rather verbose to make clear what happens, it can be made shorter by using "inversion H1;auto"  *)
  Lemma noeimplstrHelp (R: A -> A ->Prop) (f:nat->A) : forall l:list A, accessible (goodLi R) l  -> (goodLiImplGoodF R f l) -> (raListImpliesRaF R f l) -> exists m, (goodLi R) (Initials m f).
  Proof.
    intros l acc eqGood eqRRel .
    unfold goodLiImplGoodF in eqGood.
    unfold raListImpliesRaF in eqRRel.
    induction acc.
    exists (length l).
    apply eqGood;auto.
    pose (H0 (f (length l))).
    apply e.
    intro H1.
    simpl.
    inversion H1.
    left.
    apply eqRRel.
    exact H2.
    right.
    apply eqGood.
    exact H2.
    (* inversion H1;auto. *)
    intros a H1.
    inversion H1.
    simpl.
    left.
    exact H2.
    right.
    pose (eqRRel a) as e0.
    apply e0;auto.
  Qed.

  Lemma NoeimplStr (R:A->A->Prop) : Noetherian R -> Streamless R.
  Proof.
    unfold Noetherian.
    intros acc f.
    apply noeimplstrHelp with (l:=nil);auto.
    intro H; contradiction H.
    intros a H; contradiction H.
  Qed.

End NoetherianImplStreamless.