(* Copyright (c) 2014, Robert Dockins *)

Require Import basics.
Require Import categories.
Require Import preord.
Require Import directed.

(** * Directed colimits and continuous functors.
 *)
Record directed_system (I:directed_preord) (C:category) :=
  DirSys
  { ds_F    : I -> ob C
  ; ds_hom : forall i j:I, i ≤ j -> ds_F i → ds_F j
  ; ds_ident : forall i (Hii:i≤i), ds_hom i i Hii ≈ id
  ; ds_compose : forall i j k (Hij:i≤j) (Hjk:j≤k) (Hik:i≤k),
                       ds_hom j k Hjk ∘ ds_hom i j Hij ≈ ds_hom i k Hik
  }.
Arguments ds_F [I] [C] _ _.
Arguments ds_hom [I] [C] _ _ _ _.
Arguments ds_ident [I] [C] _ _ _.
Arguments ds_compose [I] [C] _ _ _ _ _ _ _.

Record cocone (I:directed_preord) C (DS:directed_system I C) :=
  Cocone
  { cocone_point :> ob C
  ; cocone_spoke : forall i, ds_F DS i → cocone_point
  ; cocone_commute : forall i j (Hij:i≤j),
       cocone_spoke i ≈ cocone_spoke j ∘ ds_hom DS i j Hij
  }.
Arguments cocone [I] [C] DS.
Arguments Cocone [I] [C] DS _ _ _.
Arguments cocone_point [I] [C] [DS] _.
Arguments cocone_spoke [I] [C] [DS] _ _.
Arguments cocone_commute [I] [C] [DS] _ _ _ _.

Record directed_colimit (I:directed_preord) C (DS:directed_system I C)
  (XC:cocone DS) :=
  DirectedColimit
  { colim_univ : forall (YC:cocone DS), XC → YC
  ; colim_commute : forall (YC:cocone DS) i,
       cocone_spoke YC i ≈ colim_univ YC ∘ cocone_spoke XC i
  ; colim_uniq : forall (YC:cocone DS) (f:XC → YC),
       (forall i, cocone_spoke YC i ≈ f ∘ cocone_spoke XC i) ->
       f ≈ colim_univ YC
  }.
Arguments directed_colimit [I] [C] DS XC.
Arguments DirectedColimit [I] [C] DS XC _ _ _.
Arguments colim_univ [I] [C] [DS] [XC] _ YC.
Arguments colim_commute [I] [C] [DS] [XC] _ _ _.
Arguments colim_uniq [I] [C] [DS] [XC] _ YC f _.

Program Definition dir_sys_app I C D
  (DS:directed_system I C) (F:functor C D)
  : directed_system I D:=

  DirSys I D
    (fun i => F (ds_F DS i))
    (fun i j Hij => F·(ds_hom DS i j Hij))
    _ _.
Next Obligation.
  intros.
  apply Functor.ident.
  apply ds_ident.
Qed.
Next Obligation.
  intros.
  rewrite <- Functor.compose.
  reflexivity.
  symmetry; apply ds_compose.
Qed.
Arguments dir_sys_app [I] [C] [D] DS F.

Program Definition cocone_app I C D (DS:directed_system I C)
  (CC:cocone DS) (F:functor C D)
  : cocone (dir_sys_app DS F) :=

  Cocone (dir_sys_app DS F) (F CC) (fun i => F·cocone_spoke CC i) _.
Next Obligation.
  simpl; intros.
  rewrite <- (Functor.compose F). 2: reflexivity.
  rewrite <- (cocone_commute CC i j Hij).
  auto.
Qed.
Arguments cocone_app [I] [C] [D] [DS] CC F.

Definition continuous_functor (C D:category) (F:functor C D) :=
  forall I (DS:directed_system I C) (CC:cocone DS),
    directed_colimit DS CC ->
    directed_colimit (dir_sys_app DS F) (cocone_app CC F).
Arguments continuous_functor [C] [D] F.

(**  * Fixpoints of continuous functors.

     We can construct fixpoints of continuous endofunctors in
     any category that has an initial object and colimits of
     directed systems.

     This is essentially the categorical analogue of Kleene's
     fixpoint theorem for posets.
 *)

Require Import Arith.
Section fixpoint.
  Variable C:initialized.
  Variable F:functor C C.

  Variable colimit_cocone :
    forall (I:directed_preord) (DS:directed_system I C), cocone DS.

  Variable has_colimits :
    forall (I:directed_preord) (DS:directed_system I C),
            directed_colimit DS (colimit_cocone I DS).

  (** Iterated application of the functor [F]; the initial object
      provides the base case of the recursion.
    *)
  Fixpoint iterF (x:nat) : ob C :=
    match x with
    | O => ¡
    | S x' => F (iterF x')
    end.

  Lemma HSle0 j (Hij: S j <= O) : False.
  Proof.
    inversion Hij.
  Qed.

  (** Iterated action of the functor [F] on homs. The base case is
      provided by the universal hom associated to ¡.
   *)
  Fixpoint iter_hom (i:nat) : forall (j:nat) (Hij:i <= j), iterF i → iterF j :=
    match i as i' return forall (j:nat) (Hij:i' <= j), iterF i' → iterF j with
    | O => fun j Hij => initiate
    | S i' => fun j =>
        match j as j' return forall (Hij:S i' <= j'), iterF (S i') → iterF j' with
        | O => fun Hij => False_rect _ (HSle0 i' Hij) (* impossible case *)
        | S j' => fun Hij => F·(iter_hom i' j' (gt_S_le i' j' Hij))
        end
    end.

  Lemma iter_hom_proof_irr i : forall j H1 H2,
    iter_hom i j H1 ≈ iter_hom i j H2.
  Proof.
    induction i; simpl; intros; auto.
    destruct j.
    - elimtype False. inversion H1.
    - apply Functor.respects.
      apply IHi.
  Qed.

  (** The Kleene chain is a directed system. *)
  Program Definition kleene_chain : directed_system nat_dirord C :=
    DirSys nat_dirord C iterF iter_hom _ _.
  Next Obligation.
    induction i; simpl; intros.
    - symmetry. apply initiate_univ.
    - apply Functor.ident; auto.
  Qed.
  Next Obligation.
    induction i. simpl; intros.
    - apply initiate_univ.
    - intros. destruct j.
      + elimtype False. inversion Hij.
      + destruct k.
        * elimtype False. inversion Hjk.
        * simpl.
          rewrite <- (Functor.compose F _ _ _ (iter_hom j k (gt_S_le j k Hjk))).
          ** reflexivity.
          ** auto.
  Qed.

  (** The fixpoint we desire is the point of the colimiting cocone
      corresponding to the Kleene chain.
   *)
  Definition fixpoint := cocone_point (colimit_cocone nat_dirord kleene_chain).

  (** It is mildly interesting to note that we can construct the fixpoint
      object without the continuity assumption.

      However, if we suppose [F] _is_ a continuous functor, we can demonstrate
      that [fixpoint] forms an initial algebra and thus actually is
      the least fixpoint of [F].
    *)
  Hypothesis Fcontinuous : continuous_functor F.

  (** Because [F] is continuous, the additional application of F
      to the fixpoint colimiting cocone is a colimiting cocone
      for the [n+1] Kleene chain.
   *)
  Let BL := Fcontinuous
               nat_dirord kleene_chain
               (colimit_cocone nat_dirord kleene_chain)
               (has_colimits nat_dirord kleene_chain).

  Program Definition cocone_plus1 : cocone (dir_sys_app kleene_chain F)
    := Cocone (dir_sys_app kleene_chain F) fixpoint
      (fun i => cocone_spoke (colimit_cocone nat_dirord kleene_chain) (S i)) _.
  Next Obligation.
    simpl; intros.
    assert (Hij' : S i <= S j) by auto with arith.
    rewrite (cocone_commute (colimit_cocone nat_dirord kleene_chain) (S i) (S j) Hij').
    simpl. apply cat_respects; auto.
    apply Functor.respects.
    apply iter_hom_proof_irr.
  Qed.

  (** The algebra associated with the fixpoint. *)
  Definition fixpoint_alg : alg C F
    := @Alg C F fixpoint (colim_univ BL cocone_plus1).

  (** Next we define the catamorphism by iterating the action
      of a given algebra.
    *)
  Section cata.
    Variable AG : alg C F.

    Fixpoint cata_hom' (i:nat) : iterF i → AG :=
      match i as i' return iterF i' → AG with
      | O => initiate
      | S i' => Alg.iota AG ∘ F·(cata_hom' i')
      end.

    Lemma cata_hom_iter_hom : forall (i j:nat_ord) (Hij:i≤j),
      cata_hom' i ≈ cata_hom' j ∘ (iter_hom i j Hij).
    Proof.
      induction i; intros.
      - simpl. symmetry. apply initiate_univ.
      - destruct j; [ inversion Hij |].
        simpl.
        rewrite <- (cat_assoc _ _ _ _ _ (Alg.iota AG)).
        apply cat_respects; auto.
        rewrite <- (Functor.compose F); [ | reflexivity ].
        rewrite IHi; eauto.
    Qed.

    Program Definition AG_cocone : cocone kleene_chain :=
      Cocone _ _ cata_hom' cata_hom_iter_hom.

    Program Definition AG_cocone' :
      cocone (dir_sys_app kleene_chain F) :=
        Cocone _ _ (fun i => cata_hom' (S i)) _.
    Next Obligation.
      simpl; intros.
      rewrite (cata_hom_iter_hom i j Hij).
      rewrite Functor.compose; [ | reflexivity ].
      apply cat_assoc.
    Qed.

    Definition cata_hom : fixpoint → AG :=
      colim_univ (has_colimits nat_dirord kleene_chain) AG_cocone.

    Program Definition cata_alg_hom : Alg.alg_hom fixpoint_alg AG :=
      Alg.Alg_hom cata_hom _.
    Next Obligation.
      simpl.
      generalize (colim_uniq BL AG_cocone').
      intros.
      rewrite (H (cata_hom ∘ colim_univ BL cocone_plus1)).
      - symmetry. apply H.

        intros. simpl.
        rewrite <- (cat_assoc _ _ _ _ _ (Alg.iota AG)).
        rewrite <- (Functor.compose F); [ | reflexivity ].
        apply cat_respects; auto.
        apply Functor.respects.
        unfold cata_hom.
        apply (colim_commute (has_colimits nat_dirord kleene_chain) AG_cocone).

      - intros.
        rewrite <- (cat_assoc _ _ _ _ _ cata_hom).
        rewrite <- (colim_commute BL cocone_plus1).
        unfold cata_hom.
        apply (colim_commute (has_colimits nat_dirord kleene_chain) AG_cocone (S i)).
    Qed.
  End cata.

  (**  Now we show that the catamorphims is universal and construct
       the initial algebra.
    *)
  Program Definition fixpoint_initial : Alg.initial_alg C F :=
    Alg.Initial_alg fixpoint_alg cata_alg_hom _.
  Next Obligation.
    simpl; intros.
    unfold cata_hom.
    apply (colim_uniq (has_colimits nat_dirord kleene_chain) (AG_cocone M)).
    intro i. simpl.
    induction i.
    - simpl.
      symmetry. apply initiate_univ.
    - simpl.
      rewrite IHi.
      rewrite Functor.compose; [ | reflexivity ].
      rewrite (cat_assoc _ _ _ _ _ (Alg.iota M)).
      rewrite <- (Alg.hom_axiom h). simpl.
      repeat rewrite <- (cat_assoc C).
      apply cat_respects; auto.
      symmetry.
      apply (colim_commute BL cocone_plus1).
  Qed.

  (**  With the initial algebra in hand, we immediately
       get an isomorphism via standard facts about initial algebras.
    *)
  Definition fixpoint_iso :
    F fixpoint ↔ fixpoint :=

    Isomorphism C (F fixpoint) fixpoint
      (colim_univ BL cocone_plus1)
      (Alg.out _ F fixpoint_initial)
      (Alg.out_in _ F fixpoint_initial)
      (Alg.in_out _ F fixpoint_initial).

End fixpoint.

(** * Standard continuous functors.

    The identity and constant functors are continuous, as is
    the composition of two continuous functors.

    Pairing and projection functors are also continuous.
 *)

Lemma identF_continuous (C:category) : continuous_functor id(C).
Proof.
  repeat intro.
  apply (DirectedColimit (dir_sys_app DS id(C)) (cocone_app CC id(C))
    (fun YC => colim_univ X (Cocone DS
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC)))).
  simpl; intros.
  apply (colim_commute X (Cocone DS
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC)) i).
  intros.
  apply (colim_uniq X (Cocone DS
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC))); auto.
Qed.

Lemma fconst_continuous (C D:category) (X:ob D) : continuous_functor (fconst C D X).
Proof.
  repeat intro.
  destruct (choose_ub_set I nil) as [j _].
  apply (DirectedColimit
    (dir_sys_app DS (fconst C D X))
    (cocone_app CC (fconst C D X))
    (fun YC => cocone_spoke YC j)); simpl; intros.
  - destruct (choose_ub I i j) as [k [??]].
    rewrite (cocone_commute YC i k H). simpl.
    rewrite (cocone_commute YC j k H0). simpl.
    rewrite (cat_ident1 _ _ _ (cocone_spoke YC k)).
    rewrite (cat_ident1 _ _ _ (cocone_spoke YC k)). auto.
  - rewrite (H j). symmetry. apply cat_ident1.
Qed.

Lemma composeF_continuous (C D E:category)
  (F:functor D E) (G:functor C D) :
  continuous_functor F ->
  continuous_functor G ->
  continuous_functor (F ∘ G).
Proof.
  repeat intro.
  cut (directed_colimit
    (dir_sys_app (dir_sys_app DS G) F)
    (cocone_app (cocone_app CC G) F)).
  { intros.
    apply (DirectedColimit
             (dir_sys_app DS (F∘G)) (cocone_app CC (F∘G))
             (fun YC => colim_univ X2 (Cocone (dir_sys_app (dir_sys_app DS G) F)
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC)))).
    - simpl; intros.
      apply (colim_commute X2 (Cocone (dir_sys_app (dir_sys_app DS G) F)
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC)) i).
    - intros.
      apply (colim_uniq X2 (Cocone (dir_sys_app (dir_sys_app DS G) F)
                 (cocone_point YC) (cocone_spoke YC) (cocone_commute YC))); auto.
  }
  apply X. apply X0. auto.
Qed.

Section pairF_continuous.
  Variables C D E:category.
  Variable F:functor C D.
  Variable G:functor C E.

  Section cocones.
    Variable I:directed_preord.
    Variable DS:directed_system I C.

    Program Definition cocone_fstF (YC:cocone (dir_sys_app DS (pairF F G)))
      : cocone (dir_sys_app DS F)
      := Cocone (dir_sys_app DS F)
                (obl (cocone_point YC))
                (fun i => homl (cocone_spoke YC i))
                _.
    Next Obligation.
      simpl; intros.
      destruct (cocone_commute YC i j Hij); auto.
    Qed.

    Program Definition cocone_sndF (YC:cocone (dir_sys_app DS (pairF F G)))
      : cocone (dir_sys_app DS G)
      := Cocone (dir_sys_app DS G)
                (obr (cocone_point YC))
                (fun i => homr (cocone_spoke YC i))
                _.
    Next Obligation.
      simpl; intros.
      destruct (cocone_commute YC i j Hij); auto.
    Qed.
  End cocones.

  Hypothesis HcontF : continuous_functor F.
  Hypothesis HcontG : continuous_functor G.

  Lemma pairF_continuous : continuous_functor (pairF F G).
  Proof.
    repeat intro.
    generalize (HcontF I DS CC X). intro.
    generalize (HcontG I DS CC X). intro.
    apply DirectedColimit with
      (fun YC => PROD.Hom D E
        (PROD.Ob D E (F (cocone_point CC)) (G (cocone_point CC)))
        (cocone_point YC)
        (colim_univ X0 (cocone_fstF I DS YC))
        (colim_univ X1 (cocone_sndF I DS YC))).
    - simpl; intros. split; simpl.
      apply (colim_commute X0 (cocone_fstF I DS YC)).
      apply (colim_commute X1 (cocone_sndF I DS YC)).
    - simpl; intros. split; simpl.
      + apply (colim_uniq X0 (cocone_fstF I DS YC)).
        intro i; destruct (H i); auto.
      + apply (colim_uniq X1 (cocone_sndF I DS YC)).
        intro i; destruct (H i); auto.
  Qed.
End pairF_continuous.

Section fstF_continuous.
  Variables C D:category.
  Variable I:directed_preord.
  Variable DS:directed_system I (PROD C D).
  Variable CC:cocone DS.
  Variable Hcolim : directed_colimit DS CC.

  Program Definition fstF_cocone
    (CC1 : cocone (dir_sys_app DS (fstF C D))) : cocone DS
    := Cocone DS (PROD.Ob C D (cocone_point CC1)
                                          (obr (cocone_point CC)))
                 (fun i => PROD.Hom C D _ _
                            (cocone_spoke CC1 i)
                            (homr (cocone_spoke CC i) :
                                 obr (ds_F DS i) → obr (cocone_point CC)))

                 _.
  Next Obligation.
    intros. split; simpl.
    - apply (cocone_commute CC1 i).
    - apply (cocone_commute CC i).
  Qed.

  Definition fstF_univ (YC : cocone (dir_sys_app DS (fstF C D))) :
    cocone_app CC (fstF C D) → YC :=
    homl (colim_univ Hcolim (fstF_cocone YC)).

  Lemma fstF_continuous' :
    directed_colimit (dir_sys_app DS (fstF C D)) (cocone_app CC (fstF C D)).
  Proof.
    apply DirectedColimit with fstF_univ.
    - simpl. intros.
      destruct (colim_commute Hcolim (fstF_cocone YC) i). auto.
    - intros.
      destruct (colim_uniq Hcolim (fstF_cocone YC)
        (PROD.Hom C D
           (cocone_point CC)
           (PROD.Ob _ _ (cocone_point YC) (obr (cocone_point CC)))
           f id
           )); auto.
      intros. split; simpl; auto.
      + apply H.
      + symmetry. apply cat_ident2.
  Qed.
End fstF_continuous.

Lemma fstF_continuous C D :
  continuous_functor (fstF C D).
Proof.
  repeat intro. apply fstF_continuous'; auto.
Qed.

Section sndF_continuous.
  Variables C D:category.
  Variable I:directed_preord.
  Variable DS:directed_system I (PROD C D).
  Variable CC:cocone DS.
  Variable Hcolim : directed_colimit DS CC.

  Program Definition sndF_cocone
    (CC1 : cocone (dir_sys_app DS (sndF C D))) : cocone DS
    := Cocone DS (PROD.Ob C D (obl (cocone_point CC))
                              (cocone_point CC1))
                 (fun i => PROD.Hom C D _ _
                            (homl (cocone_spoke CC i) :
                                 obl (ds_F DS i) → obl (cocone_point CC))
                            (cocone_spoke CC1 i))
                 _.
  Next Obligation.
    intros. split; simpl.
    - apply (cocone_commute CC i).
    - apply (cocone_commute CC1 i).
  Qed.

  Definition sndF_univ (YC : cocone (dir_sys_app DS (sndF C D))) :
    cocone_app CC (sndF C D) → YC :=
    homr (colim_univ Hcolim (sndF_cocone YC)).

  Lemma sndF_continuous' :
    directed_colimit (dir_sys_app DS (sndF C D)) (cocone_app CC (sndF C D)).
  Proof.
    apply DirectedColimit with sndF_univ.
    - simpl. intros.
      destruct (colim_commute Hcolim (sndF_cocone YC) i). auto.
    - intros.
      destruct (colim_uniq Hcolim (sndF_cocone YC)
        (PROD.Hom C D
           (cocone_point CC)
           (PROD.Ob _ _ (obl (cocone_point CC)) (cocone_point YC))
           id f)); auto.
      intros. split; simpl; auto.
      symmetry. apply cat_ident2.
      apply H.
  Qed.
End sndF_continuous.

Lemma sndF_continuous C D : continuous_functor (sndF C D).
Proof.
  repeat intro. apply sndF_continuous'; auto.
Qed.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import omega.Omega.
From LF Require Import Maps.
From LF Require Import Imp.

Ltac inv H := inversion H; subst; clear H.
Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* 断言的证明 *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b 求值为 true *)
    apply IHE1. assumption.
  - (* b 求值为 false（矛盾） *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b 求值为 false（矛盾） *)
    rewrite H in H5. inversion H5.
  - (* b 求值为 false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b 求值为 false *)
    reflexivity.
  - (* b 求值为 true（矛盾） *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b 求值为 false（矛盾） *)
    rewrite H in H4. inversion H4.
  - (* b 求值为 true *)
    assert (st' = st'0) as EQ1.
    { (* 断言的证明 *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption. Qed.

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

Example auto_example_2 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.
Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b 求值为 false（矛盾） *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b 求值为 true（矛盾） *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b 求值为 true（矛盾） *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b 求值为 false（矛盾） *)
    rewrite H in H4. inversion H4.
  - (* b 求值为 true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.
Theorem ceval_deterministic'': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b 求值为 false（矛盾） *)
      rwinv H H5.
  - (* E_IfFalse *)
    + (* b 求值为 true（矛盾） *)
      rwinv H H5.
  - (* E_WhileFalse *)
    + (* b 求值为 true（矛盾） *)
      rwinv H H2.
  (* E_WhileTrue *)
  - (* b 求值为 false（矛盾） *)
    rwinv H H4.
  - (* b 求值为 true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwinv H1 H2
  end.

Theorem ceval_deterministic''': forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_WhileTrue *)
    + (* b 求值为 true *)
      assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.


Require Import CoqChess.Util.Rel.

Definition sbetween : Rel 3 nat :=
  fun x y z =>
      (x < y /\ y < z)
   \/ (z < y /\ y < x).

Lemma sbetween_sym : forall x y z,
  sbetween x y z -> sbetween z y x.
Proof.
  unfold sbetween; tauto.
Qed.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rmult.
Require Export XR_Rmult_0_r.
Require Export XR_Rmult_eq_reg_l.
Require Export XR_Rtotal_order.
Require Export XR_Rlt_not_eq.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_integral : forall r1 r2, r1 * r2 = R0 -> r1 = R0 \/ r2 = R0.
Proof.
intros x y.
intro heq.
destruct (Rtotal_order x R0) as [ hxneg | [ hxeq | hxpos ] ].
{
  right.
  apply Rmult_eq_reg_l with x.
  {
    rewrite Rmult_0_r.
    exact heq.
  }
  {
    apply Rlt_not_eq.
    exact hxneg.
  }
}
{
  left.
  exact hxeq.
}
{
  right.
  apply Rmult_eq_reg_l with x.
  {
    rewrite Rmult_0_r.
    exact heq.
  }
  {
    apply not_eq_sym.
    apply Rlt_not_eq.
    exact hxpos.
  }
}
Qed.


Require Export XR_Rinv_0_lt_compat.
Require Export XR_Ropp_lt_cancel.
Require Export XR_Ropp_inv_permute.

Local Open Scope R_scope.

Lemma Rinv_lt_0_compat : forall r, r < R0 -> / r < R0.
Proof.
  intros x h.
  apply Ropp_lt_cancel.
  rewrite Ropp_0.
  rewrite Ropp_inv_permute.
  {
    apply Rinv_0_lt_compat.
    rewrite <- Ropp_0.
    apply Ropp_lt_contravar.
    exact h.
  }
  {
    apply Rlt_not_eq.
    exact h.
  }
Qed.


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

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

From mathcomp.ssreflect Require Import ssrnat.

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 -Hierarchy.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 f_neg_continuous x beta (H0x : 0 < x) (Hx1 : x <> 1):
  continuous (fun x0 : R => / (x0 * ln x0 ^ beta.+1)) 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.+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.
apply: Hlnn0; lra.
Qed.

Lemma f_neg_correct_RInt_0_1 a b beta (Hab1 : 0 < a <= b) (Hb1 : b < 1) (Hbeta : (0 < beta)%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.
  rewrite /f_neg.
  rewrite -[/(_ * _)]Ropp_involutive.
  apply: is_derive_opp.
  auto_derive.
    repeat (split; try lra).
    apply: Rmult_integral_contrapositive; split => // .
    exact: Hlnn0.
  case: beta Hbeta Hbetn0 Hlnn0 => [|beta] // Hbeta Hbetn0 Hlnn0.
  rewrite -pred_Sn.
  rewrite -!tech_pow_Rmult.
  field; repeat (split; try easy).
    exact: Hlnn0.
    by rewrite -[ln _]pow_1; exact: Hlnn0.
    by lra.
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 : (1 < beta)%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.
  rewrite /f_neg.
  rewrite -[/(_ * _)]Ropp_involutive.
  apply: is_derive_opp.
  auto_derive.
    repeat (split; try lra).
    apply: Rmult_integral_contrapositive; split => // .
    exact: Hlnn0.
  case: beta Hbeta Hbetn0 Hlnn0 => [|beta] // Hbeta Hbetn0 Hlnn0.
  rewrite -pred_Sn.
  rewrite -!tech_pow_Rmult.
  field; repeat (split; try easy).
    exact: Hlnn0.
    by rewrite -[ln _]pow_1; exact: Hlnn0.
    by lra.
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 : (0 < beta)%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 : (1 < beta)%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 < IZR alpha) :
  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 Halpha1 : (-1 < alpha)%Z by apply: lt_IZR.
  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.
    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 < IZR alpha) :
  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 < IZR alpha) (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.
    have Halpha1 : (-1 < alpha)%Z by apply: lt_IZR.
    by lia.
Qed.

Lemma f0eps_lim_is_lim_sing alpha beta epsilon sing (Halpha : -1 < IZR alpha) (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 < IZR alpha) (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: f0eps_lim_is_lim.
Qed.

Lemma f0eps_lim_correct_sing alpha beta epsilon sing (Halpha : -1 < IZR alpha) (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: f0eps_lim_is_lim_sing.
Qed.

End ZeroToEpsilon.

Module BertrandInterval (F : FloatOps with Definition even_radix := true) (I : IntervalOps with Definition bound_type := F.type with Definition precision := F.precision with Definition convert_bound := F.toX).

Module J := IntervalExt I.

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

Variable prec : F.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.neg (I.inv prec (I.mul prec (I.fromZ (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.
apply: J.neg_correct.
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 :=
  match beta with
    | 0 => I.div prec (I.neg A_pow_Salpha) (I.fromZ (alpha + 1))
    | S m =>
       I.sub prec (I.div prec (I.neg (I.mul prec A_pow_Salpha (I.power_int prec ln_A (Z.of_nat beta)))) (I.fromZ (alpha + 1)))
      (I.mul prec (I.div prec (I.fromZ (Z.of_nat beta)) (I.fromZ (alpha+1))) (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 :=
  match beta with
    | 0 => I.div prec (I.neg (I.power_int prec A (alpha+1))) (I.fromZ (alpha + 1))
    | S m =>
       I.sub prec (I.div prec (I.neg (I.mul prec (I.power_int prec A (alpha+1)) (I.power_int prec (I.ln prec A) (Z.of_nat beta)))) (I.fromZ (alpha + 1)))
      (I.mul prec (I.div prec (I.fromZ (Z.of_nat beta)) (I.fromZ (alpha+1))) (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 f0eps_int (alpha : Z) (beta : nat) :=
  I.mul prec (I.power_int prec (I.fromZ (-1)) (Z.of_nat beta)) (f_int_fast (I.div prec (I.fromZ 1) 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.
  by apply: I.fromZ_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_correct.
exact: Rinv_0_lt_compat.
by lia.
Qed.

End Sing.

End EffectiveBertrand.

End BertrandInterval.

(*
Module NumericTests.

Require Import Interval_interval_float_full.
Require Import Interval_bigint_carrier.
Require Import Interval_specific_ops.
Require Import Interval_bisect Interval_integral.
Module SFBI2 := SpecificFloat BigIntRadix2.
Module I := FloatIntervalFull SFBI2.

Module MyBertrand := BertrandInterval SFBI2 I.

About MyBertrand.f_int.

Eval vm_compute in MyBertrand.f_int (SFBI2.PtoP 50) (I.fromZ 100000%Z) (-2%Z) (2).

Module II := IntegralTactic SFBI2 I.
Module IT := IntegralTaylor I.
Module IA := IntervalAlgos I.

Definition prec := SFBI2.PtoP 30.

Definition est a b :=
  II.naive_integral prec (fun x =>
    I.mul prec (I.sqr prec (I.cos prec x))
    (I.mul prec (I.power_int prec x (-2)) (I.power_int prec (I.ln prec x) 3)))
  a b.

Definition est_i x :=
  I.join (I.fromZ 0) (MyBertrand.f_int prec x (-2) 3).

Definition eps := SFBI2.scale2 (SFBI2.fromZ 1) (SFBI2.ZtoS (-12)).

Definition v1 := II.integral_interval_relative prec est  5 (I.fromZ 1) (I.fromZ 3) eps.

Definition v2 := II.integral_interval_relative_infty prec est est_i 15 (I.fromZ 1) eps.

Definition prog :=
  (Unary Ln 0
         :: Unary (PowerInt 3) 0
            :: Unary (PowerInt (-2)) 2
               :: Unary Cos 3
                  :: Unary Sqr 0
                     :: Binary Mul 0 2 :: Binary Mul 0 4 :: Datatypes.nil)%list.

Import List.

Definition prog' := Unary Ln 0
        :: Unary (PowerInt 3) 0
           :: Unary (PowerInt (-2)) 2
              :: Unary Atan 3
                 :: Binary Mul 0 1 :: Binary Mul 0 3 :: Datatypes.nil.

Definition est_i' x :=
  I.mul prec (I.join (I.fromZ 0) (MyBertrand.f_int prec x (-2) 3)) (I.div prec (I.pi prec) (I.fromZ 2)).

Definition est' :=
  let deg := 10%nat in
  let bounds := nil in
  let prog := prog' in
  let iF'' := fun xi =>
    nth 0 (IA.TaylorValuator.eval prec deg xi prog (IA.TaylorValuator.TM.var ::
      map (fun b => IA.TaylorValuator.TM.const (IA.interval_from_bp b)) bounds)
) IA.TaylorValuator.TM.dummy in
  let iF' := fun xi => IA.TaylorValuator.TM.get_tm (prec, deg) xi (iF'' xi) in
  let iF := fun xi => nth 0 (IA.BndValuator.eval prec prog (xi::map IA.interval_from_bp bounds)) I.nai in
  fun fa fb =>
    let xi := I.join fa fb in
    IT.taylor_integral_naive_intersection prec iF (iF' xi) xi fa fb.

Definition v3 :=
  II.integral_interval_relative_infty prec est' est_i' 30 (I.fromZ 1) eps.

(* Eval vm_compute in v3. *)

Require Import Interval_tactic.

Goal forall x:R, True.
intros x.
let v := Private.extract_algorithm ((atan x) * (powerRZ x (-2)) * powerRZ (ln x) 3)%R (List.cons x List.nil) in set (w := v).
Abort.

End NumericTests.
*)


Require Import syntax little denot Bool List String ZArith.

Module ax(S:little_syntax).
Module D := denot.denot(S).
Import D L S.

Fixpoint subst (e:aexpr)(s:string)(v:aexpr) {struct e} : aexpr :=
  match e with
    avar s' =>
      if string_dec s s' then v else e
  | anum n => anum n
  | aplus e1 e2 => aplus (subst e1 s v) (subst e2 s v)
  end.

Definition b_subst (b:bexpr) (s:string) (v:aexpr) : bexpr :=
  match b with blt e1 e2 => blt (subst e1 s v)(subst e2 s v) end.

Fixpoint l_subst (l:list aexpr)(s:string)(v:aexpr) {struct l} : list aexpr :=
  match l with
    nil => nil
  | a::tl => subst a s v::l_subst tl s v
  end.

Fixpoint a_subst (a:assert)(s:string)(v:aexpr) {struct a} :assert :=
  match a with
    a_b e => a_b (b_subst e s v)
  | a_not a => a_not (a_subst a s v)
  | pred p l => pred p (l_subst l s v)
  | a_conj a1 a2 => a_conj(a_subst a1 s v)(a_subst a2 s v)
  end.

Fixpoint pc (i:a_instr)(a:assert) {struct i} : assert :=
  match i with
    prec a' i => a'
  | a_skip => a
  | a_assign x e => a_subst a x e
  | a_sequence i1 i2 => pc i1 (pc i2 a)
  | a_while b a' i => a'
  end.

Fixpoint vcg (i:a_instr)(post : assert) {struct i} :
   list condition :=
match i with
  prec a i => c_imp a (pc i post)::vcg i post
| a_skip => nil
| a_assign _ _ => nil
| a_sequence i1 i2 =>
    vcg i2 post ++ vcg i1 (pc i2 post)
| a_while e a i =>
    c_imp (a_conj (a_not (a_b e)) a) post ::
    c_imp (a_conj (a_b e) a) (pc i a) :: vcg i a
  end.

Fixpoint af' (g:string->Z)(a:aexpr) {struct a} : Z :=
  match a with
    avar s => g s
  | anum n => n
  | aplus e1 e2 => af' g e1 + af' g e2
  end.

Fixpoint lf' (g:string->Z)(l:list aexpr){struct l} :
   list Z :=
   match l with
     nil => nil
   | e::tl => af' g e::lf' g tl
   end.

Definition p_env := list(string*(list Z->Prop)).

Fixpoint f_p (preds : p_env)
  (s:string) (args:list Z) {struct preds} : Prop :=
  match preds with
    (a,m)::tl =>
    if string_dec a s then m args else f_p tl s args
  | nil => True
  end.

Definition bf' (g:string->Z)(b:bexpr) : Prop :=
 match b with
   blt e1 e2 => af' g e1 < af' g e2
 end.

Fixpoint i_a
  (preds: p_env) (g:string->Z)(a:assert) {struct a}: Prop :=
  match a with
    a_b e => bf' g e
  | a_not a => ~ i_a preds g a
  | pred p l => f_p preds p (lf' g l)
  | a_conj a1 a2 =>
    i_a preds g a1 /\ i_a preds g a2
  end.

Definition i_c
  (m: p_env) (g:string->Z)(c:condition) :=
match c with
  c_imp a1 a2 => i_a m g a1 -> i_a m g a2
end.

Definition valid (preds: p_env) (c:condition) :=
  forall g, i_c preds g c.

Inductive ax_sem (preds : p_env) :
      assert -> instr -> assert -> Prop :=
  ax1 : forall P, ax_sem preds P skip P
| ax2 : forall P x e, ax_sem preds (a_subst P x e) (assign x e) P
| ax3 : forall P Q R i1 i2,
          ax_sem preds P i1 Q -> ax_sem preds Q i2 R ->
          ax_sem preds P (sequence i1 i2) R
| ax4 : forall P b i,
          ax_sem preds (a_conj (a_b b) P) i P ->
          ax_sem preds P (while b i) (a_conj (a_not (a_b b)) P)
| ax5 : forall P P' Q' Q i,
        valid preds (c_imp P P') -> ax_sem preds P' i Q' ->
        valid preds (c_imp Q' Q) ->
        ax_sem preds P i Q.

Inductive nax (preds: p_env) :
  assert -> instr -> assert -> Prop :=
  nax1 : forall P Q, valid preds (c_imp P Q) ->
      nax preds P skip Q
| nax2 : forall P P' Q x e,
    valid preds (c_imp P (a_subst P' x e)) ->
    valid preds (c_imp P' Q) ->
    nax preds P (assign x e) Q
| nax3 : forall P P' Q' R' R i1 i2,
    valid preds (c_imp P P') ->
    valid preds (c_imp R' R) ->
    nax preds P' i1 Q' -> nax preds Q' i2 R' ->
    nax preds P (sequence i1 i2) R
| nax4 : forall P P' Q b i,
    valid preds (c_imp P P') ->
    valid preds (c_imp (a_conj (a_not (a_b b)) P') Q) ->
    nax preds (a_conj (a_b b) P') i P' ->
    nax preds P (while b i) Q.

Fixpoint i_lc (preds: list (string*(list Z->Prop)))
  (g:string->Z)(l:list condition) {struct l}: Prop :=
  match l with
    nil => True
  | c::tl => i_c preds g c /\ i_lc preds g tl
  end.

Fixpoint e_to_f(r:list(string*Z))(g:string->Z)(var:string):Z :=
  match r with
    nil => g var
  | (s,v)::tl =>
    if string_dec s var then v else e_to_f tl g var
  end.

Declare Scope a_scope.
Notation "r @ g" := (e_to_f r g) (at level 30, right associativity): a_scope.
Delimit Scope a_scope with A.
Open Scope a_scope.

(* Correctness proofs: axiomatic semantics is correct. *)

Lemma af'_correct : forall r1 e v g,
  aeval r1 e v -> af' (r1@g) e = v.
intros r1 e v g H; induction H; simpl; auto.
case (string_dec x x); auto.
intros Habs; elim Habs; auto.
simpl in IHaeval; case (string_dec y x); auto.
intros Hxy ; assert (Habs:x<>y) by auto; elim Habs; auto.
rewrite IHaeval1; rewrite IHaeval2; auto.
Qed.

Lemma update_af' : forall x v r1 r2 g,
  s_update r1 x v r2 -> af' (r2@g) (avar x) = v.
intros x v r1 r2 g H; induction H.
simpl; case (string_dec x x); auto.
intros Habs; case Habs; auto.
simpl; case (string_dec y x).
intros Hxy.
assert (Hnxy : x<> y) by assumption; case Hnxy; auto.
intros _; simpl in IHs_update; apply IHs_update.
Qed.

Lemma update_af'_diff : forall x v r1 r2 g s,
  s_update r1 x v r2 -> x <> s ->
  af' (r2@g)(avar s) = af' (r1@g) (avar s).
intros x v r1 r2 g s H; induction H; intros Hnxs.
simpl; case (string_dec x s).
intros Hxs; elim Hnxs; auto.
auto.
simpl; case (string_dec y s); auto.
Qed.

Lemma update_af'_var_subst : forall r1 x v r2 e g s,
  s_update r1 x v r2 -> aeval r1 e v ->
  af' (r2@g) (avar s) = af' (r1@g) (subst (avar s) x e).
intros r1 x v r2 e g s H He; simpl subst.
case (string_dec x s).
intros; subst s; rewrite (af'_correct r1 e v); auto.
apply update_af' with (1:= H).
intros Hnxs; apply update_af'_diff with (1:= H); auto.
Qed.

Lemma update_af'_subst : forall r1 x v r2 e' g e,
  s_update r1 x v r2 -> aeval r1 e' v ->
  af' (r2@g) e = af' (r1@g) (subst e x e').
intros r1 x v r2 e' g e Hup He'; induction e.
apply update_af'_var_subst with (1:= Hup); auto.
trivial.
simpl; rewrite IHe1; rewrite IHe2; auto.
Qed.

Lemma update_lf'_subst :
  forall r1 x v r2 e' g l, s_update r1 x v r2 -> aeval r1 e' v ->
  lf' (r2@g) l = lf' (r1@g) (l_subst l x e').
intros r1 x v r2 e' g l Hu He'; induction l.
simpl; auto.
simpl; rewrite update_af'_subst with (1:= Hu)(2:= He').
rewrite IHl; auto.
Qed.

Lemma update_f_p_subst :
  forall r1 x v r2 e' m g s l, s_update r1 x v r2 -> aeval r1 e' v ->
  (f_p m s (lf' (r1@g) (l_subst l x e')) <-> f_p m s (lf' (r2@g) l)).
intros r1 x v r2 e' m g s l Hu He'; induction m.
simpl; intros; split; auto.
destruct a as [p1 P]; simpl; case (string_dec p1 s).
rewrite update_lf'_subst with (1:= Hu) (2:= He').
intros; split; auto.
intros; apply IHm.
Qed.

Lemma a_subst_correct :
  forall a r1 e v m g r2 x,
    aeval r1 e v ->
    s_update r1 x v r2 ->
    (i_a m (r1@g) (a_subst a x e)<->
    i_a m (r2@g) a).
induction a; simpl; intros r1 e v m g r2 x H Hu.
destruct b as [e1 e2]; unfold bf', b_subst.
repeat rewrite update_af'_subst with (1:= Hu) (2:=H); split; auto.
split; intros H1 Habs; case H1;
elim (IHa r1 e v m g r2 x H Hu); auto.
split; intros [H1 H2]; (split; [elim (IHa1 r1 e v m g r2 x H Hu)|
                               elim (IHa2 r1 e v m g r2 x H Hu)]); auto.
apply update_f_p_subst with (1:=Hu)(2:=H).
Qed.

Lemma beval_true_interpret :
  forall r b g, beval r b true -> bf' (r@g) b.
intros r b g H; inversion H; simpl.
rewrite (af'_correct r e1 v1);
 try rewrite (af'_correct r e2 v2); auto.
Qed.

Lemma beval_false_interpret :
  forall r b g, beval r b false -> ~ bf' (r@g) b.
intros r b g H; inversion H; simpl.
rewrite (af'_correct r e1 v1);
 try rewrite (af'_correct r e2 v2); auto with zarith.
Qed.

Global Hint Resolve beval_true_interpret beval_false_interpret : core.

Lemma ax_sem_nax :
  forall m P i Q, ax_sem m P i Q -> nax m P i Q.
induction 1.
apply nax1; red; simpl; auto.
apply nax2 with P; red; simpl; auto.
apply nax3 with P Q R; try red; simpl; auto.
apply nax4 with P; try red; simpl; auto.
inversion_clear IHax_sem.
apply nax1; unfold valid in *; simpl in *; auto.
apply nax2 with P'0; unfold valid in *; simpl in *; auto.
apply nax3 with P'0 Q'0 R'; unfold valid in *; simpl in *; auto.
apply nax4 with P'0; unfold valid in *; simpl in *; auto.
Qed.

Global Hint Resolve ax1 ax2 ax3 ax4 : core.

Lemma nax_ax_sem :
  forall m P i Q, nax m P i Q -> ax_sem m P i Q.
induction 1.
apply ax5 with Q Q; unfold valid in *; simpl in *; eauto.
apply ax5 with (a_subst P' x e) P'; simpl in *; eauto.
apply ax5 with P' R'; simpl in *; eauto.
apply ax5 with P' (a_conj (a_not (a_b b)) P'); simpl in *; eauto.
Qed.

Theorem nax_sound :
  forall m r i r' g, exec r i r' ->
  forall P Q, nax m P i Q ->
  i_a m (r@g) P -> i_a m (r'@g) Q.
Proof.
intros m r i r' g H; induction H; intros P Q Ha; inversion Ha;
unfold valid in *; simpl in *; intros; subst; clear Ha; eauto.
match goal with
 H: aeval _ _ _, G: s_update _ _ _ _ |- _ =>
 destruct (a_subst_correct P' _ _ _ m g _ _ H G) as [Hs1 _]
end; auto.
match goal with
  H:nax m (a_conj _ ?P') ?i1 ?Q',G:exec _ (while ?b _) ?r'',
  K: _ |- _ => assert (Ha := H); apply K;
  change (i_a m (r''@g) (a_conj (a_not (a_b b)) P'));
  apply IHexec2 with (P:=P')
end.
apply nax4 with (3:= Ha); unfold valid; simpl; auto.
apply IHexec1 with (1:= Ha); simpl; auto.
Qed.

Theorem ax_sem_sound :
  forall m r i r' g P Q, exec r i r' -> ax_sem m P i Q ->
  i_a m (r@g) P -> i_a m (r'@g) Q.
intros; eapply nax_sound; eauto.
apply ax_sem_nax; auto.
Qed.

(* Correctness proof: the vcg *)

Definition valid_l (ps: p_env)(l:list condition) : Prop :=
  forall g, i_lc ps g l.

Theorem i_lc_app_l :
  forall m g l1 l2, i_lc m g (l1++l2) ->
    i_lc m g l1.
intros m g l1 l2; induction l1; simpl; auto.
intros [H1 H2]; auto.
Qed.

Theorem i_lc_app_r :
 forall m g l1 l2, i_lc m g (l1++l2) ->
  i_lc m g l2.
intros m g l1 l2; induction l1;simpl; auto.
intros [H1 H2]; auto.
Qed.

Theorem vcg_ax :
  forall m i A, valid_l m (vcg i A) ->
  ax_sem m (pc i A) (un_annot i) A.
unfold valid_l; intros m i; induction i; intros A Hc; simpl.
simpl in *; apply ax5 with (pc i A) A.
intros g; elim (Hc g); auto.
apply IHi; intros g; elim (Hc g); auto.
red; simpl; auto.
apply ax1.
apply ax2.
simpl in *; apply ax3 with (pc i2 A).
apply IHi1; intros g; apply i_lc_app_r with (1:= Hc g).
apply IHi2; intros g; apply i_lc_app_l with (1:= Hc g).
simpl in *; apply ax5 with a (a_conj (a_not (a_b b)) a).
red; simpl; auto.
apply ax4.
apply ax5 with (pc i a) a.
intros g; simpl; generalize (Hc g); intuition.
apply IHi; intros g; simpl; generalize (Hc g); intuition.
red; simpl; auto.
intros g; simpl; generalize (Hc g); intuition.
Qed.

Theorem vcg_sound :
  forall ps i A g r1 r2, valid_l ps (vcg i A) -> exec r1 (un_annot i) r2 ->
  i_a ps (r1@g) (pc i A) -> i_a ps (r2@g) A.
Proof.
intros; eapply ax_sem_sound; eauto.
apply vcg_ax; auto.
Qed.

End ax.


(* -*- coding: utf-8; mode:coq -*-
 * Auto-generated - Do not edit or overwrite!
 *)

Require Import Arith. (* ouvre droit, notamment, à 'auto with arith' *)

Section exo2.

  Parameter a b : nat.

  (* Programme annoté :

  { (x = a and y = b) }
    Auto0:t <- x
    Auto1:x <- y
    Auto2:y <- t
  { (x = b and y = a) }

  *)

  (* Valeurs des Weakest Least Preconditions (WLP) *)
  Definition Post (t x y : nat) := (x = b /\ y = a).
  Definition Pre (t x y : nat) := (x = a /\ y = b).
  Definition Auto2 (t x y : nat) := (x = b /\ t = a).
  Definition Auto1 (t x y : nat) := (y = b /\ t = a).
  Definition Auto0 (t x y : nat) := (y = b /\ x = a).

  (* Obligations de preuve engendrées *)
  Lemma obligation_Pre : forall t x y : nat,
    ((x = a /\ y = b) -> (y = b /\ x = a)).
  Proof.
    intros.
    destruct H.
    split.
    assumption.
    assumption.
  Qed.

End exo2.


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

(**********************************************************************
    LucasLehamer.v

    Build the sequence for the primality test of Mersenne numbers

    Definition: LucasLehmer
  **********************************************************************)
Require Import ZArith.
Require Import ZCAux.
Require Import Tactic.
Require Import Wf_nat.
Require Import NatAux.
Require Import UList.
Require Import ListAux.
Require Import FGroup.
Require Import EGroup.
Require Import PGroup.
Require Import IGroup.

Open Scope Z_scope.

(**************************************
  The seeds of the serie
 **************************************)

Definition w := (2, 1).

Definition v := (2, -1).

Theorem w_plus_v: pplus w v = (4, 0).
simpl; auto.
Qed.

Theorem w_mult_v : pmult w v = (1, 0).
simpl; auto.
Qed.

(**************************************
  Definition of the power function for pairs p^n
 **************************************)

Definition ppow p n := match n with  Zpos q => iter_pos _ (pmult p) (1, 0) q | _ => (1, 0) end.

(**************************************
  Some properties of ppow
 **************************************)

Theorem ppow_0: forall n, ppow n 0 = (1, 0).
simpl; auto.
Qed.

Theorem ppow_1: forall n, ppow (1, 0) n = (1, 0).
intros n; case n; simpl; auto.
intros p; apply iter_pos_invariant with (Inv := fun x => x = (1, 0)); auto.
intros x H; rewrite H; auto.
Qed.

Theorem ppow_op: forall a b p, iter_pos _ (pmult a) b p = pmult (iter_pos _ (pmult a) (1, 0) p) b.
intros a b p; generalize b; elim p; simpl; auto; clear  b p.
intros p Rec b.
rewrite (Rec b).
try rewrite (fun x y => Rec (pmult x y)); try rewrite (fun x y => Rec (iter_pos _ x y p)); auto.
repeat rewrite pmult_assoc; auto.
intros p Rec b.
rewrite (Rec b); try rewrite (fun x y => Rec (pmult x y)); try rewrite (fun x y => Rec (iter_pos _ x y p)); auto.
repeat rewrite pmult_assoc; auto.
intros b; rewrite pmult_1_r; auto.
Qed.

Theorem ppow_add: forall n m p, 0 <= m -> 0 <= p ->  ppow n (m + p) = pmult (ppow n m) (ppow n p).
intros n m; case m; clear m.
intros p _ _; rewrite ppow_0; rewrite pmult_1_l; auto.
2: intros p m H; contradict H; auto with zarith.
intros p1 m _; case m.
intros _; rewrite Zplus_0_r; simpl; apply sym_equal; apply pmult_1_r.
2: intros p2 H; contradict H; auto with zarith.
intros p2 _; simpl.
rewrite iter_pos_plus.
rewrite ppow_op; auto.
Qed.

Theorem ppow_ppow: forall n m p, 0 <= n -> 0 <= m -> ppow p (n * m ) = ppow (ppow p n) m.
intros n m; case n.
intros p _ Hm; rewrite Zmult_0_l.
rewrite ppow_0; apply sym_equal; apply ppow_1.
2: intros p p1 H; contradict H; auto with zarith.
intros p1 p _; case m; simpl; auto.
intros p2 _;  pattern p2; apply Pind; simpl; auto.
rewrite Pmult_1_r; rewrite pmult_1_r; auto.
intros p3 Rec; rewrite Pplus_one_succ_r; rewrite Pmult_plus_distr_l.
rewrite Pmult_1_r.
simpl; repeat rewrite iter_pos_plus; simpl.
rewrite pmult_1_r.
rewrite ppow_op; try rewrite Rec; auto.
apply sym_equal; apply ppow_op; auto.
Qed.

Theorem ppow_mult: forall n m p, 0 <= n -> ppow (pmult m p) n = pmult (ppow m n) (ppow p n).
intros n m p; case n; simpl; auto.
intros p1 _; pattern p1; apply Pind; simpl; auto.
repeat rewrite pmult_1_r; auto.
intros p3 Rec; rewrite Pplus_one_succ_r.
repeat rewrite iter_pos_plus; simpl.
repeat rewrite (fun x y z => ppow_op x (pmult y z)) ; auto.
rewrite Rec.
repeat rewrite pmult_1_r; auto.
repeat rewrite <- pmult_assoc; try eq_tac; auto.
rewrite (fun x y => pmult_comm (iter_pos _ x y p3) p); auto.
rewrite (pmult_assoc m); try apply pmult_comm; auto.
Qed.

(**************************************
  We can now define our series of pairs s
 **************************************)

Definition s n := pplus (ppow w (2 ^ n)) (ppow v (2 ^ n)).

(**************************************
  Some properties of s
 **************************************)

Theorem s0 : s 0 = (4, 0).
simpl; auto.
Qed.

Theorem sn_aux: forall n, 0 <= n -> s (n+1) = (pplus (pmult (s n) (s n)) (-2, 0)).
intros n Hn.
assert (Hu: 0 <= 2 ^n); auto with zarith.
set (y := (fst (s n) * fst (s n) - 2, 0)).
unfold s; simpl; rewrite Zpower_exp; auto with zarith.
rewrite Zpower_1_r; rewrite ppow_ppow; auto with zarith.
repeat rewrite pplus_pmult_dist_r || rewrite pplus_pmult_dist_l.
repeat rewrite <- pplus_assoc.
eq_tac; auto.
pattern 2 at 2; replace 2 with (1 + 1); auto with zarith.
rewrite ppow_add; auto with zarith; simpl.
rewrite pmult_1_r; auto.
rewrite Zmult_comm; rewrite ppow_ppow; simpl; auto with zarith.
repeat rewrite <- ppow_mult; auto with zarith.
rewrite (pmult_comm v w); rewrite w_mult_v.
rewrite ppow_1.
repeat rewrite tpower_1.
rewrite pplus_comm; repeat rewrite <- pplus_assoc;
rewrite pplus_comm; repeat rewrite <- pplus_assoc.
simpl; case (ppow (7, -4) (2 ^n)); simpl; intros z1 z2; eq_tac; auto with zarith.
Qed.

Theorem sn_snd: forall n, snd (s n) = 0.
intros n; case n; simpl; auto.
intros p; pattern p; apply Pind; auto.
intros p1 H; rewrite Zpos_succ_morphism; unfold Zsucc.
rewrite sn_aux; auto with zarith.
generalize H; case (s (Zpos p1)); simpl.
intros x y H1; rewrite H1; auto with zarith.
Qed.

Theorem sn: forall n, 0 <= n -> s (n+1) = (fst (s n) * fst  (s n) -2, 0).
intros n Hn; rewrite sn_aux; generalize (sn_snd n); case (s n); auto.
intros x y H; simpl in H; rewrite H; simpl.
eq_tac; ring.
Qed.

Theorem sn_w: forall n, 0 <= n ->  ppow w (2 ^ (n + 1)) = pplus (pmult (s n) (ppow w (2 ^ n))) (- 1, 0).
intros n H; unfold s; simpl; rewrite Zpower_exp; auto with zarith.
assert (Hu: 0 <= 2 ^n); auto with zarith.
rewrite Zpower_1_r; rewrite ppow_ppow; auto with zarith.
repeat rewrite pplus_pmult_dist_r || rewrite pplus_pmult_dist_l.
pattern 2 at 2; replace 2 with (1 + 1); auto with zarith.
rewrite ppow_add; auto with zarith; simpl.
rewrite pmult_1_r; auto.
repeat rewrite <- ppow_mult; auto with zarith.
rewrite (pmult_comm v w); rewrite w_mult_v.
rewrite ppow_1; simpl.
simpl; case (ppow (7, 4) (2 ^n)); simpl; intros z1 z2; eq_tac; auto with zarith.
Qed.

Theorem sn_w_next: forall n, 0 <= n ->  ppow w (2 ^ (n + 1)) = pplus (pmult (s n) (ppow w (2 ^ n))) (- 1, 0).
intros n H; unfold s; simpl; rewrite Zpower_exp; auto with zarith.
assert (Hu: 0 <= 2 ^n); auto with zarith.
rewrite Zpower_1_r; rewrite ppow_ppow; auto with zarith.
repeat rewrite pplus_pmult_dist_r || rewrite pplus_pmult_dist_l.
pattern 2 at 2; replace 2 with (1 + 1); auto with zarith.
rewrite ppow_add; auto with zarith; simpl.
rewrite pmult_1_r; auto.
repeat rewrite <- ppow_mult; auto with zarith.
rewrite (pmult_comm v w); rewrite w_mult_v.
rewrite ppow_1; simpl.
simpl; case (ppow (7, 4) (2 ^n)); simpl; intros z1 z2; eq_tac; auto with zarith.
Qed.

Section Lucas.

Variable p: Z.

(**************************************
  Definition of the mersenne number
 **************************************)

Definition Mp := 2^p -1.

Theorem mersenne_pos:  1 < p -> 1 < Mp.
intros H; unfold Mp; assert (2 < 2 ^p); auto with zarith.
apply Zlt_le_trans with (2^2); auto with zarith.
refine (refl_equal _).
apply Zpower_le_monotone; auto with zarith.
Qed.

Hypothesis p_pos2: 2 < p.

(**************************************
  We suppose that the mersenne number divides s
 **************************************)

Hypothesis Mp_divide_sn: (Mp  | fst (s (p - 2))).

Variable q: Z.

(**************************************
  We take a divisor of Mp and shows that Mp <= q^2, hence Mp is prime
 **************************************)

Hypothesis q_divide_Mp: (q | Mp).

Hypothesis q_pos2: 2 < q.

Theorem q_pos: 1 < q.
apply Zlt_trans with (2 := q_pos2); auto with zarith.
Qed.

(**************************************
  The definition of the groups of inversible pairs
 **************************************)

Definition pgroup := PGroup q q_pos.

Theorem w_in_pgroup: (In w pgroup.(FGroup.s)).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
simpl; apply isupport_is_in; auto.
assert (zpmult q w (2, q - 1) = (1, 0)).
unfold zpmult, w, pmult, base; repeat (rewrite Zmult_1_r || rewrite Zmult_1_l).
eq_tac.
apply trans_equal with ((3 * q + 1) mod q).
eq_tac; auto with zarith.
rewrite Zplus_mod; auto.
rewrite Zmult_mod; auto.
rewrite Z_mod_same; auto with zarith.
rewrite Zmult_0_r; repeat rewrite Zmod_small; auto with zarith.
apply trans_equal with (2 * q mod q).
eq_tac; auto with zarith.
apply Zdivide_mod; auto with zarith; exists 2; auto with zarith.
apply is_inv_true with (2, q - 1); auto.
apply mL_in; auto with zarith.
intros; apply zpmult_1_l; auto with zarith.
intros; apply zpmult_1_r; auto with zarith.
rewrite zpmult_comm; auto.
apply mL_in; auto with zarith.
unfold w; apply mL_in; auto with zarith.
Qed.

Theorem e_order_divide_order: (e_order P_dec w pgroup | g_order pgroup).
apply e_order_divide_g_order.
apply w_in_pgroup.
Qed.

Theorem order_lt:  g_order pgroup < q * q.
unfold g_order, pgroup, PGroup; simpl.
rewrite <- (Zabs_eq (q * q)); auto with zarith.
rewrite <- (inj_Zabs_nat (q * q)); auto with zarith.
rewrite <- mL_length; auto with zarith.
apply inj_lt; apply isupport_length_strict with (0, 0).
apply mL_ulist.
apply mL_in; auto with zarith.
intros a _; left; rewrite zpmult_0_l; auto with zarith.
intros; discriminate.
Qed.

(**************************************
  The power function zpow: a^n
 **************************************)

Definition zpow a := gpow a pgroup.

(**************************************
  Some properties of zpow
 **************************************)

Theorem zpow_def:
  forall a b, In a pgroup.(FGroup.s) -> 0 <= b ->
     zpow a b = ((fst (ppow a b)) mod q, (snd (ppow a b)) mod q).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
intros a b Ha Hb; generalize Hb; pattern b; apply natlike_ind; auto.
intros _; repeat rewrite Zmod_small; auto with zarith.
rewrite ppow_0; simpl; auto with zarith.
unfold zpow; intros n1 H Rec _; unfold Zsucc.
rewrite gpow_add; auto with zarith.
rewrite ppow_add; simpl; try rewrite pmult_1_r; auto with zarith.
rewrite Rec; unfold zpmult; auto with zarith.
case (ppow a n1); case a; unfold pmult, fst, snd.
intros x y z t.
repeat (rewrite Zmult_1_r || rewrite Zmult_0_r || rewrite Zplus_0_r || rewrite Zplus_0_l); eq_tac.
repeat rewrite (fun u v => Zplus_mod (u * v)); auto.
eq_tac; try eq_tac; auto.
repeat rewrite (Zmult_mod z); auto with zarith.
repeat rewrite (fun u v => Zmult_mod (u * v)); auto.
eq_tac; try eq_tac; auto with zarith.
repeat rewrite (Zmult_mod base); auto with zarith.
eq_tac; try eq_tac; auto with zarith.
apply Zmod_mod; auto.
apply Zmod_mod; auto.
repeat rewrite (fun u v => Zplus_mod (u * v)); auto.
eq_tac; try eq_tac; auto.
repeat rewrite (Zmult_mod z); auto with zarith.
repeat rewrite (Zmult_mod t); auto with zarith.
Qed.

Theorem zpow_w_n_minus_1: zpow w (2 ^ (p - 1)) = (-1 mod q, 0).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
rewrite zpow_def.
replace (p - 1) with ((p - 2) + 1); auto with zarith.
rewrite sn_w; auto with zarith.
generalize Mp_divide_sn (sn_snd (p - 2)); case (s (p -2)); case (ppow w (2 ^ (p -2))).
unfold fst, snd; intros x y z t H1 H2; unfold pmult, pplus; subst.
repeat (rewrite Zmult_0_l || rewrite Zmult_0_r || rewrite Zplus_0_l || rewrite Zplus_0_r).
assert (H2: z mod q = 0).
case H1; intros q1 Hq1; rewrite Hq1.
case q_divide_Mp; intros q2 Hq2; rewrite Hq2.
rewrite Zmult_mod; auto.
rewrite (Zmult_mod q2); auto.
rewrite Z_mod_same; auto with zarith.
repeat (rewrite Zmult_0_r; rewrite (Zmod_small 0)); auto with zarith.
assert (H3:  forall x, (z * x) mod q = 0).
intros y1; rewrite Zmult_mod; try rewrite H2; auto.
assert (H4:  forall x y,  (z * x +  y) mod q = y mod q).
intros x1 y1; rewrite Zplus_mod; try rewrite H3; auto.
rewrite Zplus_0_l; apply Zmod_mod; auto.
eq_tac; auto.
apply w_in_pgroup.
apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith.
Qed.

Theorem zpow_w_n: zpow w (2 ^ p) = (1, 0).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
replace p with ((p - 1) + 1); auto with zarith.
rewrite Zpower_exp; try rewrite Zpower_exp_1; auto with zarith.
unfold zpow; rewrite gpow_gpow; auto with zarith.
generalize zpow_w_n_minus_1; unfold zpow; intros H1; rewrite H1; clear H1.
simpl; unfold zpmult, pmult.
repeat (rewrite Zmult_0_l || rewrite Zmult_0_r || rewrite Zplus_0_l ||
              rewrite Zplus_0_r || rewrite Zmult_1_r).
eq_tac; auto.
pattern (-1 mod q) at 1; rewrite <- (Zmod_mod (-1) q); auto with zarith.
repeat rewrite <- Zmult_mod; auto.
rewrite Zmod_small; auto with zarith.
apply w_in_pgroup.
Qed.

(**************************************
  As e = (1, 0), the previous equation implies that the order of the group divide 2^p
 **************************************)

Theorem e_order_divide_pow: (e_order P_dec w pgroup | 2 ^ p).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
apply e_order_divide_gpow.
apply w_in_pgroup.
apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith.
exact zpow_w_n.
Qed.

(**************************************
  So it is less than equal
 **************************************)

Theorem e_order_le_pow : e_order P_dec w pgroup <= 2 ^ p.
apply Zdivide_le.
apply Zlt_le_weak; apply e_order_pos.
apply Zpower_gt_0; auto with zarith.
apply e_order_divide_pow.
Qed.

(**************************************
  So order(w) must be 2^q
 **************************************)

Theorem e_order_eq_pow:  exists q, (e_order P_dec w pgroup)  = 2 ^ q.
case (Zdivide_power_2 (e_order P_dec w pgroup) 2 p); auto with zarith.
apply Zlt_le_weak; apply e_order_pos.
apply prime_2.
apply e_order_divide_pow; auto.
intros x H; exists x; auto with zarith.
Qed.

(**************************************
  Buth this q can only be p otherwise it would contradict w^2^(p -1) = (-1, 0)
 **************************************)

Theorem e_order_eq_p: e_order P_dec w pgroup = 2 ^ p.
case (Zdivide_power_2 (e_order P_dec w pgroup) 2 p); auto with zarith.
apply Zlt_le_weak; apply e_order_pos.
apply prime_2.
apply e_order_divide_pow; auto.
intros p1 Hp1.
case (Zle_lt_or_eq p1 p); try (intro H1; subst; auto; fail).
case (Zle_or_lt p1 p); auto; intros H1.
absurd (2 ^ p1 <= 2 ^ p); auto with zarith.
apply Zlt_not_le; apply Zpower_lt_monotone; auto with zarith.
apply Zdivide_le.
apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith.
apply Zpower_gt_0; auto with zarith.
rewrite <- Hp1; apply e_order_divide_pow.
intros H1.
assert (Hu: 0 <= p1).
generalize Hp1; case p1; simpl; auto with zarith.
intros p2 Hu; absurd (0 < e_order  P_dec w pgroup).
rewrite Hu; auto with zarith.
apply e_order_pos.
absurd (zpow w (2 ^ (p - 1)) = (1, 0)).
rewrite zpow_w_n_minus_1.
intros H2; injection H2; clear H2; intros H2.
assert (H0: 0 < q); auto with zarith.
absurd (0 mod q = 0).
pattern 0 at 1; replace 0 with (-1 + 1); auto with zarith.
rewrite Zplus_mod; auto with zarith.
rewrite H2; rewrite (Zmod_small 1); auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite Zmod_small; auto with zarith.
unfold zpow; apply (gpow_pow _ _ w pgroup) with p1; auto with zarith.
apply w_in_pgroup.
rewrite <- Hp1.
apply (gpow_e_order_is_e _ P_dec _ w pgroup).
apply w_in_pgroup.
Qed.

(**************************************
  We have then the expected conclusion
 **************************************)

Theorem q_more_than_square:  Mp <  q * q.
unfold Mp.
assert (2 ^ p <= q * q); auto with zarith.
rewrite <- e_order_eq_p.
apply Zle_trans with (g_order pgroup).
apply Zdivide_le; auto with zarith.
apply Zlt_le_weak; apply e_order_pos; auto with zarith.
2: apply e_order_divide_order.
2: apply Zlt_le_weak; apply order_lt.
apply Zlt_le_trans with 2; auto with zarith.
replace 2 with (Z_of_nat (length ((1, 0)::w::nil))); auto.
unfold g_order; apply inj_le.
apply ulist_incl_length.
apply ulist_cons; simpl; auto.
unfold w; intros [H2 | H2];  try (case H2; fail); discriminate.
intro a; simpl; intros [H1 | [H1 | H1]]; subst.
assert (In (1, 0) (mL q)).
apply mL_in; auto with zarith.
apply isupport_is_in; auto.
apply is_inv_true with (1, 0); simpl; auto.
intros; apply zpmult_1_l; auto with zarith.
intros; apply zpmult_1_r; auto with zarith.
rewrite zpmult_1_r; auto with zarith.
rewrite zpmult_1_r; auto with zarith.
exact w_in_pgroup.
case H1.
Qed.

End Lucas.

(**************************************
  We build the sequence in Z
 **************************************)

Definition SS p :=
  let n := Mp p in
  match p - 2 with
    Zpos p1 => iter_pos _ (fun x => Zmodd (Zsquare x - 2) n) (Zmodd 4 n) p1
  | _ => (Zmodd 4 n)
  end.

Theorem SS_aux_correct:
  forall p z1 z2 n, 0 <= n -> 0 < z1 -> z2 = fst (s n) mod z1 ->
        iter_pos _ (fun x => Zmodd (Zsquare x - 2) z1) z2 p = fst (s (n + Zpos p)) mod z1.
intros p; pattern p; apply Pind.
simpl.
intros z1 z2 n Hn H H1; rewrite sn; auto; rewrite H1;  rewrite Zmodd_correct; rewrite Zsquare_correct; simpl.
unfold Zminus; rewrite Zplus_mod; auto.
rewrite (Zplus_mod (fst (s n) * fst (s n))); auto with zarith.
eq_tac; auto.
eq_tac; auto.
apply sym_equal; apply Zmult_mod; auto.
intros n Rec z1 z2 n1 Hn1 H1 H2.
rewrite Pplus_one_succ_l; rewrite iter_pos_plus.
rewrite Rec with (n0 := n1); auto.
replace (n1 + Zpos (1 + n)) with ((n1 + Zpos n) + 1); auto with zarith.
rewrite sn; simpl; try rewrite Zmodd_correct; try rewrite Zsquare_correct; simpl; auto with zarith.
unfold Zminus; rewrite Zplus_mod; auto.
unfold Zmodd.
rewrite (Zplus_mod (fst (s (n1 + Zpos n)) * fst (s (n1 + Zpos n)))); auto with zarith.
eq_tac; auto.
eq_tac; auto.
apply sym_equal; apply Zmult_mod; auto.
rewrite Zpos_plus_distr; auto with zarith.
Qed.

Theorem SS_prop: forall n, 1 < n -> SS n = fst(s (n -2)) mod (Mp n).
intros n Hn; unfold SS.
cut (0 <= n - 2); auto with zarith.
case (n - 2).
intros _; rewrite Zmodd_correct; rewrite s0; auto.
intros p1 H2; rewrite SS_aux_correct with (n := 0); auto with zarith.
apply Zle_lt_trans with 1; try apply mersenne_pos; auto with zarith.
rewrite Zmodd_correct; rewrite s0; auto.
intros p1 H2; case H2; auto.
Qed.

Theorem SS_prop_cor: forall p, 1 < p -> SS p = 0 -> (Mp p | fst(s (p -2))).
intros p H H1.
apply Zmod_divide.
generalize (mersenne_pos _ H); auto with zarith.
apply trans_equal with (2:= H1); apply sym_equal; apply SS_prop; auto.
Qed.

Theorem LucasLehmer:  forall p, 2 < p -> SS p = 0 -> prime (Mp p).
intros p H H1; case (prime_dec (Mp p)); auto; intros H2.
case Zdivide_div_prime_le_square with (2 := H2).
apply mersenne_pos; apply Zlt_trans with 2; auto with zarith.
intros q (H3, (H4, H5)).
contradict H5; apply Zlt_not_le.
apply q_more_than_square; auto.
apply SS_prop_cor; auto.
apply Zlt_trans with 2; auto with zarith.
case (Zle_lt_or_eq 2 q); auto.
apply prime_ge_2; auto.
intros H5; subst.
absurd (2 <= 1); auto with arith.
apply Zdivide_le; auto with zarith.
case H4; intros x Hx.
exists (2 ^ (p -1) - x).
rewrite Zmult_minus_distr_r; rewrite <- Hx; unfold Mp.
pattern 2 at 2; rewrite <- Zpower_1_r; rewrite <- Zpower_exp; auto with zarith.
replace (p - 1 + 1) with p; auto with zarith.
Qed.

(**************************************
  The test
 **************************************)

Definition lucas_test  n :=
   if Z_lt_dec 2 n then if Z_eq_dec (SS n) 0 then true else false else false.

Theorem LucasTest: forall n, lucas_test n = true -> prime (Mp n).
intros n; unfold lucas_test; case (Z_lt_dec 2 n); intros H1; try (intros; discriminate).
case (Z_eq_dec (SS n) 0); intros H2; try (intros; discriminate).
intros _; apply LucasLehmer; auto.
Qed.

Theorem prime7: prime 7.
exact (LucasTest 3 (refl_equal _)).
Qed.

Theorem prime31: prime 31.
exact (LucasTest 5 (refl_equal _)).
Qed.

Theorem prime127: prime 127.
exact (LucasTest 7 (refl_equal _)).
Qed.

Theorem prime8191: prime 8191.
exact (LucasTest 13 (refl_equal _)).
Qed.

Theorem prime131071: prime 131071.
exact (LucasTest 17 (refl_equal _)).
Qed.

Theorem prime524287: prime 524287.
exact (LucasTest 19 (refl_equal _)).
Qed.


Variable g : nat * nat -> bool.
Variable n m : nat.
Check g(n,m).

Notation " f ( x , .. , y )" := (.. (f x) .. y)
(at level 10) : type_scope.

Variable dist : nat -> nat -> nat.
Variable foo : nat -> bool -> nat * nat.

Check dist(n,m).
Check (n,m).

Check foo (dist(n,m), false).
Check foo (dist(n,m)) false.
Check foo (dist n m) false.

Check dist(n).
Check dist(n)(m).

Goal dist(n,m) = dist n m.
Proof. reflexivity. Qed.

Require Import Reals.
Print is_lub.


Require Import Iron.Language.SystemF.TyJudge.
Require Import Iron.Language.SystemF.SubstTypeType.

(* Substitution of types in expressions preserves typing.
   Note that substituting a type into an expression can instantiate
   type variables, so we also need to perform the substitution
   to the result type.
 *)
Theorem subst_type_exp_ix
 :  forall ix ke te x1 t1 t2 k2
 ,  get ix ke = Some k2
 -> TYPE ke  te x1 t1
 -> KIND (delete ix ke)  t2 k2
 -> TYPE (delete ix ke)     (substTE ix t2 te)
         (substTX ix t2 x1) (substTT ix t2 t1).
Proof.
 intros. gen ix ke te t1 t2 k2.
 induction x1; intros; simpl; inverts H0; eauto.

 Case "XVar".
  apply TYVar.
  unfold substTE. eapply get_map. auto.
  eapply subst_type_type_ix; eauto.

 Case "XLAM".
  simpl. apply TYLAM.
  rewrite delete_rewind.
  rewrite (liftTE_substTE 0 ix).
  eapply IHx1; eauto.
   apply liftTT_weaken. auto.

 Case "XAPP".
  rewrite (substTT_substTT 0 ix).
  apply TYAPP.
   simpl. eapply (IHx1 ix) in H6; eauto.
   simpl. eapply subst_type_type_ix; eauto.

 Case "XLam".
  simpl. apply TYLam.
  eapply subst_type_type_ix; eauto.
  unfold substTE. rewrite map_rewind.
  assert ( map (substTT ix t2) (te :> t)
         = substTE ix t2 (te :> t)). auto.
  rewrite H0.
   eapply IHx1; eauto.

 Case "XApp".
  eapply TYApp.
   eapply IHx1_1 in H6; eauto.
   eapply IHx1_2 in H8; eauto.
Qed.

Theorem subst_type_value
 :  forall ke te x1 t1 t2 k2
 ,  TYPE (ke :> k2) te x1 t1
 -> KIND ke  t2 k2
 -> TYPE ke                (substTE 0 t2 te)
         (substTX 0 t2 x1) (substTT 0 t2 t1).
Proof.
 intros.
 assert (ke = delete 0 (ke :> k2)). auto. rewrite H1.
 eapply subst_type_exp_ix; simpl; eauto.
Qed.