(** **********************************************************

Benedikt Ahrens

************************************************************)

(** **********************************************************

Contents :

  - generalization of precategories

************************************************************)

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.auxiliary_lemmas_HoTT.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.

Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

(** * Definition of a generalized precategory *)

Definition gprecategory_ob_mor := total2 (
  fun ob : UU => ob -> ob -> UU).

Definition gprecategory_ob_mor_pair (ob : UU)(mor : ob -> ob -> UU) :
    gprecategory_ob_mor := tpair _ ob mor.

Definition ob (C : gprecategory_ob_mor) : Type := @pr1 _ _ C.
Coercion ob : gprecategory_ob_mor >-> Sortclass.

Definition gprecategory_morphisms { C : gprecategory_ob_mor } :
       C ->  C -> UU := pr2 C.

(** We introduce notation for morphisms *)
(** in order for this notation not to pollute subsequent files,
    we define this notation locally *)

Local Notation "a --> b" := (gprecategory_morphisms a b)(at level 50).

(** ** [gprecategory_data] *)
(** data of a gprecategory :
    - objects
    - morphisms
    - identity morphisms
    - composition
*)

Definition gprecategory_id_comp (C : gprecategory_ob_mor) :=
     dirprod (forall c : C, c --> c) (* identities *)
             (forall a b c : C,
                 a --> b -> b --> c -> a --> c).

Definition gprecategory_data := total2 gprecategory_id_comp.

Definition gprecategory_data_pair (C : gprecategory_ob_mor)
    (id : forall c : C, c --> c)
    (comp: forall a b c : C,
         a --> b -> b --> c -> a --> c) : gprecategory_data :=
   tpair _ C (dirprodpair id comp).

Definition gprecategory_ob_mor_from_gprecategory_data (C : gprecategory_data) :
     gprecategory_ob_mor := pr1 C.
Coercion gprecategory_ob_mor_from_gprecategory_data :
  gprecategory_data >-> gprecategory_ob_mor.

Definition identity { C : gprecategory_data } :
    forall c : C, c --> c :=
         pr1 (pr2 C).

Definition compose { C : gprecategory_data }
  { a b c : C } :
    a --> b -> b --> c -> a --> c := pr2 (pr2 C) a b c.

Local Notation "f ;; g" := (compose f g)(at level 50).

(** ** Axioms of a gprecategory *)
(**
        - identity is left and right neutral for composition
        - composition is associative
*)

Definition is_gprecategory (C : gprecategory_data) :=
   dirprod (dirprod (forall (a b : C) (f : a --> b),
                         identity a ;; f == f)
                     (forall (a b : C) (f : a --> b),
                         f ;; identity b == f))
            (forall (a b c d : C)
                    (f : a --> b)(g : b --> c) (h : c --> d),
                     f ;; (g ;; h) == (f ;; g) ;; h).

Definition gprecategory := total2 is_gprecategory.

Definition gprecategory_data_from_gprecategory (C : gprecategory) :
       gprecategory_data := pr1 C.
Coercion gprecategory_data_from_gprecategory : gprecategory >-> gprecategory_data.

Definition id_left (C : gprecategory) :
   forall (a b : C) (f : a --> b),
           identity a ;; f == f := pr1 (pr1 (pr2 C)).

Definition id_right (C : gprecategory) :
   forall (a b : C) (f : a --> b),
           f ;; identity b == f := pr2 (pr1 (pr2 C)).

Definition assoc (C : gprecategory) :
   forall (a b c d : C)
          (f : a --> b)(g : b --> c) (h : c --> d),
                     f ;; (g ;; h) == (f ;; g) ;; h := pr2 (pr2 C).

(** Any equality on objects a and b induces a morphism from a to b *)

Definition idtomor {C : gprecategory_data}
   (a b : C) (H : a == b) : a --> b.
Proof.
  destruct H.
  exact (identity a).
Defined.

Definition idtomor_inv {C : gprecategory}
    (a b : C) (H : a == b) : b --> a.
Proof.
  destruct H.
  exact (identity a).
Defined.

Lemma cancel_postcomposition (C : gprecategory_data) (a b c: C)
   (f f' : a --> b) (g : b --> c) : f == f' -> f ;; g == f' ;; g.
Proof.
  intro H.
  destruct H.
  apply idpath.
Defined.

(** * Equivalence in a generalized gprecategory *)

(** ** Definition of equivalences *)

Definition postcompose_with {C : gprecategory} {b c : ob C} (g : b --> c) :
      forall {a}, a --> b -> a --> c :=
   fun a f =>  f ;; g.

Definition is_leq {C : gprecategory} {b c : ob C} (g : b --> c) :=
     forall a : ob C, isweq (postcompose_with g (a:=a)).

(** being a left equivalence is a proposition *)
Lemma isaprop_is_leq {C : gprecategory} {b c : ob C} (g : b --> c) :
   isaprop (is_leq g).
Proof.
  apply impred;
  intro t; apply isapropisweq.
Qed.

Definition leq {C : gprecategory} (b c : ob C) : UU :=
   total2 (fun g : b --> c => is_leq g).
Definition morphism_from_leq (C : gprecategory)(a b : ob C)
   (f : leq a b) : a --> b := pr1 f.
Coercion morphism_from_leq : leq >-> gprecategory_morphisms.

Lemma eq_leq {C : gprecategory} (b c : ob C) (f g : leq b c) :
   pr1 f == pr1 g -> f == g.
Proof.
  apply total2_paths_hProp.
  apply isaprop_is_leq.
Defined.

Lemma id_is_leq {C : gprecategory} (a : ob C) : is_leq (identity a).
Proof.
  intro b.
  apply (gradth _ (fun x => x)).
  - intro g; apply id_right.
  - intro g; apply id_right.
Qed.

Definition id_leq {C : gprecategory} (a : ob C) : leq a a :=
        tpair _ _ (id_is_leq a).

Lemma postcompose_with_composition_ext {C : gprecategory} (b c d: ob C)
   (f : b --> c) (g : c --> d) :
   forall a (h : a --> b), postcompose_with (f ;; g) h ==
        postcompose_with g (postcompose_with f h).
Proof.
  intros a h; apply assoc.
Defined.

Lemma postcompose_with_composition {C : gprecategory} (b c d: ob C)
   (f : b --> c) (g : c --> d) :
   forall a, postcompose_with (f ;; g) (a:=a) ==
        fun x => postcompose_with g (postcompose_with f x).
Proof.
  intro a. apply funextfun.
  apply postcompose_with_composition_ext.
Defined.

Lemma is_leq_composition {C : gprecategory} (b c d: ob C)
   (f : b --> c) (g : c --> d) :
   is_leq f -> is_leq g ->  is_leq (f ;; g).
Proof.
  intros Hf Hg a.
  rewrite postcompose_with_composition.
  apply twooutof3c; auto.
Qed.

Definition leq_comp {C : gprecategory} {b c d: ob C}
   (f : leq b c) (g : leq c d) : leq b d :=
  tpair _ (f ;; g) (is_leq_composition _ _ _ f g (pr2 f) (pr2 g)).

Definition idtoleq {C : gprecategory} {c d : ob C} (p : c == d) : leq c d.
Proof.
  destruct p; exact (id_leq _ ).
Defined.

Definition is_category (C : gprecategory) := forall (a b : ob C),
    isweq (fun p : a == b => idtoleq p).

Lemma isaprop_is_category (C : gprecategory) : isaprop (is_category C).
Proof.
  apply impred; intro a.
  apply impred; intro b.
  apply isapropisweq.
Qed.

(** ** Univalent categories *)

Definition leqtoid (C : gprecategory) (H : is_category C) {a b : ob C}:
      leq a b -> a == b := invmap (weqpair _ (H a b)).

Lemma idtoleq_leqtoid (C : gprecategory) (H : is_category C) (a b : ob C) (f : leq a b) :
       idtoleq (leqtoid _ H f) == f.
Proof.
  apply (homotweqinvweq (weqpair idtoleq (H a b))).
Qed.

Lemma lefteqtoid_idtolefteq (C : gprecategory) (H : is_category C) (a b : ob C) (p : a == b) :
   leqtoid _ H (idtoleq p) == p.
Proof.
  apply (homotinvweqweq (weqpair idtoleq (H a b))).
Qed.

(** more properties of leq *)

Lemma idtoleq_postcompose (C : gprecategory) (a b b' : ob C)
  (p : b == b') (f : a --> b) :
      f ;; idtoleq p == transportf (fun b => a --> b) p f.
Proof.
  destruct p.
  apply id_right.
Qed.

Lemma idtoleq_postcompose_leq (C : gprecategory) (a b b' : ob C)
  (p : b == b') (f : leq a b) :
    leq_comp f (idtoleq p) == transportf (fun b => leq a b) p f.
Proof.
  destruct p.
  apply eq_leq.
  simpl.
  apply id_right.
Qed.

Lemma idtoleq_precompose (C : gprecategory) (a a' b : ob C)
  (p : a == a') (f : a --> b) :
      (idtoleq (!p)) ;; f == transportf (fun a => a --> b) p f.
Proof.
  destruct p.
  apply id_left.
Qed.

Lemma idtoleq_precompose_leq (C : gprecategory) (a a' b : ob C)
  (p : a == a') (f : leq a b) :
      leq_comp (idtoleq (!p)) f == transportf (fun a => leq a b) p f.
Proof.
  destruct p; apply eq_leq.
  apply id_left.
Qed.

(*
Lemma double_transport_idtoiso (C : gprecategory) (a a' b b' : ob C)
  (p : a == a') (q : b == b') (f : a --> b) :
  double_transport p q f == inv_from_iso (idtoiso p) ;; f ;; idtoiso q.
Proof.
  destruct p.
  destruct q.
  rewrite id_right.
  rewrite id_left.
  apply idpath.
Qed.
*)

(*
Lemma idtoiso_inv (C : gprecategory) (a a' : ob C)
  (p : a == a') : idtoiso (!p) == iso_inv_from_iso (idtoiso p).
Proof.
  destruct p.
  apply idpath.
Qed.
*)

Lemma idtoleq_concat (C : gprecategory) (a a' a'' : ob C)
  (p : a == a') (q : a' == a'') :
  idtoleq (p @ q) == leq_comp (idtoleq p) (idtoleq q).
Proof.
  destruct p;
  destruct q.
  apply eq_leq.
  simpl;
  rewrite id_left.
  apply idpath.
Qed.

Lemma idtoleq_inj (C : gprecategory) (H : is_category C) (a a' : ob C)
   (p p' : a == a') : idtoleq p == idtoleq p' -> p == p'.
Proof.
  apply invmaponpathsincl.
  apply isinclweq.
  apply H.
Qed.

Lemma leqtoid_inj (C : gprecategory) (H : is_category C) (a a' : ob C)
   (f f' : leq a a') : leqtoid _ H f == leqtoid _ H f' -> f == f'.
Proof.
  apply invmaponpathsincl.
  apply isinclweq.
  apply isweqinvmap.
Qed.

Lemma leqtoid_comp (C : gprecategory) (H : is_category C) (a b c : ob C)
  (e : leq a b) (f : leq b c) :
  leqtoid _ H (leq_comp e f) == leqtoid _ H e @ leqtoid _ H f.
Proof.
  apply idtoleq_inj.
    assumption.
  rewrite idtoleq_concat.
  repeat rewrite idtoleq_leqtoid.
  apply idpath.
Qed.

Lemma leqtoid_identity_leq (C : gprecategory) (H : is_category C) (a : C) :
  leqtoid _ H (id_leq a) == idpath _ .
Proof.
  apply idtoleq_inj; try assumption.
  rewrite idtoleq_leqtoid;
  apply idpath.
Qed.

(*
Lemma inv_leqtoid (C : gprecategory) (H : is_category C) (a b : C)
    (f : leq a b) : ! leqtoid _ H f == leqtoid _ H (iso_inv_from_iso f).
Proof.
  apply idtoiso_inj; try assumption.
  rewrite idtoiso_isotoid.
  rewrite idtoiso_inv.
  rewrite idtoiso_isotoid.
  apply idpath.
Qed.
*)

(*
Lemma transportf_isotoid (C : gprecategory) (H : is_category C)
   (a a' b : ob C) (p : iso a a') (f : a --> b) :
 transportf (fun a0 : C ⇒ a0 --> b) (isotoid C H p) f == inv_from_iso p ;; f.
Proof.
  rewrite <- idtoiso_precompose.
  rewrite idtoiso_inv.
  rewrite idtoiso_isotoid.
  apply idpath.
Qed.
*)

Lemma transportf_isotoid_dep (C : gprecategory)
   (a a' : C) (p : a == a') (f : forall c, a --> c) :
 transportf (fun x : C => forall c, x --> c) p f == fun c => idtoleq (!p) ;; f c.
Proof.
  destruct p.
  apply funextsec.
  intro; rewrite id_left.
  apply idpath.
Qed.

Lemma transportf_isotoid_dep' (J C : gprecategory) (F : J -> C)
   (a a' : C) (p : a == a') (f : forall c, a --> F c) :
 transportf (fun x : C => forall c, x --> F c) p f == fun c => idtoleq (!p) ;; f c.
Proof.
  destruct p.
  apply funextsec.
  intro. simpl.
  apply (! id_left _ _ _ _).
Defined.

(** for producing the inverse, we seem to need that
 - a "natural transformation" alpha : F -> G : C -> UU
   which is pointwise an equiv, is a "natural iso".
 - a natural iso has an inverse
 - natural transformations are representable
*)

(** define the category UU *)

Definition UUcat_data : gprecategory_data.
  exists (tpair (fun x => x -> x -> UU) UU (fun A B : UU => A -> B)).
  split; simpl.
  intro c; exact (fun x => x).
  intros a b c f g ; exact (fun x => g (f x)).
Defined.

Lemma is_gprecategory_UUcat : is_gprecategory UUcat_data.
Proof.
  repeat split; simpl.
Qed.

Definition UUcat : gprecategory := tpair _ _ is_gprecategory_UUcat.

(** TODO: UUcat is univalent *)

(** ** Functors *)

Definition functor_data (C C' : gprecategory_ob_mor) := total2 (
    fun F : ob C -> ob C' =>
             forall a b : ob C, a --> b -> F a --> F b).

Definition mkfunctor_data (C C' : gprecategory_ob_mor)
    a b : functor_data C C' := tpair _ a b.

Definition functor_on_objects {C C' : gprecategory_ob_mor}
     (F : functor_data C C') :  ob C -> ob C' := pr1 F.
Coercion functor_on_objects : functor_data >-> Funclass.

Definition functor_on_morphisms {C C' : gprecategory_ob_mor} (F : functor_data C C')
  { a b : ob C} :  a --> b -> F a --> F b := pr2 F a b.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).

Definition is_functor {C C' : gprecategory_data} (F : functor_data C C') :=
     dirprod (forall a : ob C, #F (identity a) == identity (F a))
             (forall a b c : ob C, forall f : a --> b, forall g : b --> c,
                #F (f ;; g) == #F f ;; #F g).

(*
Lemma isaprop_is_functor (C C' : gprecategory_data)
       (F : functor_data C C'): isaprop (is_functor F).
Proof.
  apply isofhleveldirprod.
  apply impred; intro a.
  apply (pr2 (_ --> _)).
  repeat (apply impred; intro).
  apply (pr2 (_ --> _)).
Qed.
*)

Definition functor (C C' : gprecategory) := total2 (
   fun F : functor_data C C' => is_functor F).

Definition functor_data_from_functor (C C': gprecategory)
     (F : functor C C') : functor_data C C' := pr1 F.
Coercion functor_data_from_functor : functor >-> functor_data.

Definition functor_id {C C' : gprecategory}(F : functor C C'):
       forall a : ob C, #F (identity a) == identity (F a) := pr1 (pr2 F).

Definition functor_comp {C C' : gprecategory}
      (F : functor C C'):
       forall a b c : ob C, forall f : a --> b,
                 forall g : b --> c,
                #F (f ;; g) == #F f ;; #F g := pr2 (pr2 F).

(** * Natural transformations *)

(** ** Definition of natural transformations *)

Definition is_nat_trans {C C' : gprecategory_data}
  (F F' : functor_data C C')
  (t : forall x : ob C, F x -->  F' x) :=
  forall (x x' : ob C)(f : x --> x'),
    #F f ;; t x' == t x ;; #F' f.

Definition nat_trans {C C' : gprecategory_data}
  (F F' : functor_data C C') := total2 (
   fun t : forall x : ob C, F x -->  F' x => is_nat_trans F F' t).

Definition nat_trans_data (C C' : gprecategory_data)
 (F F' : functor_data C C')(a : nat_trans F F') :
   forall x : ob C, F x --> F' x := pr1 a.
Coercion nat_trans_data : nat_trans >-> Funclass.

Definition nat_trans_ax {C C' : gprecategory_data}
  (F F' : functor_data C C') (a : nat_trans F F') :
  forall (x x' : ob C)(f : x --> x'),
    #F f ;; a x' == a x ;; #F' f := pr2 a.

(** ** opposite category *)

Definition opp_precat_ob_mor (C : gprecategory_ob_mor) : gprecategory_ob_mor :=
   tpair (fun ob : UU => ob -> ob -> UU) (ob C)
        (fun a b : ob C => b --> a  ).

Definition opp_precat_data (C : gprecategory_data) : gprecategory_data.
Proof.
  exists (opp_precat_ob_mor C).
  split.
  exact (fun c => identity c).
  simpl.
  intros a b c f g.
  exact (g ;; f).
Defined.

Hint Unfold identity.

Ltac unf := unfold identity,
                   compose,
                   gprecategory_morphisms;
                   simpl.

Lemma is_precat_opp_precat_data (C : gprecategory) : is_gprecategory (opp_precat_data C).
Proof.
  repeat split; simpl.
  intros. unf.
  apply id_right.
  intros; unf.
  apply id_left.
  intros; unf.
  rewrite assoc.
  apply idpath.
Qed.

Definition opp_precat (C : gprecategory) : gprecategory :=
  tpair _ (opp_precat_data C) (is_precat_opp_precat_data C).

Local Notation "C '^op'" := (opp_precat C) (at level 3).


Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.
From QuickChick Require Import QuickChick.

Definition TODO{T: Type}: T. Admitted.

(* (This one should be in the QuickChick library) *)
Global Instance Dec_iff {P Q} {H : Dec P} {I : Dec Q} : Dec (P <-> Q).
Proof.
  constructor. unfold ssrbool.decidable.
  destruct H as [D]; destruct D;
    destruct I as [D]; destruct D; intuition auto.
Defined.

Definition E := nat.
Definition eeq: forall (e1 e2: E), {e1 = e2} + {e1 <> e2} := Nat.eq_dec.

Definition set: Type -> Type := list.

Definition contains(A: set E)(e: E): Prop := List.In e A.

Definition union(A B: list E): list E :=
  fold_left (fun res a => if in_dec eeq a res then res else a :: res) A B.

Lemma union_spec: forall (x: E) (A B: set E),
    contains (union A B) x <-> contains A x \/ contains B x.
Proof.
  intros.
  (* In a more complex proof, assume that getting here would have taken many
     lines of tactics script, which might have taken a few minutes of
     time to process, and now I'm here at a simple goal about sets.
     Before attempting to prove this goal, I'd like to quickchick it,
     by issuing just one vernac command, eg "QuickChick." without arguments.
     The closest I can get to that is the following hack:
*)

  repeat match goal with
         | x: _ |- _ => revert x
         end.
  abstract (apply TODO).
  QuickCheck union_spec_subproof.

(*
This answers

QuickChecking union_spec_subproof
+++ Passed 10000 tests (0 discards)

which makes me confident that I should work on proving this lemma.
*)


Require Export XR_Int_part.
Require Export XR_tech_up.
Require Export XR_INR_IZR_INZ.
Require Export XR_Rle_refl.

Local Open Scope R_scope.

Lemma Int_part_INR : forall n:nat,
  Int_part (INR n) = Z.of_nat n.
Proof.
  intro n.
  unfold Int_part.
  symmetry.
  apply Zplus_minus_eq.
  symmetry.
  apply tech_up.
  {
    rewrite plus_IZR.
    rewrite <- INR_IZR_INZ.
    rewrite Rplus_comm.
    pattern (INR n) at 1 ; rewrite <- Rplus_0_r.
    apply Rplus_lt_compat_l.
    simpl.
    exact Rlt_0_1.
  }
  {
    rewrite plus_IZR.
    rewrite <- INR_IZR_INZ.
    rewrite Rplus_comm.
    simpl.
    apply Rle_refl.
  }
Qed.


From Coq Require Import Reals ZArith Psatz Fourier_util.
From Flocq Require Import Raux.
From Coquelicot Require Import Coquelicot AutoDerive.
From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool ssrnat bigop.

Require Import Stdlib.
Require Import Coquelicot.
Require Import Xreal.
Require Import Interval.

Section powerRZMissing.

Lemma powerRZ_ind (P : Z -> (R -> R) -> Prop) :
  P 0%Z (fun x => 1) ->
  (forall n, P (Z.of_nat n) (fun x => x ^ n)) ->
  (forall n, P ((-(Z.of_nat n))%Z) (fun x => / x ^ n)) ->
  (forall f g, f =1 g -> forall n, P n f -> P n g) ->
  forall (m : Z), P m (fun x => powerRZ x m).
Proof.
move => H0 Hpos Hneg Hext m.
case: m => [|p|p].
- by rewrite /=.
- rewrite -positive_nat_Z.
  apply: Hext. move => x.
  by rewrite -pow_powerRZ.
  exact: Hpos.
- rewrite /powerRZ.
  apply: Hext. move => x.
  by [].
  rewrite -Pos2Z.opp_pos.
  rewrite -positive_nat_Z.
  exact: Hneg.
Qed.

Lemma is_derive_powerRZ (n : Z) (x : R):
  ((0 <= n)%Z \/ x <> 0) ->
  is_derive (fun x : R => powerRZ x n) x (IZR n * (powerRZ x (n - 1))).
Proof.
move => Hnx.
move: (is_derive_n_powerRZ n 1 x Hnx).
case Hn : n => [|p|p] /= .
- by rewrite !Rmult_0_l; move => _; apply: is_derive_const.
- rewrite big_ord_recl /= big_ord0 /=  subn0 Rmult_1_r.
  rewrite INR_IZR_INZ positive_nat_Z.
  rewrite pow_powerRZ.
  congr (is_derive _ _ (_ * powerRZ _ _)).
  rewrite -> Nat2Z.inj_sub by apply lt_le_S, Pos2Nat.is_pos.
  now rewrite positive_nat_Z.
- rewrite big_ord_recl /= big_ord0 /= addn0 Rmult_1_r.
  rewrite INR_IZR_INZ positive_nat_Z.
  by rewrite Pos2Nat.inj_add.
Qed.

Lemma is_derive_powerRZS (n : Z) (x : R):
  ((1 <= n)%Z \/ x <> 0) ->
  is_derive (fun x : R => powerRZ x (n+1)) x (IZR (n+1) * (powerRZ x n)).
Proof.
move => Hnx.
move: (is_derive_powerRZ (n+1) x).
rewrite Z.add_simpl_r // ; apply.
case: Hnx => [Hn | Hx].
  left; lia.
by right.
Qed.

Lemma ex_derive_powerRZ (n : Z) (x : R):
  ((0 <= n)%Z \/ x <> 0) ->
  ex_derive (fun x : R => powerRZ x n) x.
Proof.
move => H.
apply: (ex_derive_is_derive ((fun x : R => powerRZ x (n)))).
exact: is_derive_powerRZ.
Qed.

Lemma ex_derive_powerRZS (n : Z) (x : R):
  ((1 <= n)%Z \/ x <> 0) ->
  ex_derive (fun x : R => powerRZ x (n+1)) x.
Proof.
move => H.
apply: ex_derive_powerRZ.
case: H => [Hn | Hx].
  left; lia.
by right.
Qed.

Lemma is_RInt_powerRZ (alpha : Z) (a b : R) (HneqN1 : alpha <> (-1)%Z) (H : 0 < a <= b) :
is_RInt (powerRZ^~ alpha) a b
    ((powerRZ b (alpha + 1) - powerRZ a (alpha + 1)) / IZR (alpha + 1)).
Proof.
have neq0 : IZR (alpha + 1) <> 0.
  apply: not_0_IZR.
  by rewrite Z.add_move_0_r; exact: HneqN1.
pose F := fun x => powerRZ x (alpha+1) / IZR (alpha + 1).
have -> : ((powerRZ b (alpha + 1) - powerRZ a (alpha + 1)) / IZR (alpha + 1)) = F b - F a.
rewrite /F.
field => // .
have xneq0 : forall x, Rmin a b <= x <= Rmax a b -> x <> 0.
  move => x [Hax Hxb].
  apply: Rgt_not_eq.
  apply: (Rlt_le_trans 0 (Rmin a b) x) => // .
  by case: H => [H0a Hab]; rewrite Rmin_left.
apply: is_RInt_derive => x Hx.
rewrite /F.
have -> : (powerRZ x alpha) = ((IZR (alpha+1)) * ((powerRZ x alpha)) / (IZR (alpha+1))).
  by field.
rewrite !/Rdiv.
apply: is_derive_scal_l.
apply: is_derive_powerRZS.
by right; apply xneq0.
apply: ex_derive_continuous.
apply: (ex_derive_n_powerRZ alpha 1).
by right; apply xneq0.
Qed.

Lemma int_x_alpha alpha A B (H : 0 < A <= B) (Halpha:  alpha <> (-1)%Z) :
is_RInt (powerRZ^~ alpha) A B
((powerRZ B (alpha + 1) - powerRZ A (alpha + 1)) / IZR (alpha + 1)).
Proof.
apply: is_RInt_powerRZ => // .
Qed.

End powerRZMissing.

Section CoquelicotMissing.

(* this one should be in Coquelicot to relieve users *)
Lemma continuous_Rdiv_1_x x (H : x <> 0) : continuous (Rdiv 1) x.
Proof.
apply: (continuous_ext (fun (x : R) => (/ x))).
  by move => x0; rewrite /Rdiv Rmult_1_l.
exact: continuous_Rinv.
Qed.

End CoquelicotMissing.

(* Bertrand Integral:                          *)
(* RInt (fun x=> x^alpha (ln x)^beta A B for   *)
(* alpha in Z, beta in N, A, B (finite) reals  *)
Definition Bertrand alpha beta A B (I : R) :=
  is_RInt (fun x => powerRZ x alpha * (pow (ln x) beta)) A B I.

(* Function computing the Bertrand integral:   *)

Fixpoint f (alpha : Z) (beta : nat) (A B : R) {struct beta} :=
  match beta with
    | 0 => (powerRZ B (alpha+1)- powerRZ A (alpha+1)) / (IZR (alpha + 1))
    | S m =>
      (powerRZ B (alpha+1) * (pow (ln B) (beta)) -
       powerRZ A (alpha+1) * (pow (ln A) beta)) / (IZR (alpha + 1)) -
      (INR beta) / (IZR (alpha+1)) * f alpha m A B end.

(* limit of the Bertrand integral              *)
Definition Bertrand_lim alpha beta (A : R) (I : R) :=
  is_RInt_gen (fun x => powerRZ x alpha * (pow (ln x) beta)) (at_point A) (Rbar_locally p_infty) I.

(* Function computing the limit of the Bertrand integral *)
Fixpoint f_lim (alpha : Z) (beta : nat) (A : R) {struct beta} :=
  match beta with
    | 0 => (- powerRZ A (alpha+1)) / (IZR (alpha + 1))
    | S m =>
       - ( powerRZ A (alpha+1) * (pow (ln A) beta)) / (IZR (alpha + 1)) -
      (INR beta) / (IZR (alpha+1)) * f_lim alpha m A end.

(* Variables (A B : R). *)

(* Eval cbn in f 1 3 A B. *)

Lemma one_step_by_parts alpha beta (A : R) (B : R) (H : 0 < A <= B) (Halpha:  alpha <> (-1)%Z) :
  forall I, Bertrand alpha beta A B I ->
  Bertrand alpha (S beta) A B
     ((powerRZ B (alpha+1) * (pow (ln B) (S beta)) -
       powerRZ A (alpha+1) * (pow (ln A) (S beta))) / (IZR (alpha + 1)) -
      (INR (S beta)) / (IZR (alpha+1)) * I).
Proof.
have Salpha_neq_0 :   IZR (alpha + 1) <> 0.
  by apply: not_0_IZR; lia.
move => I HABI.
rewrite/Bertrand.
pose f := (fun x => Rdiv (powerRZ x (alpha+1)) (IZR(alpha+1))).
pose f' := (fun x => powerRZ x alpha).
pose g := (fun x => pow (ln x) (beta.+1)).
pose g' := (fun x => (1 / x) * (INR (beta.+1) * pow (ln x) beta)).
set f'g := (fun x : R => scal (f' x) (g x)).
pose fg' := (fun t => scal (f t) (g' t)).
pose f'gplusfg' := (fun t : R => plus (f'g t) (fg' t)).
apply (is_RInt_ext (fun x => minus (f'gplusfg' x) (fg' x))) => [x HX|].
rewrite /f'gplusfg' /fg' /f /g /f'g.
by rewrite /minus -plus_assoc plus_opp_r plus_zero_r /scal.
apply: is_RInt_minus.
- apply: (is_RInt_ext (fun t : R => plus (scal (f' t) (g t)) (scal (f t) (g' t)))) =>[x Hx|].
    by [].
  have -> : ((powerRZ B (alpha + 1) * ln B ^ beta.+1 -
      powerRZ A (alpha + 1) * ln A ^ beta.+1) / IZR (alpha + 1)) = (minus (scal (f B) (g B)) (scal (f A) (g A))).
    rewrite /f /g /minus /opp /plus /scal /mult  /= /mult /= .
    by field.
  apply: (is_RInt_scal_derive f g f' g' A B) => x Hx.
  have xgt0 : x > 0 by case: Hx; rewrite Rmin_left; lra.
  + rewrite /f /f'.
    apply: (is_derive_ext (fun x0 => scal (powerRZ x0 (alpha + 1)) (1 / IZR (alpha + 1)))) => [t|].
      by rewrite /scal /= /mult /=;field.
    have -> : powerRZ x alpha = scal (IZR (alpha+1) * (powerRZ x alpha)) (1 / IZR (alpha + 1)).
      by rewrite /scal /mult /= /mult /=; field.
    apply: is_derive_scal_l.
    apply: (is_derive_powerRZS alpha x).
    by lra.
  + rewrite /g /g'.
    have -> : (1 / x * (INR beta.+1 * ln x ^ beta)) = (INR beta.+1 * ( / x) * ln x ^ beta.+1.-1).
      rewrite -pred_Sn; field.
      by case: Hx; rewrite Rmin_left; lra.
    apply: (is_derive_pow).
    apply: is_derive_ln.
    by case: Hx; rewrite Rmin_left; lra.
  + have Hxneq0 : x <> 0 by rewrite Rmin_left in Hx; lra.
    apply: ex_derive_continuous.
    apply: ex_derive_powerRZ; right => // .
  + have Hxgt0 : x > 0 by rewrite Rmin_left in Hx; lra.
    have Hxneq0 : x <> 0 by lra.
    apply: continuous_mult.
    apply: continuous_Rdiv_1_x => // .
    apply: continuous_mult; first exact: continuous_const.
    (* intermediary lemmas needed here *)
    apply: ex_derive_continuous.
    apply: ex_derive_is_derive.
    apply: is_derive_pow.
    by apply: is_derive_ln.
    move: HABI; rewrite /Bertrand.
    suff Hx : forall x, Rmin A B < x < Rmax A B -> (fun x => scal (INR beta.+1 / IZR (alpha + 1)) (powerRZ x alpha * ln x ^ beta)) x = fg' x => [HABI|t HAtB].
      apply: is_RInt_ext.
      exact: Hx.
      apply: is_RInt_scal => // .
    have Hxgt0 : t > 0 by rewrite Rmin_left in HAtB; lra.
    have Hxneq0 : t <> 0 by lra.
    rewrite /fg' /f /g'.
    rewrite powerRZ_add // .
    rewrite /scal /= /mult /=.
    field; lra.
Qed.

Lemma f_correct alpha beta A B (H : 0 < A <= B) (Halpha:  alpha <> (-1)%Z) :
 Bertrand alpha beta A B (f alpha beta A B).
Proof.
elim: beta => [|m HIm] // .
  rewrite /f /Bertrand.
  apply: (is_RInt_ext (fun x => powerRZ x alpha)).
  + by move => x Hx; rewrite pow_O Rmult_1_r.
  exact: int_x_alpha.
by move: (one_step_by_parts alpha m A B H Halpha _ HIm).
Qed.

Lemma f_correct_RInt alpha beta A B (H : 0 < A <= B) (Halpha:  alpha <> (-1)%Z) : f alpha beta A B = RInt (fun x => powerRZ x alpha * (pow (ln x) beta)) A B.
Proof.
  symmetry.
  apply: is_RInt_unique.
  exact: f_correct.
Qed.

Lemma is_lim_RInv_p_infty:
is_lim [eta Rinv] p_infty 0.
Proof.
suff -> : 0 = Rbar_inv p_infty => // .
apply: (is_lim_inv (fun x => x) p_infty p_infty) => // .
Qed.

Lemma is_lim_RInv_m_infty:
is_lim [eta Rinv] m_infty 0.
Proof.
suff -> : 0 = Rbar_inv m_infty => // .
apply: (is_lim_inv (fun x => x) m_infty m_infty) => // .
Qed.

Lemma is_lim_powerRZ_0 alpha (Halpha : (alpha < 0)%Z) :
  is_lim (powerRZ^~ (alpha)%Z) p_infty (0%R).
Proof.
apply: (powerRZ_ind (fun n f => (n < 0)%Z -> is_lim f p_infty (0%R))) => // [n Hn|n Hn|].
- move: Hn. have -> : 0%Z = (Z.of_nat 0%N)%Z by [].
  rewrite -Nat2Z.inj_lt; lia.
- elim: n Hn => [|m Hm Hn] // .
  rewrite /= .
  apply: (is_lim_ext_loc (fun x => / x * / x^m)).
    exists 0 => x Hx.
    field.
    split.
      by apply: pow_nonzero; lra.
      by lra.
  case: m Hm Hn => [|m Hm] Hn.
  + move => _ /=.
    have -> : 0 = Rbar_mult (Finite 0) (Finite 1) by rewrite /= Rmult_0_l.
    apply: (is_lim_mult (fun x => / x) (fun x => / 1) p_infty 0 1) => // .
    exact: is_lim_RInv_p_infty.
    by rewrite Rinv_1; exact: is_lim_const.

  have -> : 0 = Rbar_mult (Finite 0) (Finite 0) by rewrite /= Rmult_0_l.
  (* why so much detail needed ? *)
  apply: (is_lim_mult (fun x => / x) (fun x => / x^m.+1) p_infty 0 0) => // .
  exact: is_lim_RInv_p_infty.
  apply: Hm. rewrite Z.opp_neg_pos.
  have -> : 0%Z = (Z.of_nat 0%N)%Z by [].
  by rewrite -Nat2Z.inj_lt; lia.
move => f g Hfg n H1 H2.
apply: (is_lim_ext f g _ _ Hfg).
by apply: H1.
Qed.

Lemma is_lim_pow_infty n : is_lim (fun x => x^n.+1) p_infty p_infty.
Proof.
elim: n => [|n Hn].
- apply: (is_lim_ext id) => // .
  by move => y; rewrite pow_1.
- apply: (is_lim_ext (fun x => x * x^n.+1)).
    by move => y.
  have {2}-> : p_infty = Rbar_mult p_infty p_infty => // .
  apply: is_lim_mult => // .
Qed.

Lemma is_lim_pow_0 (f : R -> R) n :
  is_lim f p_infty 0 ->
  is_lim (fun x => (f x)^n.+1) p_infty 0.
Proof.
elim: n => [|n Hn].
- apply: (is_lim_ext f) => // .
  by move => y; rewrite pow_1.
- move =>  Hf0.
apply: (is_lim_ext (fun x => (f x) * (f x)^n.+1)).
  by move => y.
have {1}-> : 0 = Rbar_mult 0 0 by rewrite /= Rmult_0_l.
apply: (is_lim_mult f (fun x => (f x)^n.+1) p_infty 0 0) => // .
exact: Hn.
Qed.

Lemma Rbar_mult_p_l y (Hy : 0 < y) :
  Rbar_mult y p_infty = p_infty.
Proof.
rewrite /Rbar_mult /Rbar_mult'.
case: (Rle_dec 0 y) => Hy1; last by lra.
by case: (Rle_lt_or_eq_dec 0 y Hy1) => // ; lra.
Qed.

Lemma Rbar_mult_p_r y (Hy : 0 < y) :
  Rbar_mult p_infty y = p_infty.
Proof.
by rewrite Rbar_mult_comm; exact: Rbar_mult_p_l.
Qed.

Lemma Rbar_mult_m_l y (Hy : 0 < y) :
  Rbar_mult y m_infty = m_infty.
Proof.
rewrite /Rbar_mult /Rbar_mult'.
case: (Rle_dec 0 y) => Hy1; last by lra.
by case: (Rle_lt_or_eq_dec 0 y Hy1) => // ; lra.
Qed.

Lemma Rbar_mult_m_r y (Hy : 0 < y) :
  Rbar_mult m_infty y = m_infty.
Proof.
by rewrite Rbar_mult_comm; exact: Rbar_mult_m_l.
Qed.

(* TODO: variant with a composition *)
Lemma is_lim_Rpower y (Hy : 0 < y) :
  is_lim (fun x => Rpower x y) p_infty p_infty.
Proof.
rewrite /Rpower.
apply: is_lim_comp => // .
exact: is_lim_exp_p.
apply: (is_lim_ext (fun x => scal y (ln x))).
  by move => x0.
have {2}-> :  p_infty = Rbar_mult y p_infty.
  by rewrite Rbar_mult_p_l.
apply (is_lim_scal_l ln y p_infty p_infty).
exact: is_lim_ln_p.
exists 0 => x0 Hx0 //.
Qed.

Lemma x_alpha_0 alpha (Halpha : (alpha < -1)%Z) :
  is_lim (powerRZ^~ (alpha + 1)%Z) p_infty (0%R).
Proof.
apply: is_lim_powerRZ_0.
by lia.
Qed.

Lemma Rpower_pos {x y} (Hx : 0 < x) (Hy : 0 <= y) : Rpower x y > 0.
Proof.
rewrite /Rpower.
by apply: exp_pos.
Qed.

Lemma is_derive_Rpower {x y} (Hx : 0 < x) (Hy : 0 <= y) :
  is_derive (fun t => Rpower t y) x (y * Rpower x (y - 1)).
Proof.
move: (is_derive_n_Rpower 1 y x Hx) => /=.
by rewrite big_ord_recl big_ord0 /= Rminus_0_r Rmult_1_r.
Qed.

Lemma ln_Rpower x y (Hx : 0 < x) (Hy : 0 <= y) : ln (Rpower x y) = y * ln x.
Proof.
rewrite /Rpower // .
by rewrite ln_exp.
Qed.

Lemma x_alpha_beta alpha beta (Halpha : (alpha < -1)%Z) :
  is_lim (fun x => powerRZ x (alpha + 1)%Z * (pow (ln x) beta.+1)) p_infty (0%R).
Proof.
have Halpah1 : IZR (alpha + 1) < 0.
  by apply: (IZR_lt _ 0); lia.
have Hbeta1 : INR beta.+1 > 0.
  apply: lt_0_INR.
  exact: Nat.lt_0_succ.
have foo :  0 < IZR (- (alpha + 1)) / INR beta.+1.
  rewrite opp_IZR.
  by apply: RIneq.Rdiv_lt_0_compat => // ; lra.
set X := fun x => Rpower x ((IZR (Z.opp (alpha + 1))) / INR beta.+1).
(* First we rewrite our function *)
have Htransform:
  forall x,
    x > 0 ->
    powerRZ x (alpha + 1) * ln x ^ beta.+1 =
    pow (-((INR beta.+1) / IZR (alpha + 1)) * (ln (X x) * / (X x))) beta.+1.
  move => x Hx.
  have HXgt0 : X x > 0.
    by apply: Rpower_pos => // ; lra.
  have -> : -((INR beta.+1) / IZR (alpha + 1)) * (ln (X x) / (X x)) =
          (-((INR beta.+1) / IZR (alpha + 1)) * ln (X x)) / (X x).
    field.
    by split; lra.
  rewrite -ln_Rpower ?Rpow_mult_distr => // .
  + have -> : Rpower (X x) (-(INR beta.+1 / IZR (alpha + 1))) =
          x.
      rewrite Rpower_mult.
      rewrite opp_IZR.
      have -> : (- IZR ((alpha + 1)) / INR beta.+1 * -(INR beta.+1 / IZR (alpha + 1))) = 1 by field; lra.
      exact: Rpower_1.
  + rewrite Rmult_comm.
    congr (_ * _).
    have Hpow_pos :  Rpower x (IZR (- (alpha + 1)) / INR beta.+1) > 0.
      by apply: Rpower_pos => // ; lra.
    rewrite -Rinv_pow /X; try lra.
    rewrite -Rpower_pow ?Rpower_mult -?Rpower_Ropp // .
    have -> : (- (IZR (- (alpha + 1)) / INR beta.+1 * INR beta.+1)) = IZR (alpha + 1)%Z.
      by rewrite opp_IZR; field; lra.
    by rewrite powerRZ_Rpower.
  apply: Ropp_0_ge_le_contravar.
  apply: Rle_ge.
  rewrite /Rdiv.
  apply: Rmult_le_pos_neg => // ; try lra.
  by apply: Rlt_le; apply: Rinv_lt_0_compat.
(* now we can show its limit *)
apply: (is_lim_ext_loc (fun x => (- (INR beta.+1 / IZR (alpha + 1)) * (ln (X x) * / X x))
               ^ beta.+1) ).
  by exists 0; move => x Hx ; rewrite Htransform // .
apply: is_lim_pow_0.
have -> : 0 = Rbar_mult (- (INR beta.+1 / IZR (alpha + 1))) 0.
  by rewrite /Rbar_mult /Rbar_mult' Rmult_0_r.
apply (is_lim_scal_l (fun (x : R) => (ln (X x) * / X x)) (- (INR beta.+1 / IZR (alpha + 1))) p_infty 0).
apply: (is_lim_comp (fun x => ln x / x) X p_infty 0 p_infty).
  + exact: is_lim_div_ln_p.
  + apply: is_lim_Rpower => // .
  + exists 0 => x Hx // .
Qed.

Lemma f_lim_is_lim alpha beta A (H : 0 < A) (Halpha : (alpha < -1)%Z):
   filterlim (f alpha beta A) (Rbar_locally p_infty)
   (locally (f_lim alpha beta A)).
elim: beta => [ | beta Hbeta].
- rewrite /f /f_lim /Rdiv /Rminus.
  rewrite -[locally _]/(Rbar_locally (Rbar_mult (Finite _) (Finite _))).
  rewrite -[filterlim _ _ _]/(is_lim _ p_infty _).
  apply: is_lim_mult => // .
  + apply: is_lim_plus.
    * exact: x_alpha_0.
    * exact: is_lim_const.
    * rewrite /is_Rbar_plus /= .
      by apply f_equal, f_equal, Rplus_0_l.
  + apply is_lim_const.
- rewrite /f /f_lim -/f -/f_lim /Rdiv /Rminus.
  rewrite -[locally _]/(Rbar_locally (Finite _)).
  rewrite -[filterlim _ _ _]/(is_lim _ p_infty _).
  apply: is_lim_plus.
  + apply: is_lim_mult.
    * apply: is_lim_plus.
        - exact: x_alpha_beta.
        - exact: is_lim_const.
        - done.
    * exact: is_lim_const.
    * done.
  + apply: is_lim_opp.
    apply: is_lim_mult.
    * exact: is_lim_const.
    * rewrite -[locally _]/(Rbar_locally (Finite _)) in Hbeta.
      exact Hbeta.
    * done.
  + by rewrite Rplus_0_l.
Qed.

Lemma f_lim_correct alpha beta A (H : 0 < A) (Halpha : (alpha < -1)%Z) :
 Bertrand_lim alpha beta A (f_lim alpha beta A).
Proof.
rewrite /Bertrand_lim.
apply prodi_to_single_l.
apply: (filterlimi_lim_ext_loc (f alpha beta A)).
  exists A => x Hx.
  apply f_correct.
  apply (conj H).
  exact: Rlt_le.
  exact: Zlt_not_eq.
exact: f_lim_is_lim.
Qed.

Section BertrandLogNeg.

(* in this section we focus on integrals of the shape *)
(* int(1 / (x * ln^beta), x=a..infinity), a>1, beta>1   *)

Definition f_neg (a : R) (beta : nat) :=
  - / ((INR beta) * (ln a)^beta).

Lemma continuous_f_neg x beta (H0x : 0 < x) (Hx1 : x <> 1):
  continuous (fun x0 : R => / (x0 * ln x0 ^ beta)) x.
Proof.
have Hlnn0 x1 beta1 :  0 < x1 -> 1 <> x1 -> ln x1 ^ beta1 <> 0.
  by move => H0x1 Hx10; apply: pow_nonzero; case: (Rlt_dec 1 x1) => H; move: (ln_increasing 1 x1); move: (ln_increasing x1 1); rewrite ln_1; lra.
apply: continuous_comp.
  apply: continuous_mult; first exact: continuous_id.
  apply: (continuous_comp ln (fun x => pow x beta)).
    by apply: continuous_ln; lra.
  by apply: ex_derive_continuous; apply: ex_derive_pow; exact: ex_derive_id.
apply: continuous_Rinv.
apply: Rmult_integral_contrapositive; split; try lra.
apply: Hlnn0; lra.
Qed.

Lemma is_derive_f_neg :
  forall beta x,
  beta <> 0%N ->
  0 < x -> x <> 1 ->
  is_derive (fun x : R => f_neg x beta) x (/ (x * (ln x)^beta.+1)).
Proof.
intros beta x Hbeta Hx1 Hx2.
rewrite /f_neg -[/(_ * _)]Ropp_involutive.
apply: is_derive_opp.
assert (H: (ln x <> 0)%R).
  rewrite <- ln_1.
  contradict Hx2.
  exact (ln_inv x 1 Hx1 Rlt_0_1 Hx2).
auto_derive.
- refine (conj Hx1 (conj _ I)).
  apply Rmult_integral_contrapositive.
  split.
    now apply not_0_INR.
  now apply pow_nonzero.
- destruct beta as [|beta].
    easy.
  simpl Nat.pred.
  simpl pow.
  field.
  repeat split.
  now apply pow_nonzero.
  exact H.
  now apply Rgt_not_eq.
  now apply not_0_INR.
Qed.

Lemma f_neg_correct_RInt_0_1 a b beta (Hab1 : 0 < a <= b) (Hb1 : b < 1) (Hbeta : beta <> 0%N) : is_RInt (fun x => / (x * (ln x)^beta.+1)) a b (f_neg b beta - f_neg a beta).
Proof.
have Hbetn0 : INR beta <> 0 by apply: not_0_INR; case: beta Hbeta.
have Hlnn0 x beta1 : 0 < x < 1 -> ln x ^ beta1 <> 0.
  by move => Hx0; apply: pow_nonzero; move: (ln_increasing x 1); rewrite ln_1;lra.
have Hder : forall x, 0 < x < 1 -> is_derive (fun x => f_neg x beta) x (/ (x * (ln x)^beta.+1)).
  move => x Hax.
  apply is_derive_f_neg.
  now destruct beta.
  apply Hax.
  now apply Rlt_not_eq.
apply: (is_RInt_derive (fun x => f_neg x beta) _).
  by move => x Hx; apply: Hder; rewrite Rmin_left ?Rmax_right in Hx; try lra.
move => x. (rewrite Rmin_left ?Rmax_right; try (by lra)).
move => Hx.
apply: continuous_comp.
  apply: continuous_mult; first exact: continuous_id.
  apply: (continuous_comp ln (fun x => pow x beta.+1)).
    by apply: continuous_ln; lra.
  by apply: ex_derive_continuous; apply: ex_derive_pow; exact: ex_derive_id.
apply: continuous_Rinv.
apply: Rmult_integral_contrapositive; split; try lra.
by apply: Hlnn0; lra.
Qed.

Lemma f_neg_correct_RInt_a_infty a b beta (Ha : 1 < a <= b) (Hbeta : beta <> 0%N) : is_RInt (fun x => / (x * (ln x)^beta.+1)) a b (f_neg b beta - f_neg a beta).
Proof.
have Hbetn0 : INR beta <> 0 by apply: not_0_INR; case: beta Hbeta.
have Hlnn0 x beta1 : a <= x -> ln x ^ beta1 <> 0.
    by move => Hx0; apply: pow_nonzero; move: (ln_increasing 1 x); rewrite ln_1; lra.
have Hder : forall x, a <= x -> is_derive (fun x => f_neg x beta) x (/ (x * (ln x)^beta.+1)).
  move => x Hax.
  apply is_derive_f_neg.
  now destruct beta.
  apply Rlt_trans with (1 := Rlt_0_1).
  now apply Rlt_le_trans with a.
  apply Rgt_not_eq.
  now apply Rlt_le_trans with a.
apply: (is_RInt_derive (fun x => f_neg x beta) _).
  by move => x Hx; apply: Hder; rewrite Rmin_left in Hx; try lra.
move => x. (rewrite Rmin_left; last by lra); move => Hx.
apply: continuous_comp.
  apply: continuous_mult; first exact: continuous_id.
  apply: (continuous_comp ln (fun x => pow x beta.+1)).
    by apply: continuous_ln; lra.
  by apply: ex_derive_continuous; apply: ex_derive_pow; exact: ex_derive_id.
apply: continuous_Rinv.
apply: Rmult_integral_contrapositive; split; try lra.
by apply: Hlnn0; lra.
Qed.

Lemma filterlim_sqr_m_infty:
  filterlim (pow^~ 2%N) (Rbar_locally m_infty) (Rbar_locally p_infty).
Proof.
apply: (filterlim_ext (fun x => x * x)); first by move => y; rewrite /= ?Rmult_1_r.
suff -> : p_infty = Rbar_mult m_infty m_infty => // .
  apply: filterlim_comp_2; try exact: filterlim_id.
  exact: filterlim_Rbar_mult.
Qed.

Lemma is_lim_sqr_infty:
  is_lim (pow^~ 2%N) m_infty p_infty.
Proof.
apply: (is_lim_ext (fun x => x * x)); first by move => y; rewrite /= ?Rmult_1_r.
suff -> : p_infty = Rbar_mult m_infty m_infty => // .
  by apply: is_lim_mult => // .
Qed.

Lemma filterlim_pow_infty n : filterlim (pow^~ n.+1) (Rbar_locally p_infty) (Rbar_locally p_infty).
Proof.
elim: n => [|n Hn].
  apply: (filterlim_ext (fun x => x)).
    by move => x; rewrite pow_1.
  exact: filterlim_id.
apply: (filterlim_ext (fun x => x * (pow x n.+1))).
  by move => x.
apply: filterlim_comp_2; first exact: filterlim_id.
  exact: Hn.
exact: filterlim_Rbar_mult.
Qed.

Lemma filterlim_pow_m_even n : ~~ odd n.+1 -> filterlim (fun x => pow x n.+1) (Rbar_locally m_infty) (Rbar_locally p_infty).
Proof.
move => Hodd.
rewrite -(odd_double_half n.+1).
rewrite -[odd n.+1]Bool.negb_involutive Hodd /= add0n. (*ugly *)
rewrite -mul2n.
apply: filterlim_ext.
move => y; by rewrite pow_mult.
apply: (filterlim_comp _ _ _ (fun x => x ^ 2) (fun x => x ^ (uphalf n))).
apply: filterlim_sqr_m_infty.
case: n Hodd => [|n] // Hodd.
exact: filterlim_pow_infty.
Qed.

Lemma filterlim_pow_m_odd n : odd n.+1 -> filterlim (fun x => pow x n.+1) (Rbar_locally m_infty) (Rbar_locally m_infty).
Proof.
move => Hodd.
case: n Hodd => [|n] Hodd.
- apply: (filterlim_ext id).
    by move => x /=; rewrite Rmult_1_r.
  exact: filterlim_id.
apply: (filterlim_ext (fun x => x * pow x n.+1)).
  by move => x.
apply: filterlim_comp_2.
  exact: filterlim_id.
by apply: filterlim_pow_m_even.
by apply: filterlim_Rbar_mult.
Qed.

(*
Lemma is_lim_pow_m_infty n : is_lim (fun x => pow x n.+1) m_infty (if odd n.+1 then m_infty else p_infty).
Proof.
rewrite -{1}(odd_double_half n.+1).
case : ifP => Hodd.
suff {2}-> : m_infty = Rbar_mult m_infty (if (uphalf n) is m.+1 then p_infty else 1).
  apply: is_lim_mult => // .
  rewrite -mul2n.
  apply: is_lim_ext. move => y. by rewrite pow_mult.
  apply: (is_lim_comp (fun x => x ^(uphalf n)) (fun x => x ^ 2)).
  case Hhalf: (uphalf n) => [|m].
    apply: (is_lim_ext (fun x => 1)). by move => y; rewrite pow_O.
    exact: is_lim_const.
  exact: is_lim_pow_infty.
  exact: is_lim_sqr_infty.
  by exists 0 .
  case: (uphalf n) => // ; rewrite /ex_Rbar_mult; lra.
  case: (uphalf n) => // ; rewrite Rbar_mult_m_r // ; lra.

rewrite add0n -mul2n.
apply: is_lim_ext.
move => y; by rewrite pow_mult.
case: n Hodd => // n Hodd.
apply: (is_lim_comp (fun x => x ^ (n.+2)./2) (fun x => x ^2) _ _ p_infty).
apply: is_lim_pow_infty.
exact: is_lim_sqr_infty.
by exists 1.
Qed.

Lemma is_lim_pow_m_odd n : odd n.+1 -> is_lim (fun x => pow x n.+1) m_infty m_infty.
Proof.
move => Hodd.
by move: (is_lim_pow_m_infty n); rewrite Hodd.
Qed.

Lemma is_lim_pow_m_even n : ~~ odd n.+1 -> is_lim (fun x => pow x n.+1) m_infty p_infty.
Proof.
move => Hodd.
move: (is_lim_pow_m_infty n); case: ifPn => // Heven.
by rewrite Heven in Hodd.
Qed.
*)

Lemma f_neg_correct_RInt_gen_0_a a beta (Ha : 0 < a < 1) (Hbeta : beta <> 0%N) : is_RInt_gen (fun x => / (x * (ln x)^beta.+1)) (at_right 0) (at_point a) (f_neg a beta).
Proof.
apply prodi_to_single_r.
have apos : 0 < a by lra.
set ap := mkposreal a apos.
apply: (filterlimi_lim_ext_loc).
  exists ap => x Hx1 Hx2.
  apply f_neg_correct_RInt_0_1 => // ;move/ball_to_lra: Hx1 => /=; lra.
  rewrite -{2}[f_neg _ _ ]Rminus_0_r.
apply: (filterlim_comp _ _ _  (fun x => f_neg x beta) (fun x => f_neg a beta - x) (at_right 0) _ (* (Rbar_locally 0) *) _) ;last first.
rewrite /Rminus. apply: continuous_plus.
    exact: filterlim_const.
  exact: filterlim_opp.
rewrite /f_neg.
apply: filterlim_comp; last first.
  rewrite -[0]Ropp_0.
  exact: (filterlim_opp 0).
case HEvenOdd: (odd beta); last first.
- rewrite -[locally 0]/(Rbar_locally (Rbar_inv p_infty)).
  apply (filterlim_comp _ _ _ (fun x => INR beta*ln x ^ beta) Rinv _ (Rbar_locally p_infty)).
    have -> : p_infty = Rbar_mult (INR beta) p_infty.
      by rewrite Rbar_mult_p_l // ; apply: lt_0_INR; apply/ltP; case: beta Hbeta HEvenOdd.
    suff: filterlim (fun x => (ln x)^beta) (at_right 0) (Rbar_locally p_infty).
      move => Hln.
      apply: filterlim_comp; last first.
        exact: filterlim_Rbar_mult_l.
      exact: Hln.
    apply: (filterlim_comp _ _ _ _ (fun x => x ^beta)) => //; try apply: is_lim_ln_0.
    case: beta Hbeta HEvenOdd => [|beta] Hbeta HevenOdd // .
    by apply: filterlim_pow_m_even; by rewrite HevenOdd.
  exact: is_lim_RInv_p_infty.
- rewrite -[locally 0]/(Rbar_locally (Rbar_inv m_infty)).
  apply (filterlim_comp _ _ _ (fun x => INR beta*ln x ^ beta) Rinv _ (Rbar_locally m_infty)).
    have -> : m_infty = Rbar_mult (INR beta) m_infty.
      by rewrite Rbar_mult_m_l // ; apply: lt_0_INR; apply/ltP; case: beta Hbeta HEvenOdd.
    suff: filterlim (fun x => (ln x)^beta) (at_right 0) (Rbar_locally m_infty).
      move => Hln.
      apply: filterlim_comp; first exact: Hln.
        exact: filterlim_Rbar_mult_l.
    apply: (filterlim_comp _ _ _ _ (fun x => x ^ beta)); try apply: is_lim_ln_0.
    case: beta Hbeta HEvenOdd => [|beta] Hbeta HevenOdd // .
    by apply: filterlim_pow_m_odd; by rewrite HevenOdd.
  by apply: is_lim_RInv_m_infty.
Qed.

Lemma f_neg_correct_RInt_gen_a_infty a beta (Ha : 1 < a) (Hbeta : beta <> 0%N) : is_RInt_gen (fun x => / (x * (ln x)^beta.+1)) (at_point a) (Rbar_locally p_infty) (- f_neg a beta).
Proof.
apply prodi_to_single_l.
apply: (filterlimi_lim_ext_loc).
  exists a => x Hx.
  by apply f_neg_correct_RInt_a_infty => // ; lra.
  rewrite -Rminus_0_l.
apply: (filterlim_comp _ _ _  (fun x => f_neg x beta) (fun x => x - f_neg a beta) (* (Rbar_locally' p_infty) *) _ (* (Rbar_locally 0) *) _);last first.
rewrite /Rminus. apply: continuous_plus 0%R _ _.
    exact: filterlim_id.
  exact: filterlim_const.
rewrite /f_neg.
apply: filterlim_comp.
  apply: (is_lim_inv (fun x => INR beta*ln x ^ beta) (p_infty) (p_infty)) => // .

  have {2} -> : p_infty = Rbar_mult (INR beta) p_infty.
    by rewrite Rbar_mult_p_l // ; apply: lt_0_INR; apply/ltP; case: beta Hbeta.
  apply: is_lim_mult; first exact: is_lim_const.
    apply: (filterlim_comp _ _ _ _ (fun x => x ^beta)) => // ; try apply: is_lim_ln_p.
      by case :beta Hbeta => [| beta] // Hbeta; apply: is_lim_pow_infty.
  by apply: not_0_INR; case: beta Hbeta.
rewrite -[0]Ropp_0.
exact: (filterlim_opp 0).
Qed.

End BertrandLogNeg.

Section ExponentInQ.

End ExponentInQ.

Section ZeroToEpsilon.

(*
The following definition stems from the fact that
'RInt (x^alpha * (ln x)^beta) 0 eps' =
RInt_gen (u^(2 - alpha) * (ln u) ^ beta) (1/eps) p_infty
*)

Definition f0eps (alpha : Z) (beta : nat) (epsilon : R) (B : R) :=
  (-1) ^ beta * f (- 2 - alpha) beta (/ epsilon) B.

Definition f0eps_lim (alpha : Z) (beta : nat) (epsilon : R) :=
  (-1) ^ beta * f_lim (- 2 - alpha) beta (/ epsilon).

Lemma pow_negx x n : pow (- x) n = (pow (-1) n) * pow x n.
  have -> : - x = -1 * x by ring.
  by rewrite Rpow_mult_distr.
Qed.

Lemma subst_lemma alpha beta epsilon (eta : R) (Heps : 0 < epsilon) (Heta : 0 < eta <= epsilon) (Halpha : -1 < IZR alpha) :
  RInt_gen
    (fun x => powerRZ x alpha * pow (ln x) beta)
    (at_point eta)
    (at_point epsilon) =
  - RInt
      (fun x => - (pow (-1) beta) * powerRZ x (- 2 - alpha) * (pow (ln x) beta))
      (1 / epsilon)
      (1 / eta).
Proof.
  have Hint : ex_RInt (fun x : R => powerRZ x alpha * ln x ^ beta) eta epsilon.
  eexists.
  apply: f_correct => // .
  suff: (-1 < alpha)%Z by lia.
  apply: lt_IZR => // .
  (* should be a lemma *)
  have -> : RInt_gen (fun x : R => powerRZ x alpha * ln x ^ beta) (at_point eta) (at_point epsilon) = RInt (fun x : R => powerRZ x alpha * ln x ^ beta) eta epsilon.
    apply is_RInt_gen_unique; rewrite is_RInt_gen_at_point.
    exact: RInt_correct => // .
  pose g := fun x => Rinv x.
  pose dg := fun x => - 1 / x^2.
  have {1}-> : 1 / eta = (g eta).
    by rewrite /g; field; lra.
  have {1}-> : 1 / epsilon = (g epsilon).
    by rewrite /g; field; lra.
  rewrite -(RInt_comp _ _ dg).
  rewrite -opp_RInt_swap ; first congr (opp _) ; last by apply: ex_RInt_swap.
  symmetry; apply: RInt_ext.
  move => x Hx.
  rewrite Rmin_right in Hx; try lra.
  rewrite Rmax_left in Hx; try lra.
  have Hxneg0 : x <> 0 by lra.
  have Hinv : / x <> 0.
    by apply: Rinv_neq_0_compat.
  have -> : scal (dg x)(- (-1) ^ beta * powerRZ (g x) (-2 - alpha) * ln (g x) ^ beta) =
            (dg x) * (- (-1) ^ beta * powerRZ (g x) (-2 - alpha) * ln (g x) ^ beta) by [].
  rewrite /dg /g.
  rewrite powerRZ_add ?ln_Rinv; try lra.
  rewrite -> (powerRZ_neg _ 2), powerRZ_neg, Rinv_involutive by easy.
  rewrite [(- ln x) ^beta] pow_negx.
  replace (powerRZ x alpha * ln x ^ beta) with ((-1)^beta * (-1)^beta * (powerRZ x alpha * ln x ^ beta)).
  rewrite /(powerRZ x 2) /=.
  now field.
  rewrite -Rpow_mult_distr.
  have -> : -1 * -1 = 1 by ring. by rewrite pow1 Rmult_1_l.
  move => x Hx.
  rewrite Rmin_right in Hx; try lra.
  rewrite Rmax_left in Hx; try lra.
  apply: continuous_mult.
    apply: continuous_mult.
      exact: continuous_const.
    apply: ex_derive_continuous.
    apply: ex_derive_powerRZ.
    by rewrite /g; right; apply: Rinv_neq_0_compat; lra.
  rewrite /g.
  apply: continuous_ext.
    move => x0.
    by rewrite pow_powerRZ.
  apply: (continuous_comp ln (fun x => powerRZ x (Z.of_nat beta))).
    by apply: continuous_ln; apply: Rinv_0_lt_compat; lra.
  apply: ex_derive_continuous.
    by apply: ex_derive_powerRZ; left; apply: Zle_0_nat.
  move => x Hx.
  rewrite Rmin_right in Hx; try lra.
  rewrite Rmax_left in Hx; try lra.
  split.
    rewrite /g /dg.
    apply: (is_derive_inv (fun x => x) x 1); last by lra.
    exact: is_derive_id.
  rewrite /dg.
  apply: continuous_mult; first exact: continuous_const.
  apply: continuous_Rinv_comp.
    apply: (continuous_ext (fun t => t * t)) => [t|].
      by rewrite pow_powerRZ /=; ring.
    by apply: continuous_mult; exact: continuous_id.
  by apply: pow_nonzero; lra.
Qed.

Lemma f0eps_correct alpha beta epsilon (B : R) (Heps : 0 < / B <= epsilon) (HB : 0 < B) (Halpha : (-1 < alpha)%Z) :
  is_RInt_gen ((fun x => powerRZ x alpha * (pow (ln x) beta))) (at_point (/ B)) (at_point epsilon) (f0eps alpha beta epsilon B).
Proof.
  have Hint : ex_RInt (fun x : R => powerRZ x alpha * ln x ^ beta) (/ B) epsilon.
    eexists.
    apply: f_correct => // .
    by lia.
  have HinvepsinvB : 0 < / epsilon <= B.
    split.
      by apply: Rinv_0_lt_compat; by lra.
      by rewrite -[B]Rinv_involutive; try lra;  apply: Rinv_le; lra.
  rewrite is_RInt_gen_at_point.
  suff: f0eps alpha beta epsilon B = RInt (fun x : R => powerRZ x alpha * ln x ^ beta) (/B) epsilon.
    by move ->; apply: RInt_correct.
  rewrite -RInt_gen_at_point; last first.
  + eexists. apply: f_correct; try lra; try lia.
  + rewrite subst_lemma ; try lra. 2: now apply IZR_lt.
    symmetry.
    rewrite /f0eps. rewrite f_correct_RInt; try lra; try lia.
    rewrite (RInt_ext _ (fun x : R => scal (- (-1) ^ beta) (powerRZ x (-2 - alpha) * ln x ^ beta))); last first.
      by move => x Hx; rewrite /scal [in RHS]/= /mult /=; rewrite Rmult_assoc.
    set e1 := (-2 - alpha)%Z; rewrite RInt_scal /scal /= /mult /= .
    ring_simplify; congr(_ * RInt _ _ _) => // ; field; lra.
    rewrite /e1.
    by eexists; apply: f_correct;  first (split; field_simplify; lra); lia.
Qed.

Lemma f0eps_correct_sing alpha beta epsilon sing (B : R) (Heps : 0 < / B <= epsilon) (HB : 0 < B) (Halpha : (-1 < alpha)%Z) :
  is_RInt_gen ((fun x => powerRZ (x - sing) alpha * (pow (ln (x - sing)) beta))) (at_point (sing + / B)) (at_point (sing + epsilon)) (f0eps alpha beta epsilon B).
Proof.
  apply is_RInt_gen_at_point.
  apply: (is_RInt_translation_sub _ (fun x => powerRZ x alpha * ln x ^ beta)).
  apply is_RInt_gen_at_point.
  have H : forall x y, x + y - x = y by move => x y; ring.
  rewrite !H; apply f0eps_correct => // .
Qed.

Lemma f0eps_lim_is_lim alpha beta epsilon (Halpha : (-1 < alpha)%Z) (Heps : 0 < epsilon) :
  filterlim (fun x : R => f0eps alpha beta epsilon (/ x))
            (at_right 0) (locally (f0eps_lim alpha beta epsilon)).
Proof.
apply: filterlim_comp.
exact: filterlim_Rinv_0_right.
rewrite /f0eps /f0eps_lim.
have H x : ((-1) ^ beta * x) = mult ((-1) ^ beta) x by [].
rewrite H.
apply: filterlim_ext.
  by move => x; first rewrite H.
  rewrite -[locally _]/(Rbar_locally (Rbar_mult (Finite _) (Finite _))).
  rewrite -[filterlim _ _ _]/(is_lim _ p_infty _).
  apply: is_lim_mult => // .
  + exact: is_lim_const.
  + apply: f_lim_is_lim; first exact: Rinv_0_lt_compat.
    by lia.
Qed.

Lemma f0eps_lim_is_lim_sing alpha beta epsilon sing (Halpha : (-1 < alpha)%Z) (Heps : 0 < epsilon) :
  filterlim (fun x : R => f0eps alpha beta epsilon (/ (x - sing)))
            (at_right sing) (locally (f0eps_lim alpha beta epsilon)).
Proof.
  apply: (filterlim_comp _ _ _ (fun x => x - sing) (fun x => f0eps alpha beta epsilon (Rinv x)) _ (at_right 0)).
    move => P [eps HepsP].
    rewrite /filtermap /at_right /within /locally.
    exists eps => y Hy Hsing.
    apply: HepsP.
      have Hepspos : 0 < eps by exact: (cond_pos eps).
        by apply/ball_to_lra; split; move/ball_to_lra: Hy; lra.
      lra.
  exact: f0eps_lim_is_lim.
Qed.

Lemma f0eps_lim_correct alpha beta epsilon (Halpha : (-1 < alpha)%Z) (Heps : 0 < epsilon)  :
  is_RInt_gen ((fun x => powerRZ x alpha * (pow (ln x) beta))) (at_right 0) (at_point epsilon) (f0eps_lim alpha beta epsilon).
Proof.
set eps := mkposreal epsilon Heps.
apply prodi_to_single_r.
apply: (filterlimi_lim_ext_loc (fun x => f0eps alpha beta epsilon (/ x))).
  exists (pos_div_2 eps) => y /= Hy1 Hy2.
  move/ball_to_lra in Hy1.
  have {1}-> : y = / / y by rewrite Rinv_involutive; lra.
  rewrite -is_RInt_gen_at_point.
  apply (f0eps_correct); rewrite ?Rinv_involutive; try lra.
  exact: Rinv_0_lt_compat.
  exact Halpha.
exact: f0eps_lim_is_lim.
Qed.

Lemma f0eps_lim_correct_sing alpha beta epsilon sing (Halpha : (-1 < alpha)%Z) (Heps : 0 < epsilon)  :
  is_RInt_gen ((fun x => powerRZ (x - sing) alpha * (pow (ln (x - sing)) beta))) (at_right sing) (at_point (sing + epsilon)) (f0eps_lim alpha beta epsilon).
Proof.
set eps := mkposreal epsilon Heps.
apply prodi_to_single_r.
apply: (filterlimi_lim_ext_loc (fun x => f0eps alpha beta epsilon (/ (x - sing)))).
  exists (pos_div_2 eps) => y /= Hy1 Hy2.
  move/ball_to_lra in Hy1.
  have {1}-> : y = sing + / / (y - sing) by rewrite Rinv_involutive; lra.
  rewrite -is_RInt_gen_at_point.
  apply f0eps_correct_sing; rewrite ?Rinv_involutive; try lra.
  apply: Rinv_0_lt_compat; lra.
  exact Halpha.
exact: f0eps_lim_is_lim_sing.
Qed.

End ZeroToEpsilon.

Module BertrandInterval (I : IntervalOps).

Module J := IntervalExt I.

Section EffectiveBertrand.
(* TODO: factor out the A^alpha+1 and compute ln A only once for efficiency *)

Variable prec : I.precision.

Section Infinity.

Variable a : R.
Variable A : I.type.
Let iA := I.convert A.

Hypothesis Hcontainsa : contains iA (Xreal a).

Section BertrandLogNegInt.

Definition f_neg_int beta :=
  I.inv prec (I.mul prec (I.fromZ prec (Z.of_nat beta)) (I.power_int prec (I.ln prec A) (Z.of_nat beta))).

Lemma f_neg_int_correct beta : contains (I.convert (f_neg_int beta)) (Xreal (- f_neg a beta)).
Proof.
rewrite /f_neg Ropp_involutive.
apply: J.inv_correct.
apply: J.mul_correct.
  rewrite INR_IZR_INZ.
  exact: I.fromZ_correct.
rewrite pow_powerRZ.
apply: J.power_int_correct.
exact: J.ln_correct.
Qed.

End BertrandLogNegInt.

Fixpoint f_int_aux (alpha : Z) (beta : nat) (A_pow_Salpha : I.type) (ln_A : I.type) {struct beta} : I.type :=
  let alphap1 := I.fromZ prec (alpha + 1) in
  match beta with
  | 0 => I.div prec (I.neg A_pow_Salpha) alphap1
  | S m =>
    let beta := Z.of_nat beta in
    I.sub prec (I.div prec (I.neg (I.mul prec A_pow_Salpha (I.power_int prec ln_A beta))) alphap1)
      (I.mul prec (I.div prec (I.fromZ prec beta) alphap1) (f_int_aux alpha m A_pow_Salpha ln_A))
  end.

Definition f_int_fast (alpha : Z) (beta : nat) :=
  let A_pow_Salpha := I.power_int prec A (alpha+1) in
  let ln_A := I.ln prec A in
  f_int_aux alpha beta A_pow_Salpha ln_A.

Fixpoint f_int (alpha : Z) (beta : nat) {struct beta} : I.type :=
  let alphap1' := (alpha + 1)%Z in
  let alphap1 := I.fromZ prec alphap1' in
  match beta with
  | 0 => I.div prec (I.neg (I.power_int prec A alphap1')) alphap1
  | S m =>
    let beta := Z.of_nat beta in
    I.sub prec (I.div prec (I.neg (I.mul prec (I.power_int prec A alphap1') (I.power_int prec (I.ln prec A) beta))) alphap1)
      (I.mul prec (I.div prec (I.fromZ prec beta) alphap1) (f_int alpha m))
  end.

Lemma f_int_correct alpha beta (H : 0 < a) (Halpha:  alpha <> (-1)%Z) :
  contains (I.convert (f_int alpha beta)) (Xreal (f_lim alpha beta a)).
Proof.
have Salphaneq0 : IZR (alpha + 1) <> 0.
  apply: not_0_IZR.
  by rewrite Z.add_move_0_r.
have an0 : not (is_zero a).
  by move: is_zero_spec; case => // ; lra.
have Salphaneq01: not (is_zero (IZR (alpha + 1))).
  move: (is_zero_spec (IZR (alpha + 1))).
  case => // .
elim: beta => [|m HIm].
- rewrite /= .
  apply: J.div_correct.
  apply: J.neg_correct.
  apply: J.power_int_correct => // ; apply: Hcontainsa.
    exact: I.fromZ_correct.
- rewrite /f_int -/f_int /f_lim -/f_lim.
  apply: J.sub_correct.
  apply: J.div_correct.
  apply: J.neg_correct.
  apply: J.mul_correct.
  apply: J.power_int_correct; apply: Hcontainsa.
  rewrite pow_powerRZ.
  apply: J.power_int_correct.
  apply: J.ln_correct; apply: Hcontainsa.
    exact: I.fromZ_correct.
    apply: J.mul_correct => // .
    apply: J.div_correct.
  by rewrite INR_IZR_INZ; apply: I.fromZ_correct.
  exact: I.fromZ_correct.
Qed.

Lemma f_int_fast_f_int alpha beta : f_int_fast alpha beta = f_int alpha beta.
Proof.
elim: beta => [| beta Hbeta] //= .
  rewrite /f_int_fast //= .
  by rewrite -!Hbeta.
Qed.

Lemma f_int_fast_correct alpha beta (H : 0 < a) (Halpha:  alpha <> (-1)%Z) :
  contains (I.convert (f_int_fast alpha beta)) (Xreal (f_lim alpha beta a)).
Proof.
  by rewrite f_int_fast_f_int; exact: f_int_correct.
Qed.

End Infinity.

Section Sing.

Variable epsilon : R.
Variable Epsilon : I.type.
Let iEps := I.convert Epsilon.

Hypothesis HEps : contains iEps (Xreal epsilon).
Hypothesis eps_gt0 : 0 < epsilon.

Definition i1 := I.fromZ_small 1.
Definition im1 := I.fromZ_small (-1).

Definition f0eps_int (alpha : Z) (beta : nat) :=
  I.mul prec (I.power_int prec im1 (Z.of_nat beta))
    (f_int_fast (I.div prec i1 Epsilon) (- 2 - alpha) beta ).

Lemma f0eps_correct (alpha : Z) (beta : nat) (Halpha : (alpha <> -1)%Z) :
  contains (I.convert (f0eps_int alpha beta)) (Xreal (f0eps_lim alpha beta epsilon)).
Proof.
rewrite /f0eps_int /f0eps_lim.
apply: J.mul_correct.
  rewrite pow_powerRZ; apply: J.power_int_correct.
  exact: I.fromZ_small_correct.
rewrite f_int_fast_f_int; apply: f_int_correct.
  have -> : / epsilon = 1 / epsilon by field; lra.
  apply: J.div_correct => // .
  exact: I.fromZ_small_correct.
exact: Rinv_0_lt_compat.
by lia.
Qed.

End Sing.

End EffectiveBertrand.

End BertrandInterval.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable supp_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defrightangle_1 : (forall A B C : Universe, (exists X : Universe, (per_ A B C -> (betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C)))))).
Variable defrightangle2_2 : (forall A B C X : Universe, ((betS_ A B X /\ (cong_ A B X B /\ (cong_ A C X C /\ B <> C))) -> per_ A B C)).
Variable lemma_inequalitysymmetric_3 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_extension_4 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable lemma_betweennotequal_5 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_ray4_1_6 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_7 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_8 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_rightangleNC_9 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable defsupplement_10 : (forall A B C D F : Universe, (supp_ A B C D F -> (out_ B C D /\ betS_ A B F))).
Variable defsupplement2_11 : (forall A B C D F : Universe, ((out_ B C D /\ betS_ A B F) -> supp_ A B C D F)).
Variable lemma_ABCequalsCBA_12 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_supplements_13 : (forall A B C D F Xa Xb Xc Xd Xf : Universe, ((congA_ A B C Xa Xb Xc /\ (supp_ A B C D F /\ supp_ Xa Xb Xc Xd Xf)) -> congA_ D B F Xd Xb Xf)).
Variable lemma_congruencesymmetric_14 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_doublereverse_15 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable defcollinear_16 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_17 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_18 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_19 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_20 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_21 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_22 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_23 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_collinear4_24 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_equalanglestransitive_25 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable proposition_04_26 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).
Variable lemma_congruenceflip_27 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable lemma_congruencetransitive_28 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).

Theorem lemma_8_2_29 : (forall A B C : Universe, (per_ A B C -> per_ C B A)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*
 * Illustration of a common problem I see both newer students
 * and machine learning tools encounter when trying to write proofs.
 * The problem is what I call a "death loop," namely trying the
 * same thing over and over again but not noticing that the state
 * is changing only in ways that do not actually help you, since it
 * feels like you're making progress.
 *)

Require Import List.

(* Let's start with a good version that doesn't fall into a death loop: *)
Lemma app_nil_r_good:
  forall {T : Type} (l : list T),
    l ++ nil = l.
Proof.
  intros. induction l.
  - auto. (* nil ++ nil = nil by reflexivity *)
  - simpl. (* e.t.s that a :: l ++ nil = a :: l *)
    f_equal. (* e.t.s that l ++ nil = l *)
    auto. (* this holds by the inductive hypothesis *)
Qed.

(* With newer students, and with machine learning models, we often see
   something like this happen instead: *)
Lemma app_nil_r_bad:
  forall {T : Type} (l : list T),
    l ++ nil = l.
Proof.
  intros. induction l.
  - auto. (* nil ++ nil = nil by reflexivity *)
  - simpl. (* e.t.s that a :: l ++ nil = a :: l *)
    induction l. (* we can show that by induction over l *)
    + auto. (* a :: nil ++ nil = a :: nil by reflexivity. *)
    + simpl. (* e.t.s that a :: a0 :: l ++ nil = a :: a0 :: l *)
      (* ... could get stuck continuing this way forever *)
Abort.

(* The loop here happens because we induct over the same variable
   within a subcase generated by induction over that very variable.
   So we were at a proof state:

     T : Type
     a : T
     l : list T
     IHl : l ++ nil = l
     ______________________________________(1/1)
     a :: l ++ nil = a :: l

   And by the time we induct again and get to the second inductive
   case, we're at a proof state:

     T : Type
     a, a0 : T
     l : list T
     IHl : (a0 :: l) ++ nil = a0 :: l
     IHl0 : l ++ nil = l -> a :: l ++ nil = a :: l
     ______________________________________(1/1)
     a :: a0 :: l ++ nil = a :: a0 :: l
*)

(* At that point, we're no closer to the end than we were before.
   We can still finish the proof if we want: *)
Lemma app_nil_r_bad:
  forall {T : Type} (l : list T),
    l ++ nil = l.
Proof.
  intros. induction l.
  - auto. (* nil ++ nil = nil by reflexivity *)
  - simpl. (* e.t.s that a :: l ++ nil = a :: l *)
    induction l. (* we can show that by induction over l *)
    + auto. (* a :: nil ++ nil = a :: nil by reflexivity. *)
    + simpl. (* e.t.s that a :: a0 :: l ++ nil = a :: a0 :: l *)
      f_equal. (* e.t.s that a0 :: l ++ nil = a0 :: l *)
      auto. (* this holds by the [first] inductive hypothesis *)
Qed.

(*
 * But we could also keep looping infinitely, and in practice,
   many newer students and machine learning models do just this
   until they time out (machines) or get frustrated (students).

   Maybe, in the short term, some kind of repetition penalty
   is enough to catch this. But this is a bit of a hack.
   We could easily generate a different name for the variable
   in the inductive case that we induct over the second time,
   for example (and custom names for inductive cases are fairly
   common in Coq proof developments):
*)
Lemma app_nil_r_bad_subtler:
  forall {T : Type} (l : list T),
    l ++ nil = l.
Proof.
  intros. induction l as [|a l0].
  - auto. (* nil ++ nil = nil by reflexivity *)
  - simpl. (* e.t.s that a :: l0 ++ nil = a :: l0 *)
    induction l0 as [|b l1]. (* we can show that by induction over l0 *)
    + auto. (* a :: nil ++ nil = a :: nil by reflexivity. *)
    + simpl. (* e.t.s that a :: b :: l1 ++ nil = a :: b :: l1 *)
      (* ... could get stuck continuing this way forever *)
Abort.

(* Now our induction l0 takes is in a loop after inducting over l.
   Our two states that are in some sense "the same" (i.e., the latter
   is no closer to the goal than the former) are this state:

     T : Type
     a : T
     l : list T
     IHl : l0 ++ nil = l0
     ______________________________________(1/1)
     a :: l0 ++ nil = a :: l0

   and this state:

     T : Type
     a, b : T
     l1 : list T
     IHl0 : (b :: l1) ++ nil = b :: l1
     IHl1 : l1 ++ nil = l1 -> a :: l1 ++ nil = a :: l1
     ______________________________________(1/1)
     a :: b :: l1 ++ nil = a :: b :: l1
*)

(* RESEARCH QUESTION: What makes these two states "the same"
   in a way that we could actually teach a machine to use
   in proof automation? I don't know the answer.

   As a human, I get a sense of "deja vu," like I realize I'm
   doing the same thing over and over again, and I stop.
   But I don't know how it is I get the sense that I'm repeating myself!

   One thing that seems relevant to me is the fact that l "becomes" a :: l
   or similarly a :: l0 in the inductive case. But I can't get much more
   crisp than that. And I think figuring this out is important for building good
   machine learning tools for proofs.

   Another thing that seems relevant to me is the relationship to proof
   checking in proof systems that have cyclic induction. Likely some
   reduction can be made to that, but I don't know for sure. *)

(* Hopefully I'll add more examples of these later!
   Including more interesting ones, as they come up.
   Like this is even more of a problem when the goal is
   not provable but you feel like you're getting closer,
   or with proofs that are really cyclic where you need
   a more general IH. I can add an even/odd example for that. *)


Definition csak3(k:nat):bool:=
  match k with
  |3 => true
  |_ => false
  end.

Definition haromnalkisebb(k:nat):bool:=
negb(Init.Nat.eqb(Init.Nat.min k 3)(3)).

Eval compute in haromnalkisebb 1.

Definition mkisebb (m:nat)(n:nat):bool:=
  match Init.Nat.eqb m n with
  | true => false
  | false => (Init.Nat.eqb(Init.Nat.min m n)(m))
  end.

Eval compute in mkisebb 2 3.


Parameters p1 p2 t1 t2 : Prop.

Definition aff1 := t1 /\ t2.
Definition aff2 := t1.

Definition k := ((p1 /\ aff1) \/ (t1 /\ ~aff1)) /\ ((p2 /\ ~aff2) \/ (t2 /\ aff2)).

Definition h1 := ~(p1 /\ t1) /\ ~(p2 /\ t2).
Definition h2 := (p1 \/ t1) /\ (p2 \/ t2).

Lemma epreuve_8 : h1 /\ h2 /\ k -> t1 /\ p2.
Proof.
unfold k, h1, h2.
unfold aff1, aff2.
intros.
destruct H.
destruct H.
destruct H0.
destruct H0.
destruct H2.
destruct H2.
destruct H2.
destruct H5.
elimtype False.
apply H.
split; assumption.
destruct H2.
destruct H4.
destruct H4.
auto.
destruct H4.
elimtype False.
apply H5.
split; assumption.
Qed.


(* microyalla library for intuitionistic linear logic *)
(*   Olivier Laurent *)

Require Export List.
Export ListNotations.

(* From ollibs/Permutation_Type.v *)

Inductive Permutation_Type {A} : list A -> list A -> Type :=
| Permutation_Type_nil_nil : Permutation_Type nil nil
| Permutation_Type_skip x l l' : Permutation_Type l l' -> Permutation_Type (x::l) (x::l')
| Permutation_Type_swap x y l : Permutation_Type (y::x::l) (x::y::l)
| Permutation_Type_trans l l' l'' :
    Permutation_Type l l' -> Permutation_Type l' l'' -> Permutation_Type l l''.

(* Adapted from yalla/iformulas.v *)

(** A set of atoms for building formulas *)
Definition IAtom := nat.

(** Intuitionistic formulas *)
Inductive iformula : Set :=
| ivar  : IAtom -> iformula
| ione  : iformula
| itens : iformula -> iformula -> iformula
| ilmap : iformula -> iformula -> iformula
| itop  : iformula
| iwith : iformula -> iformula -> iformula
| izero : iformula
| iplus : iformula -> iformula -> iformula
| ioc   : iformula -> iformula.

(* Adapted from yalla/ill_def.v *)

(** Rules *)
Inductive ill : list iformula -> iformula -> Type :=
| ax_ir : forall X, ill (ivar X :: nil) (ivar X)
| ex_ir : forall l1 l2 A, ill l1 A -> Permutation_Type l1 l2 -> ill l2 A
| one_irr : ill nil ione
| one_ilr : forall l A, ill l A -> ill (ione :: l) A
| tens_irr : forall A B l1 l2, ill l1 A -> ill l2 B -> ill (l1 ++ l2) (itens A B)
| tens_ilr : forall A B l C, ill (A :: B :: l) C -> ill (itens A B :: l) C
| lmap_irr : forall A B l, ill (A :: l) B -> ill l (ilmap A B)
| lmap_ilr : forall A B l1 l2 C, ill l1 A -> ill (B :: l2) C -> ill (ilmap A B :: l1 ++ l2) C
| top_irr : forall l, ill l itop
| with_irr : forall A B l, ill l A -> ill l B -> ill l (iwith A B)
| with_ilr1 : forall A B l C, ill (A :: l) C -> ill (iwith A B :: l) C
| with_ilr2 : forall A B l C, ill (A :: l) C -> ill (iwith B A :: l) C
| zero_ilr : forall l C, ill (izero :: l) C
| plus_irr1 : forall A B l, ill l A -> ill l (iplus A B)
| plus_irr2 : forall A B l, ill l A -> ill l (iplus B A)
| plus_ilr : forall A B l C, ill (A :: l) C -> ill (B :: l) C -> ill (iplus A B :: l) C
| oc_irr : forall A l, ill (map ioc l) A -> ill (map ioc l) (ioc A)
| de_ilr : forall A l C, ill (A :: l) C -> ill (ioc A :: l) C
| wk_ilr : forall A l C, ill l C -> ill (ioc A :: l) C
| co_ilr : forall A l C, ill (ioc A :: ioc A :: l) C -> ill (ioc A :: l) C.