(**
 A proof of Zorn's Lemma and the Well-Ordering Theorem.

 Based on Kneser's short proof.

 © 2017 Johannes Kloos

 This library requires Coq 8.6. *)

 (*
 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2.1 of the License, or (at your option) any later version.

 This library is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 Lesser General Public License for more details.

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

 *)
From Coq Require Import
  Relations Equivalence Morphisms Utf8 ChoiceFacts ClassicalFacts.
From Coq.Program Require Import Basics.
From misc Require Import MoreChoice.

(** * The types of the statements *)
(** The statement of Zorn's Lemma. *)

Definition ZornsLemma
  {A} (R: relation A) {preR: PreOrder R}
  (chains_have_upper_bounds:
    ∀ (C: A → Prop), (∀ x y, C x → C y → R x y ∨ R y x) →
    ∃ m, ∀ x, C x → R x m) :=
    ∃ m, ∀ x, R m x → R x m.

(** The definition of a well-order. *)

Record well_order {A} (eqA ltA: relation A) := {
  eqA_equiv :> Equivalence eqA;
  ltA_strict :> StrictOrder ltA;
  ltA_wellfounded: well_founded ltA;
  ltA_proper :> Proper (eqA ==> eqA ==> iff) ltA;
  ltA_total: ∀ x y, eqA x y ∨ ltA x y ∨ ltA y x
}.

(** This module contains the proofs.

 Since they are long and the lemmas are not very useful outside
 the proofs, we encapsulate them away. *)

Module Type Proofs.
  Record well_ordered {A} (le equ: relation A) (X: { S | Proper (equ ==> iff) S }) :=
    { wo_total: ∀ x y, proj1_sig X x → proj1_sig X y → le x y ∨ le y x;
      wo_minima: ∀ (Y: { S | Proper (equ ==> iff) S }),
          (∀ x, proj1_sig Y x → proj1_sig X x) →
          (∃ x, proj1_sig Y x) →
          ∃ m, proj1_sig Y m ∧ ∀ x, proj1_sig Y x → le m x }.
  Axiom zorns_lemma: ∀ {A} (le equ lt: relation A),
    PreOrder le →
    (∀ x y, equ x y ↔ le x y ∧ le y x) →
    (∀ x y, lt x y ↔ le x y ∧ ¬le y x) →
    excluded_middle →
    GeneralizedSetoidRelationalChoice →
    (∀ (F: { S | Proper (equ ==> iff) S }),
           well_ordered le equ F →
           ∃ m, ∀ x, proj1_sig F x → le x m) →
    ∃ m, ∀ x, le m x → le x m.
  Axiom well_ordering_from_zorns_lemma:
    excluded_middle →
    (∀ A (R: relation A) (pre: PreOrder R)
       (chub: ∀ (C: A → Prop), (∀ x y, C x → C y → R x y ∨ R y x) →
                               ∃ m, ∀ x, C x → R x m),
        ZornsLemma R chub) →
    ∀ {A} (eqA: relation A), Equivalence eqA → ∃ ltA, well_order eqA ltA.
End Proofs.

Module Private: Proofs.
  (* begin hide *)
  Class Le A := le: relation A.
  Class Lt A := lt: relation A.
  Class Equiv A := equ: relation A.
  Infix "≤" := le.
  Infix "<" := lt.
  Infix "≡" := equ (at level 70).

  (* Some facts about orders. *)
  Section Orders.
    Context {A} (leA: Le A).
    Definition default_lt: Lt A := λ x y, x ≤ y ∧ ¬y ≤ x.
    Definition default_eq: Equiv A := λ x y, x ≤ y ∧ y ≤ x.
    Context (ltA: Lt A) (equA: Equiv A) {leA_pre: PreOrder le}.
    Hypothesis lt_spec: ∀ x y, x < y ↔ default_lt x y.
    Hypothesis equ_spec: ∀ x y, x ≡ y ↔ default_eq x y.

    Instance equ_equivalence: Equivalence equ.
    Proof.
      split; red; intros *; rewrite !equ_spec; unfold default_eq;
        intuition; etransitivity; eassumption.
    Qed.

    Instance partial_order: PartialOrder equ le := equ_spec.

    Lemma lt_le_trans x y z: x < y → y ≤ z → x < z.
    Proof.
      rewrite !lt_spec.
      intros [lexy ngexy] leyz; split; [|contradict ngexy];
        etransitivity; eassumption.
    Qed.

    Lemma le_lt_trans x y z: x ≤ y → y < z → x < z.
    Proof.
      rewrite !lt_spec.
      intros leyz [lexy ngexy]; split; [|contradict ngexy];
        etransitivity; eassumption.
    Qed.

    Instance lt_proper: Proper (equ ==> equ ==> iff) lt.
    Proof.
      apply proper_sym_impl_iff_2; [apply _..|].
      intros x x' [lex gex]%equ_spec y y' [ley gey]%equ_spec ltxy.
      eauto using lt_le_trans, le_lt_trans.
    Qed.

    Instance lt_strict: StrictOrder lt.
    Proof.
      split.
      - now intros ? [??]%lt_spec.
      - intros x y z [lexy _]%lt_spec.
        apply le_lt_trans, lexy.
    Qed.
  End Orders.

  Section Proof.
    (* We have a partially ordered set, with strict order and equivalence. *)
    Context {A} (leA: Le A) (eqA: Equiv A) (ltA: Lt A).
    Context {preA: PreOrder le} (eqA_spec: ∀ x y, x ≡ y ↔ x ≤ y ∧ y ≤ x).
    Context (ltA_spec: ∀ x y, x < y ↔ x ≤ y ∧ ¬y ≤ x).
    Hypothesis classical: excluded_middle.
    Hypothesis choice: GeneralizedSetoidRelationalChoice.

    (* Instantiate facts about the order. *)
    Instance: Equivalence equ := equ_equivalence leA eqA eqA_spec.
    Instance: PartialOrder equ le := partial_order leA eqA eqA_spec.
    Instance: Proper (equ ==> equ ==> iff) lt :=
      lt_proper leA ltA eqA ltA_spec eqA_spec.
    Instance: StrictOrder lt := lt_strict leA ltA ltA_spec.

    (* Sets. *)
    Definition set := { S: A → Prop | Proper (equ ==> iff) S }.
    Definition In x (s: set) := proj1_sig s x.
    Infix "∈" := In (at level 70).
    Definition Subset s₁ s₂ := ∀ x, x ∈ s₁ → x ∈ s₂.
    Infix "⊆" := Subset (at level 70).

    (* Closed subsets. *)
    Record closed_subset s₁ s₂ := {
      cs_subset: s₁ ⊆ s₂;
      cs_closed: ∀ x y, x ∈ s₂ → y ∈ s₁ → x ≤ y → x ∈ s₁
    }.
    Instance set_le: Le set := closed_subset.
    Instance set_lt: Lt set := default_lt set_le.
    Instance set_eq: Equiv set := default_eq set_le.
    Instance set_le_pre: @PreOrder set le.
    Proof. firstorder eauto. Qed.

    Instance: Equivalence equ :=
      equ_equivalence set_le set_eq (λ _ _, reflexivity _).
    Instance: PartialOrder (A:=set) equ le  :=
      partial_order le equ (λ _ _, reflexivity _).
    Instance: Proper (equ ==> equ ==> iff) lt :=
      lt_proper set_le set_lt set_eq (λ _ _, reflexivity _) (λ _ _, reflexivity _).
    Instance: StrictOrder lt :=
      lt_strict set_le set_lt (λ _ _, reflexivity _).

    Instance In_le_proper: Proper (equ ==> le ++> impl) In.
    Proof.
      intros x x' eqx [X Xprop] X' subX inx.
      apply subX; cbn in *.
      rewrite <- eqx; trivial.
    Qed.
    Instance: Proper (equ ==> equ ==> iff) In.
    Proof.
      intros x x' eqx X X' [sub sup].
      split; apply In_le_proper; easy.
    Qed.
    Instance: subrelation (A:=set) lt le.
    Proof. firstorder. Qed.

    Definition inhabited X := ∃ x, x ∈ X.
    Instance: Proper (equ ==> iff) inhabited.
    Proof. unfold inhabited; solve_proper. Qed.
    Instance: Proper (equ ==> equ ==> iff) Subset.
    Proof. unfold Subset; solve_proper. Qed.

    Lemma subset_equ X Y (sub: X ⊆ Y) (sup: Y ⊆ X): X ≡ Y.
    Proof. firstorder. Qed.

    (* Well-ordered subsets. *)
    Record well_ordered X := {
      wo_total: ∀ x y, x ∈ X → y ∈ X → x ≤ y ∨ y ≤ x;
      wo_minima: ∀ Y, Y ⊆ X → inhabited Y → ∃ m, m ∈ Y ∧ ∀ x, x ∈ Y → m ≤ x
    }.

    Instance: Proper (equ ==> iff) well_ordered.
    Proof.
      apply proper_sym_impl_iff; [apply _|].
      intros X X' eqX [total minima].
      split; setoid_rewrite <- eqX; auto.
    Qed.

    Lemma wo_lt_ge X (Xwo: well_ordered X) x y (inx: x ∈ X) (iny: y ∈ X):
      x < y ∨ y ≤ x.
    Proof.
      destruct (classical (y ≤ x)); auto.
      destruct (wo_total X Xwo x y); auto.
      rewrite ltA_spec; auto.
    Qed.

    (* The initial prefix lemma. *)
    Program Definition restrict x (X: set): set := λ y, y ∈ X ∧ y < x.
    Next Obligation. Proof. solve_proper. Qed.

    Hint Constructors closed_subset.

    Lemma initial_prefix X Y (Xwo: well_ordered X) (sub: Y < X):
      ∃ x, x ∈ X ∧ ¬x ∈ Y ∧ Y ≡ restrict x X.
    Proof.
      assert (Proper (equ ==> iff) (λ x, x ∈ X ∧ ¬x ∈ Y)) as diff_impl
        by solve_proper.
      set (exist _ _ diff_impl: set) as diff.
      destruct (wo_minima X Xwo diff) as [m [[inX notinY] lb]].
      - firstorder.
      - destruct (classical (∃ x, x ∈ diff)) as [|none]; trivial.
        destruct sub as [sub [ ]].
        split; [|firstorder].
        intros x inx.
        destruct (classical (x ∈ Y)); trivial.
        contradict none; exists x; split; trivial.
      - exists m; do 2 (split; trivial).
        destruct sub as [[sub closed] neq].
        apply subset_equ; intros y iny.
        + split; auto.
          destruct (wo_lt_ge X Xwo y m) as [|contra]; auto.
          now eapply cs_closed in contra; eauto.
        + destruct iny as [iny bound].
          destruct (classical (y ∈ Y)) as [|contra]; auto.
          enough (y < y) as [ ]%irreflexivity.
          eapply lt_le_trans; eauto.
          apply lb; split; trivial.
    Qed.

    Instance: Proper (equ ==> equ ==> equ) restrict.
    Proof.
      unfold restrict.
      intros x x' eqx X X' eqX.
      apply subset_equ; intro y; cbn; rewrite eqx, eqX; trivial.
    Qed.

    (* The union of a prefix chain of wo sets is a wo set,
     * and each element of the chain is a prefix of the union. *)
    Section ChainUnion.
      Variable F: set → Prop.
      Hypothesis chain: ∀ S S', F S → F S' → S ≤ S' ∨ S' ≤ S.
      Hypothesis wo: ∀ S, F S → well_ordered S.

      Program Definition union: set := λ x, ∃ S, F S ∧ x ∈ S.
      Next Obligation. Proof. solve_proper. Qed.

      Lemma prefix_union S (inS: F S): S ≤ union.
      Proof.
        split.
        - exists S; auto.
        - intros ?? [S' [inS' inx]] iny lexy.
          destruct (chain S S') as [[sub cl]|[sub cl]]; eauto.
      Qed.

      Lemma union_wo: well_ordered union.
      Proof.
        assert (total: ∀ x y : A, x ∈ union → y ∈ union → x ≤ y ∨ y ≤ x). {
          intros ?? [Sx [inSx inx]] [Sy [inSy iny]].
          destruct (chain Sx Sy) as [[sub _]|[sub _]]; auto;
            [apply (wo_total Sy)|apply (wo_total Sx)]; auto.
        }
        split; trivial.
        intros ? sub [y inh].
        destruct (sub y inh) as [Sy [inSy iny]].
        assert (Proper (equ ==> iff) (λ x, x ∈ Y ∧ x ∈ Sy)) as inter_spec
          by solve_proper.
        set (exist _ _ inter_spec) as inter.
        destruct (wo_minima Sy (wo Sy inSy) inter) as [m [[inm inm'] min]];
          [firstorder..|].
        exists m; split; auto.
        intros x inx.
        destruct (sub x inx) as [Z [inSz inx']].
        destruct (chain Sy Z) as [[sub' cl']|[??]]; eauto;
          [|apply min; split; auto].
        destruct (total m x) as [case|case]; [apply sub; trivial..|auto|].
        apply cl' in case; auto.
        apply min; split; auto.
      Qed.

      Lemma union_ub B (bound: ∀ S, F S → S ≤ B): union ≤ B.
      Proof.
        split.
        - intros x [S [inS inx]]; apply (bound S inS), inx.
        - intros ?? inx [S [inS inY]] lexy.
          exists S; split; trivial.
          eapply cs_closed; eauto.
          apply bound, inS.
      Qed.
    End ChainUnion.

    Notation "⋃ F" := (union F) (at level 55).

    Lemma restrict_well_ordered b X (wo: well_ordered X):
      well_ordered (restrict b X).
    Proof. firstorder. Qed.

    (* Theory of g-sets *)
    Section GSets.
      Variable g: set → A → Prop.
      Hypothesis unique: ∀ S b b', g S b → g S b' → b ≡ b'.
      Context (proper: Proper (equ ==> equ ==> iff) g).
      Hypothesis domain: ∀ S, well_ordered S → ∃ b, g S b.
      Hypothesis upper_bound: ∀ S b x, well_ordered S → g S b → x ∈ S → x < b.

      Record gset C := {
        C_wo:> well_ordered C;
        C_bounds: ∀ c, c ∈ C → g (restrict c C) c
      }.

      Instance gset_proper: Proper (equ ==> iff) gset.
      Proof.
        apply proper_sym_impl_iff; [apply _|].
        intros S S' eqS [wo bounds].
        split; setoid_rewrite <- eqS; trivial.
      Qed.

      (* Suspending sets *)
      Program Definition suspend S x: set := λ y, y ∈ S ∨ x ≡ y.
      Next Obligation. Proof. solve_proper. Qed.
      Instance: Proper (equ ==> equ ==> equ) suspend.
      Proof.
        intros S S' eqS x x' eqx.
        apply subset_equ; intro y; unfold suspend; cbn;
          rewrite eqS, eqx; trivial.
      Qed.

      Lemma suspend_bound_gset S x (Sg: gset S) (bound: g S x):
        gset (suspend S x).
      Proof.
        split. split.
        - intros y z [iny|iny] [inz|inz].
          + apply (wo_total S); auto using C_wo.
          + rewrite <- inz; left.
            apply ltA_spec, (upper_bound S); auto using C_wo.
          + rewrite <- iny; right.
            apply ltA_spec, (upper_bound S); auto using C_wo.
          + now rewrite <- iny, <- inz; left.
        - intros Y Ysub inh.
          destruct (classical (inhabited (restrict x Y))) as [case|case].
          + destruct (wo_minima S Sg (restrict x Y)) as [m [[inm neq] bound']];
              auto.
            * intros z [[inz|eqz]%Ysub ltz]; auto.
              rewrite eqz in ltz; apply irreflexivity in ltz; contradiction.
            * exists m; split; trivial.
              intros z inz.
              destruct (classical (z < x)) as [case'|case'];
                [apply bound'; split; trivial|].
              apply Ysub in inz.
              apply ltA_spec.
              destruct inz as [inz|<-]; trivial.
              now eapply upper_bound in inz; eauto using C_wo.
          + assert (∀ y, y ∈ Y ↔ x ≡ y). {
              split.
              - intro iny.
                unfold restrict, inhabited in case; cbn in case.
                assert (¬y < x) as bound' by firstorder.
                apply Ysub in iny; destruct iny as [iny|]; trivial.
                now eapply upper_bound in iny; eauto using C_wo.
              - intros <-.
                destruct inh as [z inz].
                destruct (classical (x ∈ Y)) as [|notinx]; trivial.
                contradict case; exists z.
                split; trivial.
                eapply upper_bound; eauto using C_wo.
                destruct (Ysub _ inz) as [|eqy]; trivial.
                now rewrite eqy in notinx.
            }
            setoid_rewrite H.
            exists x; split; [|intros ? <-]; reflexivity.
        - intros c inc.
          assert (restrict c (suspend S x) ≡ restrict c S) as ->.
          + apply subset_equ.
            * intros y [[iny|<-] lty]; [split; trivial|].
              apply (lt_le_trans _ _ ltA_spec x c x), irreflexivity in lty;
                [contradiction|].
              destruct inc as [inc| ->]; [|reflexivity].
              eapply ltA_spec, upper_bound; eauto using C_wo.
            * intros y [iny bound']; split; trivial.
              left; trivial.
          + destruct inc as [inc|<-]; trivial.
            * apply C_bounds; trivial.
            * enough (restrict x S ≡ S) as -> by trivial.
              apply subset_equ; [destruct 1; trivial|].
              intros y iny; split; trivial.
              eapply upper_bound; eauto using C_wo.
      Qed.

      Section GSetsComparableFacts.
        Variables C D: set.
        Hypothesis Cg: gset C.
        Hypothesis Dg: gset D.
        Definition common S := S ≤ C ∧ S ≤ D.
        Definition W := ⋃ common.
        Variables c d: A.
        Hypothesis Wc: W ≡ restrict c C.
        Hypothesis Wd: W ≡ restrict d D.
        Hypothesis inc: c ∈ C.
        Hypothesis ind: d ∈ D.

        Fact eq_c_d: c ≡ d.
        Proof.
          apply (unique W); [rewrite Wc|rewrite Wd]; apply C_bounds; trivial.
        Qed.

        Let W' := suspend W c.

        Lemma restrict_mono: Proper (le ++> eq ==> le) restrict.
        Proof.
          intros x y lexy S ? <-.
          split.
          - intros z [inz ltz]; split; trivial.
            eapply lt_le_trans; eauto.
          - intros x' y' [inx' ltx'] [iny' lty'] ltx'y'.
            split; trivial.
            clear ltx'.
            eapply le_lt_trans; eauto.
        Qed.

        Lemma common_comparable S S' (Sc: common S) (Sc': common S'):
          S ≤ S' ∨ S' ≤ S.
        Proof.
          destruct Sc as [subc _], Sc' as [subc' _].
          destruct (classical (C ≤ S)) as [leC|ltS];
            [right; etransitivity; eauto|].
          destruct (classical (C ≤ S')) as [leC|ltS'];
            [left; etransitivity; eauto|].
          destruct (initial_prefix C S) as [x [inx [notinx prefix]]];
            [auto using C_wo|split; auto|].
          destruct (initial_prefix C S') as [x' [inx' [notinx' prefix']]];
            [auto using C_wo|split; auto|].
          rewrite prefix, prefix'.
          now destruct (wo_total C (C_wo _ Cg) x x' inx inx') as [case|case];
            [left|right]; apply restrict_mono.
        Qed.

        Lemma common_wo S (Sc: common S): well_ordered S.
        Proof.
          destruct Sc as [[sub _] _], Cg as [[total wo] _].
          clear -sub total wo.
          split; firstorder.
        Qed.

        Lemma W_le_C: W ≤ C.
        Proof.
          apply union_ub.
          destruct 1; trivial.
        Qed.

        Lemma W_le_D: W ≤ D.
        Proof.
          apply union_ub.
          destruct 1; trivial.
        Qed.

        Lemma W_wo: well_ordered W.
        Proof.
          apply union_wo; auto using common_wo, common_comparable.
        Qed.

        Lemma W_gset: gset W.
        Proof.
          split; auto using W_wo.
          intros b inb.
          rewrite Wc.
          enough (restrict b (restrict c C) ≡ restrict b C) as ->. {
            apply C_bounds; auto.
            destruct inb as [X [[[subX _] _] inb]].
            apply subX in inb; trivial.
          }
          apply subset_equ.
          - clear; firstorder.
          - intro x; intros [inx ltb]; repeat (split; trivial).
            rewrite ltb.
            apply upper_bound with W; auto using W_wo.
            rewrite Wc.
            apply C_bounds; auto.
        Qed.

        Corollary W'_gset: gset W'.
        Proof.
          apply suspend_bound_gset; auto using W_gset.
          rewrite Wc; apply C_bounds; trivial.
        Qed.

        Lemma W'_common: common W'.
        Proof.
          assert (suspend_restrict: ∀ X x, x ∈ X →
            suspend (restrict x X) x ≤ X). {
            intros * inx.
            split.
            - intros y [[iny _]| <-]; trivial.
            - intros y z iny [[inz ltx]|<-] ley.
              + left; split; trivial.
                eapply le_lt_trans; eauto.
              + destruct (classical (x ≤ y)) as [case|case].
                * right; apply eqA_spec; auto.
                * left; split; trivial.
                  apply ltA_spec; auto.
          }
          split; unfold W'.
          - rewrite Wc; apply suspend_restrict; auto.
          - rewrite Wd, eq_c_d; apply suspend_restrict; auto.
        Qed.

        Corollary W'_le_W: W' ≤ W.
        Proof.
          apply prefix_union; auto using common_comparable, W'_common.
        Qed.

        Corollary incomparable_C_D_inconsistent: False.
        Proof.
          enough (c ∈ W) as contra. {
            rewrite Wc in contra.
            destruct contra as [_ [ ]%irreflexivity].
          }
          apply W'_le_W.
          now right.
        Qed.
      End GSetsComparableFacts.

      Lemma gsets_comparable C D (Cg: gset C) (Dg: gset D): C ≤ D ∨ D ≤ C.
      Proof.
        pose proof (W_le_C C D) as leC.
        pose proof (W_le_D C D) as leD.
        assert (W C D ≡ C ∨ W C D < C) as [<-|ltC]; auto. {
          unfold lt, set_lt, default_lt, equ, set_eq, default_eq.
          destruct (classical (C ≤ W C D)); auto.
        }
        assert (W C D ≡ D ∨ W C D < D) as [<-|ltD]; auto. {
          unfold lt, set_lt, default_lt, equ, set_eq, default_eq.
          destruct (classical (D ≤ W C D)); auto.
        }
        clear leC leD.
        destruct (initial_prefix C (W C D)) as [c [inc [notinc eqc]]];
          auto using C_wo.
        destruct (initial_prefix D (W C D)) as [d [ind [notind eqd]]];
          auto using C_wo.
        destruct (incomparable_C_D_inconsistent C D Cg Dg c d eqc eqd inc ind).
      Qed.

      Definition maxgset := ⋃ gset.
      Lemma maxgset_gset: gset maxgset.
      Proof.
        split.
        - apply union_wo.
          + apply gsets_comparable.
          + destruct 1; trivial.
        - intros c [S [inS inc]].
          enough (restrict c maxgset ≡ restrict c S) as ->
            by now apply C_bounds.
          apply subset_equ.
          + intros x [[S' [inS' sub]] ltc].
            split; trivial.
            destruct (gsets_comparable S S') as [case|case]; auto.
            * eapply cs_closed; eauto.
              apply ltA_spec, ltc.
            * eapply cs_subset; eauto.
          + intros x [inx ltc]; split; trivial.
            exists S; auto.
      Qed.

      Lemma maxgset_suspend b (b_bound: g maxgset b): gset (suspend maxgset b).
      Proof.
        apply suspend_bound_gset; auto using maxgset_gset.
      Qed.

      Corollary gsets_inconsistent: False.
      Proof.
        destruct (domain maxgset (C_wo _ maxgset_gset)) as [b b_bound].
        enough (b ∈ maxgset) as contra.
        - eapply upper_bound in contra; eauto using C_wo, maxgset_gset.
          now apply irreflexivity in contra.
        - eapply prefix_union; eauto using  gsets_comparable, maxgset_suspend.
          now right.
      Qed.
    End GSets.

    Corollary must_have_included_bound
      (g: set → A → Prop) (unique: ∀ S b b', g S b → g S b' → b ≡ b')
      (proper: Proper (equ ==> equ ==> iff) g)
      (domain: ∀ S, well_ordered S → ∃ b, g S b)
      (upper_bound: ∀ S b x, well_ordered S → g S b → x ∈ S → x ≤ b)
      (strong_upper_bounds: ∀ S b, well_ordered S → g S b →
        (∃ b', ∀ x, x ∈ S → x < b') → ¬b ∈ S):
      ∃ S b, well_ordered S ∧ g S b ∧ b ∈ S.
    Proof.
      destruct (classical (∃ S b, well_ordered S ∧ g S b ∧ b ∈ S)) as [|contra];
        trivial.
      destruct (gsets_inconsistent g unique proper domain).
      intros * woS b_bound inx.
      apply ltA_spec.
      split; [eapply upper_bound; eauto|].
      intro leb.
      assert (b ≡ x) as eqb. {
        apply eqA_spec; split; trivial.
        eapply upper_bound; eauto.
      }
      rewrite eqb in *; clear b eqb.
      eapply strong_upper_bounds in inx; eauto.
      destruct (classical (∃ b', ∀ y, y ∈ S → y < b')) as [|contra']; trivial.
      contradict contra.
      exists S, x.
      repeat (split; trivial).
    Qed.

    Definition bound_relation (W: { W | well_ordered W }) b :=
      let S := proj1_sig W in
      (∀ x, x ∈ S → x ≤ b) ∧
      ((∃ b', ∀ x, x ∈ S → x < b') → ¬b ∈ S).
    Instance: Equiv { W | well_ordered W } := λ W W', proj1_sig W ≡ proj1_sig W'.
    Instance: @Equivalence { W | well_ordered W } equ.
    Proof.
      split.
      - now intros [S W]; change (S ≡ S).
      - intros [S₁ W₁] [S₂ W₂] ?.
        now change (S₂ ≡ S₁).
      - intros [S₁ W₁] [S₂ W₂] [S₃ W₃] ??.
        change (S₁ ≡ S₃); transitivity S₂; trivial.
    Qed.

    Theorem zorns_lemma (all_chains_bounded: ∀ F, well_ordered F →
      ∃ m, ∀ x, x ∈ F → x ≤ m):
      ∃ m: A, ∀ x, m ≤ x → x ≤ m.
    Proof.
      destruct (choice _ _ _ _ _ _ bound_relation)
        as [g [g_sub [g_proper [g_complete g_unique]]]]. {
        unfold bound_relation.
        intros [S Swo] [S' S'wo] eqS b b' eqb.
        change (S ≡ S') in eqS.
        cbn.
        setoid_rewrite eqS.
        now setoid_rewrite eqb.
      } {
        intros [S Swo].
        unfold bound_relation; cbn.
        destruct (all_chains_bounded S Swo) as [m m_bound].
        destruct (classical (∃ b, ∀ x, x ∈ S → x < b)) as
          [[b b_bound]|no_strong_bound].
        - exists b; split.
          + intros; apply ltA_spec; auto.
          + intros _ [ ]%b_bound%irreflexivity.
        - exists m; tauto.
      } {
        destruct (must_have_included_bound (λ S b, ∃ W, g (exist _ S W) b))
          as [S [b [Swo [[W bbound] inb]]]].
        - intros S b b' [W bbound] [W' b'bound].
          eapply g_unique; eauto.
          eapply g_proper; eauto.
          now change (S ≡ S).
        - apply proper_sym_impl_iff_2; [firstorder|apply _|].
          intros S S' eqS b b' eqb [W bound].
          assert (well_ordered S') as W' by now rewrite <- eqS.
          exists W'.
          now revert bound; apply g_proper; [change (S' ≡ S)|].
        - intros S Swo.
          destruct (g_complete (exist _ S Swo)) as [b rel].
          eauto.
        - intros ??? Swo [W [bound _]%g_sub] inx.
          apply bound; trivial.
        - intros S b Swo [W [_ strong]%g_sub] strong_bound.
          apply strong; trivial.
        - exists b; intros x lb.
          destruct (classical (x ≤ b)) as [|contra]; trivial.
          apply g_sub in bbound.
          destruct bbound as [bound strong]; cbn in strong.
          apply strong in inb; [contradiction|].
          exists x.
          intros y iny%bound.
          eapply le_lt_trans; eauto.
          rewrite ltA_spec; auto.
      }
    Qed.
  End Proof.

  Section WellOrderingTheorem.
    Context {A} (eqA: relation A) {equA: Equivalence eqA}.
    Record ordered_subset (S: A → Prop) (R: relation A) := {
      S_proper:> Proper (eqA ==> iff) S;
      R_strict:> StrictOrder R;
      R_wellfounded: well_founded R;
      R_proper:> Proper (eqA ==> eqA ==> iff) R;
      R_carrier_correct: ∀ x y, R x y → S x ∧ S y;
      R_carrier_complete: ∀ x y, S x → S y → eqA x y ∨ R x y ∨ R y x
    }.
    Record continues_raw (S S': A → Prop) (R R': relation A) := {
      S_sub: ∀ x, S x → S' x;
      S_closed: ∀ x y, S' x → S y → R' x y → S x;
      R_coincides: ∀ x y, S x → S y → (R x y ↔ R' x y)
    }.
    Definition order := { O | ordered_subset (fst O) (snd O) }.
    Notation "o .S" := (fst (proj1_sig o)) (at level 30).
    Notation "o .R" := (snd (proj1_sig o)) (at level 30).
    Notation "o .good" := (proj2_sig o) (at level 30).
    Instance: ∀ o: order, Proper (eqA ==> iff) (o.S).
    Proof. intro; apply (o.good). Qed.
    Instance: ∀ o: order, Proper (eqA ==> eqA ==> iff) (o.R).
    Proof. intro; apply (o.good). Qed.
    Instance: ∀ o: order, StrictOrder (o.R).
    Proof. intro; apply (o.good). Qed.

    Definition continues (o₁ o₂: order) :=
      continues_raw (o₁.S) (o₂.S) (o₁.R) (o₂.R).

    Instance continues_preorder: PreOrder continues.
    Proof.
      split.
      - intros [[S R] good]; red; cbn.
        split; intuition.
      - intros [[S₁ R₁] good₁] [[S₂ R₂] good₂] [[S₃ R₃] good₃];
          unfold continues; cbn.
        intros [sub₁₂ closed₁₂ coincides₁₂] [sub₂₃ closed₂₃ coincides₂₃].
        split; [firstorder|..].
        + intros ?? inx iny rel.
          eapply closed₁₂; eauto.
          apply coincides₂₃; auto.
          eapply closed₂₃; eauto.
        + intros * inx iny.
          rewrite coincides₁₂; auto.
    Qed.

    Local Infix "≤" := continues.

    Hypothesis classical: excluded_middle.

    Definition suspend_S S x y := S y ∨ eqA x y.
    Definition suspend_R S (R: relation A) x y z := R y z ∨ S y ∧ eqA x z.
    Lemma suspend_good S R x (x_not_in: ¬S x):
      ordered_subset S R → ordered_subset (suspend_S S x) (suspend_R S R x).
    Proof.
      intros [sproper strict wf proper correct complete].
      unfold suspend_S, suspend_R.
      split. 2:split.
      - solve_proper.
      - intros y [[ ]%irreflexivity|[iny eqz]].
        now rewrite <- eqz in iny.
      - intros a b c [ltab|[ina eqb]] [ltbc|[inb eqc]].
        + left; transitivity b; trivial.
        + right; split; trivial.
          apply correct in ltab; tauto.
        + apply correct in ltbc.
          rewrite <- eqb in ltbc; tauto.
        + auto.
      - assert (∀ y, ¬eqA x y → Acc (λ y z, R y z ∨ S y ∧ eqA x z) y).
        + induction y as [y IH] using (well_founded_ind wf).
          intro neq; constructor; intros z [ltz|[inz eqy]]; [|contradiction].
          apply IH; trivial.
          apply correct in ltz.
          intro contra; rewrite <- contra in ltz; tauto.
        + intro y.
          destruct (classical (eqA x y)) as [eqxy|neq]; auto.
          constructor.
          intros z [ltz|[inz eqy]].
          * apply H.
            intro contra; rewrite <- contra, eqxy in ltz.
            apply irreflexivity in ltz; contradiction.
          * apply H.
            now intro contra; rewrite contra in x_not_in.
      - solve_proper.
      - intros y z [relyz|[iny eqxz]]; [|tauto].
        apply correct in relyz; tauto.
      - intros y z [iny|eqy] [inz|eqz]; auto.
        + destruct (complete y z) as [?|[?|?]]; auto.
        + rewrite <- eqz, eqy; auto.
          now left.
    Qed.

    Definition suspend' (o: order) x (x_not_in: ¬o.S x): order :=
      exist _ (suspend_S (o.S) x, suspend_R (o.S) (o.R) x)
        (suspend_good (o.S) (o.R) x x_not_in (o.good)).

    Lemma maximal_continuation_total o (o_max: ∀ o', o ≤ o' → o' ≤ o):
      ∀ x y, eqA x y ∨ o.R x y ∨ o.R y x.
    Proof.
      enough (∀ x, o.S x)
        by (intros; eapply R_carrier_complete; [apply (o.good)|auto..]).
      intro.
      destruct (classical (o.S x)) as [|notinx]; trivial.
      apply (o_max (suspend' o x notinx)); [|now right].
      split; cbn; auto.
      - now left.
      - intros y z [iny|eqy] inz [rel|[iny' eqz]]; eauto.
        destruct (o.good) as [_ _ _ _ correct _].
        apply correct in rel.
        rewrite eqy in notinx; tauto.
      - intros y z iny inz.
        unfold suspend_R.
        split; [tauto|].
        intros [|[_ eqxz]]; auto.
        clear -notinx inz eqxz.
        destruct o as [[S R] []]; cbn in *.
        now rewrite eqxz in notinx.
    Qed.

    Definition union_S (F: order → Prop) x := ∃ o, F o ∧ o.S x.
    Definition union_R (F: order → Prop) x y := ∃ o, F o ∧ o.R x y.

    Lemma continuation_subrelation o o' (cont: o ≤ o'):
      subrelation (o.R) (o'.R).
    Proof.
      destruct cont as [sub cont coincide].
      intros x y rel.
      destruct (o.good) as [_ _ _ _ correct _].
      apply coincide; trivial; apply correct in rel; tauto.
    Qed.

    Lemma union_good (F: order → Prop)
      (F_chain: ∀ o o', F o → F o' → o ≤ o' ∨ o' ≤ o):
      ordered_subset (union_S F) (union_R F).
    Proof.
      unfold union_S, union_R.
      split. 2:split.
      - solve_proper.
      - intros x [o [_ [ ]%irreflexivity]].
      - intros x y z [o [ino sto]] [o' [ino' sto']].
        destruct (F_chain _ _ ino ino') as [case|case].
        + exists o'; split; trivial; transitivity y; trivial.
          apply continuation_subrelation in case.
          apply case, sto.
        + exists o; split; trivial; transitivity y; trivial.
          apply continuation_subrelation in case.
          apply case, sto'.
      - intro a.
        constructor.
        intros b [o [ino rel]].
        destruct (o.good) as [sproper rstrict rwf rproper rcorrect rcomplete].
        apply rcorrect in rel.
        destruct rel as [inb _]; clear a.
        induction b as [a IH] using (well_founded_ind rwf).
        constructor.
        intros b [o' [ino' rel]].
        destruct (F_chain _ _ ino ino') as [case|case].
        + destruct case as [sub closed coincides].
          rewrite <- coincides in rel; auto.
          * apply IH; trivial.
            apply rcorrect in rel; tauto.
          * eapply closed; eauto.
            destruct (o'.good) as [_ _ _ _ correct _].
            apply correct in rel; tauto.
        + apply IH.
          * apply continuation_subrelation in case.
            apply case, rel.
          * apply continuation_subrelation in case.
            apply case in rel.
            destruct (o.good) as [_ _ _ _ correct _].
            apply correct in rel; tauto.
      - solve_proper.
      - intros x y [o [ino relo]].
        destruct (o.good) as [_ _ _ _ correct _].
        apply correct in relo.
        destruct relo; split; eauto.
      - intros x y [o [ino relo]] [o' [ino' relo']].
        destruct (F_chain o o' ino ino') as [case|case].
        + destruct (case) as [S_sub _ _].
          apply S_sub in relo.
          destruct (o'.good) as [_ _ _ _ _ complete].
          destruct (complete x y) as [?|[?|?]]; eauto.
        + destruct (case) as [S_sub _ _].
          apply S_sub in relo'.
          destruct (o.good) as [_ _ _ _ _ complete].
          destruct (complete x y) as [?|[?|?]]; eauto.
    Qed.
  End WellOrderingTheorem.

  Notation "o .S" := (fst (proj1_sig o)) (at level 30).
  Notation "o .R" := (snd (proj1_sig o)) (at level 30).
  Notation "o .good" := (proj2_sig o) (at level 30).

  Theorem well_ordering_from_zorns_lemma
    (classical: excluded_middle)
    (zl: ∀ A R preR chub, @ZornsLemma A R preR chub)
    {A} (eqA: relation A) {equA: Equivalence eqA}:
    ∃ ltA, well_order eqA ltA.
  Proof.
    pose proof (zl _ (continues eqA) (continues_preorder eqA)) as zl'.
    unfold ZornsLemma in zl'.
    destruct zl' as [o omax].
    - intros C Cchain.
      exists (exist _ (union_S eqA C, union_R eqA C)
        (union_good eqA C Cchain): order eqA).
      intros o ino.
      split; cbn.
      + intros x inx; exists o; auto.
      + intros ?? [o' [ino' inx]] iny [o'' [ino'' rel']].
        destruct (Cchain o' o ino' ino) as [[ ]|[sub cl co]]; auto.
        pose proof (sub _ iny) as iny'.
        destruct (Cchain o'' o' ino'' ino') as [[sub' cl' co']|[sub' cl' co']].
        * destruct (o''.good) as [_ _ _ _ correct _].
          destruct (correct _ _ rel') as [inx'' iny''].
          rewrite co' in rel'; auto.
          destruct (o'.good); eauto.
        * rewrite <- co' in rel'; trivial.
          destruct (o'.good); eauto.
      + intros ?? inx iny; split; [exists o; auto|].
        intros [o' [ino' rel]].
        destruct (Cchain _ _ ino ino') as [[sub cl co]|[sub cl co]];
          [now apply co|].
        destruct (o'.good) as [_ _ _ _ correct _].
        destruct (correct _ _ rel).
        now apply co.
    - exists (o.R).
      pose proof (maximal_continuation_total eqA classical o omax) as total.
      clear omax.
      destruct o as [[S R] [sproper strict wf rproper correct complete]].
      now split.
  Qed.
  (* end hide *)
End Private.

(** * The key theorems *)

Section Theorems.
  Hypothesis classical: excluded_middle.

  (** The classical formulation of Zorn's lemma. *)

  Theorem zorns_lemma (choice: GeneralizedSetoidRelationalChoice)
    {A} R {preR: PreOrder R}
    (chains_have_upper_bounds: ∀ (C: A → Prop),
      (∀ x y, C x → C y → R x y ∨ R y x) → ∃ m, ∀ x, C x → R x m):
    ∃ m: A, ∀ x, R m x → R x m.
  Proof.
    apply Private.zorns_lemma with
      (equ := λ x y, R x y ∧ R y x)
      (lt := λ x y, R x y ∧ ¬R y x);
      auto;
      [reflexivity..|].
    intros [C Cset] [total _]; cbn in *.
    apply chains_have_upper_bounds, total.
  Qed.

  (** Zorn's lemma proves the well-ordering theorem. *)

  Theorem zorns_lemma_imp_well_ordering_theorem
    (zl: ∀ A R preR chub, @ZornsLemma A R preR chub)
    {A} (eqA: relation A) {equA: Equivalence eqA}:
    ∃ ltA, well_order eqA ltA.
  Proof.
    now apply Private.well_ordering_from_zorns_lemma.
  Qed.

  (** Deriving the well-ordering theorem from choice. *)

  Corollary well_ordering_theorem
    (choice: GeneralizedSetoidRelationalChoice)
    {A} (eqA: relation A) {equA: Equivalence eqA}:
    ∃ ltA, well_order eqA ltA.
  Proof.
    apply zorns_lemma_imp_well_ordering_theorem; trivial.
    apply zorns_lemma, choice.
  Qed.

  (** The well-ordering theorem implies choice, closing the circle. *)

  Theorem well_ordering_theorem_imp_axiom_of_choice
    (wo: ∀ {A} (eqA: relation A) {equA: Equivalence eqA},
      ∃ ltA, well_order eqA ltA):
    GeneralizedSetoidRelationalChoice.
  Proof.
    intros A B eqA eqB equA equB R Rproper Rfull.
    destruct (wo B eqB equB) as [ltB [_ ltB_strict ltB_wf ltB_proper ltB_total]].
    exists (λ a b, R a b ∧ ∀ b', R a b' → ¬ltB b' b).
    split; [tauto|].
    split; [solve_proper|].
    split. {
      intro.
      destruct (Rfull x) as [y rel].
      induction y as [y IH] using (well_founded_ind ltB_wf).
      destruct (classical (∃ y', R x y' ∧ ltB y' y)) as [[y' [rel' lt']]|none].
      - now apply (IH y').
      - exists y; split; trivial.
        firstorder.
    } {
      intros ??? [rel min] [rel' min'].
      apply min in rel'.
      apply min' in rel.
      destruct (ltB_total y y'); tauto.
    }
  Qed.
End Theorems.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo1.
Require Import R_sqrt.
Local Open Scope R_scope.

Lemma tan_PI : tan PI = 0.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.tan_PI".
unfold tan; rewrite sin_PI; rewrite cos_PI; unfold Rdiv;
apply Rmult_0_l.
Qed.

Lemma sin_3PI2 : sin (3 * (PI / 2)) = -1.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_3PI2".
replace (3 * (PI / 2)) with (PI + PI / 2).
rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; rewrite sin_PI2; ring.
pattern PI at 1; rewrite (double_var PI); ring.
Qed.

Lemma tan_2PI : tan (2 * PI) = 0.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.tan_2PI".
unfold tan; rewrite sin_2PI; unfold Rdiv; apply Rmult_0_l.
Qed.

Lemma sin_cos_PI4 : sin (PI / 4) = cos (PI / 4).
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_cos_PI4".
rewrite cos_sin.
replace (PI / 2 + PI / 4) with (- (PI / 4) + PI) by field.
rewrite neg_sin, sin_neg; ring.
Qed.

Lemma sin_PI3_cos_PI6 : sin (PI / 3) = cos (PI / 6).
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_PI3_cos_PI6".
replace (PI / 6) with (PI / 2 - PI / 3) by field.
now rewrite cos_shift.
Qed.

Lemma sin_PI6_cos_PI3 : cos (PI / 3) = sin (PI / 6).
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_PI6_cos_PI3".
replace (PI / 6) with (PI / 2 - PI / 3) by field.
now rewrite sin_shift.
Qed.

Lemma PI6_RGT_0 : 0 < PI / 6.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.PI6_RGT_0".
unfold Rdiv; apply Rmult_lt_0_compat;
[ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
Qed.

Lemma PI6_RLT_PI2 : PI / 6 < PI / 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.PI6_RLT_PI2".
unfold Rdiv; apply Rmult_lt_compat_l.
apply PI_RGT_0.
apply Rinv_lt_contravar; prove_sup.
Qed.

Lemma sin_PI6 : sin (PI / 6) = 1 / 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_PI6".
apply Rmult_eq_reg_l with (2 * cos (PI / 6)).
replace (2 * cos (PI / 6) * sin (PI / 6)) with
(2 * sin (PI / 6) * cos (PI / 6)) by ring.
rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3) by field.
rewrite sin_PI3_cos_PI6.
field.
apply prod_neq_R0.
discrR.
cut (0 < cos (PI / 6));
[ intro H1; auto with real
| apply cos_gt_0;
[ apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)
| apply PI6_RLT_PI2 ] ].
Qed.

Lemma sqrt2_neq_0 : sqrt 2 <> 0.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sqrt2_neq_0".
assert (Hyp : 0 < 2);
[ prove_sup0
| generalize (Rlt_le 0 2 Hyp); intro H1; red; intro H2;
generalize (sqrt_eq_0 2 H1 H2); intro H; absurd (2 = 0);
[ discrR | assumption ] ].
Qed.

Lemma R1_sqrt2_neq_0 : 1 / sqrt 2 <> 0.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.R1_sqrt2_neq_0".
generalize (Rinv_neq_0_compat (sqrt 2) sqrt2_neq_0); intro H;
generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H);
intro H0; assumption.
Qed.

Lemma sqrt3_2_neq_0 : 2 * sqrt 3 <> 0.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sqrt3_2_neq_0".
apply prod_neq_R0;
[ discrR
| assert (Hyp : 0 < 3);
[ prove_sup0
| generalize (Rlt_le 0 3 Hyp); intro H1; red; intro H2;
generalize (sqrt_eq_0 3 H1 H2); intro H; absurd (3 = 0);
[ discrR | assumption ] ] ].
Qed.

Lemma Rlt_sqrt2_0 : 0 < sqrt 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.Rlt_sqrt2_0".
assert (Hyp : 0 < 2);
[ prove_sup0
| generalize (sqrt_positivity 2 (Rlt_le 0 2 Hyp)); intro H1; elim H1;
intro H2;
[ assumption
| absurd (0 = sqrt 2);
[ apply (not_eq_sym (A:=R)); apply sqrt2_neq_0 | assumption ] ] ].
Qed.

Lemma Rlt_sqrt3_0 : 0 < sqrt 3.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.Rlt_sqrt3_0".
cut (0%nat <> 1%nat);
[ intro H0; assert (Hyp : 0 < 2);
[ prove_sup0
| generalize (Rlt_le 0 2 Hyp); intro H1; assert (Hyp2 : 0 < 3);
[ prove_sup0
| generalize (Rlt_le 0 3 Hyp2); intro H2;
generalize (lt_INR_0 1 (neq_O_lt 1 H0));
unfold INR; intro H3;
generalize (Rplus_lt_compat_l 2 0 1 H3);
rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3;
[ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3;
apply (Rlt_trans 0 (sqrt 2) (sqrt 3) Rlt_sqrt2_0 H3)
| ring ] ] ]
| discriminate ].
Qed.

Lemma PI4_RGT_0 : 0 < PI / 4.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.PI4_RGT_0".
unfold Rdiv; apply Rmult_lt_0_compat;
[ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
Qed.

Lemma cos_PI4 : cos (PI / 4) = 1 / sqrt 2.
Proof with trivial. hammer_hook "Rtrigo_calc" "Rtrigo_calc.cos_PI4".
apply Rsqr_inj...
apply cos_ge_0...
left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 4) _PI2_RLT_0 PI4_RGT_0)...
left; apply PI4_RLT_PI2...
left; apply (Rmult_lt_0_compat 1 (/ sqrt 2))...
prove_sup...
apply Rinv_0_lt_compat; apply Rlt_sqrt2_0...
rewrite Rsqr_div...
rewrite Rsqr_1; rewrite Rsqr_sqrt...
unfold Rsqr; pattern (cos (PI / 4)) at 1;
rewrite <- sin_cos_PI4;
replace (sin (PI / 4) * cos (PI / 4)) with
(1 / 2 * (2 * sin (PI / 4) * cos (PI / 4))) by field.
rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2) by field.
rewrite sin_PI2...
field.
left; prove_sup...
apply sqrt2_neq_0...
Qed.

Lemma sin_PI4 : sin (PI / 4) = 1 / sqrt 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_PI4".
rewrite sin_cos_PI4; apply cos_PI4.
Qed.

Lemma tan_PI4 : tan (PI / 4) = 1.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.tan_PI4".
unfold tan; rewrite sin_cos_PI4.
unfold Rdiv; apply Rinv_r.
change (cos (PI / 4) <> 0); rewrite cos_PI4; apply R1_sqrt2_neq_0.
Qed.

Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.cos3PI4".
replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field.
rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4.
unfold Rdiv.
ring.
Qed.

Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin3PI4".
replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4)) by field.
now rewrite sin_shift, cos_neg, cos_PI4.
Qed.

Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2.
Proof with trivial. hammer_hook "Rtrigo_calc" "Rtrigo_calc.cos_PI6".
apply Rsqr_inj...
apply cos_ge_0...
left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)...
left; apply PI6_RLT_PI2...
left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))...
apply Rlt_sqrt3_0...
apply Rinv_0_lt_compat; prove_sup0...
rewrite Rsqr_div...
rewrite cos2; unfold Rsqr; rewrite sin_PI6; rewrite sqrt_def...
field.
left ; prove_sup0.
discrR.
Qed.

Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.tan_PI6".
unfold tan; rewrite sin_PI6; rewrite cos_PI6; unfold Rdiv;
repeat rewrite Rmult_1_l; rewrite Rinv_mult_distr.
rewrite Rinv_involutive.
rewrite (Rmult_comm (/ 2)); rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
apply Rmult_1_r.
discrR.
discrR.
red; intro; assert (H1 := Rlt_sqrt3_0); rewrite H in H1;
elim (Rlt_irrefl 0 H1).
apply Rinv_neq_0_compat; discrR.
Qed.

Lemma sin_PI3 : sin (PI / 3) = sqrt 3 / 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_PI3".
rewrite sin_PI3_cos_PI6; apply cos_PI6.
Qed.

Lemma cos_PI3 : cos (PI / 3) = 1 / 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.cos_PI3".
rewrite sin_PI6_cos_PI3; apply sin_PI6.
Qed.

Lemma tan_PI3 : tan (PI / 3) = sqrt 3.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.tan_PI3".
unfold tan; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv;
rewrite Rmult_1_l; rewrite Rinv_involutive.
rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
apply Rmult_1_r.
discrR.
discrR.
Qed.

Lemma sin_2PI3 : sin (2 * (PI / 3)) = sqrt 3 / 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_2PI3".
rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3;
unfold Rdiv; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2));
repeat rewrite <- Rmult_assoc; rewrite double_var;
reflexivity.
Qed.

Lemma cos_2PI3 : cos (2 * (PI / 3)) = -1 / 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.cos_2PI3".
rewrite cos_2a, sin_PI3, cos_PI3.
replace (sqrt 3 / 2 * (sqrt 3 / 2)) with ((sqrt 3 * sqrt 3) / 4) by field.
rewrite sqrt_sqrt.
field.
left ; prove_sup0.
Qed.

Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.tan_2PI3".
unfold tan; rewrite sin_2PI3, cos_2PI3.
field.
Qed.

Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.cos_5PI4".
replace (5 * (PI / 4)) with (PI / 4 + PI) by field.
rewrite neg_cos; rewrite cos_PI4; unfold Rdiv.
ring.
Qed.

Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_5PI4".
replace (5 * (PI / 4)) with (PI / 4 + PI) by field.
rewrite neg_sin; rewrite sin_PI4; unfold Rdiv.
ring.
Qed.

Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)).
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_cos5PI4".
rewrite cos_5PI4; rewrite sin_5PI4; reflexivity.
Qed.

Lemma Rgt_3PI2_0 : 0 < 3 * (PI / 2).
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.Rgt_3PI2_0".
apply Rmult_lt_0_compat;
[ prove_sup0
| unfold Rdiv; apply Rmult_lt_0_compat;
[ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ] ].
Qed.

Lemma Rgt_2PI_0 : 0 < 2 * PI.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.Rgt_2PI_0".
apply Rmult_lt_0_compat; [ prove_sup0 | apply PI_RGT_0 ].
Qed.

Lemma Rlt_PI_3PI2 : PI < 3 * (PI / 2).
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.Rlt_PI_3PI2".
generalize PI2_RGT_0; intro H1;
generalize (Rplus_lt_compat_l PI 0 (PI / 2) H1);
replace (PI + PI / 2) with (3 * (PI / 2)).
rewrite Rplus_0_r; intro H2; assumption.
pattern PI at 2; rewrite double_var; ring.
Qed.

Lemma Rlt_3PI2_2PI : 3 * (PI / 2) < 2 * PI.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.Rlt_3PI2_2PI".
generalize PI2_RGT_0; intro H1;
generalize (Rplus_lt_compat_l (3 * (PI / 2)) 0 (PI / 2) H1);
replace (3 * (PI / 2) + PI / 2) with (2 * PI).
rewrite Rplus_0_r; intro H2; assumption.
rewrite double; pattern PI at 1 2; rewrite double_var; ring.
Qed.

Definition plat : R := 180.
Definition toRad (x:R) : R := x * PI * / plat.
Definition toDeg (x:R) : R := x * plat * / PI.

Lemma rad_deg : forall x:R, toRad (toDeg x) = x.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.rad_deg".
intro; unfold toRad, toDeg;
replace (x * plat * / PI * PI * / plat) with
(x * (plat * / plat) * (PI * / PI)); [ idtac | ring ].
repeat rewrite <- Rinv_r_sym.
ring.
apply PI_neq0.
unfold plat; discrR.
Qed.

Lemma toRad_inj : forall x y:R, toRad x = toRad y -> x = y.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.toRad_inj".
intros; unfold toRad in H; apply Rmult_eq_reg_l with PI.
rewrite <- (Rmult_comm x); rewrite <- (Rmult_comm y).
apply Rmult_eq_reg_l with (/ plat).
rewrite <- (Rmult_comm (x * PI)); rewrite <- (Rmult_comm (y * PI));
assumption.
apply Rinv_neq_0_compat; unfold plat; discrR.
apply PI_neq0.
Qed.

Lemma deg_rad : forall x:R, toDeg (toRad x) = x.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.deg_rad".
intro x; apply toRad_inj; rewrite (rad_deg (toRad x)); reflexivity.
Qed.

Definition sind (x:R) : R := sin (toRad x).
Definition cosd (x:R) : R := cos (toRad x).
Definition tand (x:R) : R := tan (toRad x).

Lemma Rsqr_sin_cos_d_one : forall x:R, Rsqr (sind x) + Rsqr (cosd x) = 1.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.Rsqr_sin_cos_d_one".
intro x; unfold sind; unfold cosd; apply sin2_cos2.
Qed.

Lemma sin_lb_ge_0 : forall a:R, 0 <= a -> a <= PI / 2 -> 0 <= sin_lb a.
Proof. hammer_hook "Rtrigo_calc" "Rtrigo_calc.sin_lb_ge_0".
intros; case (Rtotal_order 0 a); intro.
left; apply sin_lb_gt_0; assumption.
elim H1; intro.
rewrite <- H2; unfold sin_lb; unfold sin_approx;
unfold sum_f_R0; unfold sin_term;
repeat rewrite pow_ne_zero.
unfold Rdiv; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
repeat rewrite Rplus_0_r; right; reflexivity.
discriminate.
discriminate.
discriminate.
discriminate.
elim (Rlt_irrefl 0 (Rle_lt_trans 0 a 0 H H2)).
Qed.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Export Rlimit.
Require Export Rderiv.
Local Open Scope R_scope.
Implicit Type f : R -> R.

Definition plus_fct f1 f2 (x:R) : R := f1 x + f2 x.
Definition opp_fct f (x:R) : R := - f x.
Definition mult_fct f1 f2 (x:R) : R := f1 x * f2 x.
Definition mult_real_fct (a:R) f (x:R) : R := a * f x.
Definition minus_fct f1 f2 (x:R) : R := f1 x - f2 x.
Definition div_fct f1 f2 (x:R) : R := f1 x / f2 x.
Definition div_real_fct (a:R) f (x:R) : R := a / f x.
Definition comp f1 f2 (x:R) : R := f1 (f2 x).
Definition inv_fct f (x:R) : R := / f x.

Delimit Scope Rfun_scope with F.

Arguments plus_fct (f1 f2)%F x%R.
Arguments mult_fct (f1 f2)%F x%R.
Arguments minus_fct (f1 f2)%F x%R.
Arguments div_fct (f1 f2)%F x%R.
Arguments inv_fct f%F x%R.
Arguments opp_fct f%F x%R.
Arguments mult_real_fct a%R f%F x%R.
Arguments div_real_fct a%R f%F x%R.
Arguments comp (f1 f2)%F x%R.

Infix "+" := plus_fct : Rfun_scope.
Notation "- x" := (opp_fct x) : Rfun_scope.
Infix "*" := mult_fct : Rfun_scope.
Infix "-" := minus_fct : Rfun_scope.
Infix "/" := div_fct : Rfun_scope.
Local Notation "f1 'o' f2" := (comp f1 f2)
(at level 20, right associativity) : Rfun_scope.
Notation "/ x" := (inv_fct x) : Rfun_scope.

Definition fct_cte (a x:R) : R := a.
Definition id (x:R) := x.

Definition increasing f : Prop := forall x y:R, x <= y -> f x <= f y.
Definition decreasing f : Prop := forall x y:R, x <= y -> f y <= f x.
Definition strict_increasing f : Prop := forall x y:R, x < y -> f x < f y.
Definition strict_decreasing f : Prop := forall x y:R, x < y -> f y < f x.
Definition constant f : Prop := forall x y:R, f x = f y.

Definition no_cond (x:R) : Prop := True.

Definition constant_D_eq f (D:R -> Prop) (c:R) : Prop :=
forall x:R, D x -> f x = c.

Definition continuity_pt f (x0:R) : Prop := continue_in f no_cond x0.
Definition continuity f : Prop := forall x:R, continuity_pt f x.

Arguments continuity_pt f%F x0%R.
Arguments continuity f%F.

Lemma continuity_pt_locally_ext :
forall f g a x, 0 < a -> (forall y, R_dist y x < a -> f y = g y) ->
continuity_pt f x -> continuity_pt g x.
intros f g a x a0 q cf eps ep.
destruct (cf eps ep) as [a' [a'p Pa']].
exists (Rmin a a'); split.
unfold Rmin; destruct (Rle_dec a a').
assumption.
assumption.
intros y cy; rewrite <- !q.
apply Pa'.
split;[| apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_r]];tauto.
rewrite R_dist_eq; assumption.
apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_l]; tauto.
Qed.

Lemma continuity_pt_plus :
forall f1 f2 (x0:R),
continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 + f2) x0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_pt_plus".
unfold continuity_pt, plus_fct; unfold continue_in; intros;
apply limit_plus; assumption.
Qed.

Lemma continuity_pt_opp :
forall f (x0:R), continuity_pt f x0 -> continuity_pt (- f) x0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_pt_opp".
unfold continuity_pt, opp_fct; unfold continue_in; intros;
apply limit_Ropp; assumption.
Qed.

Lemma continuity_pt_minus :
forall f1 f2 (x0:R),
continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 - f2) x0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_pt_minus".
unfold continuity_pt, minus_fct; unfold continue_in; intros;
apply limit_minus; assumption.
Qed.

Lemma continuity_pt_mult :
forall f1 f2 (x0:R),
continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 * f2) x0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_pt_mult".
unfold continuity_pt, mult_fct; unfold continue_in; intros;
apply limit_mul; assumption.
Qed.

Lemma continuity_pt_const : forall f (x0:R), constant f -> continuity_pt f x0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_pt_const".
unfold constant, continuity_pt; unfold continue_in;
unfold limit1_in; unfold limit_in;
intros; exists 1; split;
[ apply Rlt_0_1
| intros; generalize (H x x0); intro; rewrite H2; simpl;
rewrite R_dist_eq; assumption ].
Qed.

Lemma continuity_pt_scal :
forall f (a x0:R),
continuity_pt f x0 -> continuity_pt (mult_real_fct a f) x0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_pt_scal".
unfold continuity_pt, mult_real_fct; unfold continue_in;
intros; apply (limit_mul (fun x:R => a) f (D_x no_cond x0) a (f x0) x0).
unfold limit1_in; unfold limit_in; intros; exists 1; split.
apply Rlt_0_1.
intros; rewrite R_dist_eq; assumption.
assumption.
Qed.

Lemma continuity_pt_inv :
forall f (x0:R), continuity_pt f x0 -> f x0 <> 0 -> continuity_pt (/ f) x0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_pt_inv".
intros.
replace (/ f)%F with (fun x:R => / f x).
unfold continuity_pt; unfold continue_in; intros;
apply limit_inv; assumption.
unfold inv_fct; reflexivity.
Qed.

Lemma div_eq_inv : forall f1 f2, (f1 / f2)%F = (f1 * / f2)%F.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.div_eq_inv".
intros; reflexivity.
Qed.

Lemma continuity_pt_div :
forall f1 f2 (x0:R),
continuity_pt f1 x0 ->
continuity_pt f2 x0 -> f2 x0 <> 0 -> continuity_pt (f1 / f2) x0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_pt_div".
intros; rewrite (div_eq_inv f1 f2); apply continuity_pt_mult;
[ assumption | apply continuity_pt_inv; assumption ].
Qed.

Lemma continuity_pt_comp :
forall f1 f2 (x:R),
continuity_pt f1 x -> continuity_pt f2 (f1 x) -> continuity_pt (f2 o f1) x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_pt_comp".
unfold continuity_pt; unfold continue_in; intros;
unfold comp.
cut
(limit1_in (fun x0:R => f2 (f1 x0))
(Dgf (D_x no_cond x) (D_x no_cond (f1 x)) f1) (
f2 (f1 x)) x ->
limit1_in (fun x0:R => f2 (f1 x0)) (D_x no_cond x) (f2 (f1 x)) x).
intro; apply H1.
eapply limit_comp.
apply H.
apply H0.
unfold limit1_in; unfold limit_in; unfold dist;
simpl; unfold R_dist; intros.
assert (H3 := H1 eps H2).
elim H3; intros.
exists x0.
split.
elim H4; intros; assumption.
intros; case (Req_dec (f1 x) (f1 x1)); intro.
rewrite H6; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
assumption.
elim H4; intros; apply H8.
split.
unfold Dgf, D_x, no_cond.
split.
split.
trivial.
elim H5; unfold D_x, no_cond; intros.
elim H9; intros; assumption.
split.
trivial.
assumption.
elim H5; intros; assumption.
Qed.

Lemma continuity_plus :
forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 + f2).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_plus".
unfold continuity; intros;
apply (continuity_pt_plus f1 f2 x (H x) (H0 x)).
Qed.

Lemma continuity_opp : forall f, continuity f -> continuity (- f).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_opp".
unfold continuity; intros; apply (continuity_pt_opp f x (H x)).
Qed.

Lemma continuity_minus :
forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 - f2).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_minus".
unfold continuity; intros;
apply (continuity_pt_minus f1 f2 x (H x) (H0 x)).
Qed.

Lemma continuity_mult :
forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 * f2).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_mult".
unfold continuity; intros;
apply (continuity_pt_mult f1 f2 x (H x) (H0 x)).
Qed.

Lemma continuity_const : forall f, constant f -> continuity f.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_const".
unfold continuity; intros; apply (continuity_pt_const f x H).
Qed.

Lemma continuity_scal :
forall f (a:R), continuity f -> continuity (mult_real_fct a f).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_scal".
unfold continuity; intros; apply (continuity_pt_scal f a x (H x)).
Qed.

Lemma continuity_inv :
forall f, continuity f -> (forall x:R, f x <> 0) -> continuity (/ f).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_inv".
unfold continuity; intros; apply (continuity_pt_inv f x (H x) (H0 x)).
Qed.

Lemma continuity_div :
forall f1 f2,
continuity f1 ->
continuity f2 -> (forall x:R, f2 x <> 0) -> continuity (f1 / f2).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_div".
unfold continuity; intros;
apply (continuity_pt_div f1 f2 x (H x) (H0 x) (H1 x)).
Qed.

Lemma continuity_comp :
forall f1 f2, continuity f1 -> continuity f2 -> continuity (f2 o f1).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.continuity_comp".
unfold continuity; intros.
apply (continuity_pt_comp f1 f2 x (H x) (H0 (f1 x))).
Qed.

Definition derivable_pt_lim f (x l:R) : Prop :=
forall eps:R,
0 < eps ->
exists delta : posreal,
(forall h:R,
h <> 0 -> Rabs h < delta -> Rabs ((f (x + h) - f x) / h - l) < eps).

Definition derivable_pt_abs f (x l:R) : Prop := derivable_pt_lim f x l.

Definition derivable_pt f (x:R) := { l:R | derivable_pt_abs f x l }.
Definition derivable f := forall x:R, derivable_pt f x.

Definition derive_pt f (x:R) (pr:derivable_pt f x) := proj1_sig pr.
Definition derive f (pr:derivable f) (x:R) := derive_pt f x (pr x).

Arguments derivable_pt_lim f%F x%R l.
Arguments derivable_pt_abs f%F (x l)%R.
Arguments derivable_pt f%F x%R.
Arguments derivable f%F.
Arguments derive_pt f%F x%R pr.
Arguments derive f%F pr x.

Definition antiderivative f (g:R -> R) (a b:R) : Prop :=
(forall x:R,
a <= x <= b ->  exists pr : derivable_pt g x, f x = derive_pt g x pr) /\
a <= b.

Record Differential : Type := mkDifferential
{d1 :> R -> R; cond_diff : derivable d1}.

Record Differential_D2 : Type := mkDifferential_D2
{d2 :> R -> R;
cond_D1 : derivable d2;
cond_D2 : derivable (derive d2 cond_D1)}.

Lemma uniqueness_step1 :
forall f (x l1 l2:R),
limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l1 0 ->
limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l2 0 ->
l1 = l2.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.uniqueness_step1".
intros;
apply
(single_limit (fun h:R => (f (x + h) - f x) / h) (
fun h:R => h <> 0) l1 l2 0); try assumption.
unfold adhDa; intros; exists (alp / 2).
split.
unfold Rdiv; apply prod_neq_R0.
red; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
apply Rinv_neq_0_compat; discrR.
unfold R_dist; unfold Rminus; rewrite Ropp_0;
rewrite Rplus_0_r; unfold Rdiv; rewrite Rabs_mult.
replace (Rabs (/ 2)) with (/ 2).
replace (Rabs alp) with alp.
apply Rmult_lt_reg_l with 2.
prove_sup0.
rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
[ idtac | discrR ]; rewrite Rmult_1_r; rewrite double;
pattern alp at 1; replace alp with (alp + 0);
[ idtac | ring ]; apply Rplus_lt_compat_l; assumption.
symmetry ; apply Rabs_right; left; assumption.
symmetry ; apply Rabs_right; left; change (0 < / 2);
apply Rinv_0_lt_compat; prove_sup0.
Qed.

Lemma uniqueness_step2 :
forall f (x l:R),
derivable_pt_lim f x l ->
limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.uniqueness_step2".
unfold derivable_pt_lim; intros; unfold limit1_in;
unfold limit_in; intros.
assert (H1 := H eps H0).
elim H1; intros.
exists (pos x0).
split.
apply (cond_pos x0).
simpl; unfold R_dist; intros.
elim H3; intros.
apply H2;
[ assumption
| unfold Rminus in H5; rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5;
assumption ].
Qed.

Lemma uniqueness_step3 :
forall f (x l:R),
limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 ->
derivable_pt_lim f x l.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.uniqueness_step3".
unfold limit1_in, derivable_pt_lim; unfold limit_in;
unfold dist; simpl; intros.
elim (H eps H0).
intros; elim H1; intros.
exists (mkposreal x0 H2).
simpl; intros; unfold R_dist in H3; apply (H3 h).
split;
[ assumption
| unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; assumption ].
Qed.

Lemma uniqueness_limite :
forall f (x l1 l2:R),
derivable_pt_lim f x l1 -> derivable_pt_lim f x l2 -> l1 = l2.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.uniqueness_limite".
intros.
assert (H1 := uniqueness_step2 _ _ _ H).
assert (H2 := uniqueness_step2 _ _ _ H0).
assert (H3 := uniqueness_step1 _ _ _ _ H1 H2).
assumption.
Qed.

Lemma derive_pt_eq :
forall f (x l:R) (pr:derivable_pt f x),
derive_pt f x pr = l <-> derivable_pt_lim f x l.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_eq".
intros; split.
intro; assert (H1 := proj2_sig pr); unfold derive_pt in H; rewrite H in H1;
assumption.
intro; assert (H1 := proj2_sig pr); unfold derivable_pt_abs in H1.
assert (H2 := uniqueness_limite _ _ _ _ H H1).
unfold derive_pt; unfold derivable_pt_abs.
symmetry ; assumption.
Qed.

Lemma derive_pt_eq_0 :
forall f (x l:R) (pr:derivable_pt f x),
derivable_pt_lim f x l -> derive_pt f x pr = l.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_eq_0".
intros; elim (derive_pt_eq f x l pr); intros.
apply (H1 H).
Qed.

Lemma derive_pt_eq_1 :
forall f (x l:R) (pr:derivable_pt f x),
derive_pt f x pr = l -> derivable_pt_lim f x l.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_eq_1".
intros; elim (derive_pt_eq f x l pr); intros.
apply (H0 H).
Qed.

Lemma derive_pt_D_in :
forall f (df:R -> R) (x:R) (pr:derivable_pt f x),
D_in f df no_cond x <-> derive_pt f x pr = df x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_D_in".
intros; split.
unfold D_in; unfold limit1_in; unfold limit_in;
simpl; unfold R_dist; intros.
apply derive_pt_eq_0.
unfold derivable_pt_lim.
intros; elim (H eps H0); intros alpha H1; elim H1; intros;
exists (mkposreal alpha H2); intros; generalize (H3 (x + h));
intro; cut (x + h - x = h);
[ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
[ intro; generalize (H6 H8); rewrite H7; intro; assumption
| split;
[ unfold D_x; split;
[ unfold no_cond; trivial
| apply Rminus_not_eq_right; rewrite H7; assumption ]
| rewrite H7; assumption ] ]
| ring ].
intro.
assert (H0 := derive_pt_eq_1 f x (df x) pr H).
unfold D_in; unfold limit1_in; unfold limit_in;
unfold dist; simpl; unfold R_dist;
intros.
elim (H0 eps H1); intros alpha H2; exists (pos alpha); split.
apply (cond_pos alpha).
intros; elim H3; intros; unfold D_x in H4; elim H4; intros; cut (x0 - x <> 0).
intro; generalize (H2 (x0 - x) H8 H5); replace (x + (x0 - x)) with x0.
intro; assumption.
ring.
auto with real.
Qed.

Lemma derivable_pt_lim_D_in :
forall f (df:R -> R) (x:R),
D_in f df no_cond x <-> derivable_pt_lim f x (df x).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_D_in".
intros; split.
unfold D_in; unfold limit1_in; unfold limit_in;
simpl; unfold R_dist; intros.
unfold derivable_pt_lim.
intros; elim (H eps H0); intros alpha H1; elim H1; intros;
exists (mkposreal alpha H2); intros; generalize (H3 (x + h));
intro; cut (x + h - x = h);
[ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
[ intro; generalize (H6 H8); rewrite H7; intro; assumption
| split;
[ unfold D_x; split;
[ unfold no_cond; trivial
| apply Rminus_not_eq_right; rewrite H7; assumption ]
| rewrite H7; assumption ] ]
| ring ].
intro.
unfold derivable_pt_lim in H.
unfold D_in; unfold limit1_in; unfold limit_in;
unfold dist; simpl; unfold R_dist;
intros.
elim (H eps H0); intros alpha H2; exists (pos alpha); split.
apply (cond_pos alpha).
intros.
elim H1; intros; unfold D_x in H3; elim H3; intros; cut (x0 - x <> 0).
intro; generalize (H2 (x0 - x) H7 H4); replace (x + (x0 - x)) with x0.
intro; assumption.
ring.
auto with real.
Qed.

Lemma derivable_pt_lim_ext : forall f g x l, (forall z, f z = g z) ->
derivable_pt_lim f x l -> derivable_pt_lim g x l.
intros f g x l fg df e ep; destruct (df e ep) as [d pd]; exists d; intros h;
rewrite <- !fg; apply pd.
Qed.

Lemma derivable_pt_lim_locally_ext : forall f g x a b l,
a < x < b ->
(forall z, a < z < b -> f z = g z) ->
derivable_pt_lim f x l -> derivable_pt_lim g x l.
intros f g x a b l axb fg df e ep.
destruct (df e ep) as [d pd].
assert (d'h : 0 < Rmin d (Rmin (b - x) (x - a))).
apply Rmin_pos;[apply cond_pos | apply Rmin_pos; apply Rlt_Rminus; tauto].
exists (mkposreal _ d'h); simpl; intros h hn0 cmp.
rewrite <- !fg;[ |assumption | ].
apply pd;[assumption |].
apply Rlt_le_trans with (1 := cmp), Rmin_l.
assert (-h < x - a).
apply Rle_lt_trans with (1 := Rle_abs _).
rewrite Rabs_Ropp; apply Rlt_le_trans with (1 := cmp).
rewrite Rmin_assoc; apply Rmin_r.
assert (h < b - x).
apply Rle_lt_trans with (1 := Rle_abs _).
apply Rlt_le_trans with (1 := cmp).
rewrite Rmin_comm, <- Rmin_assoc; apply Rmin_l.
split.
apply (Rplus_lt_reg_l (- h)).
replace ((-h) + (x + h)) with x by ring.
apply (Rplus_lt_reg_r (- a)).
replace (((-h) + a) + - a) with (-h) by ring.
assumption.
apply (Rplus_lt_reg_r (- x)).
replace (x + h + - x) with h by ring.
assumption.
Qed.

Lemma derivable_derive :
forall f (x:R) (pr:derivable_pt f x),  exists l : R, derive_pt f x pr = l.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_derive".
intros; exists (proj1_sig pr).
unfold derive_pt; reflexivity.
Qed.

Theorem derivable_continuous_pt :
forall f (x:R), derivable_pt f x -> continuity_pt f x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_continuous_pt".
intros f x X.
generalize (derivable_derive f x X); intro.
elim H; intros l H1.
cut (l = fct_cte l x).
intro.
rewrite H0 in H1.
generalize (derive_pt_D_in f (fct_cte l) x); intro.
elim (H2 X); intros.
generalize (H4 H1); intro.
unfold continuity_pt.
apply (cont_deriv f (fct_cte l) no_cond x H5).
unfold fct_cte; reflexivity.
Qed.

Theorem derivable_continuous : forall f, derivable f -> continuity f.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_continuous".
unfold derivable, continuity; intros f X x.
apply (derivable_continuous_pt f x (X x)).
Qed.

Lemma derivable_pt_lim_plus :
forall f1 f2 (x l1 l2:R),
derivable_pt_lim f1 x l1 ->
derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 + f2) x (l1 + l2).
intros.
apply uniqueness_step3.
assert (H1 := uniqueness_step2 _ _ _ H).
assert (H2 := uniqueness_step2 _ _ _ H0).
unfold plus_fct.
cut
(forall h:R,
(f1 (x + h) + f2 (x + h) - (f1 x + f2 x)) / h =
(f1 (x + h) - f1 x) / h + (f2 (x + h) - f2 x) / h).
intro.
generalize
(limit_plus (fun h':R => (f1 (x + h') - f1 x) / h')
(fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
unfold limit1_in; unfold limit_in; unfold dist;
simpl; unfold R_dist; intros.
elim (H4 eps H5); intros.
exists x0.
elim H6; intros.
split.
assumption.
intros; rewrite H3; apply H8; assumption.
intro; unfold Rdiv; ring.
Qed.

Lemma derivable_pt_lim_opp :
forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_opp".
intros.
apply uniqueness_step3.
assert (H1 := uniqueness_step2 _ _ _ H).
unfold opp_fct.
cut (forall h:R, (- f (x + h) - - f x) / h = - ((f (x + h) - f x) / h)).
intro.
generalize
(limit_Ropp (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 H1).
unfold limit1_in; unfold limit_in; unfold dist;
simpl; unfold R_dist; intros.
elim (H2 eps H3); intros.
exists x0.
elim H4; intros.
split.
assumption.
intros; rewrite H0; apply H6; assumption.
intro; unfold Rdiv; ring.
Qed.

Lemma derivable_pt_lim_minus :
forall f1 f2 (x l1 l2:R),
derivable_pt_lim f1 x l1 ->
derivable_pt_lim f2 x l2 -> derivable_pt_lim (f1 - f2) x (l1 - l2).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_minus".
intros.
apply uniqueness_step3.
assert (H1 := uniqueness_step2 _ _ _ H).
assert (H2 := uniqueness_step2 _ _ _ H0).
unfold minus_fct.
cut
(forall h:R,
(f1 (x + h) - f1 x) / h - (f2 (x + h) - f2 x) / h =
(f1 (x + h) - f2 (x + h) - (f1 x - f2 x)) / h).
intro.
generalize
(limit_minus (fun h':R => (f1 (x + h') - f1 x) / h')
(fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
unfold limit1_in; unfold limit_in; unfold dist;
simpl; unfold R_dist; intros.
elim (H4 eps H5); intros.
exists x0.
elim H6; intros.
split.
assumption.
intros; rewrite <- H3; apply H8; assumption.
intro; unfold Rdiv; ring.
Qed.

Lemma derivable_pt_lim_mult :
forall f1 f2 (x l1 l2:R),
derivable_pt_lim f1 x l1 ->
derivable_pt_lim f2 x l2 ->
derivable_pt_lim (f1 * f2) x (l1 * f2 x + f1 x * l2).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_mult".
intros.
assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x).
elim H1; intros.
assert (H4 := H3 H).
assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) x).
elim H5; intros.
assert (H8 := H7 H0).
clear H1 H2 H3 H5 H6 H7.
assert
(H1 :=
derivable_pt_lim_D_in (f1 * f2)%F (fun y:R => l1 * f2 x + f1 x * l2) x).
elim H1; intros.
clear H1 H3.
apply H2.
unfold mult_fct.
apply (Dmult no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x); assumption.
Qed.

Lemma derivable_pt_lim_const : forall a x:R, derivable_pt_lim (fct_cte a) x 0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_const".
intros; unfold fct_cte, derivable_pt_lim.
intros; exists (mkposreal 1 Rlt_0_1); intros; unfold Rminus;
rewrite Rplus_opp_r; unfold Rdiv; rewrite Rmult_0_l;
rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
Qed.

Lemma derivable_pt_lim_scal :
forall f (a x l:R),
derivable_pt_lim f x l -> derivable_pt_lim (mult_real_fct a f) x (a * l).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_scal".
intros.
assert (H0 := derivable_pt_lim_const a x).
replace (mult_real_fct a f) with (fct_cte a * f)%F.
replace (a * l) with (0 * f x + a * l); [ idtac | ring ].
apply (derivable_pt_lim_mult (fct_cte a) f x 0 l); assumption.
unfold mult_real_fct, mult_fct, fct_cte; reflexivity.
Qed.

Lemma derivable_pt_lim_div_scal :
forall f x l a, derivable_pt_lim f x l ->
derivable_pt_lim (fun y => f y / a) x (l / a).
intros f x l a df;
apply (derivable_pt_lim_ext (fun y => /a * f y)).
intros z; rewrite Rmult_comm; reflexivity.
unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption.
Qed.

Lemma derivable_pt_lim_scal_right :
forall f x l a, derivable_pt_lim f x l ->
derivable_pt_lim (fun y => f y * a) x (l * a).
intros f x l a df;
apply (derivable_pt_lim_ext (fun y => a * f y)).
intros z; rewrite Rmult_comm; reflexivity.
unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption.
Qed.

Lemma derivable_pt_lim_id : forall x:R, derivable_pt_lim id x 1.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_id".
intro; unfold derivable_pt_lim.
intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2;
unfold id; replace ((x + h - x) / h - 1) with 0.
rewrite Rabs_R0; apply Rle_lt_trans with (Rabs h).
apply Rabs_pos.
assumption.
unfold Rminus; rewrite Rplus_assoc; rewrite (Rplus_comm x);
rewrite Rplus_assoc.
rewrite Rplus_opp_l; rewrite Rplus_0_r; unfold Rdiv;
rewrite <- Rinv_r_sym.
symmetry ; apply Rplus_opp_r.
assumption.
Qed.

Lemma derivable_pt_lim_Rsqr : forall x:R, derivable_pt_lim Rsqr x (2 * x).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_Rsqr".
intro; unfold derivable_pt_lim.
unfold Rsqr; intros eps Heps; exists (mkposreal eps Heps);
intros h H1 H2; replace (((x + h) * (x + h) - x * x) / h - 2 * x) with h.
assumption.
replace ((x + h) * (x + h) - x * x) with (2 * x * h + h * h);
[ idtac | ring ].
unfold Rdiv; rewrite Rmult_plus_distr_r.
repeat rewrite Rmult_assoc.
repeat rewrite <- Rinv_r_sym; [ idtac | assumption ].
ring.
Qed.

Lemma derivable_pt_lim_comp :
forall f1 f2 (x l1 l2:R),
derivable_pt_lim f1 x l1 ->
derivable_pt_lim f2 (f1 x) l2 -> derivable_pt_lim (f2 o f1) x (l2 * l1).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_comp".
intros; assert (H1 := derivable_pt_lim_D_in f1 (fun y:R => l1) x).
elim H1; intros.
assert (H4 := H3 H).
assert (H5 := derivable_pt_lim_D_in f2 (fun y:R => l2) (f1 x)).
elim H5; intros.
assert (H8 := H7 H0).
clear H1 H2 H3 H5 H6 H7.
assert (H1 := derivable_pt_lim_D_in (f2 o f1)%F (fun y:R => l2 * l1) x).
elim H1; intros.
clear H1 H3; apply H2.
unfold comp;
cut
(D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1)
(Dgf no_cond no_cond f1) x ->
D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1) no_cond x).
intro; apply H1.
rewrite Rmult_comm;
apply (Dcomp no_cond no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x);
assumption.
unfold Dgf, D_in, no_cond; unfold limit1_in;
unfold limit_in; unfold dist; simpl;
unfold R_dist; intros.
elim (H1 eps H3); intros.
exists x0; intros; split.
elim H5; intros; assumption.
intros; elim H5; intros; apply H9; split.
unfold D_x; split.
split; trivial.
elim H6; intros; unfold D_x in H10; elim H10; intros; assumption.
elim H6; intros; assumption.
Qed.

Lemma derivable_pt_plus :
forall f1 f2 (x:R),
derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_plus".
unfold derivable_pt; intros f1 f2 x X X0.
elim X; intros.
elim X0; intros.
exists (x0 + x1).
apply derivable_pt_lim_plus; assumption.
Qed.

Lemma derivable_pt_opp :
forall f (x:R), derivable_pt f x -> derivable_pt (- f) x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_opp".
unfold derivable_pt; intros f x X.
elim X; intros.
exists (- x0).
apply derivable_pt_lim_opp; assumption.
Qed.

Lemma derivable_pt_minus :
forall f1 f2 (x:R),
derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 - f2) x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_minus".
unfold derivable_pt; intros f1 f2 x X X0.
elim X; intros.
elim X0; intros.
exists (x0 - x1).
apply derivable_pt_lim_minus; assumption.
Qed.

Lemma derivable_pt_mult :
forall f1 f2 (x:R),
derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 * f2) x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_mult".
unfold derivable_pt; intros f1 f2 x X X0.
elim X; intros.
elim X0; intros.
exists (x0 * f2 x + f1 x * x1).
apply derivable_pt_lim_mult; assumption.
Qed.

Lemma derivable_pt_const : forall a x:R, derivable_pt (fct_cte a) x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_const".
intros; unfold derivable_pt.
exists 0.
apply derivable_pt_lim_const.
Qed.

Lemma derivable_pt_scal :
forall f (a x:R), derivable_pt f x -> derivable_pt (mult_real_fct a f) x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_scal".
unfold derivable_pt; intros f1 a x X.
elim X; intros.
exists (a * x0).
apply derivable_pt_lim_scal; assumption.
Qed.

Lemma derivable_pt_id : forall x:R, derivable_pt id x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_id".
unfold derivable_pt; intro.
exists 1.
apply derivable_pt_lim_id.
Qed.

Lemma derivable_pt_Rsqr : forall x:R, derivable_pt Rsqr x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_Rsqr".
unfold derivable_pt; intro; exists (2 * x).
apply derivable_pt_lim_Rsqr.
Qed.

Lemma derivable_pt_comp :
forall f1 f2 (x:R),
derivable_pt f1 x -> derivable_pt f2 (f1 x) -> derivable_pt (f2 o f1) x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_comp".
unfold derivable_pt; intros f1 f2 x X X0.
elim X; intros.
elim X0; intros.
exists (x1 * x0).
apply derivable_pt_lim_comp; assumption.
Qed.

Lemma derivable_plus :
forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 + f2).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_plus".
unfold derivable; intros f1 f2 X X0 x.
apply (derivable_pt_plus _ _ x (X _) (X0 _)).
Qed.

Lemma derivable_opp : forall f, derivable f -> derivable (- f).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_opp".
unfold derivable; intros f X x.
apply (derivable_pt_opp _ x (X _)).
Qed.

Lemma derivable_minus :
forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 - f2).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_minus".
unfold derivable; intros f1 f2 X X0 x.
apply (derivable_pt_minus _ _ x (X _) (X0 _)).
Qed.

Lemma derivable_mult :
forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 * f2).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_mult".
unfold derivable; intros f1 f2 X X0 x.
apply (derivable_pt_mult _ _ x (X _) (X0 _)).
Qed.

Lemma derivable_const : forall a:R, derivable (fct_cte a).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_const".
unfold derivable; intros.
apply derivable_pt_const.
Qed.

Lemma derivable_scal :
forall f (a:R), derivable f -> derivable (mult_real_fct a f).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_scal".
unfold derivable; intros f a X x.
apply (derivable_pt_scal _ a x (X _)).
Qed.

Lemma derivable_id : derivable id.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_id".
unfold derivable; intro; apply derivable_pt_id.
Qed.

Lemma derivable_Rsqr : derivable Rsqr.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_Rsqr".
unfold derivable; intro; apply derivable_pt_Rsqr.
Qed.

Lemma derivable_comp :
forall f1 f2, derivable f1 -> derivable f2 -> derivable (f2 o f1).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_comp".
unfold derivable; intros f1 f2 X X0 x.
apply (derivable_pt_comp _ _ x (X _) (X0 _)).
Qed.

Lemma derive_pt_plus :
forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
derive_pt (f1 + f2) x (derivable_pt_plus _ _ _ pr1 pr2) =
derive_pt f1 x pr1 + derive_pt f2 x pr2.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_plus".
intros.
assert (H := derivable_derive f1 x pr1).
assert (H0 := derivable_derive f2 x pr2).
assert
(H1 := derivable_derive (f1 + f2)%F x (derivable_pt_plus _ _ _ pr1 pr2)).
elim H; clear H; intros l1 H.
elim H0; clear H0; intros l2 H0.
elim H1; clear H1; intros l H1.
rewrite H; rewrite H0; apply derive_pt_eq_0.
assert (H3 := proj2_sig pr1).
unfold derive_pt in H; rewrite H in H3.
assert (H4 := proj2_sig pr2).
unfold derive_pt in H0; rewrite H0 in H4.
apply derivable_pt_lim_plus; assumption.
Qed.

Lemma derive_pt_opp :
forall f (x:R) (pr1:derivable_pt f x),
derive_pt (- f) x (derivable_pt_opp _ _ pr1) = - derive_pt f x pr1.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_opp".
intros.
assert (H := derivable_derive f x pr1).
assert (H0 := derivable_derive (- f)%F x (derivable_pt_opp _ _ pr1)).
elim H; clear H; intros l1 H.
elim H0; clear H0; intros l2 H0.
rewrite H; apply derive_pt_eq_0.
assert (H3 := proj2_sig pr1).
unfold derive_pt in H; rewrite H in H3.
apply derivable_pt_lim_opp; assumption.
Qed.

Lemma derive_pt_minus :
forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
derive_pt (f1 - f2) x (derivable_pt_minus _ _ _ pr1 pr2) =
derive_pt f1 x pr1 - derive_pt f2 x pr2.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_minus".
intros.
assert (H := derivable_derive f1 x pr1).
assert (H0 := derivable_derive f2 x pr2).
assert
(H1 := derivable_derive (f1 - f2)%F x (derivable_pt_minus _ _ _ pr1 pr2)).
elim H; clear H; intros l1 H.
elim H0; clear H0; intros l2 H0.
elim H1; clear H1; intros l H1.
rewrite H; rewrite H0; apply derive_pt_eq_0.
assert (H3 := proj2_sig pr1).
unfold derive_pt in H; rewrite H in H3.
assert (H4 := proj2_sig pr2).
unfold derive_pt in H0; rewrite H0 in H4.
apply derivable_pt_lim_minus; assumption.
Qed.

Lemma derive_pt_mult :
forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x),
derive_pt (f1 * f2) x (derivable_pt_mult _ _ _ pr1 pr2) =
derive_pt f1 x pr1 * f2 x + f1 x * derive_pt f2 x pr2.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_mult".
intros.
assert (H := derivable_derive f1 x pr1).
assert (H0 := derivable_derive f2 x pr2).
assert
(H1 := derivable_derive (f1 * f2)%F x (derivable_pt_mult _ _ _ pr1 pr2)).
elim H; clear H; intros l1 H.
elim H0; clear H0; intros l2 H0.
elim H1; clear H1; intros l H1.
rewrite H; rewrite H0; apply derive_pt_eq_0.
assert (H3 := proj2_sig pr1).
unfold derive_pt in H; rewrite H in H3.
assert (H4 := proj2_sig pr2).
unfold derive_pt in H0; rewrite H0 in H4.
apply derivable_pt_lim_mult; assumption.
Qed.

Lemma derive_pt_const :
forall a x:R, derive_pt (fct_cte a) x (derivable_pt_const a x) = 0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_const".
intros.
apply derive_pt_eq_0.
apply derivable_pt_lim_const.
Qed.

Lemma derive_pt_scal :
forall f (a x:R) (pr:derivable_pt f x),
derive_pt (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr) =
a * derive_pt f x pr.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_scal".
intros.
assert (H := derivable_derive f x pr).
assert
(H0 := derivable_derive (mult_real_fct a f) x (derivable_pt_scal _ _ _ pr)).
elim H; clear H; intros l1 H.
elim H0; clear H0; intros l2 H0.
rewrite H; apply derive_pt_eq_0.
assert (H3 := proj2_sig pr).
unfold derive_pt in H; rewrite H in H3.
apply derivable_pt_lim_scal; assumption.
Qed.

Lemma derive_pt_id : forall x:R, derive_pt id x (derivable_pt_id _) = 1.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_id".
intros.
apply derive_pt_eq_0.
apply derivable_pt_lim_id.
Qed.

Lemma derive_pt_Rsqr :
forall x:R, derive_pt Rsqr x (derivable_pt_Rsqr _) = 2 * x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_Rsqr".
intros.
apply derive_pt_eq_0.
apply derivable_pt_lim_Rsqr.
Qed.

Lemma derive_pt_comp :
forall f1 f2 (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 (f1 x)),
derive_pt (f2 o f1) x (derivable_pt_comp _ _ _ pr1 pr2) =
derive_pt f2 (f1 x) pr2 * derive_pt f1 x pr1.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_comp".
intros.
assert (H := derivable_derive f1 x pr1).
assert (H0 := derivable_derive f2 (f1 x) pr2).
assert
(H1 := derivable_derive (f2 o f1)%F x (derivable_pt_comp _ _ _ pr1 pr2)).
elim H; clear H; intros l1 H.
elim H0; clear H0; intros l2 H0.
elim H1; clear H1; intros l H1.
rewrite H; rewrite H0; apply derive_pt_eq_0.
assert (H3 := proj2_sig pr1).
unfold derive_pt in H; rewrite H in H3.
assert (H4 := proj2_sig pr2).
unfold derive_pt in H0; rewrite H0 in H4.
apply derivable_pt_lim_comp; assumption.
Qed.

Definition pow_fct (n:nat) (y:R) : R := y ^ n.

Lemma derivable_pt_lim_pow_pos :
forall (x:R) (n:nat),
(0 < n)%nat -> derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_pow_pos".
intros.
induction  n as [| n Hrecn].
elim (lt_irrefl _ H).
cut (n = 0%nat \/ (0 < n)%nat).
intro; elim H0; intro.
rewrite H1; simpl.
replace (fun y:R => y * 1) with (id * fct_cte 1)%F.
replace (1 * 1) with (1 * fct_cte 1 x + id x * 0).
apply derivable_pt_lim_mult.
apply derivable_pt_lim_id.
apply derivable_pt_lim_const.
unfold fct_cte, id; ring.
reflexivity.
replace (fun y:R => y ^ S n) with (fun y:R => y * y ^ n).
replace (pred (S n)) with n; [ idtac | reflexivity ].
replace (fun y:R => y * y ^ n) with (id * (fun y:R => y ^ n))%F.
set (f := fun y:R => y ^ n).
replace (INR (S n) * x ^ n) with (1 * f x + id x * (INR n * x ^ pred n)).
apply derivable_pt_lim_mult.
apply derivable_pt_lim_id.
unfold f; apply Hrecn; assumption.
unfold f.
pattern n at 1 5; replace n with (S (pred n)).
unfold id; rewrite S_INR; simpl.
ring.
symmetry ; apply S_pred with 0%nat; assumption.
unfold mult_fct, id; reflexivity.
reflexivity.
inversion H.
left; reflexivity.
right.
apply lt_le_trans with 1%nat.
apply lt_O_Sn.
assumption.
Qed.

Lemma derivable_pt_lim_pow :
forall (x:R) (n:nat),
derivable_pt_lim (fun y:R => y ^ n) x (INR n * x ^ pred n).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_lim_pow".
intros.
induction  n as [| n Hrecn].
simpl.
rewrite Rmult_0_l.
replace (fun _:R => 1) with (fct_cte 1);
[ apply derivable_pt_lim_const | reflexivity ].
apply derivable_pt_lim_pow_pos.
apply lt_O_Sn.
Qed.

Lemma derivable_pt_pow :
forall (n:nat) (x:R), derivable_pt (fun y:R => y ^ n) x.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pt_pow".
intros; unfold derivable_pt.
exists (INR n * x ^ pred n).
apply derivable_pt_lim_pow.
Qed.

Lemma derivable_pow : forall n:nat, derivable (fun y:R => y ^ n).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derivable_pow".
intro; unfold derivable; intro; apply derivable_pt_pow.
Qed.

Lemma derive_pt_pow :
forall (n:nat) (x:R),
derive_pt (fun y:R => y ^ n) x (derivable_pt_pow n x) = INR n * x ^ pred n.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.derive_pt_pow".
intros; apply derive_pt_eq_0.
apply derivable_pt_lim_pow.
Qed.

Lemma pr_nu :
forall f (x:R) (pr1 pr2:derivable_pt f x),
derive_pt f x pr1 = derive_pt f x pr2.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.pr_nu".
intros f x (x0,H0) (x1,H1).
apply (uniqueness_limite f x x0 x1 H0 H1).
Qed.

Theorem deriv_maximum :
forall f (a b c:R) (pr:derivable_pt f c),
a < c ->
c < b ->
(forall x:R, a < x -> x < b -> f x <= f c) -> derive_pt f c pr = 0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.deriv_maximum".
intros; case (Rtotal_order 0 (derive_pt f c pr)); intro.
assert (H3 := derivable_derive f c pr).
elim H3; intros l H4; rewrite H4 in H2.
assert (H5 := derive_pt_eq_1 f c l pr H4).
cut (0 < l / 2);
[ intro
| unfold Rdiv; apply Rmult_lt_0_compat;
[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
elim (H5 (l / 2) H6); intros delta H7.
cut (0 < (b - c) / 2).
intro; cut (Rmin (delta / 2) ((b - c) / 2) <> 0).
intro; cut (Rabs (Rmin (delta / 2) ((b - c) / 2)) < delta).
intro.
assert (H11 := H7 (Rmin (delta / 2) ((b - c) / 2)) H9 H10).
cut (0 < Rmin (delta / 2) ((b - c) / 2)).
intro; cut (a < c + Rmin (delta / 2) ((b - c) / 2)).
intro; cut (c + Rmin (delta / 2) ((b - c) / 2) < b).
intro; assert (H15 := H1 (c + Rmin (delta / 2) ((b - c) / 2)) H13 H14).
cut
((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) /
Rmin (delta / 2) ((b - c) / 2) <= 0).
intro; cut (- l < 0).
intro; unfold Rminus in H11.
cut
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2) + - l < 0).
intro;
cut
(Rabs
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2) + - l) < l / 2).
unfold Rabs;
case
(Rcase_abs
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2) + - l)) as [Hlt|Hge].
replace
(-
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2) + - l)) with
(l +
-
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2))).
intro;
generalize
(Rplus_lt_compat_l (- l)
(l +
-
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2))) (l / 2) H19);
repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
rewrite Rplus_0_l; replace (- l + l / 2) with (- (l / 2)).
intro;
generalize
(Ropp_lt_gt_contravar
(-
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2))) (- (l / 2)) H20);
repeat rewrite Ropp_involutive; intro;
generalize
(Rlt_trans 0 (l / 2)
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2)) H6 H21); intro;
elim
(Rlt_irrefl 0
(Rlt_le_trans 0
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2)) 0 H22 H16)).
pattern l at 2; rewrite double_var.
ring.
ring.
intro.
assert
(H20 :=
Rge_le
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2) + - l) 0 Hge).
elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)).
assumption.
rewrite <- Ropp_0;
replace
((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
Rmin (delta / 2) ((b + - c) / 2) + - l) with
(-
(l +
-
((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) /
Rmin (delta / 2) ((b + - c) / 2)))).
apply Ropp_gt_lt_contravar;
change
(0 <
l +
-
((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) /
Rmin (delta / 2) ((b + - c) / 2))); apply Rplus_lt_le_0_compat;
[ assumption
| rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption ].
unfold Rminus; ring.
rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
replace
((f (c + Rmin (delta / 2) ((b - c) / 2)) - f c) /
Rmin (delta / 2) ((b - c) / 2)) with
(-
((f c - f (c + Rmin (delta / 2) ((b - c) / 2))) /
Rmin (delta / 2) ((b - c) / 2))).
rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge;
unfold Rdiv; apply Rmult_le_pos;
[ generalize
(Rplus_le_compat_r (- f (c + Rmin (delta * / 2) ((b - c) * / 2)))
(f (c + Rmin (delta * / 2) ((b - c) * / 2))) (
f c) H15); rewrite Rplus_opp_r; intro; assumption
| left; apply Rinv_0_lt_compat; assumption ].
unfold Rdiv.
rewrite <- Ropp_mult_distr_l_reverse.
repeat rewrite <- (Rmult_comm (/ Rmin (delta * / 2) ((b - c) * / 2))).
apply Rmult_eq_reg_l with (Rmin (delta * / 2) ((b - c) * / 2)).
repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_r_sym.
repeat rewrite Rmult_1_l.
ring.
red; intro.
unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
red; intro.
unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
assert (H14 := Rmin_r (delta / 2) ((b - c) / 2)).
assert
(H15 :=
Rplus_le_compat_l c (Rmin (delta / 2) ((b - c) / 2)) ((b - c) / 2) H14).
apply Rle_lt_trans with (c + (b - c) / 2).
assumption.
apply Rmult_lt_reg_l with 2.
prove_sup0.
replace (2 * (c + (b - c) / 2)) with (c + b).
replace (2 * b) with (b + b).
apply Rplus_lt_compat_r; assumption.
ring.
unfold Rdiv; rewrite Rmult_plus_distr_l.
repeat rewrite (Rmult_comm 2).
rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
rewrite Rmult_1_r.
ring.
discrR.
apply Rlt_trans with c.
assumption.
pattern c at 1; rewrite <- (Rplus_0_r c); apply Rplus_lt_compat_l;
assumption.
cut (0 < delta / 2).
intro;
apply
(Rmin_stable_in_posreal (mkposreal (delta / 2) H12)
(mkposreal ((b - c) / 2) H8)).
unfold Rdiv; apply Rmult_lt_0_compat;
[ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
unfold Rabs; case (Rcase_abs (Rmin (delta / 2) ((b - c) / 2))) as [Hlt|Hge].
cut (0 < delta / 2).
intro.
generalize
(Rmin_stable_in_posreal (mkposreal (delta / 2) H10)
(mkposreal ((b - c) / 2) H8)); simpl; intro;
elim (Rlt_irrefl 0 (Rlt_trans 0 (Rmin (delta / 2) ((b - c) / 2)) 0 H11 Hlt)).
unfold Rdiv; apply Rmult_lt_0_compat;
[ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
apply Rle_lt_trans with (delta / 2).
apply Rmin_l.
unfold Rdiv; apply Rmult_lt_reg_l with 2.
prove_sup0.
rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
rewrite Rmult_1_l.
replace (2 * delta) with (delta + delta).
pattern delta at 2; rewrite <- (Rplus_0_r delta);
apply Rplus_lt_compat_l.
rewrite Rplus_0_r; apply (cond_pos delta).
symmetry ; apply double.
discrR.
cut (0 < delta / 2).
intro;
generalize
(Rmin_stable_in_posreal (mkposreal (delta / 2) H9)
(mkposreal ((b - c) / 2) H8)); simpl;
intro; red; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
unfold Rdiv; apply Rmult_lt_0_compat;
[ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
unfold Rdiv; apply Rmult_lt_0_compat.
generalize (Rplus_lt_compat_r (- c) c b H0); rewrite Rplus_opp_r; intro;
assumption.
apply Rinv_0_lt_compat; prove_sup0.
elim H2; intro.
symmetry ; assumption.
generalize (derivable_derive f c pr); intro; elim H4; intros l H5.
rewrite H5 in H3; generalize (derive_pt_eq_1 f c l pr H5); intro;
cut (0 < - (l / 2)).
intro; elim (H6 (- (l / 2)) H7); intros delta H9.
cut (0 < (c - a) / 2).
intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) < 0).
intro; cut (Rmax (- (delta / 2)) ((a - c) / 2) <> 0).
intro; cut (Rabs (Rmax (- (delta / 2)) ((a - c) / 2)) < delta).
intro; generalize (H9 (Rmax (- (delta / 2)) ((a - c) / 2)) H11 H12); intro;
cut (a < c + Rmax (- (delta / 2)) ((a - c) / 2)).
cut (c + Rmax (- (delta / 2)) ((a - c) / 2) < b).
intros; generalize (H1 (c + Rmax (- (delta / 2)) ((a - c) / 2)) H15 H14);
intro;
cut
(0 <=
(f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) /
Rmax (- (delta / 2)) ((a - c) / 2)).
intro; cut (0 < - l).
intro; unfold Rminus in H13;
cut
(0 <
(f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
Rmax (- (delta / 2)) ((a + - c) / 2) + - l).
intro;
cut
(Rabs
((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
Rmax (- (delta / 2)) ((a + - c) / 2) + - l) <
- (l / 2)).
unfold Rabs;
case
(Rcase_abs
((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
Rmax (- (delta / 2)) ((a + - c) / 2) + - l)) as [Hlt|Hge].
elim
(Rlt_irrefl 0
(Rlt_trans 0
((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
Rmax (- (delta / 2)) ((a + - c) / 2) + - l) 0 H19 Hlt)).
intros;
generalize
(Rplus_lt_compat_r l
((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
Rmax (- (delta / 2)) ((a + - c) / 2) + - l) (
- (l / 2)) H20); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l;
rewrite Rplus_0_r; replace (- (l / 2) + l) with (l / 2).
cut (l / 2 < 0).
intros;
generalize
(Rlt_trans
((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21);
intro;
elim
(Rlt_irrefl 0
(Rle_lt_trans 0
((f (c + Rmax (- (delta / 2)) ((a - c) / 2)) - f c) /
Rmax (- (delta / 2)) ((a - c) / 2)) 0 H17 H23)).
rewrite <- (Ropp_involutive (l / 2)); rewrite <- Ropp_0;
apply Ropp_lt_gt_contravar; assumption.
pattern l at 3; rewrite double_var.
ring.
assumption.
apply Rplus_le_lt_0_compat; assumption.
rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
unfold Rdiv;
replace
((f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) *
/ Rmax (- (delta * / 2)) ((a - c) * / 2)) with
(- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) *
/ - Rmax (- (delta * / 2)) ((a - c) * / 2)).
apply Rmult_le_pos.
generalize
(Rplus_le_compat_l (- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)))
(f (c + Rmax (- (delta * / 2)) ((a - c) * / 2))) (
f c) H16); rewrite Rplus_opp_l;
replace (- (f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c)) with
(- f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) + f c).
intro; assumption.
ring.
left; apply Rinv_0_lt_compat; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar;
assumption.
unfold Rdiv.
rewrite <- Ropp_inv_permute.
rewrite Rmult_opp_opp.
reflexivity.
unfold Rdiv in H11; assumption.
generalize (Rplus_lt_compat_l c (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H10);
rewrite Rplus_0_r; intro; apply Rlt_trans with c;
assumption.
generalize (RmaxLess2 (- (delta / 2)) ((a - c) / 2)); intro;
generalize
(Rplus_le_compat_l c ((a - c) / 2) (Rmax (- (delta / 2)) ((a - c) / 2)) H14);
intro; apply Rlt_le_trans with (c + (a - c) / 2).
apply Rmult_lt_reg_l with 2.
prove_sup0.
replace (2 * (c + (a - c) / 2)) with (a + c).
rewrite double.
apply Rplus_lt_compat_l; assumption.
field; discrR.
assumption.
unfold Rabs; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))) as [Hlt|Hge].
generalize (RmaxLess1 (- (delta / 2)) ((a - c) / 2)); intro;
generalize
(Ropp_le_ge_contravar (- (delta / 2)) (Rmax (- (delta / 2)) ((a - c) / 2))
H12); rewrite Ropp_involutive; intro;
generalize (Rge_le (delta / 2) (- Rmax (- (delta / 2)) ((a - c) / 2)) H13);
intro; apply Rle_lt_trans with (delta / 2).
assumption.
apply Rmult_lt_reg_l with 2.
prove_sup0.
unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
rewrite <- Rinv_r_sym.
rewrite Rmult_1_l; rewrite double.
pattern delta at 2; rewrite <- (Rplus_0_r delta);
apply Rplus_lt_compat_l; rewrite Rplus_0_r; apply (cond_pos delta).
discrR.
cut (- (delta / 2) < 0).
cut ((a - c) / 2 < 0).
intros;
generalize
(Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13)
(mknegreal ((a - c) / 2) H12)); simpl;
intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 Hge);
intro;
elim
(Rlt_irrefl 0
(Rle_lt_trans 0 (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H15 H14)).
rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
assumption.
unfold Rdiv.
rewrite <- Ropp_mult_distr_l_reverse.
rewrite (Ropp_minus_distr a c).
reflexivity.
rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv;
apply Rmult_lt_0_compat;
[ apply (cond_pos delta)
| assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
red; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
cut ((a - c) / 2 < 0).
intro; cut (- (delta / 2) < 0).
intro;
apply
(Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H11)
(mknegreal ((a - c) / 2) H10)).
rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv;
apply Rmult_lt_0_compat;
[ apply (cond_pos delta)
| assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
assumption.
unfold Rdiv.
rewrite <- Ropp_mult_distr_l_reverse.
rewrite (Ropp_minus_distr a c).
reflexivity.
unfold Rdiv; apply Rmult_lt_0_compat;
[ generalize (Rplus_lt_compat_r (- a) a c H); rewrite Rplus_opp_r; intro;
assumption
| assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
replace (- (l / 2)) with (- l / 2).
unfold Rdiv; apply Rmult_lt_0_compat.
rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ].
unfold Rdiv; apply Ropp_mult_distr_l_reverse.
Qed.

Theorem deriv_minimum :
forall f (a b c:R) (pr:derivable_pt f c),
a < c ->
c < b ->
(forall x:R, a < x -> x < b -> f c <= f x) -> derive_pt f c pr = 0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.deriv_minimum".
intros.
rewrite <- (Ropp_involutive (derive_pt f c pr)).
apply Ropp_eq_0_compat.
rewrite <- (derive_pt_opp f c pr).
cut (forall x:R, a < x -> x < b -> (- f)%F x <= (- f)%F c).
intro.
apply (deriv_maximum (- f)%F a b c (derivable_pt_opp _ _ pr) H H0 H2).
intros; unfold opp_fct; apply Ropp_ge_le_contravar; apply Rle_ge.
apply (H1 x H2 H3).
Qed.

Theorem deriv_constant2 :
forall f (a b c:R) (pr:derivable_pt f c),
a < c ->
c < b -> (forall x:R, a < x -> x < b -> f x = f c) -> derive_pt f c pr = 0.
Proof. hammer_hook "Ranalysis1" "Ranalysis1.deriv_constant2".
intros.
eapply deriv_maximum with a b; try assumption.
intros; right; apply (H1 x H2 H3).
Qed.

Lemma nonneg_derivative_0 :
forall f (pr:derivable f),
increasing f -> forall x:R, 0 <= derive_pt f x (pr x).
Proof. hammer_hook "Ranalysis1" "Ranalysis1.nonneg_derivative_0".
intros; unfold increasing in H.
assert (H0 := derivable_derive f x (pr x)).
elim H0; intros l H1.
rewrite H1; case (Rtotal_order 0 l); intro.
left; assumption.
elim H2; intro.
right; assumption.
assert (H4 := derive_pt_eq_1 f x l (pr x) H1).
cut (0 < - (l / 2)).
intro; elim (H4 (- (l / 2)) H5); intros delta H6.
cut (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta).
intro; decompose [and] H7; intros; generalize (H6 (delta / 2) H8 H11);
cut (0 <= (f (x + delta / 2) - f x) / (delta / 2)).
intro; cut (0 <= (f (x + delta / 2) - f x) / (delta / 2) - l).
intro; unfold Rabs;
case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)) as [Hlt|Hge].
elim
(Rlt_irrefl 0
(Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 H12 Hlt)).
intros;
generalize
(Rplus_lt_compat_r l ((f (x + delta / 2) - f x) / (delta / 2) - l)
(- (l / 2)) H13); unfold Rminus;
replace (- (l / 2) + l) with (l / 2).
rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; intro;
generalize
(Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) (l / 2) H9 H14);
intro; cut (l / 2 < 0).
intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (l / 2) 0 H15 H16)).
rewrite <- Ropp_0 in H5;
generalize (Ropp_lt_gt_contravar (-0) (- (l / 2)) H5);
repeat rewrite Ropp_involutive; intro; assumption.
pattern l at 3; rewrite double_var.
ring.
unfold Rminus; apply Rplus_le_le_0_compat.
unfold Rdiv; apply Rmult_le_pos.
cut (x <= x + delta * / 2).
intro; generalize (H x (x + delta * / 2) H12); intro;
generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H13);
rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
left; assumption.
left; apply Rinv_0_lt_compat; assumption.
left; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
unfold Rdiv; apply Rmult_le_pos.
cut (x <= x + delta * / 2).
intro; generalize (H x (x + delta * / 2) H9); intro;
generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H12);
rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
left; assumption.
left; apply Rinv_0_lt_compat; assumption.
split.
unfold Rdiv; apply prod_neq_R0.
generalize (cond_pos delta); intro; red; intro H9; rewrite H9 in H7;
elim (Rlt_irrefl 0 H7).
apply Rinv_neq_0_compat; discrR.
split.
unfold Rdiv; apply Rmult_lt_0_compat;
[ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
replace (Rabs (delta / 2)) with (delta / 2).
unfold Rdiv; apply Rmult_lt_reg_l with 2.
prove_sup0.
rewrite (Rmult_comm 2).
rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
rewrite Rmult_1_r.
rewrite double.
pattern (pos delta) at 1; rewrite <- Rplus_0_r.
apply Rplus_lt_compat_l; apply (cond_pos delta).
symmetry ; apply Rabs_right.
left; change (0 < delta / 2); unfold Rdiv;
apply Rmult_lt_0_compat;
[ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse;
apply Rmult_lt_0_compat.
apply Rplus_lt_reg_l with l.
unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r; assumption.
apply Rinv_0_lt_compat; prove_sup0.
Qed.