Require Import List Setoid Classes.RelationClasses Arith FunctionalExtensionality ProofIrrelevance.
Require Export Database.
Require Import Common.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

(** * Morphisms between database schemas *)
Section RowTypeMorphisms.
  (** A [RowTypeMorphism r1 r2] is a way of assigning columns of [r1]
      to columns of [r2].  We require that the types of the columns be
      the same. *)

  Inductive RowTypeMorphism : RowType -> RowType -> Type :=
  | RTMNil : forall toTs, RowTypeMorphism nil toTs
  | RTMCons : forall T fromTs toTs,
                Column T toTs
                -> RowTypeMorphism fromTs toTs
                -> RowTypeMorphism (T :: fromTs) toTs.

  Fixpoint ColumnListOfRowTypeMorphism r1 r2 (m : RowTypeMorphism r1 r2) : ColumnList r2 r1
    := match m with
           | RTMNil ts => CNil ts
           | RTMCons T fromTs toTs c m' => @CCons T toTs fromTs c (ColumnListOfRowTypeMorphism m')
         end.

  Fixpoint RowTypeMorphismOfColumnList r1 r2 (m : ColumnList r1 r2) : RowTypeMorphism r2 r1
    := match m with
         | CNil ts => RTMNil ts
         | CCons T fromTs toTs c m' => @RTMCons T toTs fromTs c (RowTypeMorphismOfColumnList m')
       end.

  Global Coercion ColumnListOfRowTypeMorphism : RowTypeMorphism >-> ColumnList.
  Global Coercion RowTypeMorphismOfColumnList : ColumnList >-> RowTypeMorphism.

  Lemma RowTypeMorphism_ColumnList_iso r1 r2 (m : RowTypeMorphism r1 r2)
  : ((m : ColumnList _ _) : RowTypeMorphism _ _) = m.
    induction m; simpl; try rewrite IHm; reflexivity.
  Qed.

  Lemma ColumnList_RowTypeMorphism_iso r1 r2 (m : ColumnList r1 r2)
  : ((m : RowTypeMorphism _ _) : ColumnList _ _) = m.
    induction m; simpl; try rewrite IHm; reflexivity.
  Qed.
End RowTypeMorphisms.

Section ListIndex.
  Variable T : Type.

  Inductive ListIndex : list T -> Type :=
  | ListFirst : forall x l, ListIndex (x :: l)
  | ListNext : forall x l, ListIndex l -> ListIndex (x :: l).

  Fixpoint NatOfListIndex l (i : ListIndex l) : { n : nat | n < length l }
    := match i in (ListIndex l0) return {n : nat | n < length l0} with
         | ListFirst _ _
           => exist _ 0 (lt_0_Sn _)
         | ListNext x l0 i0
           => exist (fun n : nat => n < length (x :: l0))
                    (S (proj1_sig (@NatOfListIndex l0 i0)))
                    (lt_n_S _ _ (proj2_sig (@NatOfListIndex l0 i0)))
       end.

   Fixpoint ListIndexOfNat l n (H : n < length l) {struct n} : ListIndex l
     := match l as l return (n < length l -> ListIndex l) with
          | nil => fun H0 => match lt_n_0 n H0 with end
          | t :: l0
            => match
              n as n return (n < length (t :: l0) -> ListIndex (t :: l0))
            with
              | 0 => fun _ => ListFirst t l0
              | S n0 =>
                fun H1 =>
                  ListNext t
                           (@ListIndexOfNat l0 n0 (lt_S_n _ _ H1))
            end
        end H.

   Global Arguments ListIndexOfNat : clear implicits.

   Local Hint Extern 0 (@eq ?T _ _) => match type of T with Prop => apply proof_irrelevance end.
   Local Hint Extern 2 => apply f_equal.
   Local Hint Extern 1 => exfalso; eapply lt_n_0.

   Local Ltac t :=
     repeat match goal with
               | _ => intro
               | _ => progress simpl in *
               | _ => progress trivial
               | _ => progress destruct_to_empty_set_in_match
               | _ => progress eauto
               | [ |- appcontext[@ListIndexOfNat _ _ (?f ?x)] ] => generalize (f x); intro
               | [ H : _ |- _ ] => erewrite <- H; solve [ eauto ]
               | _ => apply f_equal
             end.

  Lemma ListIndex_iso_1 l
  : forall i H, @ListIndexOfNat l (proj1_sig (NatOfListIndex i)) H = i.
    induction i; t.
  Qed.

  Lemma ListIndex_iso_2 l
  : forall n H, proj1_sig (NatOfListIndex (@ListIndexOfNat l n H)) = n.
    intros n.
    revert l.
    induction n; t;
    destruct l; t.
  Qed.
End ListIndex.

Section SyntacticalListMap.
  Variables T1 T2 : Type.
  Inductive SyntacticalListMap : list T1 -> list T2 -> Type :=
  | SLMNil : forall l2, SyntacticalListMap nil l2
  | SLMCons : forall t1 l1 l2,
                ListIndex l2
                -> SyntacticalListMap l1 l2
                -> SyntacticalListMap (t1 :: l1) l2.

  Fixpoint SyntacticalListMapOfSemanticalListMap l1 l2 {struct l1}
  : ({ n : nat | n < length l1 } -> { n : nat | n < length l2 })
    -> SyntacticalListMap l1 l2
    := match
        l1 as l1
        return
        (({n : nat | n < length l1} -> {n : nat | n < length l2}) -> SyntacticalListMap l1 l2)
      with
        | nil => fun _ => SLMNil l2
        | t :: l3 =>
          fun f =>
            SLMCons
              t
              (ListIndexOfNat l2 _ (proj2_sig (f (exist _ 0 (lt_0_Sn (length l3))))))
              (@SyntacticalListMapOfSemanticalListMap
                 l3
                 l2
                 (fun nH =>
                    f (exist _ (S (proj1_sig nH)) (lt_n_S _ _ (proj2_sig nH)))))
      end.

  Fixpoint SemanticalListMapOfSyntacticalListMap l1 l2 (m : SyntacticalListMap l1 l2)
  : { n : nat | n < length l1 } -> { n : nat | n < length l2 }
    := match
        m in (SyntacticalListMap l1 l2)
        return ({n : nat | n < length l1} -> {n : nat | n < length l2})
      with
        | SLMNil _ => fun nH0 => match lt_n_0 _ (proj2_sig nH0) with end
        | SLMCons t1 l1' l2' l m0 =>
          fun nH =>
            match nH with
              | exist 0 _ => NatOfListIndex l
              | exist (S n') H =>
                @SemanticalListMapOfSyntacticalListMap l1' l2' m0
                                                       (exist _ n' (lt_S_n _ _ H))
            end
      end.

   Local Hint Extern 0 (@eq ?T _ _) => match type of T with Prop => apply proof_irrelevance end.
   Local Hint Extern 2 => apply f_equal.
   Local Hint Extern 1 => exfalso; eapply lt_n_0.
   Local Hint Extern 0 => apply ListIndex_iso_1.

   Local Ltac t :=
     repeat match goal with
               | _ => intro
               | _ => progress simpl in *
               | _ => progress trivial
               | _ => progress destruct_to_empty_set_in_match
               | _ => progress eauto
               | [ |- appcontext[@ListIndexOfNat _ _ (?f ?x)] ] => generalize (f x); intro
               | [ H : _ |- _ ] => erewrite <- H; solve [ eauto ]
               | [ |- appcontext[match ?E with _ => _ end] ] => progress destruct E
               | _ => apply f_equal
               | _ => progress (etransitivity; try eassumption; [])
               | _ => apply functional_extensionality_dep
               | _ => solve [ simpl_eq; trivial ]
               | _ => simpl_eq; rewrite ListIndex_iso_2
               | _ => apply f_equal2
             end.

  Lemma SemanticalListMapOfSyntacticalListMapOfSemanticalListMap_id l1 l2 m
  : @SyntacticalListMapOfSemanticalListMap l1 l2 (SemanticalListMapOfSyntacticalListMap m) = m.
    induction m; t.
  Qed.

  Lemma SyntacticalListMapOfSemanticalListMapOfSyntacticalListMap_id l1 l2 f
  : SemanticalListMapOfSyntacticalListMap (@SyntacticalListMapOfSemanticalListMap l1 l2 f) = f.
    revert l2 f.
    induction l1; t.
    rewrite IHl1.
    t.
  Qed.
End SyntacticalListMap.

Section TableMorphisms.
  (** A [TableMorphism m t1 t2] is, given a way [m] of assigning
      columns of [t1] to columns of [t2], a way of assigning each row
      in [t1] to a row in [t2].  We require that the types of the
      columns be the same. *)
  Definition TableMorphism rt1 rt2 (m : RowTypeMorphism rt1 rt2)
  : Table rt1 -> Table rt2 -> Type
    := @SyntacticalListMap _ _.
End TableMorphisms.

Section RowMorphisms.
  (** We can perform a pull-back along a RowTypeMorphism. *)

End RowMorphisms.


(* A strange way to specify addition. *)

Require Import Omega.

Inductive added: nat -> nat -> nat -> Prop :=
| add_z: added 0 0 0
| add_l: forall m n r, added m n r -> added (S m) n (S r)
| add_r: forall m n r, added m n r -> added m (S n) (S r).

Hint Constructors added.

Lemma added_r:
  forall r, added 0 r r.
Proof.

Qed.

Lemma added_plus:
  forall m n r, added m n r -> m + n = r.
Proof.

Qed.

Lemma plus_added:
  forall m n r, m + n = r -> added m n r.
Proof.

Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.X2448.Karatsuba.C64.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import A1_Plan A2_Orientation A4_Droite .
Require Import B7_Tactics .
Require Import E4_Tactics .
Require Import G1_Angles .
Require Import I2_Supplement I3_OpposedAngles .
Require Import J1_MidLine J2_MidPoint .
Require Import K1_RightAngle .
Require Import L6_Tactics .
Require Import M1_SuperImposedLines M3_SecantLines.

Section PERPENDICULAR_LINES.

Inductive Perpendicular (l1 l2 : Line) : Prop :=
	| PerpRightAngle : forall A B C : Point, RightAngle A B C ->
				OnLine l1 A -> OnLine l1 B ->
				OnLine l2 B -> OnLine l2 C ->
				Perpendicular l1 l2.

Lemma PerpendicularSym : forall l1 l2 : Line,
	Perpendicular l1 l2 -> Perpendicular l2 l1.
Proof.
	intros; inversion H.
	apply (PerpRightAngle l2 l1 C B A); immediate11.
Qed.

Lemma EqEqPerpendicular : forall l1 l2 l3 l4 : Line,
	EqLine l1 l2 ->
	EqLine l3 l4 ->
	Perpendicular l1 l3 ->
	Perpendicular l2 l4.
Proof.
	intros.
	inversion H1.
	apply (PerpRightAngle l2 l4 A B C).
	 immediate11.
	 apply (EqLineOnLine l1); immediate11.
	 apply (EqLineOnLine l1); immediate11.
	 apply (EqLineOnLine l3); immediate11.
	 apply (EqLineOnLine l3); immediate11.
Qed.

Lemma PerpendicularSecant : forall l1 l2 : Line,
	Perpendicular l1 l2 -> SecantLines l1 l2.
Proof.
	intros; inversion H.
	apply (TwoPointsSecantLine l1 l2 B A).
	 immediate11.
	 immediate11.
	 immediate11.
	 intro.
	   assert (Collinear A B C).
	  step11 l2.
	  unfold RightAngle in H0.
	    assert (Collinear Uu Oo Vv).
	   step11 H0.
	   assert (Clockwise Oo Vv Uu).
	    immediate11.
	    contradict1 H7 H8.
Qed.

Definition PerpendicularPoint : forall l1 l2 : Line,
	Perpendicular l1 l2 -> Point.
Proof.
	intros.
	setInterLinesPoint4 l1 l2 ipattern:(M).
	 apply PerpendicularSecant; immediate11.
	 exact M.
Defined.

Lemma PerpendicularPointOnLine1 : forall l1 l2 : Line, forall Hp : Perpendicular l1 l2,
	OnLine l1 (PerpendicularPoint l1 l2 Hp).
Proof.
	intros.
	unfold PerpendicularPoint in |- *.
	immediate11.
Qed.

Lemma PerpendicularPointOnLine2 : forall l1 l2 : Line, forall Hp : Perpendicular l1 l2,
	OnLine l2 (PerpendicularPoint l1 l2 Hp).
Proof.
	intros.
	unfold PerpendicularPoint in |- *.
	immediate11.
Qed.

Lemma UniquePerpendicularPoint : forall M : Point, forall d1 d2 : Line, forall Hp : Perpendicular d1 d2,
	OnLine d1 M ->
	OnLine d2 M ->
	M = PerpendicularPoint d1 d2 Hp.
Proof.
	intros; unfold PerpendicularPoint in |- *.
	immediate11.
Qed.

Lemma  PerpendicularRightAngle : forall l1 l2 : Line, forall Hp : Perpendicular l1 l2,
	forall A B : Point,
	A <> PerpendicularPoint l1 l2 Hp ->
	B <> PerpendicularPoint l1 l2 Hp ->
	OnLine l1 A ->
	OnLine l2 B ->
	RightAngle A (PerpendicularPoint l1 l2 Hp) B.
Proof.
	intros.
	inversion Hp.
	assert (B0 = PerpendicularPoint l1 l2 Hp).
	 unfold PerpendicularPoint in |- *.
	   immediate11.
	 rewrite <- H8; rewrite <- H8 in H; rewrite <- H8 in H0.
	   assert (Collinear A A0 B0).
	  step11 l1.
	  assert (Collinear B B0 C).
	   step11 l2.
	   by3SegmentCases1 H9; by3SegmentCases1 H10.
	    from11 H12 (CongruentAngle A B0 C A B0 B).
	     step11 H13.
	       from11 H11 (Between A B0 A0).
	      as11 (Supplement A B0 C A0 B0 C).
	    from11 H13 (CongruentAngle A B0 C A B0 B).
	      step11 H12.
	      from11 H11 (Between A B0 A0).
	     as11 (Supplement A B0 C A0 B0 C).
	    since11 (OpposedAngles B0 A0 C A B).
	     from11 H11 (Between A B0 A0).
	      from11 H13 (Between C B0 B).
	     step11 H3.
	    from11 H12 (CongruentAngle A0 B0 C A B0 B).
	     step11 H11.
	       immediate11.
	     step11 H13.
	    from11 H12 (CongruentAngle A0 B0 C A B0 B).
	      step11 H11.
	    from11 H12 (CongruentAngle A0 B0 B A B0 B).
	      step11 H11.
	      from11 H13 (Between C B0 B).
	     as11 (Supplement A0 B0 B A0 B0 C).
	    from11 H12 (CongruentAngle A0 B0 C A B0 B).
	     step11 H13.
	    from11 H12 (CongruentAngle A0 B0 C A B0 B).
	     step11 H11.
	    from11 H12 (CongruentAngle A0 B0 B A B0 B).
	     step11 H11.
	       from11 H13 (Between C B0 B).
	      as11 (Supplement A0 B0 B A0 B0 C).
Qed.

Lemma  PointsPerpendicularRightAngle : forall A B C : Point, forall l1 l2 : Line,
	Perpendicular l1 l2 ->
	A <> B ->
	C <> B ->
	OnLine l1 A ->
	OnLine l1 B ->
	OnLine l2 B ->
	OnLine l2 C ->
	RightAngle A B C.
Proof.
	intros.
	assert (B = PerpendicularPoint l1 l2 H).
	 apply UniquePerpendicularPoint; immediate11.
	 subst.
	   apply PerpendicularRightAngle; immediate11.
Qed.

Lemma PerpendicularMidLine : forall A B : Point, forall Hab : A <> B,
	Perpendicular (Ruler A B Hab) (MidLine A B Hab).
Proof.
	intros; apply (PerpRightAngle (Ruler A B Hab) (MidLine A B Hab) A  (MidPoint A B Hab) (LineA (MidLine A B Hab))).
	 immediate11.
	 immediate11.
	 since11 (Collinear A B (MidPoint A B Hab)).
	 immediate11.
	 immediate11.
Qed.

End PERPENDICULAR_LINES.


Require Import BaseLists.

(** *** Filter *)

Section Filter.
  Variable X : Type.
  Implicit Types (x y: X) (A B C: list X) (p q: X -> bool).

  (* Fixpoint filter p A : list X := *)
  (*   match A with *)
  (*   | nil => nil *)
  (*   | x::A' => if p x then x :: filter p A' else filter p A' *)
  (*   end. *)

  Lemma in_filter_iff x p A :
    x el filter p A <-> x el A /\ p x.
  Proof.
    induction A as [|y A]; cbn.
    - tauto.
    - destruct (p y) eqn:E; cbn;
        rewrite IHA; intuition; subst; auto.
      destruct (p x); auto.
  Qed.

  Lemma filter_incl p A :
    filter p A <<= A.
  Proof.
    intros x D. apply in_filter_iff in D. apply D.
  Qed.

  Lemma filter_mono p A B :
    A <<= B -> filter p A <<= filter p B.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_id p A :
    (forall x, x el A -> p x) -> filter p A = A.
  Proof.
    intros D.
    induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:E.
      + f_equal; auto.
      + exfalso. apply bool_Prop_false in E. auto.
  Qed.

  Lemma filter_app p A B :
    filter p (A ++ B) = filter p A ++ filter p B.
  Proof.
    induction A as [|y A]; cbn.
    - reflexivity.
    - rewrite IHA. destruct (p y); reflexivity.
  Qed.

  Lemma filter_fst p x A :
    p x -> filter p (x::A) = x::filter p A.
  Proof.
    cbn. destruct (p x); auto.
  Qed.

  Lemma filter_fst' p x A :
    ~ p x -> filter p (x::A) = filter p A.
  Proof.
    cbn. destruct (p x); auto.
  Qed.

  Lemma filter_pq_mono p q A :
    (forall x, x el A -> p x -> q x) -> filter p A <<= filter q A.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_pq_eq p q A :
    (forall x, x el A -> p x = q x) -> filter p A = filter q A.
  Proof.
    intros C; induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:D, (q x) eqn:E.
      + f_equal. auto.
      + exfalso. enough (p x = q x) by congruence. auto.
      + exfalso. enough (p x = q x) by congruence. auto.
      + auto.
  Qed.

  Lemma filter_and p q A :
    filter p (filter q A) = filter (fun x => p x && q x) A.
  Proof.
    induction A as [|x A]; cbn. reflexivity.
    destruct (p x) eqn:E, (q x); cbn;
      try rewrite E; now rewrite IHA.
  Qed.

  Lemma filter_comm p q A :
    filter p (filter q A) = filter q (filter p A).
  Proof.
    rewrite !filter_and. apply filter_pq_eq.
    intros x _. now destruct (p x), (q x).
  Qed.

End Filter.

Lemma filter_map X Y p (f: X -> Y) A :
  filter p (map f A) = map f (filter (fun x => p (f x)) A).
  induction A;cbn. reflexivity. destruct _;cbn; congruence.
Qed.


(**
 ============================================================================
 Project     : Nominal A, AC and C Unification
 File        : C_Unif_Completeness.v
 Authors     : Washington Lu\'is R. de Carvalho Segundo and
               Mauricio Ayala Rinc\'on
               Universidade de Bras\'ilia (UnB) - Brazil
               Group of Theory of Computation

 Description : The formalisation of the theorem of C-unification
               completeness (unif_path_completeness) is the main result
	       of this file. It also contains two preliminary lemmas
	       (equ_sys_compl and unif_step_compl).

 Last Modified On: Sep 17, 2018.
 ============================================================================
*)

Require Export C_Unif_Soundness.

(** Completeness of equ\_sys *)
(**
	The following lemma express the completeness of the reductions
	by the equational system equ_sys. Its proof is done by case
	analysis over equ_sys and uses Lemma equ_sol_preserv.
 *)

Lemma equ_sys_compl  : forall T Sl varSet,
                       valid_triple T ->
                       ~ NF _ (equ_sys varSet) T ->
                       (sol_c Sl T  <-> (exists T', equ_sys varSet T T' /\ sol_c Sl T')).

Proof.
  intros.
  apply equ_sys_neg_NF in H0.
  case H0; clear H0; intros T' H0.

  split~; intro.
  destruct T. destruct T'.
  destruct p. destruct p1. destruct Sl.
  unfold sol_c in H1|-*. simpl in H1|-*.
  destruct H1. destruct H2. destruct H3.

  inverts H0.

  (* equ_sys_refl *)
  exists (c0,s0,p0\(s2~?s2)); simpl.
  repeat split~; intros.
  apply equ_sys_refl; trivial.
  apply H2. apply set_remove_1 in H0. trivial.
  apply H3. apply set_remove_1 in H0. trivial.

  (* equ_sys_Pr *)
  exists (c0,s0,(p0|+(s2~?t0)|+(s3~?t1))\((<|s2,s3|>)~?(<|t0,t1|>))); simpl.
  repeat split~; intros.
  apply equ_sys_Pr; trivial.
  apply H2. apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply set_add_elim in H0. destruct H0. inverts H0. trivial.
  assert (Q:c1|-(<|s2,s3|>)|^s1~c((<|t0,t1|>)|^s1)).
   apply H3; trivial.
  inverts Q.
  apply set_remove_1 in H0. apply set_add_elim in H0.
  destruct H0. inverts H0; trivial.
  apply set_add_elim in H0. destruct H0. inverts H0; trivial.
  apply H3; trivial.

  (* equ_sys_Fc *)
  exists (c0,s0,(p0|+(t~?t'))\(Fc E n t~?Fc E n t')); simpl.
  repeat split~; intros.
  apply equ_sys_Fc; trivial.
  apply H2. apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0; trivial. inverts H0.
  apply set_remove_1 in H0. apply set_add_elim in H0.
  destruct H0. inverts H0.
  assert (Q : c1 |- (Fc E n t)|^s1 ~c ((Fc E n t')|^s1)).
   apply H3; trivial.
  inverts Q; trivial. simpl in H10; omega. simpl in H10; omega.
  false. false.
  apply H3; trivial.

  (* equ_sys_C1 *)
  generalize H6; intro H6'.
  apply H3 in H6'. simpl in H6'. inverts H6'.
  destruct H8. simpl in H0. omega. destruct H0. false.
  simpl in H5. destruct H5; apply H5; trivial.
  exists (c0,s0,(p0|+(s2~?t0)|+(s3~?t1))\
          (Fc 2 n (<|s2,s3|>)~?Fc 2 n (<|t0,t1|>))); simpl.
  repeat split~; intros. apply equ_sys_C1; trivial.
  apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply H2; trivial.
  apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0. inverts H0; trivial.
  apply set_add_elim in H0. destruct H0. inverts H0; trivial.
  apply H3; trivial.
  clear H10.
  exists (c0,s0,(p0|+(s2~?t1)|+(s3~?t0))\
          (Fc 2 n (<|s2,s3|>)~?Fc 2 n (<|t0,t1|>))); simpl.
  repeat split~; intros. apply equ_sys_C2; trivial.
  apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply H2; trivial.
  apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0. inverts H0; trivial.
  apply set_add_elim in H0. destruct H0. inverts H0; trivial.
  apply H3; trivial.

  (* equ_sys_C2 *)
  generalize H6; intro H6'.
  apply H3 in H6'. simpl in H6'. inverts H6'.
  destruct H8. simpl in H0. omega. destruct H0. false.
  simpl in H5. destruct H5; apply H5; trivial.
  exists (c0,s0,(p0|+(s2~?t0)|+(s3~?t1))\
          (Fc 2 n (<|s2,s3|>)~?Fc 2 n (<|t0,t1|>))); simpl.
  repeat split~; intros. apply equ_sys_C1; trivial.
  apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply H2; trivial.
  apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0. inverts H0; trivial.
  apply set_add_elim in H0. destruct H0. inverts H0; trivial.
  apply H3; trivial.
  clear H10.
  exists (c0,s0,(p0|+(s2~?t1)|+(s3~?t0))\
          (Fc 2 n (<|s2,s3|>)~?Fc 2 n (<|t0,t1|>))); simpl.
  repeat split~; intros. apply equ_sys_C2; trivial.
  apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply H2; trivial.
  apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0. inverts H0; trivial.
  apply set_add_elim in H0. destruct H0. inverts H0; trivial.
  apply H3; trivial.

  (* equ_sys_Ab1 *)
  exists (c0,s0,(p0|+(t~?t'))\(([a]^t)~?([a]^t'))); simpl.
  repeat split~; intros.
  apply equ_sys_Ab1; trivial.
  apply H2. apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0; trivial. inverts H0.
  assert (Q : c1 |- ([a]^ t)|^s1 ~c (([a]^ t')|^s1)).
   apply H3; trivial.
  apply set_remove_1 in H0. apply set_add_elim in H0.
  destruct H0. inverts H0. inverts Q; trivial. false.
  apply H3; trivial.

  (* equ_sys_Ab2 *)
  exists (c0,s0,((p0|+(t~?(|[(a,b)]|@t'))|+(a#?t')))\(([a]^t)~?([b]^t'))); simpl.
  repeat split~; intros.
  apply equ_sys_Ab2; trivial.
  apply set_remove_1 in H0.
  assert (Q : c1 |- ([a]^ t)|^s1 ~c (([b]^ t')|^s1)).
   apply H3; trivial.
  apply set_add_elim in H0. destruct H0. inverts H0.
  inverts Q. false. trivial.
  apply set_add_elim in H0. destruct H0. inverts H0.
  apply H2; trivial.
  assert (Q : c1 |- ([a]^ t)|^s1 ~c (([b]^ t')|^s1)).
   apply H3; trivial.
  apply set_remove_1 in H0. apply set_add_elim in H0.
  destruct H0. inverts H0. apply set_add_elim in H0.
  destruct H0. inverts H0. inverts Q. false.
  rewrite subst_perm_comm. trivial.
  apply H3; trivial.

  (* equ_sys_inst *)
  gen_eq s' : (s©(|[(X,(!pi)@t)]|)); intro H11.
  exists (c0,s',((p0\(pi|.X~?t)\(t~?(pi|.X)))|^^(|[(X,(!pi)@t)]|))\cup(c0/?s')); simpl.
  repeat split~; intros.
  apply equ_sys_inst; trivial.

  case H4; clear H4; intros s2 H4.

  assert (Q0 : c1 |- (pi|.X)|^s1 ~c (t|^s1)).
   destruct H12. apply H3; trivial.
   apply c_equiv_sym. apply H3; trivial.

  apply c_equiv_unif in Q0.

  apply set_union_elim in H0. destruct H0.
  apply set_In_subs_remove_problem in H0.
  apply set_In_subs_remove_problem in H0.
  apply set_In_subs in H0. case H0; clear H0; intros u H0.
  destruct H0. destruct u; simpl in H; inverts H0.

  rewrite <- subst_comp_expand.
  apply c_equiv_unif_fresh with (S1:=s1).
  apply subst_sym; trivial. apply H2; trivial.

  apply set_In_subs_fresh_constraints in H0.
  case H0; clear H0; intros Y H0. destruct H0.
  apply H1 in H0. rewrite H5. rewrite H11. clear H1 H2 H3 H5 H12.
  rewrite subst_comp_expand.
  rewrite <- subst_comp_expand with (t:= (([])|.Y)|^ s).
  apply c_equiv_unif_fresh with (S1:=s1). apply subst_sym; trivial.
  rewrite <- subst_comp_expand.
  apply c_equiv_unif_fresh with (S1:=s1); trivial.

  apply subst_trans with (S2:= s © s2).
  apply subst_sym; trivial.
  apply subst_trans with (S2:= s © s © s2).
  apply subst_sym. apply subst_idem. apply H.
  apply subst_assoc. apply subst_cancel_left; trivial.

  case H4; clear H4; intros s2 H4.

  assert (Q0 : c1 |- (pi|.X)|^s1 ~c (t|^s1)).
   destruct H12. apply H3; trivial.
   apply c_equiv_sym. apply H3; trivial.

  apply c_equiv_unif in Q0.

  apply set_union_elim in H0. destruct H0.
  apply set_In_subs_remove_problem in H0.
  apply set_In_subs_remove_problem in H0.
  apply set_In_subs in H0. case H0; clear H0; intros u H0.
  destruct H0. destruct u; simpl in H0; inverts H0.

  rewrite <- 2 subst_comp_expand.
  apply c_equiv_unif_2 with (S1:=s1).
  apply subst_sym; trivial. apply H3; trivial.

  apply equ_subs_fresh in H0. contradiction.

  case H4; clear H4; intros s2 H4.

  assert (Q0 : c1 |- (pi|.X)|^s1 ~c (t|^s1)).
   destruct H12. apply H3; trivial.
   apply c_equiv_sym. apply H3; trivial.

  apply c_equiv_unif in Q0.

  exists s1. rewrite H11.
  apply subst_trans with (S2 := s © s1).
  apply subst_assoc.
  apply subst_cancel_left; trivial.
  apply subst_trans with (S2 := s © (s © s2)).
  apply subst_cancel_left.
  apply subst_sym; trivial.
  apply subst_trans with (S2 := s © s2); trivial.
  apply subst_assoc. apply subst_idem. apply H.

  (* equ_sys_inv *)
  exists (c0,s0,(p0|+((pi++(!pi'))|.X~?([]|.X)))\((pi|.X)~?(pi'|.X))); simpl.
  repeat split~; intros.
  apply equ_sys_inv; trivial.
  apply H2. apply set_remove_1 in H0.
  apply set_add_elim in H0. destruct H0; trivial. inverts H0.
  apply set_remove_1 in H0. apply set_add_elim in H0.
  destruct H0. inverts H0.
  replace (pi ++ (! pi')|.X) with (pi ++ (! pi') @ ([]|.X)).
  rewrite <- perm_comp. apply c_equiv_sym.
  rewrite subst_perm_comm. apply -> c_equiv_pi_inv_side.
  apply c_equiv_sym. rewrite <- subst_perm_comm.
  autorewrite with perm. simpl app. apply H3; trivial.
  autorewrite with perm. simpl. trivial.
  apply H3; trivial.

  case H1; clear H1; intros T'' H1. destruct H1.
  apply equ_sol_preserv with (T':=T'') (varSet:=varSet); trivial.

Qed.

(**  Completeness of unif\_step *)
(**
	If T is a valid triple and it is not a leaf,
	then Sl is a solution for T if, and only if, there exists a triple T' such
	that T reduces to T', by a unif_step, and Sl is also a solution for T'.
	The proof is done by case analysis on the possible reductions from T,
	and uses lemmas fresh_sys_compl, equ_sys_compl and unif_step_preserv.
*)

Lemma unif_step_compl : forall T Sl varSet,
      valid_triple T ->
      ~ leaf varSet T ->
      (sol_c Sl T  <-> (exists T', unif_step varSet T T' /\ sol_c Sl T')).
Proof.
  intros. split~; intro.

  apply unif_step_neg_NF in H0.
  case H0; clear H0; intros T0 H0. inverts H0.
  assert (Q : ~ NF _ (equ_sys varSet) T).
   apply equ_sys_neg_NF. exists T0; trivial.
  apply equ_sys_compl with (Sl := Sl) in Q; trivial.
  apply Q in H1. case H1; clear H1; intros T1 H1. destruct H1.
  exists T1. split~. apply equ_unif_step; trivial.
  generalize H3; intro H3'.
  apply fresh_sys_compl with (Sl:=Sl) in H3'.
  exists T0. split~. apply fresh_unif_step; trivial.
  apply H3'; trivial.

  case H1; clear H1; intros T' H1.
  destruct H1. apply unif_step_preserv with (Sl:=Sl) in H1; trivial.

Qed.

(** Completeness of unif\_path *)
(**
    This is the main result of this file. It establishes
    that the set of solutions for a triple T is equal to the set of
    solutions of the successful leaves. These leaves are gererated
    by the application of the C-unification algorithm to T.

    Formally: Sl is a solution for T, a valid triple, if and only if
    there exists a unification path form T to T', with Sl
    being also a solution for T'. The proof is done by well-founded
    induction in the unif_step_order, and it uses Theorem c_unif_soundness
    and Lemma unif_step_compl.
*)

Theorem unif_path_compl : forall T Sl varSet,
        valid_triple T ->
        (sol_c Sl T <-> exists T', unif_path varSet T T' /\ sol_c Sl T').
Proof.
  intros. split~; intro. gen T. intro T.
  apply well_founded_ind with (R := unif_step_order varSet) (a := T).
  apply unif_step_order_wf.

  intros T0 H0 H1 H2. unfold unif_step_order in H0.
  case (unif_step_NF_dec T0) with (varSet:=varSet); intro H3.

  exists T0. split~. unfold unif_path. split~. apply tr_rf.

  apply unif_step_neg_NF in H3.
  apply unif_step_compl with (Sl := Sl) in H3; trivial.
  generalize H2; intro H2'. apply H3 in H2'.
  clear H3. case H2'; clear H2'; intros T1 H2'.
  destruct H2'. generalize H. intro H'.
  apply H0 in H'; trivial.
  case H'; clear H'; intros T2 H'. destruct H'. destruct H4.
  exists T2. split~. split~.
  apply tr_ms with (t := T1); trivial.
  apply unif_step_valid_preserv with (T:=T0) (varSet:=varSet); trivial.

  case H0; clear H0; intros T' H0. destruct H0.
  apply c_unif_path_soundness with (Sl:=Sl) in H0; trivial.
Qed.


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

Copyright (C) 2007-2016, Inria

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

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

From Coq Require Import Reals.
From Flocq Require Import Raux.

Require Import Stdlib.
Require Import Xreal.

Theorem derivable_imp_defined :
  forall f r d u v,
  f (Xreal r) = Xreal u -> u <> v ->
  derivable_pt_lim (proj_fun v f) r d ->
  locally_true r (fun a => exists w, f (Xreal a) = Xreal w).
Proof.
intros.
(* by continuity ... *)
assert (continuity_pt (proj_fun v f) r).
apply derivable_continuous_pt.
exists d.
exact H1.
clear H1.
(* ... the projected result cannot be the default value ... *)
replace u with (proj_fun v f r) in H0.
destruct (continuity_pt_ne _ _ _ H0 H2) as (delta, (Hdelta, H3)).
exists delta.
split.
exact Hdelta.
intros.
generalize (H3 _ H1).
unfold proj_fun.
(* ... so the result is not NaN *)
case (f (Xreal (r + h))).
intro H4.
elim H4.
apply refl_equal.
intros.
exists r0.
apply refl_equal.
unfold proj_fun.
rewrite H.
apply refl_equal.
Qed.

Theorem derivable_imp_defined_any :
  forall f r d u,
  f (Xreal r) = Xreal u ->
 (forall v, derivable_pt_lim (proj_fun v f) r d) ->
  locally_true r (fun a => exists w, f (Xreal a) = Xreal w).
Proof.
intros.
eapply derivable_imp_defined.
apply H.
apply Rlt_not_eq.
apply Rlt_plus_1.
apply H0.
Qed.

Theorem derivable_imp_defined_any_2 :
  forall f1 f2 r d1 d2 u1 u2,
  f1 (Xreal r) = Xreal u1 ->
  f2 (Xreal r) = Xreal u2 ->
 (forall v, derivable_pt_lim (proj_fun v f1) r d1) ->
 (forall v, derivable_pt_lim (proj_fun v f2) r d2) ->
  locally_true r (fun a =>
    (exists w1, f1 (Xreal a) = Xreal w1) /\
    (exists w2, f2 (Xreal a) = Xreal w2)).
Proof.
intros.
apply locally_true_and.
apply (derivable_imp_defined_any _ _ _ _ H H1).
apply (derivable_imp_defined_any _ _ _ _ H0 H2).
Qed.

Theorem derivable_imp_defined_gt :
  forall f r d u t,
  f (Xreal r) = Xreal u -> (t < u)%R ->
 (forall v, derivable_pt_lim (proj_fun v f) r d) ->
  locally_true r (fun a => exists w, (t < w)%R /\ f (Xreal a) = Xreal w).
Proof.
intros.
apply locally_true_imp with
  (fun a => (exists w, f (Xreal a) = Xreal w) /\ (t < proj_fun 0 f a)%R).
intros x ((w, H2), H3).
exists w.
split.
replace (proj_fun 0 f x) with w in H3.
exact H3.
unfold proj_fun.
rewrite H2.
apply refl_equal.
exact H2.
apply locally_true_and.
eapply derivable_imp_defined_any ; eassumption.
apply continuity_pt_gt.
replace (proj_fun 0 f r) with u.
exact H0.
unfold proj_fun.
rewrite H.
apply refl_equal.
apply derivable_continuous_pt.
exists d.
apply H1.
Qed.

Theorem derivable_imp_defined_lt :
  forall f r d u t,
  f (Xreal r) = Xreal u -> (u < t)%R ->
 (forall v, derivable_pt_lim (proj_fun v f) r d) ->
  locally_true r (fun a => exists w, (w < t)%R /\ f (Xreal a) = Xreal w).
Proof.
intros.
apply locally_true_imp with
  (fun a => (exists w, f (Xreal a) = Xreal w) /\ (proj_fun 0 f a < t)%R).
intros x ((w, H2), H3).
exists w.
split.
replace (proj_fun 0 f x) with w in H3.
exact H3.
unfold proj_fun.
now rewrite H2.
exact H2.
apply locally_true_and.
eapply derivable_imp_defined_any ; eassumption.
apply continuity_pt_lt.
replace (proj_fun 0 f r) with u.
exact H0.
unfold proj_fun.
rewrite H.
apply refl_equal.
apply derivable_continuous_pt.
exists d.
apply H1.
Qed.

Theorem derivable_imp_defined_ne :
  forall f r d u t,
  f (Xreal r) = Xreal u -> (u <> t)%R ->
 (forall v, derivable_pt_lim (proj_fun v f) r d) ->
  locally_true r (fun a => exists w, (w <> t)%R /\ f (Xreal a) = Xreal w).
Proof.
intros.
apply locally_true_imp with
  (fun a => (exists w, f (Xreal a) = Xreal w) /\ (proj_fun 0 f a <> t)%R).
intros x ((w, H2), H3).
exists w.
split.
replace (proj_fun 0 f x) with w in H3.
exact H3.
unfold proj_fun.
rewrite H2.
apply refl_equal.
exact H2.
apply locally_true_and.
eapply derivable_imp_defined_any ; eassumption.
apply continuity_pt_ne.
replace (proj_fun 0 f r) with u.
exact H0.
unfold proj_fun.
rewrite H.
apply refl_equal.
apply derivable_continuous_pt.
exists d.
apply H1.
Qed.

Definition Xderive_pt f x y' :=
  match x, y', f x with
  | Xreal r, Xreal d, Xreal _ => forall v, derivable_pt_lim (proj_fun v f) r d
  | _, Xnan, _ => True
  | _, _, _ => False
  end.

Definition Xderive f f' := forall x, Xderive_pt f x (f' x).

Ltac xtotal_get_spec1 f :=
  match f with
  | Req_bool => Req_bool_spec
  | Rle_bool => Rle_bool_spec
  | Rlt_bool => Rlt_bool_spec
  | is_zero => is_zero_spec
  | is_positive => is_positive_spec
  | is_negative => is_negative_spec
  end.

Ltac xtotal_destruct_xreal v :=
  match v with
  | context [?f ?x] =>
    let r := fresh "r" in
    let X := fresh "X" in
    case_eq v ; [ intros X | intros r X ] ; try rewrite X in *
  | _ =>
    let r := fresh "r" in
    destruct v as [|r]
  end.

Ltac xtotal_aux :=
  trivial ;
  try discriminate ;
  match goal with
  | H: False |- _ => elim H
  (*
  | |- ?v = ?v => apply refl_equal
  | |- True => exact I
  | H: Xreal _ = Xnan |- _ => discriminate H
  | H: Xnan = Xreal _ |- _ => discriminate H
  | H: true = false |- _ => discriminate H
  | H: false = true |- _ => discriminate H
  *)
  | H: ?v = ?v |- _ => clear H
  | H: Xreal _ = Xreal _ |- _ =>
    injection H ; clear H ; intro H
  | H: context [match ?v with Xnan => _ | Xreal _ => _ end] |- _ =>
    xtotal_destruct_xreal v ; try discriminate H ; trivial
  (*| H: match ?v with true => Xnan | false => Xreal _ end = Xreal _ |- _ =>
    (*case_eq v ; intro X ; rewrite X in H ; [ discriminate H | idtac ]*)
    xtotal_destruct_xreal v ; [ discriminate H | idtac ]
  | H: match ?v with true => Xnan | false => Xreal _ end = Xnan |- _ =>
    (*case_eq v ; intro X ; rewrite X in H ; [ idtac | discriminate H ]*)
    xtotal_destruct_xreal v ; [ idtac | discriminate H ]*)
  | H1 : Xderive ?f1 ?f2 , H2 : context [?f2 ?v] |- _ =>
    generalize (H1 v) ; clear H1 ; intro H1 ; unfold Xderive_pt in H1
  | H: ?v = Xreal _ |- _ => rewrite H in *
  | H: ?v = Xnan |- _ => rewrite H in *
  | v: R, H: ?v = _ |- _ =>
    try rewrite H in * ; clear H v
  | v: R, H: _ = ?v |- _ =>
    try rewrite <- H in * ; clear H v
  | H: context [?f ?v] |- _ =>
    let s := xtotal_get_spec1 f in
    let Y := fresh "Y" in
    destruct (s v) as [Y|Y]
  | H: match ?v with true => Xnan | false => Xreal _ end = _ |- _ =>
    let X := fresh "X" in
    case_eq v ; intro X ; rewrite X in H ; try discriminate H
  | |- match ?v with Xnan => _ | Xreal _ => _ end =>
    xtotal_destruct_xreal v
  | |- context [?f ?v] =>
    let s := xtotal_get_spec1 f in
    let Y := fresh "Y" in
    destruct (s v) as [Y|Y]
  end.

Ltac xtotal :=
  unfold Xderive_pt, Xinv', Xdiv', Xsqrt', Xtan', Xln', Xpower_int, Xpower_int', Xmask, Xbind2, Xbind in * ;
  repeat xtotal_aux.

Theorem Xderive_pt_add :
  forall f g f' g' x,
  Xderive_pt f x f' -> Xderive_pt g x g' ->
  Xderive_pt (fun x => Xadd (f x) (g x)) x (Xadd f' g').
Proof.
intros f g f' g' x Hf Hg.
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (plus_fct (proj_fun v f) (proj_fun v g)).
apply locally_true_imp with (2 := derivable_imp_defined_any_2 _ _ _ _ _ _ _ X0 X Hf Hg).
intros x ((w1, Hw1), (w2, Hw2)).
unfold plus_fct, proj_fun.
now rewrite Hw1, Hw2.
now apply derivable_pt_lim_plus.
Qed.

Theorem Xderive_pt_sub :
  forall f g f' g' x,
  Xderive_pt f x f' -> Xderive_pt g x g' ->
  Xderive_pt (fun x => Xsub (f x) (g x)) x (Xsub f' g').
Proof.
intros f g f' g' x Hf Hg.
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (minus_fct (proj_fun v f) (proj_fun v g)).
apply locally_true_imp with (2 := derivable_imp_defined_any_2 _ _ _ _ _ _ _ X0 X Hf Hg).
intros x ((w1, Hw1), (w2, Hw2)).
unfold minus_fct, proj_fun.
now rewrite Hw1, Hw2.
now apply derivable_pt_lim_minus.
Qed.

Theorem Xderive_pt_mul :
  forall f g f' g' x,
  Xderive_pt f x f' -> Xderive_pt g x g' ->
  Xderive_pt (fun x => Xmul (f x) (g x)) x (Xadd (Xmul f' (g x)) (Xmul g' (f x))).
Proof.
intros f g f' g' x Hf Hg.
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (mult_fct (proj_fun v f) (proj_fun v g)).
apply locally_true_imp with (2 := derivable_imp_defined_any_2 _ _ _ _ _ _ _ X0 X Hf Hg).
intros x ((w1, Hw1), (w2, Hw2)).
unfold mult_fct, proj_fun.
now rewrite Hw1, Hw2.
replace r1 with (proj_fun v g r).
replace r3 with (proj_fun v f r).
rewrite (Rmult_comm r0).
now apply derivable_pt_lim_mult.
unfold proj_fun.
now rewrite X0.
unfold proj_fun.
now rewrite X.
Qed.

Theorem Xderive_pt_div :
  forall f g f' g' x,
  Xderive_pt f x f' -> Xderive_pt g x g' ->
  Xderive_pt (fun x => Xdiv (f x) (g x)) x (Xdiv (Xsub (Xmul f' (g x)) (Xmul g' (f x))) (Xmul (g x) (g x))).
Proof.
intros f g f' g' x Hf Hg.
xtotal.
elim Y.
apply Rmult_0_l.
intro v.
apply derivable_pt_lim_eq_locally with (div_fct (proj_fun v f) (proj_fun v g)).
generalize (derivable_imp_defined_any _ _ _ _ X0 Hf).
generalize (derivable_imp_defined_ne _ _ _ _ _ X Y0 Hg).
intros H2 H1.
apply locally_true_imp with (2 := locally_true_and _ _ _ H1 H2).
intros x ((w1, Hw1), (w2, (Hw2a, Hw2b))).
unfold div_fct, proj_fun.
rewrite Hw1, Hw2b.
destruct (is_zero_spec w2).
now elim Hw2a.
apply refl_equal.
replace r1 with (proj_fun v g r).
replace r3 with (proj_fun v f r).
fold (Rsqr (proj_fun v g r)).
apply derivable_pt_lim_div.
apply Hf.
apply Hg.
unfold proj_fun.
now rewrite X.
unfold proj_fun.
now rewrite X0.
unfold proj_fun.
now rewrite X.
Qed.

Theorem Xderive_pt_neg :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xneg (f x)) x (Xneg f').
Proof.
intros f f' x Hf.
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (opp_fct (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf).
intros x (w, Hw).
unfold opp_fct, proj_fun.
now rewrite Hw.
now apply derivable_pt_lim_opp.
Qed.

Theorem Xderive_pt_abs :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xabs (f x)) x (match Xcmp (f x) (Xreal 0) with Xlt => Xneg f' | Xgt => f' | _ => Xnan end).
Proof.
intros f f' x Hf.
xtotal.
revert X.
now case Xcmp.
revert X.
now case Xcmp.
simpl Xcmp in X0.
destruct (Rcompare_spec r1 0) ; try easy.
intro v.
apply derivable_pt_lim_eq_locally with (fun x => Ropp (proj_fun v f x)).
apply locally_true_imp with (2 := derivable_imp_defined_lt _ _ _ _ _ X H Hf).
intros x (w, (Hw1, Hw2)).
unfold proj_fun.
rewrite Hw2.
now rewrite Rabs_left.
inversion X0.
now apply derivable_pt_lim_opp.
intro v.
apply derivable_pt_lim_eq_locally with (proj_fun v f).
apply locally_true_imp with (2 := derivable_imp_defined_gt _ _ _ _ _ X H Hf).
intros x (w, (Hw1, Hw2)).
unfold proj_fun.
rewrite Hw2.
rewrite Rabs_right.
apply refl_equal.
apply Rle_ge.
now apply Rlt_le.
inversion X0.
now rewrite <- H1.
Qed.

Theorem Xderive_pt_inv :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xinv (f x)) x (Xneg (Xdiv f' (Xsqr (f x)))).
Proof.
intros f f' x Hf.
xtotal.
elim Y.
apply Rmult_0_l.
intro v.
apply derivable_pt_lim_eq_locally with (inv_fct (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_ne _ _ _ _ _ X Y0 Hf).
intros x (w, (Hw1, Hw2)).
unfold inv_fct, proj_fun.
rewrite Hw2.
destruct (is_zero_spec w).
now elim Hw1.
apply refl_equal.
apply derivable_pt_lim_eq with (div_fct (fct_cte 1) (proj_fun v f)).
intro x.
unfold div_fct, fct_cte, Rdiv.
apply Rmult_1_l.
replace (- (r0 / Rsqr r1))%R with ((0 * proj_fun v f r - r0 * fct_cte 1 r) / Rsqr (proj_fun v f r))%R.
apply (derivable_pt_lim_div (fct_cte 1)).
apply derivable_pt_lim_const.
apply Hf.
unfold proj_fun.
now rewrite X.
unfold proj_fun, fct_cte.
rewrite X.
now field.
Qed.

Theorem Xderive_pt_sqrt :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xsqrt (f x)) x (Xdiv f' (Xadd (Xsqrt (f x)) (Xsqrt (f x)))).
Proof.
intros f f' x Hf.
xtotal.
intro v.
assert (Hx: (0 < r1)%R).
{ apply Rnot_le_lt; intro Hr1.
  apply Y.
  now rewrite sqrt_neg; [rewrite Rplus_0_r|]. }
apply derivable_pt_lim_eq_locally with (comp sqrt (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_gt _ _ _ _ R0 X Hx Hf).
intros x (w, (Hw1, Hw2)).
unfold comp, proj_fun.
rewrite Hw2.
destruct (is_negative_spec w).
elim (Rlt_not_le _ _ Hw1).
now left.
apply refl_equal.
unfold Rdiv.
rewrite Rmult_comm.
apply derivable_pt_lim_comp.
apply Hf.
unfold proj_fun.
rewrite X.
replace (sqrt r1 + sqrt r1)%R with (2 * sqrt r1)%R by ring.
now apply derivable_pt_lim_sqrt.
Qed.

Theorem Xderive_pt_sin :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xsin (f x)) x (Xmul f' (Xcos (f x))).
Proof.
intros f f' x Hf.
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (comp sin (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf).
intros x (w, Hw).
unfold comp, proj_fun.
now rewrite Hw.
rewrite Rmult_comm.
apply derivable_pt_lim_comp.
apply Hf.
unfold proj_fun.
rewrite X.
apply derivable_pt_lim_sin.
Qed.

Theorem Xderive_pt_cos :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xcos (f x)) x (Xmul f' (Xneg (Xsin (f x)))).
Proof.
intros f f' x Hf.
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (comp cos (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf).
intros x (w, Hw).
unfold comp, proj_fun.
now rewrite Hw.
rewrite Rmult_comm.
apply derivable_pt_lim_comp.
apply Hf.
unfold proj_fun.
rewrite X.
apply derivable_pt_lim_cos.
Qed.

Theorem Xderive_pt_tan :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xtan (f x)) x (Xmul f' (Xadd (Xreal 1) (Xsqr (Xtan (f x))))).
Proof.
intros f f' x Hf.
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (comp tan (proj_fun v f)).
assert (continuity_pt (comp cos (proj_fun v f)) r).
apply derivable_continuous_pt.
exists (- sin (proj_fun v f r) * r0)%R.
unfold derivable_pt_abs.
apply derivable_pt_lim_comp.
apply Hf.
apply derivable_pt_lim_cos.
replace (cos r1) with (comp cos (proj_fun v f) r) in Y.
generalize (derivable_imp_defined_any _ _ _ _ X Hf).
generalize (continuity_pt_ne _ _ R0 Y H).
intros H2 H1.
apply locally_true_imp with (2 := locally_true_and _ _ _ H1 H2).
unfold comp, proj_fun.
intros x ((w, Hw1), Hw2).
rewrite Hw1.
rewrite Hw1 in Hw2.
destruct (is_zero_spec (cos w)).
now elim Hw2.
apply refl_equal.
unfold comp, proj_fun.
now rewrite X.
rewrite Rmult_comm.
apply derivable_pt_lim_comp.
apply Hf.
unfold proj_fun.
rewrite X.
change (sin r1 / cos r1 * (sin r1 / cos r1))%R with (Rsqr (tan r1))%R.
now apply derivable_pt_lim_tan.
Qed.

Theorem Xderive_pt_exp :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xexp (f x)) x (Xmul f' (Xexp (f x))).
Proof.
intros f f' x Hf.
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (comp exp (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf).
intros x (w, Hw).
unfold comp, proj_fun.
now rewrite Hw.
rewrite Rmult_comm.
apply derivable_pt_lim_comp.
apply Hf.
unfold proj_fun.
rewrite X.
apply (derivable_pt_lim_exp r1).
Qed.

Theorem Xderive_pt_ln :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xln (f x)) x (match Xcmp (f x) (Xreal 0) with Xgt => Xdiv f' (f x) | _ => Xnan end).
Proof.
intros f f' x Hf.
xtotal.
revert X.
now case Xcmp.
revert X.
now case Xcmp.
revert X.
now case Xcmp.
revert X0.
now case Xcmp.
revert X0.
now case Xcmp.
simpl Xcmp in X0.
destruct (Rcompare_spec r1 0) ; try easy.
now elim Rle_not_lt with (1 := Y0).
simpl Xcmp in X0.
destruct (Rcompare_spec r1 0) ; try easy.
intro v.
apply derivable_pt_lim_eq_locally with (comp ln (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_gt _ _ _ _ R0 X H Hf).
intros x (w, (Hw1, Hw2)).
unfold comp, proj_fun.
rewrite Hw2.
destruct (is_positive_spec w).
easy.
now elim (Rlt_not_le _ _ Hw1).
injection X0.
clear X0.
intros <-.
unfold Rdiv.
rewrite Rmult_comm.
apply derivable_pt_lim_comp.
apply Hf.
unfold proj_fun.
rewrite X.
now apply derivable_pt_lim_ln.
Qed.

Theorem Xderive_pt_atan :
  forall f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xatan (f x)) x (Xdiv f' (Xadd (Xreal 1) (Xsqr (f x)))).
Proof.
intros f f' x Hf.
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (comp atan (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf).
intros x (w, Hw).
unfold comp, proj_fun.
now rewrite Hw.
unfold Rdiv.
rewrite Rmult_comm.
apply derivable_pt_lim_comp.
apply Hf.
unfold proj_fun.
rewrite X.
rewrite Rsqr_pow2.
apply (derivable_pt_lim_atan r1).
Qed.

Theorem Xderive_pt_power_int :
  forall n f f' x,
  Xderive_pt f x f' ->
  Xderive_pt (fun x => Xpower_int (f x) n) x (Xmul f' (Xmul (Xreal (IZR n)) (Xpower_int (f x) (Z.pred n)))).
Proof.
intros n f f' x Hf.
destruct n as [|n|n].
(* *)
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (comp (fun x => powerRZ x 0) (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf).
intros x (w, Hw).
unfold comp, proj_fun.
now rewrite Hw.
rewrite Rmult_0_l, Rmult_0_r.
unfold comp, proj_fun.
simpl.
apply derivable_pt_lim_const.
(* *)
replace (Xpower_int (f x) (Z.pred (Zpos n))) with (match f x with Xnan => Xnan | Xreal r => Xreal (pow r (pred (nat_of_P n))) end).
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (comp (fun x => pow x (nat_of_P n)) (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf).
intros x (w, Hw).
unfold comp, proj_fun.
now rewrite Hw.
rewrite Rmult_comm.
apply derivable_pt_lim_comp.
apply Hf.
unfold proj_fun.
rewrite X.
rewrite <- (positive_nat_Z n), <- INR_IZR_INZ.
apply derivable_pt_lim_pow_pos.
apply lt_O_nat_of_P.
case (f x).
easy.
intros r.
unfold Xpower_int, Xpower_int', Xbind.
case_eq (Z.pred (Zpos n))%Z.
intros H.
replace (nat_of_P n) with 1.
easy.
apply inj_eq_rev.
rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P.
apply Zsucc_eq_compat in H.
now rewrite <- Zsucc_pred in H.
intros p H.
apply f_equal.
apply f_equal.
apply inj_eq_rev.
rewrite pred_of_minus.
rewrite inj_minus1.
now rewrite <- 2!Zpos_eq_Z_of_nat_o_nat_of_P.
apply lt_le_S.
apply lt_O_nat_of_P.
now case n.
(* *)
replace (Xpower_int (f x) (Z.pred (Zneg n))) with (match f x with Xnan => Xnan | Xreal r => if is_zero r then Xnan else Xreal (/ (pow r (S (nat_of_P n)))) end).
xtotal.
intro v.
apply derivable_pt_lim_eq_locally with (comp (fun x => Rinv (pow x (nat_of_P n))) (proj_fun v f)).
apply locally_true_imp with (2 := derivable_imp_defined_ne _ _ _ _ _ X Y Hf).
intros x (w, (Hw1, Hw2)).
unfold comp, proj_fun.
rewrite Hw2.
now case is_zero_spec.
rewrite Rmult_comm.
apply derivable_pt_lim_comp.
apply Hf.
change (fun x => (/ x ^ nat_of_P n)%R) with (comp Rinv (fun x => pow x (nat_of_P n))).
unfold proj_fun.
rewrite X.
change (IZR (Zneg n)) with (Ropp (IZR (Zpos n))).
rewrite <- positive_nat_Z, <- INR_IZR_INZ.
replace (- INR (nat_of_P n) * / (r1 * r1 ^ nat_of_P n))%R with
  ((0 * r1 ^ (nat_of_P n) - 1 * fct_cte 1 r1) / Rsqr (r1 ^ (nat_of_P n)) * (INR (nat_of_P n) * (r1 ^ pred (nat_of_P n))))%R.
apply derivable_pt_lim_comp.
apply derivable_pt_lim_pow.
apply derivable_pt_lim_eq with (div_fct (fct_cte 1) (fun x => x)).
intros x.
apply Rmult_1_l.
apply derivable_pt_lim_div with (x := (r1 ^ nat_of_P n)%R).
apply derivable_pt_lim_const.
apply derivable_pt_lim_id.
now apply pow_nonzero.
unfold fct_cte.
unfold Rsqr.
pattern (nat_of_P n) at -5 ; replace (nat_of_P n) with (1 + pred (nat_of_P n))%nat.
rewrite pow_add.
field.
refine (conj _ Y).
now apply pow_nonzero.
rewrite pred_of_minus.
apply le_plus_minus_r.
apply lt_le_S.
apply lt_O_nat_of_P.
case (f x).
easy.
intros r.
simpl.
rewrite <- Pplus_one_succ_r.
now rewrite nat_of_P_succ_morphism.
Qed.

Theorem Xderive_pt_partial_fun :
  forall g f f',
 (forall x y, g x = Xreal y -> f x = Xreal y) ->
  forall x,
  Xderive_pt g x f' ->
  Xderive_pt f x f'.
Proof.
intros g f f' Heq x Hg.
assert (Heqx := Heq x).
xtotal.
now assert (H := Heqx _ (refl_equal _)).
intro v.
apply derivable_pt_lim_eq_locally with (2 := Hg v).
apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hg).
intros x (w, Hw).
unfold proj_fun.
rewrite Hw.
now rewrite (Heq _ _ Hw).
Qed.

Theorem Xderive_pt_eq_fun :
  forall g f f',
 (forall x, f x = g x) ->
  forall x,
  Xderive_pt g x f' ->
  Xderive_pt f x f'.
Proof.
intros g f f' Heq x Hg.
apply Xderive_pt_partial_fun with (2 := Hg).
intros.
now rewrite Heq.
Qed.

Theorem Xderive_pt_identity :
  forall x, Xderive_pt (fun x => x) x (Xmask (Xreal 1) x).
Proof.
intros [|x].
exact I.
intro.
apply derivable_pt_lim_id.
Qed.

Theorem Xderive_pt_constant :
  forall v x,
  Xderive_pt (fun _ => Xreal v) x (Xmask (Xreal 0) x).
Proof.
intros v [|x].
exact I.
unfold proj_fun.
intros w.
apply (derivable_pt_lim_const v).
Qed.

Theorem Xderive_MVT :
  forall f f',
  Xderive f f' ->
  forall dom : R -> Prop,
  connected dom ->
 (forall x, dom x -> f' (Xreal x) <> Xnan) ->
  forall m, dom m ->
  forall x, dom x ->
  exists c, dom c /\
  f (Xreal x) = Xadd (f (Xreal m)) (Xmul (f' (Xreal c)) (Xsub (Xreal x) (Xreal m))).
Proof.
intros f f' Hd dom Hdom Hf'.
set (fr := proj_fun 0 f).
set (fr' := proj_fun 0 f').
unfold Xderive, Xderive_pt in Hd.
(* f defined on [a,b] *)
assert (R1: forall x, dom x -> f (Xreal x) = Xreal (fr x)).
intros x Hx.
generalize (Hd (Xreal x)) (Hf' x Hx).
unfold fr, proj_fun at 2.
case (f' (Xreal x)).
intros _ H.
elim H.
apply refl_equal.
case (f (Xreal x)).
intros _ H _.
elim H.
intros r _ _ _.
apply refl_equal.
(* f' defined on [a,b] *)
assert (R2: forall x, dom x -> f' (Xreal x) = Xreal (fr' x)).
intros x Hx.
generalize (Hd (Xreal x)) (Hf' x Hx).
unfold fr', proj_fun at 2.
case (f' (Xreal x)).
intros _ H.
elim H.
apply refl_equal.
intros r _ _.
apply refl_equal.
(* for any u < v *)
assert (H9: forall u v, dom u -> dom v -> (u < v)%R ->
        exists c, dom c /\ f (Xreal v) = Xadd (f (Xreal u)) (Xmul (f' (Xreal c)) (Xsub (Xreal v) (Xreal u)))).
intros u v Hu Hv Huv.
destruct (MVT_cor3 fr fr' u v Huv) as [c [P1 [P2 P3]]].
intros c Hc1 Hc2.
assert (Hc := Hdom _ _ Hu Hv _ (conj Hc1 Hc2)).
generalize (Hd (Xreal c)).
rewrite (R2 _ Hc), (R1 _ Hc).
intro H2.
exact (H2 R0).
exists c.
assert (Hc := Hdom _ _ Hu Hv _ (conj P1 P2)).
split.
exact Hc.
rewrite (R2 _ Hc), (R1 _ Hu), (R1 _ Hv).
simpl.
apply f_equal.
exact P3.
(* . *)
intros m Hm x Hx.
destruct (total_order_T m x) as [[H|H]|H].
now apply (H9 m x).
(* m = x *)
exists m.
split.
exact Hm.
rewrite H, (R1 _ Hx), (R2 _ Hx).
simpl.
apply f_equal.
ring.
(* m > x *)
destruct (H9 x m Hx Hm H) as (c, (Hc, H0)).
exists c.
split.
exact Hc.
rewrite H0.
rewrite (R2 _ Hc), (R1 _ Hx).
simpl.
apply f_equal.
ring.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************
    Proof of Bertrand's conjecture: Misc.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)
From Coq Require Import Arith ArithRing.
From Bertrand Require Export sTactic.

(** Some facts about arithmetics *)

Theorem lt_mult_right : forall x y z t : nat, x < z -> y < t -> x * y < z * t.
Proof.
intros x y z t; case x; case z.
intros H'; Contradict H'; auto with arith.
simpl in |- *; intros n H'; case t; auto with arith.
intros H'0; Contradict H'0; auto with arith.
intros n H'; Contradict H'; auto with arith.
intros n n0 H'; case t.
intros H'0; Contradict H'0; auto with arith.
intros n1 H'0; apply Nat.lt_trans with (m := S n0 * S n1); auto with arith.
rewrite (Nat.mul_comm (S n0)); rewrite (Nat.mul_comm (S n)); auto with arith.
Qed.

Theorem le_mult_right : forall x y : nat, 0 < y -> x <= x * y.
Proof.
intros x y; case y.
intros H'; Contradict H'; auto with arith.
intros n H'; rewrite Nat.mul_comm; simpl in |- *; auto with arith.
Qed.

Lemma lt_minus_O_lt : forall n m : nat, m < n -> 0 < n - m.
Proof.
intros n m H'.
apply Nat.add_lt_mono_l with (p := m).
rewrite (Nat.add_comm m (n - m)).
rewrite Nat.sub_add; auto with arith.
rewrite Nat.add_0_r; auto.
Qed.

Lemma eq_minus : forall a b c : nat, c < a -> a - c = b - c -> a = b.
Proof.
intros a b c H' H'0.
rewrite <- (Nat.sub_add c a); auto with arith.
rewrite <- (Nat.sub_add c b); auto with arith.
apply Nat.lt_le_incl.
apply (Nat.lt_add_lt_sub_r 0).
rewrite <- H'0; auto.
apply lt_minus_O_lt; auto.
Qed.

Lemma eq_minus' :
 forall a b c : nat, c <= a -> c <= b -> a - c = b - c -> a = b.
Proof.
intros.
rewrite <- (Nat.sub_add c a); auto with arith.
rewrite H1.
rewrite Nat.sub_add; auto.
Qed.

Lemma eq_plus : forall a b c : nat, c + a = c + b -> a = b.
Proof.
intros a b c H'.
apply Nat.add_cancel_l with (p := c); auto.
Qed.

Lemma plus_eqO : forall x y : nat, x + y = 0 -> x = 0.
Proof.
intros x; case x; simpl in |- *; auto.
intros x' y; case y; simpl in |- *; intros; discriminate.
Qed.

Lemma mult_eqO : forall a b : nat, a * b = 0 -> a = 0 \/ b = 0.
Proof.
intros x; case x; simpl in |- *; auto.
intros x' y; case y; simpl in |- *; auto; intros; discriminate.
Qed.

Lemma mult_SO : forall x y : nat, x * y = 1 -> x = 1.
Proof.
intros x; case x; simpl in |- *; auto.
intros x' y; case y; simpl in |- *; auto.
rewrite Nat.mul_comm; intros; discriminate.
intros n H'; case (mult_eqO x' (S n)).
apply plus_eqO with (y := n).
rewrite Nat.add_comm; apply eq_add_S; auto.
intros H'0; rewrite H'0; auto.
intros; discriminate.
Qed.

Lemma mult_eq_Sn : forall a b : nat, 0 < b -> a * b = b -> a = 1.
Proof.
intros a b; case b; simpl in |- *; auto.
intros H; Contradict H; auto with arith.
case a; simpl in |- *; auto.
intros; discriminate.
intros b' a' H' H'1; case (mult_eqO b' (S a')); auto.
apply Nat.add_cancel_l with (p := S a'); simpl in |- *; rewrite <- plus_n_O; auto.
intros H'0; Contradict H'0; auto; rewrite H'0; auto with arith.
Qed.

Theorem simpl_mult_r : forall n m p : nat, 0 < n -> m * n = p * n -> m = p.
Proof.
intros n m; elim m; simpl in |- *; auto.
intros p H' H'0; case (mult_eqO p n); auto.
intros H'1; Contradict H'; auto; rewrite H'1; auto with arith.
intros m' H' p; case p; simpl in |- *; auto.
case n; simpl in |- *; try (intros; discriminate); intros H1; Contradict H1;
 auto with arith.
intros p' H'0 H'1.
rewrite (H' p'); auto.
apply Nat.add_cancel_l with (p := n); auto.
Qed.

Lemma eq_mult : forall a b c : nat, c <> 0 -> c * a = c * b -> a = b.
Proof.
intros a b c; case c; auto.
intros H'; case H'; auto.
intros n H' H'0; apply simpl_mult_r with (n := S n);
 repeat rewrite Nat.mul_comm with (m := S n); auto with arith.
Qed.

Lemma le_plus_le : forall a b c d : nat, a <= b -> a + c = b + d -> d <= c.
Proof.
intros.
cut (c = b - a + d).
intros H1; rewrite H1.
auto with arith.
apply Nat.add_cancel_l with (p := a); auto.
rewrite Nat.add_assoc.
rewrite (Nat.add_comm a (b - a)).
rewrite Nat.sub_add; auto.
Qed.

Lemma plus_minus_assoc : forall a b c : nat, b <= a -> a - b + c = a + c - b.
Proof.
simple induction c.
repeat rewrite Nat.add_comm with (m := 0); simpl in |- *; auto with arith.
intros n H0 H1; repeat rewrite <- plus_n_Sm.
rewrite H0; auto with arith.
Qed.

Theorem lt_mult_right_anti : forall x y z : nat, z * x < z * y -> x < y.
Proof.
intros x y z H0; case (Nat.le_gt_cases y x); auto; intros H1.
contradict H0; auto; apply Nat.le_ngt; auto with arith.
Qed.

Theorem mult_lt_bis : forall p q r : nat, 0 < r -> p < q -> r * p < r * q.
Proof.
intros p q r; case r; auto with arith.
Qed.
#[export] Hint Resolve mult_lt_bis: arith.

Theorem lt_O_mult : forall p q : nat, 0 < p -> 0 < q -> 0 < p * q.
Proof.
intros p q H1 H2; inversion H1; inversion H2; simpl in |- *; auto with arith.
Qed.
#[export] Hint Resolve lt_O_mult: arith.

Theorem minus_plus_le :
 forall a b c d : nat, a <= c -> b <= d -> c + d - (a + b) = c - a + (d - b).
Proof.
intros a b c d H H0.
apply Nat.add_sub_eq_l.
apply trans_equal with (a + (c - a) + (b + (d - b))); auto with arith; ring.
Qed.

Theorem minus_O : forall a b : nat, a <= b -> a - b = 0.
Proof.
intros a; elim a; simpl in |- *; auto with arith.
intros a1 Rec b; case b; elim b; auto with arith.
Qed.

Theorem minus_le : forall a b c : nat, a <= b + c -> a - c <= b.
Proof.
intros a b c H; apply (fun p n m : nat => Nat.add_le_mono_l n m p) with (p := c).
case (Nat.le_gt_cases a c); intros H1.
replace (a - c) with 0; auto with arith.
apply sym_equal; apply minus_O; auto with arith.
rewrite Nat.add_comm, Nat.sub_add; auto with arith.
rewrite Nat.add_comm; auto with arith.
Qed.

(** A generic function to find the maximal natural number such that
      the property P hols *)

Fixpoint max_such (P : nat -> Prop) (P_dec : forall n : nat, {P n} + {~ P n})
 (n : nat) {struct n} : nat :=
  match P_dec n with
  | left _ => n
  | right _ => match n with
               | O => 0
               | S n1 => max_such P P_dec n1
               end
  end.

Theorem max_such_prop :
 forall (P : nat -> Prop) (P_dec : forall n : nat, {P n} + {~ P n}) (n : nat),
 (exists x : nat, x <= n /\ P x) ->
 max_such P P_dec n <= n /\
 P (max_such P P_dec n) /\
 (forall x : nat, max_such P P_dec n < x -> x <= n -> ~ P x).
Proof.
intros P P_dec n; elim n; simpl in |- *; auto.
intros (x1, (H1, H2)).
case (P_dec 0); auto.
intros H3; repeat split; auto; intros x H4 H5; inversion H5; auto.
Contradict H5; auto with arith; rewrite H; auto with arith.
intros H3; Contradict H2; auto; inversion H1; auto.
intros n1 Rec (x1, (H1, H2)); case (P_dec (S n1)); auto.
intros H3; repeat split; auto with arith.
intros x H H0; (Contradict H0; auto with arith).
intros H3; case Rec.
exists x1; split; auto with arith.
inversion H1; auto.
case H3; rewrite <- H; auto.
intros H4 (H5, H'5); repeat split; auto.
intros x H6 H7; auto.
inversion H7; auto with arith.
Qed.

Definition le_dec : forall n m : nat, {n <= m} + {~ n <= m}.
intros n m; case (le_lt_dec n m); auto.
intros H1; right; auto with arith.
Defined.

Theorem not_le_lt : forall n m : nat, ~ n <= m -> m < n.
Proof.
intros n m H1; case (Nat.le_gt_cases n m); auto; intros H2; case H1; auto.
Qed.

Theorem odd_or_even :
 forall n : nat,
 (exists x : nat, n = 2 * x) \/ (exists x : nat, n = 2 * x + 1).
Proof.
intros n; elim n.
left; exists 0; auto.
intros n1 [(x1, H1)| (x1, H1)]; [ right | left ]; rewrite H1; auto with arith.
exists x1; ring.
exists (x1 + 1); simpl in |- *; repeat (rewrite <- plus_n_Sm; simpl in |- *);
 repeat (rewrite <- plus_n_O; simpl in |- *); auto.
Qed.

Theorem le_mult : forall m n p q : nat, n <= p -> m <= q -> n * m <= p * q.
Proof.
intros m n p q H1 H2; apply Nat.le_trans with (p * m); auto with arith.
repeat rewrite (fun x => Nat.mul_comm x m); auto with arith.
Qed.

Theorem mult_id_le_inv : forall n m : nat, n * n <= m * m -> n <= m.
Proof.
intros n m H; case (Nat.le_gt_cases n m); auto; intros H1; contradict H;
 apply Nat.lt_nge.
apply Nat.le_lt_trans with (n * m); auto with arith.
apply le_mult; auto with arith; apply Nat.lt_le_incl; auto.
apply mult_lt_bis; auto with arith; apply Nat.le_lt_trans with (2 := H1);
 auto with arith.
Qed.

Theorem mult_id_lt_inv : forall n m : nat, n * n < m * m -> n < m.
Proof.
intros n m H; case (Nat.le_gt_cases m n); auto; intros H1; contradict H;
 apply Nat.le_ngt.
apply Nat.le_trans with (n * m); auto with arith.
apply le_mult; auto with arith.
Qed.
(*****************************************************************
                        Definition of ominus
  *****************************************************************)

(** ominus computes the difference of two nat.
    (ominus n m) = (Some O) iff n = m
*)
Fixpoint ominus (m : nat) : nat -> option nat :=
  fun n =>
  match m, n with
  | _, O => Some m
  | O, _ => None
  | S m1, S n1 => ominus m1 n1
  end.
(*****************************************************************
                        Properties of  ominus
  *****************************************************************)

Theorem ominus_def :
 forall m n : nat,
 match ominus m n with
 | Some q => m = n + q
 | None => m < n
 end.
Proof.
intros m; elim m; simpl in |- *; auto with arith.
intros n; case n; simpl in |- *; auto with arith.
intros m1 Rec n; case n; simpl in |- *; auto with arith.
intros n1; generalize (Rec n1); case (ominus m1 n1); simpl in |- *;
 auto with arith.
Qed.

Definition le_dec1 : forall n m : nat, {n <= m} + {~ n <= m}.
intros n m; generalize (ominus_def m n); case (ominus m n).
intros n0 H; left; rewrite H; auto with arith.
intros H; auto with arith.
Defined.
(*****************************************************************
                        Definition of  sqr
  *****************************************************************)

(** sqr computes the square root of a number *)
Definition sqr (n : nat) :=
  max_such (fun x => x * x <= n) (fun x => le_dec1 (x * x) n) n.
(*****************************************************************
                        Properties of  sqr
  *****************************************************************)

Theorem sqr_le : forall n : nat, sqr n * sqr n <= n.
Proof.
intros n; unfold sqr in |- *;
 generalize
  (max_such_prop (fun x => x * x <= n) (fun x => le_dec1 (x * x) n) n);
 case (max_such (fun x => x * x <= n) (fun x => le_dec1 (x * x) n)).
simpl in |- *; intros H1; case H1; auto with arith.
exists 0; split; auto with arith.
intros n0 H; case H; auto with arith.
exists 0; split; auto with arith.
intros H2 (H3, H4); auto.
Qed.

Theorem sqr_lt : forall n : nat, n < S (sqr n) * S (sqr n).
Proof.
intros n; unfold sqr in |- *;
 generalize
  (max_such_prop (fun x => x * x <= n) (fun x => le_dec1 (x * x) n) n);
 case (max_such (fun x => x * x <= n) (fun x => le_dec1 (x * x) n)).
case n; auto with arith.
intros n0 H; case H; auto with arith.
exists 0; split; auto with arith.
intros H2 (H3, H4); auto.
apply not_le_lt; auto with arith.
intros n0 H; case H; auto with arith.
exists 0; split; auto with arith.
intros H2 (H3, H4); auto.
apply not_le_lt; auto with arith.
case ((proj1 (Nat.lt_eq_cases _ _)) H2); intros H5.
apply H4; auto with arith.
rewrite H5; auto with arith.
apply Nat.lt_nge; auto with arith.
apply Nat.lt_le_trans with (S n); auto with arith.
pattern (S n) at 1 in |- *; replace (S n) with (S n * 1); auto with arith.
Qed.

Theorem sqr_inv : forall n m : nat, m * m <= n -> n < S m * S m -> sqr n = m.
Proof.
intros n m H1 H2.
case (proj1 (Nat.lt_eq_cases 0 m)); auto with arith; intros H3.
cut (m <= n); [ intros H4 | idtac ].
unfold sqr in |- *;
 generalize
  (max_such_prop (fun x : nat => x * x <= n)
     (fun x : nat => le_dec1 (x * x) n) n);
 case
  (max_such (fun x : nat => x * x <= n) (fun x : nat => le_dec1 (x * x) n) n).
intros H5; case H5.
exists m; auto with arith.
intros H6 (H7, H8); case (H8 m); auto with arith.
intros n0 H.
case H; auto with arith.
exists m; auto with arith.
intros H5 (H6, H7).
case (proj1 (Nat.lt_eq_cases (S n0) m)); auto with arith.
apply Nat.lt_succ_r; apply mult_id_lt_inv.
apply Nat.le_lt_trans with (1 := H6); auto with arith.
intros H0; case (H7 m); auto with arith.
apply Nat.le_trans with (2 := H1); auto with arith.
apply Nat.le_trans with (m * 1); auto with arith.
rewrite Nat.mul_1_r; auto with arith.
rewrite <- H3; rewrite <- H3 in H2; simpl in H2; inversion H2.
simpl in |- *; auto.
inversion H0.
Qed.

Theorem sqr_mult2 : forall n : nat, sqr (n * n) = n.
Proof.
intros n; apply sqr_inv; auto with arith.
apply Nat.le_lt_trans with (S n * n); auto with arith.
simpl in |- *; auto with arith.
Qed.

Theorem sqr_mono : forall n m : nat, n <= m -> sqr n <= sqr m.
Proof.
intros n m H; elim H; auto with arith.
intros m0 H0 H1.
apply Nat.le_trans with (1 := H1).
apply Nat.lt_succ_r; apply mult_id_lt_inv.
apply Nat.le_lt_trans with m0.
apply sqr_le; auto.
apply Nat.lt_trans with (S m0); auto with arith; apply sqr_lt; auto.
Qed.


(*
(C) Copyright 2010, COQTAIL team

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

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

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

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

(** Properties of real functions sequences. *)

Require Import Reals.
Require Import RFsequence.
Require Import Fourier.
Require Import Max.

Open Scope R_scope.

(* begin hide *)
Lemma ub_lt_2_pos : forall x ub lb, lb < x -> x < ub -> 0 < (ub-lb)/2.
Proof.
intros x ub lb lb_lt_x x_lt_ub.
 assert (T : 0 < ub - lb).
  fourier.
 unfold Rdiv ; apply Rlt_mult_inv_pos ; intuition.
Qed.

Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb<x) (x_lt_ub:x<ub) : posreal.
intros x lb ub lb_lt_x x_lt_ub.
 apply (mkposreal ((ub-lb)/2) (ub_lt_2_pos x ub lb lb_lt_x x_lt_ub)).
Defined.
(* end hide *)

Lemma RFseq_cvu_derivable : forall (fn fn':nat -> R -> R) (f g:R->R)
      (x lb ub:R) (lb_lt_x:lb < x) (x_lt_ub:x < ub),
      (forall (x:R) (n:nat), lb < x -> x < ub -> derivable_pt_lim (fn n) x (fn' n x)) ->
      (RFseq_cv_interv fn f lb ub) ->
      (RFseq_cvu fn' g ((lb + ub)/2) (mkposreal_lb_ub x lb ub lb_lt_x x_lt_ub)) ->
      (forall (x:R), lb < x -> x < ub -> continuity_pt g x) ->
      derivable_pt_lim f x (g x).
Proof.
intros fn fn' f g x lb ub lb_lt_x x_lt_ub Dfn_eq_fn' fn_CV_f fn'_CVU_g g_cont eps eps_pos.
 assert (eps_8_pos : 0 < eps / 8) by fourier.
 destruct (g_cont x lb_lt_x x_lt_ub (eps/8)%R eps_8_pos) as (delta1, Hdelta1) ; clear g_cont ;
 destruct Hdelta1 as (delta1_pos, g_cont).
 assert (delta_pos : 0 < Rmin (Rmin ((x-lb)/2) ((ub-x)/2)) delta1).
  apply Rmin_pos ; [apply Rmin_pos | intuition] ; unfold Rdiv ;
  apply Rlt_mult_inv_pos ; intuition ; apply Rlt_Rminus ; intuition.
 pose (delta := mkposreal (Rmin (Rmin ((x-lb)/2) ((ub-x)/2)) delta1) (delta_pos)).
 exists delta ; intros h h_neq h_ub.
 assert (eps'_pos : 0 < (Rabs h) * eps / 4).
  unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat.
  apply Rabs_pos_lt ; assumption.
  fourier.
 elim (fn_CV_f x lb_lt_x x_lt_ub ((Rabs h) * eps / 4)%R eps'_pos) ; intros N2 fnx_CV_fx.
 assert(lb_lt_xh : lb < x + h).
  apply Rlt_trans with (x - delta)%R.
  unfold delta.
  assert (Temp : forall a b c, a + c < b -> a < b - c).
   intros ; fourier.
  apply Temp ; clear Temp ; apply Rle_lt_trans with (lb + Rmin ((x - lb) / 2) ((ub - x) / 2))%R.
  apply Rplus_le_compat_l ; apply Rmin_l.
  apply Rle_lt_trans with (lb + (x - lb) / 2)%R.
  apply Rplus_le_compat_l ; apply Rmin_l.
  replace (lb + (x - lb) / 2) with ((lb + x)/2) by field.
  assert (Temp : forall a b, a < b -> (a+b)/2 < b).
   clear ; intros a b a_lt_b.
   unfold Rdiv ; rewrite Rmult_plus_distr_r.
   fourier.
  apply Temp ; assumption.
  apply Rplus_lt_compat_l.
  exact (proj2 (Rabs_def2 h delta h_ub)).
 assert(xh_lt_ub : x + h < ub).
  apply Rlt_trans with (x + delta).
  apply Rplus_lt_compat_l.
  exact (proj1 (Rabs_def2 h delta h_ub)).
  unfold delta.
  apply Rle_lt_trans with (x + Rmin ((x - lb) / 2) ((ub - x) / 2)).
  apply Rplus_le_compat_l ; apply Rmin_l.
  apply Rle_lt_trans with (x + (ub - x) / 2).
  apply Rplus_le_compat_l ; apply Rmin_r.
  replace (x + (ub - x) / 2) with ((ub + x)/2) by field.
  assert (Temp : forall a b, a < b -> (b+a)/2 < b).
   clear ; intros a b a_lt_b.
   unfold Rdiv ; rewrite Rmult_plus_distr_r.
   fourier.
  apply Temp ; assumption.
 elim (fn_CV_f (x+h) lb_lt_xh xh_lt_ub ((Rabs h) * eps / 4) eps'_pos) ;
 clear fn_CV_f ; intros N1 fnxh_CV_fxh.
 elim (fn'_CVU_g (eps/8) eps_8_pos) ; intros N3 fn'c_CVU_gc.
 pose (N := max (max N1 N2) N3).
 assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn N x - h * (g x))) < (Rabs h)*eps).
 apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h) - (f x - fn N x)) +  Rabs ((fn N (x + h) - fn N x - h * g x))).
 apply Rabs_triang.
 apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h)) + Rabs (- (f x - fn N x)) + Rabs (fn N (x + h) - fn N x - h * g x)).
 apply Rplus_le_compat_r ; apply Rabs_triang.
 rewrite Rabs_Ropp.
 case (Rlt_le_dec h 0) ; intro sgn_h.
 assert (pr1 : forall c : R, x + h < c < x -> derivable_pt (fn N) c).
  intros c c_encad ; unfold derivable_pt.
  assert (lb_lt_c : lb < c).
   apply Rlt_trans with (x+h) ; intuition.
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with x ; intuition.
  exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
 assert (pr2 : forall c : R, x + h < c < x -> derivable_pt id c).
  intros c c_encad ; apply derivable_id.
 assert (xh_x : x+h < x).
  fourier.
 assert (pr3 : forall c : R, x + h <= c <= x -> continuity_pt (fn N) c).
  intros c c_encad ; apply derivable_continuous_pt.
  exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
  apply Rlt_le_trans with (x+h) ; intuition.
  apply Rle_lt_trans with x ; intuition.
 assert (pr4 : forall c : R, x + h <= c <= x -> continuity_pt id c).
  intros c c_encad ; apply derivable_continuous ; apply derivable_id.
 elim (MVT (fn N) id (x+h) x pr1 pr2 xh_x pr3 pr4) ; intros c Hc ; elim Hc ; clear Hc ; intros P Hc.
 assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = (fn N (x+h) - fn N x)).
  apply Rmult_eq_reg_l with (-1).
  replace (-1 * (h * derive_pt (fn N) c (pr1 c P))) with (-h * derive_pt (fn N) c (pr1 c P)) by field.
  replace (-1 * (fn N (x + h) - fn N x)) with (- (fn N (x + h) - fn N x)) by field.
  replace (-h) with (id x - id (x + h)).
  rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
  replace (- (fn N (x + h) - fn N x)) with (fn N x - fn N (x + h)) by field.
  assumption.
  unfold id ; field.
  apply Rlt_not_eq ; intuition.
 clear Hc.
 rewrite <- Hc'.
 replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
 replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
 rewrite Rabs_mult.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
 rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
 unfold N ; apply le_trans with (max N1 N2) ; apply le_max_l.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
 unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
 unfold N ; apply le_trans with (max N1 N2) ; [apply le_max_r | apply le_max_l].
 replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
 apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; rewrite <- Rmult_plus_distr_l ;
 apply Rmult_le_compat_l. apply Rabs_pos.
 apply Rabs_triang.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
          Rabs h * Rabs (g c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 apply fn'c_CVU_gc.
 unfold N ; apply le_max_r.
 unfold Boule.
 assert (Rabs (c - (lb + ub) / 2) < (ub - lb) / 2).
  apply Rabs_def1.
  assert (Temp : forall a b c, a < b + c -> a - b < c). intros ; fourier.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 + (ub - lb) / 2) with ub by field.
  apply Rlt_trans with x ; [exact (proj2 P) | intuition].
  assert (Temp : forall a b c, a - b < c -> - b < c - a). intros ; fourier.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 - ((ub - lb) / 2)) with lb by field.
  apply Rlt_trans with (x+h) ; [intuition | exact (proj1 P)].
  assumption.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
         Rabs h * (eps / 8)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ;
 rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
 unfold no_cond ; intuition. apply Rgt_not_eq ; exact (proj2 P).
 unfold R_dist. apply Rlt_trans with (Rabs h).
 apply Rabs_def1. apply Rlt_trans with 0.
 assert (Temp : forall a b, a < b -> a - b < 0).
  intros ; fourier.
 apply Temp ; exact (proj2 P).
 apply Rabs_pos_lt ; assumption.
 apply Rle_lt_trans with h.
 rewrite Rabs_left1.
 apply Req_le ; field.
 apply Rlt_le ; assumption.
 assert (Temp : forall a b c, a + b < c -> b < c - a). intros ; fourier.
 apply Temp ; clear Temp ; exact (proj1 P).
 apply Rlt_le_trans with delta ; [intuition | unfold delta ; apply Rmin_r].
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
 replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
 apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 fourier.
 assert (lb_lt_c : lb < c).
   apply Rlt_trans with (x+h) ; intuition ; exact (proj1 P).
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with x ; intuition ; exact (proj2 P).
 assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
 assert (Temp : l = fn' N c).
  assert (Hl' := Dfn_eq_fn' c N lb_lt_c c_lt_ub).
  unfold derivable_pt_abs in Hl.
  clear -Hl Hl'.
  apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
  rewrite <- Temp.
  assert (Hl' : derivable_pt (fn N) c).
   exists l ; apply Hl.
  rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
  elim Hl' ; clear Hl' ; intros l' Hl'.
  assert (Main : l = l').
 apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
 rewrite Main ; reflexivity.
 reflexivity.
 assert (h_pos : h > 0).
  case sgn_h ; intro Hyp.
  assumption.
  apply False_ind ; apply h_neq ; symmetry ; assumption.
 clear sgn_h.
 assert (pr1 : forall c : R, x < c < x + h -> derivable_pt (fn N) c).
  intros c c_encad ; unfold derivable_pt.
  assert (lb_lt_c : lb < c).
   apply Rlt_trans with x ; intuition.
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with (x+h) ; intuition.
  exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
 assert (pr2 : forall c : R, x < c < x + h -> derivable_pt id c).
  intros c c_encad ; apply derivable_id.
 assert (xh_x : x < x + h).
  fourier.
 assert (pr3 : forall c : R, x <= c <= x + h -> continuity_pt (fn N) c).
  intros c c_encad ; apply derivable_continuous_pt.
  exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
  apply Rlt_le_trans with x ; intuition.
  apply Rle_lt_trans with (x+h) ; intuition.
 assert (pr4 : forall c : R, x <= c <= x + h -> continuity_pt id c).
  intros c c_encad ; apply derivable_continuous ; apply derivable_id.
 elim (MVT (fn N) id x (x+h) pr1 pr2 xh_x pr3 pr4) ; intros c Hc ; elim Hc ; clear Hc ; intros P Hc.
 assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = (fn N (x+h) - fn N x)).
  replace (h * derive_pt (fn N) c (pr1 c P)) with ((id (x+h) - id x)* derive_pt (fn N) c (pr1 c P)).
  rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
  assumption.
  unfold id ; field.
 clear Hc.
 rewrite <- Hc'.
 replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
 replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
 rewrite Rabs_mult.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
 rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
 unfold N ; apply le_trans with (max N1 N2) ; apply le_max_l.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
 unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
 unfold N ; apply le_trans with (max N1 N2) ; [apply le_max_r | apply le_max_l].
 replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
 apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; rewrite <- Rmult_plus_distr_l ;
 apply Rmult_le_compat_l. apply Rabs_pos.
 apply Rabs_triang.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
          Rabs h * Rabs (g c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 apply fn'c_CVU_gc.
 unfold N ; apply le_max_r.
 unfold Boule.
 assert (Rabs (c - (lb + ub) / 2) < (ub - lb) / 2).
  apply Rabs_def1.
  assert (Temp : forall a b c, a < b + c -> a - b < c). intros ; fourier.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 + (ub - lb) / 2) with ub by field.
  apply Rlt_trans with (x+h) ; [exact (proj2 P) | intuition].
  assert (Temp : forall a b c, a - b < c -> - b < c - a). intros ; fourier.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 - ((ub - lb) / 2)) with lb by field.
  apply Rlt_trans with x ; [intuition | exact (proj1 P)].
  assumption.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
         Rabs h * (eps / 8)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ;
 rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
 unfold no_cond ; intuition. apply Rlt_not_eq ; exact (proj1 P).
 unfold R_dist. apply Rlt_trans with (Rabs h).
 apply Rabs_def1.
 assert (Temp : forall a b c, c < a + b -> c - a < b). intros ; fourier.
 apply Temp ; clear Temp ; rewrite Rabs_right. exact (proj2 P).
 apply Rgt_ge ; assumption.
 assert (Temp : forall a b, a - b < c -> - b < c - a). intros ; fourier.
 apply Temp ; apply Rlt_trans with x ; [| exact (proj1 P)].
 rewrite <- Rplus_0_r.
 apply Rplus_lt_compat_l.
 apply Ropp_lt_gt_0_contravar ; apply Rabs_pos_lt ; apply Rgt_not_eq ; assumption.
 apply Rle_lt_trans with h.
 rewrite Rabs_right. apply Req_le ; reflexivity.
 fourier.
 apply Rlt_le_trans with delta ; [intuition | unfold delta ; apply Rmin_r].
 rewrite Rabs_right in h_ub ; intuition.
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
 replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
 apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 fourier.
 assert (lb_lt_c : lb < c).
   apply Rlt_trans with x ; intuition ; exact (proj1 P).
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with (x+h) ; intuition ; exact (proj2 P).
 assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
 assert (Temp : l = fn' N c).
  assert (Hl' := Dfn_eq_fn' c N lb_lt_c c_lt_ub).
  unfold derivable_pt_abs in Hl.
  clear -Hl Hl'.
  apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
  rewrite <- Temp.
  assert (Hl' : derivable_pt (fn N) c).
   exists l ; apply Hl.
  rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
  elim Hl' ; clear Hl' ; intros l' Hl'.
  assert (Main : l = l').
 apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
 rewrite Main ; reflexivity.
 reflexivity.
 replace ((f (x + h) - f x) / h - g x) with ((/h) * ((f (x + h) - f x) - h * g x)).
 rewrite Rabs_mult ; rewrite Rabs_Rinv.
 replace eps with (/ Rabs h * (Rabs h * eps)).
 apply Rmult_lt_compat_l.
 apply Rinv_0_lt_compat ; apply Rabs_pos_lt ; assumption.
 replace (f (x + h) - f x - h * g x) with (f (x + h) - fn N (x + h) - (f x - fn N x) +
          (fn N (x + h) - fn N x - h * g x)) by field.
 assumption.
 field ; apply Rgt_not_eq ; apply Rabs_pos_lt ; assumption.
 assumption.
 field. assumption.
Qed.

Definition SFL_interv (fn:nat -> R -> R) (r:posreal)
  (cv:forall x:R, Boule 0 r x -> {l:R | Un_cv (fun N:nat => SP fn N x) l }) (y:R) : R.
Proof.
intros fn r cv x.
 case (Rlt_le_dec x r) ; intro x_bd1.
 case (Rlt_le_dec (-r) x) ; intro x_bd2.
 assert (x_bd : Boule 0 r x).
  apply Rabs_def1 ; rewrite Rminus_0_r ; assumption.
 destruct (cv _ x_bd) as (l, _) ; apply l.
 exact 0.
 exact 0.
Defined.

Lemma SFL_interv_right : forall fn r cv y, Boule 0 r y ->
     Un_cv (fun N:nat => SP fn N y) (SFL_interv fn r cv y).
Proof.
intros fn r cv y y_bd ; unfold SFL_interv ; case (Rlt_le_dec y r) ; intro y_bd1.
 case (Rlt_le_dec (- r) y) ; intro y_bd2.
 destruct (cv y
       (Rabs_def1 (y - 0) r
          (eq_ind_r (fun r0 : R => r0 < r) y_bd1 (Rminus_0_r y))
          (eq_ind_r (fun r0 : R => - r < r0) y_bd2 (Rminus_0_r y)))) as (l', Hl').
  assumption.
  clear -y_bd y_bd1 y_bd2 ;
  destruct (Rabs_def2 _ _ y_bd) as [H1 H2] ; rewrite Rminus_0_r in H1, H2 ;
  apply False_ind ; apply Rlt_irrefl with (-r) ; apply Rlt_le_trans with y ; assumption.
  clear -y_bd y_bd1; destruct (Rabs_def2 _ _ y_bd) as [H1 H2] ;
  rewrite Rminus_0_r in H1, H2 ; apply False_ind ; apply Rlt_irrefl with y ;
  apply Rlt_le_trans with r ; assumption.
Qed.

(** In a complete space, normal convergence implies uniform convergence *)
Lemma CVN_CVU_interv : forall (fn:nat -> R -> R) (r:posreal)
    (cv:forall x:R, Boule 0 r x -> {l:R | Un_cv (fun N:nat => SP fn N x) l }),
    CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL_interv fn r cv) 0 r.
Proof.
  intros; unfold CVU in |- *; intros.
  unfold CVN_r in X.
  elim X; intros An X0.
  elim X0; intros s H0.
  elim H0; intros.
  cut (Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n - s) 0).
  intro; unfold Un_cv in H3.
  elim (H3 eps H); intros N0 H4.
  exists N0; intros.
  apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)).
  rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)).
    rewrite Ropp_minus_distr';
      rewrite (Rabs_right (s - sum_f_R0 (fun k:nat => Rabs (An k)) n)).
  eapply sum_maj1.
  unfold SFL in |- *; case (cv y H6) ; intro.
  unfold SFL_interv.
  case (Rlt_le_dec y r) ; intro y_bd1.
  case (Rlt_le_dec (- r) y) ; intro y_bd2.
  destruct (cv y
         (Rabs_def1 (y - 0) r
            (eq_ind_r (fun r0 : R => r0 < r) y_bd1 (Rminus_0_r y))
            (eq_ind_r (fun r0 : R => - r < r0) y_bd2 (Rminus_0_r y)))) as (l, Hl).
   trivial.
   clear -H6 y_bd1 y_bd2 ;
   destruct (Rabs_def2 _ _ H6) as [H1 H2] ; rewrite Rminus_0_r in H1, H2 ;
   apply False_ind ; apply Rlt_irrefl with (-r) ; apply Rlt_le_trans with y ; assumption.
   clear -H6 y_bd1; destruct (Rabs_def2 _ _ H6) as [H1 H2] ;
   rewrite Rminus_0_r in H1, H2 ; apply False_ind ; apply Rlt_irrefl with y ;
   apply Rlt_le_trans with r ; assumption.
   apply H1.
  intro; elim H0; intros.
  rewrite (Rabs_right (An n0)).
  apply H8; apply H6.
  apply Rle_ge; apply Rle_trans with (Rabs (fn n0 y)).
  apply Rabs_pos.
  apply H8; apply H6.
  apply Rle_ge;
    apply Rplus_le_reg_l with (sum_f_R0 (fun k:nat => Rabs (An k)) n).
  rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm s);
    rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l;
      apply sum_incr.
  apply H1.
  intro; apply Rabs_pos.
  unfold R_dist in H4; unfold Rminus in H4; rewrite Ropp_0 in H4.
  assert (H7 := H4 n H5).
  rewrite Rplus_0_r in H7; apply H7.
  unfold Un_cv in H1; unfold Un_cv in |- *; intros.
  elim (H1 _ H3); intros.
  exists x; intros.
  unfold R_dist in |- *; unfold R_dist in H4.
  rewrite Rminus_0_r; apply H4; assumption.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Construction.Product.
Require Import Category.Instance.Fun.

Generalizable All Variables.

#[export]
Program Instance Diagonal {C : Category} (J : Category) : C ⟶ [J, C] := {
  fobj := fun x =>
    {| fobj := fun _ => x
     ; fmap := fun _ _ _ => id[x] |};
  fmap := fun _ _ f =>
    {| transform := fun _ => f |}
}.

Section Diagonal_Product.

#[local] Set Transparent Obligations.

#[export]
Program Instance Diagonal_Product `(C : Category) : C ⟶ C ∏ C.

End Diagonal_Product.

Notation "Δ[ J ]( c )" := (Diagonal J c) (at level 90, format "Δ[ J ]( c )") : functor_scope.

Require Import Category.Instance.One.

Notation "Δ( c )" := (Diagonal _ c) (at level 90, format "Δ( c )") : functor_scope.
Notation "=( c )" := (Diagonal 1 c) (at level 90, format "=( c )") : functor_scope.

Definition Δ {C J : Category} := @Diagonal C J.

(* Wikipedia: "In category theory, a branch of mathematics, the diagonal
   functor C → C × C is given by Δ(a) = ⟨a, a⟩, which maps objects as well as
   morphisms. This functor can be employed to give a succinct alternate
   description of the product of objects within the category C: a product a ×
   b is a universal arrow from Δ to ⟨a, b⟩. The arrow comprises the projection
   maps."

  "More generally, in any functor category Cᴶ (here J should be thought of as
  a small index category), for each object a in C, there is a constant functor
  with fixed object a : Δ(a) ∈ Cᴶ. The diagonal functor Δ : C → Cᴶ assigns to
  each object of C the functor Δ(a), and to each morphism f : a → b in C the
  obvious natural transformation η in Cᴶ (given by ηⱼ = f). In the case that J
  is a discrete category with two objects, the diagonal functor C → C × C is
  recovered." *)

Require Import Category.Instance.Two.Discrete.

Theorem Diagonal_Product_Two (C : Category) :
  (∀ x, Diagonal_Product C x ≅ (Diagonal Two_Discrete x TwoDX,
                                Diagonal Two_Discrete x TwoDY)) *
  (∀ x y (f : x ~> y),
     fmap[Diagonal_Product C] f
       ≈ (transform[fmap[Diagonal Two_Discrete] f] TwoDX,
          transform[fmap[Diagonal Two_Discrete] f] TwoDY)).
Proof.
  split; intros.
  - isomorphism; simpl; intros; try exact (id, id); cat.
  - reflexivity.
Qed.

#[export]
Instance Transform_Const `(x ~{C}~> y) : Δ(x) ⟹ Δ(y).
Proof. construct; auto; cat_simpl. Qed.


(* Test apply in *)

Goal (forall x y, x = S y -> y=y) -> 2 = 4 -> 3=3.
intros H H0.
apply H in H0.
assumption.
Qed.

Require Import ZArith.
Goal (forall x y z, ~ z <= 0 -> x * z < y * z -> x <= y)%Z.
intros; apply Znot_le_gt, Zgt_lt in H.
apply Zmult_lt_reg_r, Zlt_le_weak in H0; auto.
Qed.

(* Test application under tuples *)

Goal (forall x, x=0 <-> 0=x) -> 1=0 -> 0=1.
intros H H'.
apply H in H'.
exact H'.
Qed.

(* Test as clause *)

Goal (forall x, x=0 <-> (0=x /\ True)) -> 1=0 -> True.
intros H H'.
apply H in H' as (_,H').
exact H'.
Qed.

(* Test application modulo conversion *)

Goal (forall x, id x = 0 -> 0 = x) -> 1 = id 0 -> 0 = 1.
intros H H'.
apply H in H'.
exact H'.
Qed.

(* Check apply/eapply distinction in presence of open terms *)

Parameter h : forall x y z : nat, x = z -> x = y.
Implicit Arguments h [[x] [y]].
Goal 1 = 0 -> True.
intro H.
apply h in H || exact I.
Qed.

Goal False -> 1 = 0.
intro H.
apply h || contradiction.
Qed.

(* Check if it unfolds when there are not enough premises *)

Goal forall n, n = S n -> False.
intros.
apply n_Sn in H.
assumption.
Qed.

(* Check naming in with bindings; printing used to be inconsistent before *)
(* revision 9450 *)

Notation S':=S (only parsing).
Goal (forall S, S = S' S) -> (forall S, S = S' S).
intros.
apply H with (S0 := S).
Qed.

(* Check inference of implicit arguments in bindings *)

Goal exists y : nat -> Type, y 0 = y 0.
exists (fun x => True).
trivial.
Qed.

(* Check universe handling in typed unificationn *)

Definition E := Type.
Goal exists y : E, y = y.
exists Prop.
trivial.
Qed.

Variable Eq : Prop = (Prop -> Prop) :> E.
Goal Prop.
rewrite Eq.
Abort.

(* Check insertion of coercions in bindings *)

Coercion eq_true : bool >-> Sortclass.
Goal exists A:Prop, A = A.
exists true.
trivial.
Qed.

(* Check use of unification of bindings types in specialize *)

Variable P : nat -> Prop.
Variable L : forall (l : nat), P l -> P l.
Goal P 0 -> True.
intros.
specialize L with (1:=H).
Abort.
Reset P.

(* Two examples that show that hnf_constr is used when unifying types
   of bindings (a simplification of a script from Field_Theory) *)

Require Import List.
Open Scope list_scope.
Fixpoint P (l : list nat) : Prop :=
  match l with
  | nil => True
  | e1 :: nil => e1 = e1
  | e1 :: l1 => e1 = e1 /\ P l1
  end.
Variable L : forall n l, P (n::l) -> P l.

Goal forall (x:nat) l, P (x::l) -> P l.
intros.
apply L with (1:=H).
Qed.

Goal forall (x:nat) l, match l with nil => x=x | _::_ => x=x /\ P l end -> P l.
intros.
apply L with (1:=H).
Qed.

(* The following call to auto fails if the type of the clause
   associated to the H is not beta-reduced [but apply H works]
   (a simplification of a script from FSetAVL) *)

Definition apply (f:nat->Prop) := forall x, f x.
Goal apply (fun n => n=0) -> 1=0.
intro H.
auto.
Qed.

(* The following fails if the coercion Zpos is not introduced around p
   before trying a subterm that matches the left-hand-side of the equality
   (a simplication of an example taken from Nijmegen/QArith) *)

Require Import ZArith.
Coercion Zpos : positive >-> Z.
Variable f : Z -> Z -> Z.
Variable g : forall q1 q2 p : Z, f (f q1 p) (f q2 p) = Z0.
Goal forall p q1 q2, f (f q1 (Zpos p)) (f q2 (Zpos p)) = Z0.
intros; rewrite g with (p:=p).
reflexivity.
Qed.

(* A funny example where the behavior differs depending on which of a
   multiple solution to a unification problem is chosen (an instance
   of this case can be found in the proof of Buchberger.BuchRed.nf_divp) *)

Definition succ x := S x.
Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop),
  (forall x y, P x -> Q x y) ->
  (forall x, P (S x)) -> forall y: I (S 0), Q (succ 0) y.
intros.
apply H with (y:=y).
(* [x] had two possible instances: [S 0], coming from unifying the
   type of [y] with [I ?n] and [succ 0] coming from the unification with
   the goal; only the first one allows to make the next apply (which
   does not work modulo delta) working *)
apply H0.
Qed.

(* A similar example with a arbitrary long conversion between the two
   possible instances *)

Fixpoint compute_succ x :=
  match x with O => S 0 | S n => S (compute_succ n) end.

Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop),
  (forall x y, P x -> Q x y) ->
  (forall x, P (S x)) -> forall y: I (S 100), Q (compute_succ 100) y.
intros.
apply H with (y:=y).
apply H0.
Qed.

(* Another example with multiple convertible solutions to the same
   metavariable (extracted from Algebra.Hom_module.Hom_module, 10th
   subgoal which precisely fails) *)

Definition ID (A:Type) := A.
Goal forall f:Type -> Type,
  forall (P : forall A:Type, A -> Prop),
  (forall (B:Type) x, P (f B) x -> P (f B) x) ->
  (forall (A:Type) x, P (f (f A)) x) ->
  forall (A:Type) (x:f (f A)), P (f (ID (f A))) x.
intros.
apply H.
(* The parameter [B] had two possible instances: [ID (f A)] by direct
   unification and [f A] by unification of the type of [x]; only the
   first choice makes the next command fail, as it was
   (unfortunately?) in Hom_module *)
try apply H.
unfold ID; apply H0.
Qed.

(* Test coercion below product and on non meta-free terms in with bindings *)
(* Cf wishes #1408 from E. Makarov *)

Parameter bool_Prop :> bool -> Prop.
Parameter r : bool -> bool -> bool.
Axiom ax : forall (A : Set) (R : A -> A -> Prop) (x y : A), R x y.

Theorem t : r true false.
apply ax with (R := r).
Qed.

(* Check verification of type at unification (submitted by Stéphane Lengrand):
   without verification, the first "apply" works what leads to the incorrect
   instantiation of x by Prop *)

Theorem u : ~(forall x:Prop, ~x).
unfold not.
intro.
eapply H.
apply (forall B:Prop,B->B) || (instantiate (1:=True); exact I).
Defined.

(* Fine-tuning coercion insertion in presence of unfolding (bug #1883) *)

Parameter name : Set.
Definition atom := name.

Inductive exp : Set :=
  | var : atom -> exp.

Coercion var : atom >-> exp.

Axiom silly_axiom : forall v : exp, v = v -> False.

Lemma silly_lemma : forall x : atom, False.
intros x.
apply silly_axiom with (v := x).  (* fails *)
reflexivity.
Qed.

(* Check that unification does not commit too early to a representative
   of an eta-equivalence class that would be incompatible with other
   unification constraints *)

Lemma eta : forall f : (forall P, P 1),
  (forall P, f P = f P) ->
   forall Q, f (fun x => Q x) = f (fun x => Q x).
intros.
apply H.
Qed.

(* Test propagation of evars from subgoal to brother subgoals *)

  (* This works because unfold calls clos_norm_flags which calls nf_evar *)

Lemma eapply_evar_unfold : let x:=O in O=x -> 0=O.
intros x H; eapply trans_equal;
[apply H | unfold x;match goal with |- ?x = ?x => reflexivity end].
Qed.

(* Test non-regression of (temporary) bug 1981 *)

Goal exists n : nat, True.
eapply ex_intro.
exact O.
trivial.
Qed.

(* Check pattern-unification on evars in apply unification *)

Lemma evar : exists f : nat -> nat, forall x, f x = 0 -> x = 0.
Proof.
eexists; intros x H.
apply H.
Qed.

(* Check that "as" clause applies to main premise only and leave the
   side conditions away *)

Lemma side_condition :
  forall (A:Type) (B:Prop) x, (True -> B -> x=0) -> B -> x=x.
Proof.
intros.
apply H in H0 as ->.
reflexivity.
exact I.
Qed.

(* Check that "apply" is chained on the last subgoal of each lemma and
   that side conditions come first (as it is the case since 8.2) *)

Lemma chaining :
  forall A B C : Prop,
  (1=1 -> (2=2 -> A -> B) /\ True) ->
  (3=3 -> (True /\ (4=4 -> C -> A))) -> C -> B.
Proof.
intros.
apply H, H0.
exact (refl_equal 1).
exact (refl_equal 2).
exact (refl_equal 3).
exact (refl_equal 4).
assumption.
Qed.

(* Check that the side conditions of "apply in", even when chained and
   used through conjunctions, come last (as it is the case for single
   calls to "apply in" w/o destruction of conjunction since 8.2) *)

Lemma chaining_in :
  forall A B C : Prop,
  (1=1 -> True /\ (B -> 2=2 -> 5=0)) ->
  (3=3 -> (A -> 4=4 -> B) /\ True) -> A -> 0=5.
Proof.
intros.
apply H0, H in H1 as ->.
exact (refl_equal 0).
exact (refl_equal 1).
exact (refl_equal 2).
exact (refl_equal 3).
exact (refl_equal 4).
Qed.

(* From 12612, descent in conjunctions is more powerful *)
(* The following, which was failing badly in bug 1980, is now
   properly rejected, as descend in conjunctions builds an
   ill-formed elimination from Prop to Type. *)

Goal True.
Fail eapply ex_intro.
exact I.
Qed.

(* The following, which were not accepted, are now accepted as
    expected by descent in conjunctions *)

Goal True.
eapply (ex_intro (fun _ => True) I).
exact I.
Qed.

Goal True.
eapply (fun (A:Prop) (x:A) => conj I x).
exact I.
Qed.

(* The following was not accepted from r12612 to r12657 *)

Record sig0 := { p1 : nat; p2 : p1 = 0 }.

Goal forall x : sig0, p1 x = 0.
intro x;
apply x.
Qed.

(* The following worked in 8.2 but was not accepted from r12229 to
   r12926 because "simple apply" started to use pattern unification of
   evars. Evars pattern unification for simple (e)apply was disabled
   in 12927 but "simple eapply" below worked from 12898 to 12926
   because pattern-unification also started supporting abstraction
   over Metas. However it did not find the "simple" solution and hence
   the subsequent "assumption" failed. *)

Goal exists f:nat->nat, forall x y, x = y -> f x = f y.
intros; eexists; intros.
simple eapply (@f_equal nat).
assumption.
Existential 1 := fun x => x.
Qed.

(* The following worked in 8.2 but was not accepted from r12229 to
   r12897 for the same reason because eauto uses "simple apply". It
   worked from 12898 to 12926 because eauto uses eassumption and not
   assumption. *)

Goal exists f:nat->nat, forall x y, x = y -> f x = f y.
intros; eexists; intros.
eauto.
Existential 1 := fun x => x.
Qed.

(* The following was accepted before r12612 but is still not accepted in r12658

Goal forall x : { x:nat | x = 0}, proj1_sig x = 0.
intro x;
apply x.

*)