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

Require Import Rsequence.
Require Import Rsequence_facts.
Require Import Rsequence_cv_facts.
Require Import Rsequence_usual_facts.
Require Import MyRIneq.

Require Import Cprop_base.
Require Import Csequence.
Require Import Csequence_facts.
Require Import Cpser_def.
Require Import Cpser_facts.
Require Import Canalysis_def.
Require Import Cseries.
Require Import Cseries_facts.

Open Scope C_scope.

(** * Definition and manipulation of the general term of the power serie of the exponential *)

Definition exp_seq (n : nat) := / INC (fact n).

Lemma exp_seq_neq : forall n : nat, exp_seq n <> 0.
Proof.
intro n ; unfold exp_seq ; apply Cinv_neq_0_compat ;
 apply not_0_INC ; apply fact_neq_0.
Qed.

Lemma Cdiv_exp_seq_simpl : forall n, (exp_seq (S n)) / (exp_seq n) = / INC (S n).
Proof.
intros n ; unfold exp_seq.
 replace (fact (S n))%nat with ((S n) * fact n)%nat by reflexivity ;
 unfold Cdiv ; rewrite mult_INC, Cinv_involutive ;
 [rewrite Cinv_mult_distr ;
  [rewrite Cmult_assoc, Cinv_l, Cmult_1_r ;
   [reflexivity |] | |] |] ;
   apply not_0_INC ; auto ;  apply fact_neq_0.
Qed.

Lemma Deriv_exp_seq_simpl : forall n, An_deriv exp_seq n = exp_seq n.
Proof.
intro n ; unfold exp_seq, An_deriv.
 replace (fact (S n))%nat with ((S n) * fact n)%nat by reflexivity.
 rewrite mult_INC, Cinv_mult_distr, <- Cmult_assoc, Cinv_r, Cmult_1_l ;
 [reflexivity | | |] ; replace C0 with (INC O) by reflexivity ; apply not_INC ;
 try apply fact_neq_0 ; intuition.
Qed.

(** * This power serie has a radius of convergence that is infinite *)

Lemma exp_infinite_cv_radius : infinite_cv_radius exp_seq.
Proof.
intros r.
 pose (M := (/ (Rabs r + 1))%R) ; assert (M_pos : 0 < M).
  unfold M ; apply Rinv_0_lt_compat ;
  apply Rplus_le_lt_0_compat ; [apply Rabs_pos | apply Rlt_0_1].
 apply (Cpser_alembert_prelim2 exp_seq M M_pos exp_seq_neq).

assert (t : (1 > 0)%nat) by constructor ;
 assert (H := Rseq_poly_cv 1 t) ;
 assert (H2 := Rseq_cv_pos_infty_shift_compat_reciprocal _ H) ;
 assert (H3 := Rseq_cv_pos_infty_inv_compat _ H2) ;
 clear t H H2 ; destruct (H3 _ M_pos) as [N HN] ; exists N ;
 intros n.
 rewrite Cdiv_exp_seq_simpl, <- IRC_INR_INC, <- Cinv_IRC_Rinv.
 rewrite Cnorm_IRC_Rabs.
 apply Rle_trans with (R_dist ((/ Rseq_shift (Rseq_poly 1))%Rseq (N + n)%nat) 0).
 right ; unfold R_dist, Rseq_shift, Rseq_poly, pow ; apply Rabs_eq_compat ;
 rewrite Rminus_0_r, <- (Rmult_1_r (INR (S (N + n)))) ; reflexivity.
 left ; apply HN ; intuition.
 apply not_0_INR ; intuition.

unfold M ; rewrite Rinv_involutive ; [| apply Rgt_not_eq ; apply Rplus_le_lt_0_compat ;
 [apply Rabs_pos | apply Rlt_0_1]] ; intuition.
Qed.

Definition Cexp (z : C) := sum  _ exp_infinite_cv_radius z.

Definition Deriv_Cexp (z : C) := sum_derive _ exp_infinite_cv_radius z.

(** * The exponential is its own derivative *)

Lemma Cexp_eq_Deriv_Cexp : forall z, Cexp z = Deriv_Cexp z.
Proof.
intro z.
 assert (T1 := sum_sums _ exp_infinite_cv_radius z) ;
 assert (T2 := sum_derive_sums _ exp_infinite_cv_radius z).
 symmetry ; eapply Pser_unique_extentionality.
 apply Deriv_exp_seq_simpl.
 apply T2.
 apply T1.
Qed.

Lemma derivable_pt_lim_Cexp : forall z, derivable_pt_lim Cexp z (Cexp z).
Proof.
intro z ; rewrite Cexp_eq_Deriv_Cexp ;
 apply derivable_pt_lim_sum.
Qed.

(** ** Euler's Formula*)

Lemma Cexp_exp_compat : forall a : R, Cexp a =  exp a.
Proof.
intros a ; unfold exp, Cexp ; destruct (exist_exp a) as (l, H).
 pose (l1 := sum exp_seq exp_infinite_cv_radius (a +i  0)) ;
 assert (H1 := sum_sums _ exp_infinite_cv_radius (a +i 0)) ;
 replace (sum exp_seq exp_infinite_cv_radius (a +i  0)) with l1 in * by reflexivity.
rewrite <- Ceq ; simpl.

split.
apply (Rseq_cv_unique (sum_f_R0 (fun j : nat => (/ INR (fact j) * a ^ j)%R))).
  apply Rseq_cv_eq_compat with (fun n => Cre (sum_f_C0 (fun j : nat => / INC (fact j) * (a +i  0) ^ j) n)).
   intro n ; induction n.
  simpl ; field.
  rewrite sum_f_C0_simpl, tech5, <- Cre_add_compat, IHn ;
  apply Rplus_eq_compat_l.
  rewrite Cre_mul, Cpow_Cim_0, Cpow_Cre_0, Rmult_0_r, Rminus_0_r.
  rewrite INC_inv_Cre_INR ; [reflexivity | apply fact_neq_0].
 apply (Cseq_Rseq_Rseq_equiv _ _) ; apply Pser_Cseqcv_link ; unfold exp_seq in H1 ; apply H1.
 apply H.

 apply (Rseq_cv_unique (fun n => Cim (sum_f_C0 (fun j : nat => / INC (fact j) * (a +i  0) ^ j) n))).
  apply (Cseq_Rseq_Rseq_equiv _ _) ; apply Pser_Cseqcv_link ; unfold exp_seq in H1 ; apply H1.
  apply (Rseq_cv_eq_compat R0) ; [| apply Rseq_constant_cv].
  intro n ; induction n ; unfold Rseq_constant in *.
  simpl ; field.
  rewrite sum_f_C0_simpl, <- Cim_add_compat, <- IHn, Cim_mul, Cpow_Cim_0,
  Cpow_Cre_0, INC_inv_Cim_INR ; [ring | apply fact_neq_0].
Qed.

Lemma Cre_Cpow_2 : forall (a : R) (n : nat), Cre ((0 +i a) ^ (2 * n)) = ((-1) ^ n * a ^ (2*n))%R.
Proof.
intros a n ; induction n.
 simpl ; ring.
 replace (2 * S n)%nat with (S (S (2 * n))) by intuition.
 do 2 rewrite Cpow_S, Cre_mul ; rewrite IHn.
 rewrite Cim_mul.
 replace (Cre (0 +i a)) with R0 by reflexivity.
 repeat rewrite IHn ; simpl ; ring.
Qed.

Lemma Cim_Cpow_2 : forall (a : R) (n : nat), Cim ((0 +i a) ^ (2 * n)) = R0.
Proof.
intros a n ; induction n.
 simpl ; ring.
 replace (2 * S n)%nat with (S (S (2 * n))) by intuition.
 do 2 rewrite Cpow_S, Cim_mul ; rewrite IHn.
 rewrite Cre_mul.
 replace (Cre (0 +i a)) with R0 by reflexivity.
 repeat rewrite IHn ; ring.
Qed.

Lemma Cre_Cpow_S2 : forall (a : R) (p : nat), Cre ((0 +i  a) ^ S (2 * p)) = R0.
Proof.
intros a n ; induction n.
 simpl ; ring.
 replace (2 * S n)%nat with (S (S (2 * n))) by intuition.
 do 2 rewrite Cpow_S, Cre_mul ; rewrite IHn.
 rewrite Cim_mul.
 replace (Cre (0 +i a)) with R0 by reflexivity.
 repeat rewrite IHn ; ring.
Qed.

Lemma Cim_Cpow_S2 : forall (a : R) (n : nat), Cim ((0 +i a) ^ (S (2 * n))) = ((-1) ^ n * a ^ S (2*n))%R.
Proof.
intros a n ; induction n.
 simpl ; ring.
 replace (2 * S n)%nat with (S (S (2 * n))) by intuition.
 do 2 rewrite Cpow_S, Cim_mul ; rewrite IHn.
 rewrite Cre_mul.
 replace (Cre (0 +i a)) with R0 by reflexivity.
 repeat rewrite IHn ; simpl ; ring.
Qed.

Lemma n_modulo_2 : forall n:nat, {p | (n = 2 * p)%nat} + {p | n = S (2 * p)}.
Proof.
intro n ; induction n.
 left ; exists 0%nat ; intuition.
 case IHn ; intro H ; destruct H as (p,Hp) ;
 [right ; exists p | left ; exists (S p)] ; intuition.
Qed.

Lemma Cexp_trigo_compat : forall a, Cexp (0 +i a) = cos a +i sin a.
Proof.
intros a ; rewrite <- Ceq ; split ; simpl ;
 pose (l := sum _ exp_infinite_cv_radius (0 +i  a)) ;
 replace (Cexp (0 +i  a)) with l by reflexivity.
 unfold cos ; destruct (exist_cos (Rsqr a)) as (l', Hl') ; unfold cos_in, cos_n in Hl'.
 apply Rseq_cv_unique with (fun N => Cre (sum_f_C0 (gt_Pser exp_seq (0 +i a)) N)).
 apply (Cseq_Rseq_Rseq_equiv _ _) ; apply Pser_Cseqcv_link ; apply sum_sums.
 intros eps eps_pos ; destruct (Hl' _ eps_pos) as [N HN] ; exists (2 * N)%nat ;
 intros n n_lb ; unfold R_dist.

 destruct (n_modulo_2 n) as [H|H] ; destruct H as [p Hp] ; rewrite Hp.
 replace (Cre (sum_f_C0 (gt_Pser exp_seq (0 +i  a)) (2 * p))) with
  (sum_f_R0 (fun i : nat => ((-1) ^ i / INR (fact (2 * i)) * a² ^ i)%R) p).
 apply HN ; omega.

clear ; induction p.
 simpl ; field.
 replace (2 * S p)%nat with (S (S (2 * p)))%nat by intuition.
 do 2 rewrite sum_f_C0_simpl ; rewrite tech5 ; do 2 rewrite<- Cre_add_compat ;
 rewrite <- IHp, Rplus_assoc ; apply Rplus_eq_compat_l.
 replace ((-1) ^ S p / INR (fact (2 * S p)) * a² ^ S p)%R
 with (Cre (gt_Pser exp_seq (0 +i  a) (S (S (2 * p))))).
 replace (Cre (gt_Pser exp_seq (0 +i  a) (S (2 * p))))%R with R0.
 symmetry ; apply Rplus_0_l.
 unfold gt_Pser, exp_seq ; rewrite Cre_mul.
 replace (S (S (2 * p))) with (2 * S p)%nat by intuition.
 rewrite Cim_inv_INC, Rmult_0_l, Cre_Cpow_S2 ; ring.
 unfold gt_Pser, exp_seq ; rewrite Cre_mul.
 replace (S (S (2 * p))) with (2 * S p)%nat by intuition.
 rewrite Cre_Cpow_2, Cim_Cpow_2, INC_inv_Cre_INR.
 unfold Rsqr ; rewrite pow_mult, Rmult_0_r, Rminus_0_r.
 rewrite Rmult_comm ; unfold Rdiv ; do 2 rewrite Rmult_assoc ;
 apply Rmult_eq_compat_l.
 rewrite Rmult_comm ; simpl (pow a (S (S O))) ;
 rewrite Rmult_1_r ; reflexivity.
 apply fact_neq_0.

 replace (Cre (sum_f_C0 (gt_Pser exp_seq (0 +i  a)) (S (2 * p)))) with
  (sum_f_R0 (fun i : nat => ((-1) ^ i / INR (fact (2 * i)) * a² ^ i)%R) p).
 apply HN ; omega.

clear ; induction p.
 simpl ; field.
 replace (2 * S p)%nat with (S (S (2 * p)))%nat by intuition.
 do 2 rewrite sum_f_C0_simpl ; rewrite tech5 ; do 2 rewrite<- Cre_add_compat ;
 rewrite <- IHp, Rplus_assoc ; apply Rplus_eq_compat_l.
 replace ((-1) ^ S p / INR (fact (2 * S p)) * a² ^ S p)%R
 with (Cre (gt_Pser exp_seq (0 +i  a) (S (S (2 * p))))).
 replace (Cre (gt_Pser exp_seq (0 +i  a) (S (S (S (2 * p))))))%R with R0.
 symmetry ; apply Rplus_0_r.
 unfold gt_Pser, exp_seq ; rewrite Cre_mul.
 replace (S (S (2 * p))) with (2 * S p)%nat by intuition.
 rewrite Cim_inv_INC, Rmult_0_l, Cre_Cpow_S2 ; ring.
 unfold gt_Pser, exp_seq ; rewrite Cre_mul.
 replace (S (S (2 * p))) with (2 * S p)%nat by intuition.
 rewrite Cre_Cpow_2, Cim_Cpow_2, INC_inv_Cre_INR.
 unfold Rsqr ; rewrite pow_mult, Rmult_0_r, Rminus_0_r.
 rewrite Rmult_comm ; unfold Rdiv ; do 2 rewrite Rmult_assoc ;
 apply Rmult_eq_compat_l.
 rewrite Rmult_comm ; simpl (pow a (S (S O))) ;
 rewrite Rmult_1_r ; reflexivity.
 apply fact_neq_0.

 unfold sin ; destruct (exist_sin (Rsqr a)) as (l', Hl') ; unfold sin_in, sin_n in Hl'.
 apply Rseq_cv_unique with (fun N => Cim (sum_f_C0 (gt_Pser exp_seq (0 +i a)) N)).
 apply (Cseq_Rseq_Rseq_equiv _ _) ; apply Pser_Cseqcv_link ; apply sum_sums.
 intros eps eps_pos ; destruct (Req_dec a 0) as [a_eq | a_neq].
 exists O ; intros n n_lb ; unfold R_dist, gt_Pser ; rewrite a_eq, Rmult_0_l.
 replace (Cim (sum_f_C0 (fun n0 : nat => exp_seq n0 * (0 +i  0) ^ n0) n)) with R0.
 rewrite Rminus_0_r, Rabs_R0 ; assumption.
 induction n.
 simpl ; field.
 rewrite sum_f_C0_simpl, <- Cim_add_compat, <- IHn, Rplus_0_l ;
 unfold gt_Pser ; replace (0 +i 0) with C0 by reflexivity.
 rewrite C0_pow, Cmult_0_r ; simpl ; intuition.
 intuition.

pose (eps' := (eps / Rabs a)%R) ; assert (eps'_pos : 0 < eps').
 unfold eps', Rdiv ; apply Rlt_mult_inv_pos ; [| apply Rabs_pos_lt] ; assumption.
destruct (Hl' _ eps'_pos) as [N HN] ; exists (S (2 * N))%nat ;
 intros n n_lb ; unfold R_dist.

 destruct (n_modulo_2 n) as [H|H] ; destruct H as [p Hp] ; rewrite Hp.
 destruct p.
 apply False_ind ; clear -n_lb Hp ; omega.
 replace (Cim (sum_f_C0 (gt_Pser exp_seq (0 +i  a)) (2 * S p))) with
  (a * sum_f_R0 (fun i : nat => ((-1) ^ i / INR (fact (2 * i + 1)) * a² ^ i)%R) p)%R.
  rewrite <- Rmult_minus_distr_l, Rabs_mult ; apply Rlt_le_trans with (Rabs a * eps')%R.
  apply Rmult_lt_compat_l ; [apply Rabs_pos_lt ; assumption|] ; apply HN ; omega.
  unfold eps' ; right ; field ; apply Rabs_no_R0 ; assumption.
  rewrite scal_sum.
  clear ; induction p.
  simpl ; field.

 replace (2 * S (S p))%nat with (S (S (2 * S p))) by intuition.
 rewrite tech5 ; do 2 rewrite sum_f_C0_simpl, <- Cim_add_compat.
 rewrite IHp, Rplus_assoc ; apply Rplus_eq_compat_l.
 replace (Cim (gt_Pser exp_seq (0 +i  a) (S (S (2 * S p)))))%R with R0.
 unfold gt_Pser, exp_seq.
 rewrite Cim_mul, Cre_Cpow_S2, Cim_Cpow_S2, Rmult_0_l, Rplus_0_r,
 Rplus_0_r.
 unfold Rsqr.
 rewrite INC_inv_Cre_INR.
 replace (a ^ S (2 * S p))%R with (a * (a ^ 2) ^ (S p))%R.
 replace (2 * S p + 1)%nat with (S (2 * S p)) by intuition.
 rewrite (Rmult_comm (/ INR (fact (S (2 * S p)))) _) ; unfold Rdiv ;
 repeat rewrite Rmult_assoc ; apply Rmult_eq_compat_l.
 rewrite Rmult_comm, <- Rmult_assoc ; apply Rmult_eq_compat_r.
 rewrite Rmult_comm ; apply Rmult_eq_compat_l.
 simpl ; repeat rewrite Rmult_1_r ; reflexivity.
 rewrite <- pow_mult ; simpl ; reflexivity.
 apply fact_neq_0.
unfold gt_Pser, exp_seq ; rewrite Cim_mul ;
replace ( S (S (2 * S p))) with (2 * (S (S p)))%nat by intuition ;
rewrite Cim_Cpow_2, INC_inv_Cim_INR.
do 2 rewrite Rmult_0_r ; ring.
apply fact_neq_0.

 replace (Cim (sum_f_C0 (gt_Pser exp_seq (0 +i  a)) (S (2 * p)))) with
  (a * sum_f_R0 (fun i : nat => ((-1) ^ i / INR (fact (2 * i + 1)) * a² ^ i)%R) p)%R.
  rewrite <- Rmult_minus_distr_l, Rabs_mult ; apply Rlt_le_trans with (Rabs a * eps')%R.
  apply Rmult_lt_compat_l ; [apply Rabs_pos_lt ; assumption|] ; apply HN ; omega.
  unfold eps' ; right ; field ; apply Rabs_no_R0 ; assumption.
  rewrite scal_sum.
  clear ; induction p.
  simpl ; field.

 replace (2 * (S p))%nat with (S (S (2 * p))) by intuition.
 rewrite tech5 ; do 2 rewrite sum_f_C0_simpl, <- Cim_add_compat.
 rewrite IHp, Rplus_assoc ; apply Rplus_eq_compat_l.
 replace (Cim (gt_Pser exp_seq (0 +i  a) (S (S (2 * p)))))%R with R0.
 unfold gt_Pser, exp_seq.
 replace (S (S (S (2 * p)))) with (S (2 * (S p))) by intuition.
 rewrite Cim_mul, Cre_Cpow_S2, Cim_Cpow_S2, Rmult_0_l,
 Rplus_0_l, Rplus_0_r.
 unfold Rsqr.
 rewrite INC_inv_Cre_INR.
 replace (a ^ S (2 * S p))%R with (a * (a ^ 2) ^ (S p))%R.
 replace (2 * S p + 1)%nat with (S (2 * S p)) by intuition.
 rewrite (Rmult_comm (/ INR (fact (S (2 * S p)))) _) ; unfold Rdiv ;
 repeat rewrite Rmult_assoc ; apply Rmult_eq_compat_l.
 rewrite Rmult_comm, <- Rmult_assoc ; apply Rmult_eq_compat_r.
 rewrite Rmult_comm ; apply Rmult_eq_compat_l.
 simpl ; repeat rewrite Rmult_1_r ; reflexivity.
 rewrite <- pow_mult ; simpl ; reflexivity.
 apply fact_neq_0.
unfold gt_Pser, exp_seq ; rewrite Cim_mul ;
replace (S (S (2 * p))) with (2 * (S p))%nat by intuition ;
rewrite Cim_Cpow_2, INC_inv_Cim_INR.
do 2 rewrite Rmult_0_r ; ring.
apply fact_neq_0.
Qed.

Lemma Cexp_abs_cv : forall z, {l | Cser_abs_cv (gt_Pser exp_seq z) l}.
Proof.
intro z ; assert (z_bd : Cnorm z < Cnorm z + 1) by intuition ;
 destruct (Cpser_abel2_prelim _ _ (exp_infinite_cv_radius (Cnorm z + 1)%R) _ z_bd) as [l Hl].
 assert (H := Pser_Cseqcv_link _ _ _ Hl).
 exists l ; unfold Cser_abs_cv.
apply Rseq_cv_eq_compat with
      (fun n => Cre (sum_f_C0 (fun n : nat => Cnorm (gt_Pser exp_seq z n)) n)).
intro n ; rewrite <- sum_f_C0_Cre_compat ; simpl ; reflexivity.
replace l with (Cre l) by auto ; apply Cseq_cv_re_compat.
eapply Cseq_cv_eq_compat ; [| apply H].
intro n ; induction n.
simpl ; unfold gt_Pser ; rewrite Cnorm_Cmult ;
rewrite Cmult_IRC_Rmult, Cnorm_pow ; reflexivity.
do 2 rewrite sum_f_C0_simpl ; rewrite IHn ; apply Cadd_eq_compat_l.
simpl ; unfold gt_Pser ; rewrite Cnorm_Cmult ;
rewrite Cmult_IRC_Rmult, Cnorm_pow, IRC_pow_compat ;
reflexivity.
Qed.

Lemma binomial_diag n : Binomial.C n n = 1.
Proof.
intros n.
unfold Binomial.C.
rewrite minus_diag.
simpl.
field.
INR_solve; apply fact_neq_0.
Qed.

Lemma binomial_zero n : Binomial.C n 0 = 1.
Proof.
intros n.
unfold Binomial.C.
simpl.
rewrite <- minus_n_O.
field.
INR_solve; apply fact_neq_0.
Qed.

Open Scope C_scope.

Lemma binomial_sum (x y:C) n :
  (x + y) ^ n = sum_f_C0 (fun p => IRC (Binomial.C n p) * x ^ p * y ^ (n - p)) n.
Proof.
intros x y n.
induction n.
 unfold Binomial.C; simpl.
 rewrite <- Ceq; simpl; split; field.

 destruct n.
  unfold Binomial.C; simpl.
  rewrite <- Ceq; simpl; split; field.

  rewrite sum_f_C0_simpl.
  rewrite <- sum_f_C0_reindex.

  rewrite Csum_eq_compat with _ (fun k =>
    Binomial.C (S n)    k  * x ^ S k * y ^ (S (S n) - S k) +
    Binomial.C (S n) (S k) * x ^ S k * y ^ (S (S n) - S k)) _.
   rewrite sum_f_C0_add_compat.
   rewrite Cpow_S.
   rewrite IHn.
   rewrite Cmult_add_distr_l.
   do 2 (rewrite Cmult_comm; rewrite sum_f_C0_mult).
   assert (AP:forall a b c d e f, a = d + f -> b = c + e -> a + b = c + (d + e) + f)
     by (intros; subst; ring); apply AP; clear AP.
    rewrite sum_f_C0_simpl.
    repeat rewrite binomial_diag.
    repeat rewrite minus_diag.
    apply Cadd_eq_compat.
     apply Csum_eq_compat_weak; intro; simpl; ring.
     simpl; ring.

    rewrite <- sum_f_C0_reindex.
    apply Cadd_eq_compat.
     simpl; repeat rewrite binomial_zero; ring.
     apply Csum_eq_compat; intros j Hj.
     rewrite <- minus_Sn_m with (S n) _; [|omega].
     simpl; ring.

   intros j Hj.
   repeat rewrite <- Cmult_add_distr_r.
   rewrite <- Binomial.pascal; [|omega].
   rewrite Cadd_IRC_Rplus; trivial.
Qed.

Lemma Cexp_add : forall a b, Cexp (a + b) = (Cexp a * Cexp b)%C.
Proof.
intros a b.
unfold Cexp.
pose (gt_Pser exp_seq) as tg.
apply Cser_cv_unique with (tg (a + b)).
apply sum_sums.
destruct (Cexp_abs_cv a) as [lna Hlna].
 eapply Cser_cv_eq_compat.
  2:eapply (Ccauchy_product (tg a) (tg b)) ; try apply sum_sums.

  intro n; simpl.
  unfold tg, gt_Pser, exp_seq.
  rewrite binomial_sum.
  rewrite sum_f_C0_mult.
  apply Csum_eq_compat_weak; intros p.
  unfold Binomial.C.
  rewrite Cdiv_IRC_Rdiv.
   repeat rewrite Cmult_IRC_Rmult.
   repeat rewrite IRC_INR_INC.
   field; repeat split; replace C0 with (INC O)%C by trivial;
     apply not_INC; apply fact_neq_0.
  apply Rmult_integral_contrapositive.
   INR_solve; apply fact_neq_0.
apply Hlna.
Qed.

Lemma Cexp_0 : Cexp C0 = C1.
Proof.
replace C0 with (IRC R0) by auto.
rewrite Cexp_exp_compat ; rewrite exp_0 ; auto.
Qed.

Lemma Cexp_mult : forall a n, Cexp (INC n * a) = (Cexp a) ^ n.
Proof.
intros a n ; induction n.
simpl ; rewrite Cmult_0_l ; apply Cexp_0.
rewrite S_INC, Cpow_S, Cmult_add_distr_r,
 Cmult_1_l, Cexp_add, IHn ; ring.
Qed.


Require Import Logic.Axiom.Extensionality.

Require Import Logic.Rel.R.
Require Import Logic.Rel.Embed.
Require Import Logic.Rel.Composition.

(* The category of relations has coproducts with sum object a + b               *)

(* Injection mappings                                                           *)
Definition inj1 (a b:Type) : R a (a + b) := embed inl.
Definition inj2 (a b:Type) : R b (a + b) := embed inr.

Arguments inj1 {a} {b}.
Arguments inj2 {a} {b}.

Lemma inj1_charac : forall (a b:Type) (x:a) (y:a + b), inj1 x y <-> y = inl x.
Proof.
    intros a b x y. unfold inj1. split; intros H1.
    - destruct H1. reflexivity.
    - rewrite H1. constructor.
Qed.

Lemma inj2_charac : forall (a b:Type) (x:b) (y:a + b), inj2 x y <-> y = inr x.
Proof.
    intros a b x y. unfold inj2. split; intros H1.
    - destruct H1. reflexivity.
    - rewrite H1. constructor.
Qed.

(* Arrow needed for coproduct universal property.                               *)
Inductive either (a b c:Type) (r:R a c) (s:R b c) : R (a + b) c :=
| eitherL : forall (x:a) (y:c), r x y -> either a b c r s (inl x) y
| eitherR : forall (x:b) (y:c), s x y -> either a b c r s (inr x) y
.

Arguments either {a} {b} {c}.

Lemma either_charac : forall (a b c:Type) (r:R a c) (s:R b c) (x:a + b) (y:c),
    either r s x y
        <->
    (exists (x':a), x = inl x' /\ r x' y) \/
    (exists (x':b), x = inr x' /\ s x' y).
Proof.
    intros a b c r s x y. split.
    - intros [x' y' H1|x' y' H1].
        + left. exists x'. split.
            { reflexivity. }
            { assumption. }
        + right. exists x'. split.
            { reflexivity. }
            { assumption. }
    - intros [[x' [H1 H2]]|[x' [H1 H2]]]; rewrite H1; constructor; assumption.
Qed.

Lemma either_inj1 : forall (a b c:Type) (r:R a c) (s:R b c),
    either r s ; inj1 = r.
Proof.
    intros a b c r s. apply Ext. intros x y. unfold comp. split.
    - intros [[z|z] [H1 H2]].
        + remember (inl z) as z' eqn:E. destruct H1. inversion E.
          subst. clear E. remember (inl z) as z' eqn:E. destruct H2; inversion E.
          subst. assumption.
        + remember (inr z) as z' eqn:E. destruct H1. inversion E.
    - intros H1. exists (inl x). split.
        + constructor.
        + constructor. assumption.
Qed.

Lemma either_inj2 : forall (a b c:Type) (r:R a c) (s:R b c),
    either r s ; inj2 = s.
Proof.
    intros a b c r s. apply Ext. intros x y. unfold comp. split.
    - intros [[z|z] [H1 H2]].
        + remember (inl z) as z' eqn:E. destruct H1. inversion E.
        + remember (inr z) as z' eqn:E. destruct H1. inversion E.
          subst. clear E. remember (inr z) as z' eqn:E. destruct H2; inversion E.
          subst. assumption.
    - intros H1. exists (inr x). split.
        + constructor.
        + constructor. assumption.
Qed.

(* Existence part of universal property                                         *)
Lemma sum_existence : forall (a b c:Type) (r:R a c) (s:R b c),
    exists (t:R (a + b) c), t ; inj1 = r /\ t ; inj2 = s.
Proof.
    intros a b c r s. exists (either r s). split.
    - apply either_inj1.
    - apply either_inj2.
Qed.

(* Uniqueness part of universal property                                        *)
Lemma sum_uniqueness : forall (a b c:Type) (r s:R (a + b) c),
    r ; inj1 = s ; inj1 ->
    r ; inj2 = s ; inj2 ->
    r = s.
Proof.
    intros a b c r s H1 H2. apply Ext. intros [x|x] y.
    - split; intros H3.
        + assert (exists z, inj1 x z /\ r z y) as H4.
            { exists (inl x). split.
                { constructor. }
                { assumption. }}
          change ((r ; inj1) x y) in H4. rewrite H1 in H4.
          unfold comp in H4. destruct H4 as [z [H4 H5]]. destruct H4. assumption.
        + assert (exists z, inj1 x z /\ s z y) as H4.
            { exists (inl x). split.
                { constructor. }
                { assumption. }}
          change ((s ; inj1) x y) in H4. rewrite <- H1 in H4.
          unfold comp in H4. destruct H4 as [z [H4 H5]]. destruct H4. assumption.
    - split; intros H3.
        + assert (exists z, inj2 x z /\ r z y) as H4.
            { exists (inr x). split.
                { constructor. }
                { assumption. }}
          change ((r ; inj2) x y) in H4. rewrite H2 in H4.
          unfold comp in H4. destruct H4 as [z [H4 H5]]. destruct H4. assumption.
        + assert (exists z, inj2 x z /\ s z y) as H4.
            { exists (inr x). split.
                { constructor. }
                { assumption. }}
          change ((s ; inj2) x y) in H4. rewrite <- H2 in H4.
          unfold comp in H4. destruct H4 as [z [H4 H5]]. destruct H4. assumption.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

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

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

Delimit Scope Rfun_scope with F.

Arguments Scope plus_fct [Rfun_scope Rfun_scope R_scope].
Arguments Scope mult_fct [Rfun_scope Rfun_scope R_scope].
Arguments Scope minus_fct [Rfun_scope Rfun_scope R_scope].
Arguments Scope div_fct [Rfun_scope Rfun_scope R_scope].
Arguments Scope inv_fct [Rfun_scope R_scope].
Arguments Scope opp_fct [Rfun_scope R_scope].
Arguments Scope mult_real_fct [R_scope Rfun_scope R_scope].
Arguments Scope div_real_fct [R_scope Rfun_scope R_scope].
Arguments Scope comp [Rfun_scope Rfun_scope R_scope].

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

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

(****************************************************)
(** *          Variations of functions              *)
(****************************************************)
Definition increasing f : Prop := forall x y:R, x <= y -> f x <= f y.
Definition decreasing f : Prop := forall x y:R, x <= y -> f y <= f x.
Definition strict_increasing f : Prop := forall x y:R, x < y -> f x < f y.
Definition strict_decreasing f : Prop := forall x y:R, x < y -> f y < f x.
Definition constant f : Prop := forall x y:R, f x = f y.

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

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

(***************************************************)
(** *    Definition of continuity as a limit       *)
(***************************************************)

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

Arguments Scope continuity_pt [Rfun_scope R_scope].
Arguments Scope continuity [Rfun_scope].

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

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

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

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

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

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

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

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

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

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

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

Lemma continuity_opp : forall f, continuity f -> continuity (- f).
Proof.
  unfold continuity in |- *; intros; apply (continuity_pt_opp f x (H x)).
Qed.

Lemma continuity_minus :
  forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 - f2).
Proof.
  unfold continuity in |- *; intros;
    apply (continuity_pt_minus f1 f2 x (H x) (H0 x)).
Qed.

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

Lemma continuity_const : forall f, constant f -> continuity f.
Proof.
  unfold continuity in |- *; intros; apply (continuity_pt_const f x H).
Qed.

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

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

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

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

(*****************************************************)
(** * Derivative's definition using Landau's kernel  *)
(*****************************************************)

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

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

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

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

Arguments Scope derivable_pt_lim [Rfun_scope R_scope].
Arguments Scope derivable_pt_abs [Rfun_scope R_scope R_scope].
Arguments Scope derivable_pt [Rfun_scope R_scope].
Arguments Scope derivable [Rfun_scope].
Arguments Scope derive_pt [Rfun_scope R_scope _].
Arguments Scope derive [Rfun_scope _].

Definition antiderivative f (g:R -> R) (a b:R) : Prop :=
  (forall x:R,
    a <= x <= b ->  exists pr : derivable_pt g x, f x = derive_pt g x pr) /\
  a <= b.
(**************************************)
(** * Class of differential functions *)
(**************************************)
Record Differential : Type := mkDifferential
  {d1 :> R -> R; cond_diff : derivable d1}.

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

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

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

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

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

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

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

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

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

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

(***********************************)
(** * derivability -> continuity   *)
(***********************************)
(**********)
Lemma derivable_derive :
  forall f (x:R) (pr:derivable_pt f x),  exists l : R, derive_pt f x pr = l.
Proof.
  intros; exists (proj1_sig pr).
  unfold derive_pt in |- *; reflexivity.
Qed.

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

Theorem derivable_continuous : forall f, derivable f -> continuity f.
Proof.
  unfold derivable, continuity in |- *; intros f X x.
  apply (derivable_continuous_pt f x (X x)).
Qed.

(****************************************************************)
(** *                    Main rules                             *)
(****************************************************************)

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

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

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

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

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

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

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

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

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

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

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

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

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

Lemma derivable_pt_const : forall a x:R, derivable_pt (fct_cte a) x.
Proof.
  intros; unfold derivable_pt in |- *.
  exists 0.
  apply derivable_pt_lim_const.
Qed.

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

Lemma derivable_pt_id : forall x:R, derivable_pt id x.
Proof.
  unfold derivable_pt in |- *; intro.
  exists 1.
  apply derivable_pt_lim_id.
Qed.

Lemma derivable_pt_Rsqr : forall x:R, derivable_pt Rsqr x.
Proof.
  unfold derivable_pt in |- *; intro; exists (2 * x).
  apply derivable_pt_lim_Rsqr.
Qed.

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

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

Lemma derivable_opp : forall f, derivable f -> derivable (- f).
Proof.
  unfold derivable in |- *; intros f X x.
  apply (derivable_pt_opp _ x (X _)).
Qed.

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

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

Lemma derivable_const : forall a:R, derivable (fct_cte a).
Proof.
  unfold derivable in |- *; intros.
  apply derivable_pt_const.
Qed.

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

Lemma derivable_id : derivable id.
Proof.
  unfold derivable in |- *; intro; apply derivable_pt_id.
Qed.

Lemma derivable_Rsqr : derivable Rsqr.
Proof.
  unfold derivable in |- *; intro; apply derivable_pt_Rsqr.
Qed.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Lemma derivable_pow : forall n:nat, derivable (fun y:R => y ^ n).
Proof.
  intro; unfold derivable in |- *; intro; apply derivable_pt_pow.
Qed.

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

Lemma pr_nu :
  forall f (x:R) (pr1 pr2:derivable_pt f x),
    derive_pt f x pr1 = derive_pt f x pr2.
Proof.
  intros.
  unfold derivable_pt in pr1.
  unfold derivable_pt in pr2.
  elim pr1; intros.
  elim pr2; intros.
  unfold derivable_pt_abs in p.
  unfold derivable_pt_abs in p0.
  simpl in |- *.
  apply (uniqueness_limite f x x0 x1 p p0).
Qed.

(************************************************************)
(** *           Local extremum's condition                  *)
(************************************************************)

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

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

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

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


Require Export Lambda.PTS.Syntax Coq.Classes.RelationClasses Setoid.

Open Scope term_scope.

Section Sub.
  Context {sorts : Set}.

  Fixpoint Rename (ρ : nat -> nat) (t : term sorts) : term sorts :=
    match t with
    | sort _  => t
    | ident x => ident $ ρ x
    | A ⋅ B   => Rename ρ A ⋅ Rename ρ B
    | λ A ⇒ B => λ Rename ρ A ⇒ Rename (ext ρ) B
    | ∏ A `, B => ∏ Rename ρ A `, Rename (ext ρ) B
    end.

  Lemma Rename_mapply_id : forall A m,
      Rename (mapply m ext (fun n => n)) A = A.
  Proof.
    intro A;
      induction A as
      [ s | x | A ihA B ihb
      | A ihA B ihB | A ihA B ihB ];
      intros m;
      try specialize ihB with (m := S m);
      cbn in *; unfold "$"; f_equal; auto using mapply_id.
    generalize dependent x.
    induction m as [| m ih]; intro x; cbn; try reflexivity.
    destruct x as [| x]; cbn; f_equal; auto.
  Qed.

  Lemma Rename_id : forall A, Rename (fun n => n) A = A.
  Proof.
    intro A.
    pose proof Rename_mapply_id A 0 as h;
      cbn in h; assumption.
  Qed.

  Lemma map_Rename_id : forall As, map (Rename (fun n => n)) As = As.
  Proof.
    intro As; induction As as [| A As ih];
      cbn; f_equal; auto using Rename_id.
  Qed.

  Lemma Rename_mapply_ext : forall A ρ n,
      Rename (mapply (S n) ext ρ) (Rename (mapply n ext S) A)
      = Rename (mapply n ext S) (Rename (mapply n ext ρ) A).
  Proof.
    intro A;
      induction A as
      [ s | x | A ihA B ihB
      | A ihA B ihB | A ihA B ihB];
      intros ρ n; cbn; unfold "$"; f_equal;
      try pose proof ihB ρ (S n) as IHB;
      cbn in *; auto using mapply_ext.
  Qed.

  Lemma Rename_ext : forall A ρ,
      Rename (ext ρ) (Rename S A) = Rename S (Rename ρ A).
  Proof.
    intros A ρ.
    pose proof Rename_mapply_ext A ρ 0 as h;
      cbn in h; assumption.
  Qed.

  Lemma mapply_ext_add : forall m n k x,
      mapply m ext (add n) (mapply m ext (add k) x) = mapply m ext (add (n + k)) x.
  Proof.
    intro m; induction m as [| m ih];
      intros n k x; cbn; try lia.
    destruct x as [| x]; cbn; f_equal; auto.
  Qed.

  Lemma Rename_ext_add : forall A m n k,
      Rename (mapply m ext (add n)) (Rename (mapply m ext (add k)) A)
      = Rename (mapply m ext (add (n + k))) A.
  Proof.
    intro A; induction A as
      [ s | x | A ihA B ihb
      | A ihA B ihB | A ihA B ihB ];
      intros m n k; cbn; unfold "$";
      try specialize ihB with (S m) n k; try cbn in ihB;
      f_equal; auto using mapply_ext_add; try lia.
  Qed.

  Lemma Rename_add : forall A m n,
      Rename (add m) (Rename (add n) A) = Rename (add (m + n)) A.
  Proof.
    intros A m n.
    pose proof Rename_ext_add A 0 m n as h;
      cbn in h; assumption.
  Qed.

  Lemma map_Rename_add : forall As m n,
      map (Rename (add m)) (map (Rename (add n)) As)
      = map (Rename (add (m + n))) As.
  Proof.
    intro As; induction As as [| A As ih];
      intros m n; cbn; f_equal; auto using Rename_add.
  Qed.

  Lemma map_Rename_ext_add : forall As m n k,
      map (Rename (mapply m ext (add n))) (map (Rename (mapply m ext (add k))) As)
      = map (Rename (mapply m ext (add (n + k)))) As.
  Proof.
    intro As; induction As as [| A As ih];
      intros m n k; cbn; f_equal; auto using Rename_ext_add.
  Qed.

  Lemma mapply_Rename_sort : forall m ρ s,
      mapply m (Rename ρ) (sort s) = sort s.
  Proof.
    intro m; induction m as [| m ih];
      intros ρ s; cbn; auto.
    rewrite <- mapply_comm; cbn; auto.
  Qed.

  Lemma mapply_Rename_ident : forall m ρ x,
      mapply m (Rename ρ) (ident x) = ident (mapply m ρ x).
  Proof.
    intro m; induction m as [| m ih];
      intros ρ x; cbn; unfold "$"; auto.
    do 2 rewrite <- mapply_comm; cbn; unfold "$"; auto.
  Qed.

  Lemma mapply_Rename_app : forall m ρ A B,
      mapply m (Rename ρ) (A ⋅ B)
      = mapply m (Rename ρ) A ⋅ mapply m (Rename ρ) B.
  Proof.
    intro m; induction m as [| m ih];
      intros ρ A B; cbn; auto.
    do 3 rewrite <- mapply_comm; cbn; auto.
  Qed.

  Lemma mapply_Rename_abs : forall m ρ A B,
    mapply m (Rename ρ) (λ A ⇒ B)
    = λ mapply m (Rename ρ) A ⇒ mapply m (Rename (ext ρ)) B.
  Proof.
    intro m; induction m as [| m ih];
      intros ρ A B; cbn; auto.
    do 3 rewrite <- mapply_comm; cbn; auto.
  Qed.

  Lemma mapply_Rename_pi : forall m ρ A B,
    mapply m (Rename ρ) (∏ A `, B)
    = ∏ mapply m (Rename ρ) A `, mapply m (Rename (ext ρ)) B.
  Proof.
    intro m; induction m as [| m ih];
      intros ρ A B; cbn; auto.
    do 3 rewrite <- mapply_comm; cbn; auto.
  Qed.

  Definition exts (σ : nat -> term sorts) (x : nat) : term sorts :=
    match x with
    | O   => ident O
    | S n => Rename S $ σ n
    end.

  Fixpoint subs (σ : nat -> term sorts) (t : term sorts) : term sorts :=
    match t with
    | sort _ => t
    | ident x   => σ x
    | A ⋅ B => subs σ A ⋅ subs σ B
    | λ A ⇒ B => λ subs σ A ⇒ subs (exts σ) B
    | ∏ A `, B => ∏ subs σ A `, subs (exts σ) B
    end.

  Definition sub_helper (t : term sorts) (x : nat) : term sorts :=
    match x with
    | O => t
    | S n => ident n
    end.

  Lemma mapply_exts_ident : forall n x a,
      mapply n exts (sub_helper a) (mapply n ext S x) = ident x.
  Proof.
    intros n x a; depind n; cbn; auto.
    destruct x as [| x]; cbn; auto.
    unfold "$"; rewrite IHn; reflexivity.
  Qed.

  Local Hint Resolve mapply_exts_ident : core.

  Lemma subs_rename_S : forall (B : term sorts) a n,
      subs
        (mapply n exts (sub_helper a))
        (Rename (mapply n ext S) B) = B.
  Proof.
    intros B a n; depind B; cbn; f_equal; auto;
      specialize IHB2 with a (S n);
      cbn in *; assumption.
  Qed.

  Lemma Rename_ident_distr : forall x n ρ C,
      Rename (mapply n ext ρ) (mapply n exts (sub_helper C) x)
      = mapply n exts (sub_helper (Rename ρ C)) (ext (mapply n ext ρ) x).
  Proof.
    intro x; induction x as [| x ihx];
      intros [| n] ρ C; cbn; unfold "$"; try reflexivity.
    rewrite Rename_ext; f_equal; auto.
  Qed.

  Lemma Rename_subs_distr : forall (A B : term sorts) ρ n,
      Rename
        (mapply n ext ρ)
        (subs (mapply n exts (sub_helper B)) A)
      = subs
          (mapply n exts (sub_helper (Rename ρ B)))
          (Rename (mapply (S n) ext ρ) A).
  Proof.
    intro A;
      induction A as
      [ s | x | A ihA B ihB
      | A ihA B ihB | A ihA B ihB];
      intros C ρ n; cbn; unfold "$";
      try (f_equal; eauto using Rename_ident_distr;
           try pose proof ihB C ρ (S n) as ihB; cbn in *; assumption).
  Qed.

  Lemma Rename_mapply_σ : forall m x σ,
      Rename (mapply m ext S) (mapply m exts σ x) = mapply (S m) exts σ (mapply m ext S x).
  Proof.
    intro m; induction m as [| m ih];
      intros [| x] σ; cbn; unfold "$"; auto.
    specialize ih with x σ; cbn in ih.
    rewrite <- ih, Rename_ext; reflexivity.
  Qed.

  Lemma subs_Rename_mapply_ext : forall A σ m,
      Rename (mapply m ext S) (subs (mapply m exts σ) A)
      = subs (mapply (S m) exts σ) (Rename (mapply m ext S) A).
  Proof.
    intro A; induction A
      as [s | x | A ihA B ihB
         | A ihA B ihB | A ihA B ihB];
      intros σ m; cbn; f_equal; auto;
      try (rewrite Rename_mapply_σ; reflexivity);
      try (rewrite ihA; reflexivity);
      try (rewrite ihB; reflexivity);
      try (specialize ihB with σ (S m); cbn in ihB; assumption).
  Qed.

  Lemma subs_Rename : forall A σ,
      Rename S (subs σ A) = subs (exts σ) (Rename S A).
  Proof.
    intros A σ.
    pose proof subs_Rename_mapply_ext A σ 0 as h;
      cbn in h; assumption.
  Qed.

  Definition sub (body arg : term sorts) : term sorts :=
    subs (sub_helper arg) body.
End Sub.

Notation "x '[[' y ']]'"
  := (sub x y) (at level 12, left associativity) : term_scope.

Lemma sub_rename_S : forall {sorts : Set} (B a : term sorts),
    (Rename S B) [[ a ]] = B.
Proof.
  intros sorts B a; unfold "_ [[ _ ]]".
  pose proof subs_rename_S B a 0 as h; cbn in h; assumption.
Qed.

Notation "x '→' y"
  := (pi x (Rename S y))
       (at level 41, right associativity).

Section RenameSub.
  Context {sorts : Set}.

  Lemma Rename_sub_distr : forall (A B : term sorts) ρ,
      Rename ρ (A [[ B ]]) = Rename (ext ρ) A [[ Rename ρ B ]].
  Proof.
    intros A B ρ; unfold "_ [[ _ ]]".
    pose proof Rename_subs_distr A B ρ 0 as h;
      cbn in h; assumption.
  Qed.

  Lemma mapply_Rename_sub_distr : forall m ρ (A B : term sorts),
      mapply m (Rename ρ) (A [[ B ]])
      = mapply m (Rename (ext ρ)) A [[ mapply m (Rename ρ) B ]].
  Proof.
    intro m; induction m as [| m ih];
      intros ρ A B; cbn; auto.
    do 3 rewrite <- mapply_comm; cbn;
    rewrite Rename_sub_distr, ih; reflexivity.
  Qed.

  Lemma Rename_arrow : forall (A B : term sorts) ρ,
      Rename ρ (A → B) = Rename ρ A → Rename ρ B.
  Proof.
    intros A B ρ; cbn; f_equal;
      eauto using Rename_ext.
  Qed.

  Lemma subs_mapply_exts : forall m x (C : term sorts) σ,
        subs
          (mapply m exts σ)
          (mapply m exts (sub_helper C) x)
        = subs
            (mapply m exts (sub_helper (subs σ C)))
            (mapply (S m) exts σ x).
  Proof.
    intro m; induction m as [| m ih];
      intros [| x] C σ; cbn; unfold "$"; auto.
    - pose proof subs_rename_S (σ x) (subs σ C) 0 as h;
        cbn in h; rewrite h; reflexivity.
    - do 2 rewrite <- subs_Rename.
      rewrite ih; reflexivity.
  Qed.

  Lemma subs_subs_distr : forall (B C : term sorts) σ m,
      subs
        (mapply m exts σ)
        (subs (mapply m exts (sub_helper C)) B)
      = subs
          (mapply m exts (sub_helper (subs σ C)))
          (subs (mapply (S m) exts σ) B).
  Proof.
    intro B; induction B
      as [s | x | A ihA B ihB
         | A ihA B ihB | A ihA B ihB];
      intros C σ m; cbn in *; unfold "$";
      try (rewrite subs_mapply_exts; reflexivity);
      try (f_equal; eauto; assumption);
      try (f_equal; eauto;
           specialize ihB with C σ (S m); cbn in ihB; assumption).
  Qed.

  Lemma subs_sub_distr : forall (B C : term sorts) σ,
      subs σ (B [[ C ]]) = subs (exts σ) B [[ subs σ C ]].
  Proof.
    intros B C σ.
    pose proof subs_subs_distr B C σ 0 as h;
      cbn in h; assumption.
  Qed.
End RenameSub.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import Coq.Lists.List.

Require Import CatTheo.Functor.

Module Applicative.

Export Functor.

Class Applicative (F: Type -> Type) := {
  Applicative_Functor :> Functor F;

  pure: forall {X}, X -> F X;
  ap: forall {X Y}, F (X -> Y) -> F X -> F Y;

  app_identity : forall X (v: F X),
    ap (pure id) v = v;

  app_homomorphism : forall X Y (f: X -> Y) (x: X),
    ap (pure f) (pure x) = pure (f x);

  app_interchange : forall X Y (ff: F (X -> Y)) (x: X),
    ap ff (pure x) = ap (pure (fun w => w x)) ff;

  app_compose : forall X Y Z (fg: F (Y -> Z)) (ff: F (X -> Y)) (fx: F X),
    ap (ap (ap (pure compose) fg) ff) fx = ap fg (ap ff fx);

  app_fmap : forall X Y (f: X -> Y),
    fmap f = ap (pure f);
}.

End Applicative.

Module ApplicativeInst.

Import Applicative.

Export FunctorInst.

Section Applicative_list.

Definition pure_list {X} (x: X): list X := cons x nil.

Fixpoint ap_list {X Y} (funs: list (X -> Y)) (items: list X): list Y :=
  match funs with
  | nil => nil
  | f::fs => map f items ++ ap_list fs items
  end.

Lemma ap_list_nil {X Y}: forall ff: list (X -> Y),
  ap_list ff nil = nil.
Proof.
  intros ff.
  induction ff as [| f fs IHf].
  - trivial.
  - simpl.
    trivial.
Qed.

Lemma ap_list_distr {X Y}: forall fg ff: list (X -> Y),
  forall xs: list X,
    ap_list (fg ++ ff) xs = ap_list fg xs ++ ap_list ff xs.
Proof.
  intros fg ff xs.
  induction fg as [| g gs IHg].
  + trivial.
  + simpl.
    rewrite <- app_assoc.
    rewrite IHg.
    trivial.
Qed.

Lemma map_compose {X Y Z}: forall (f: X->Y)(g: Y -> Z)(xs: list X),
  map (compose g f) xs = map g (map f xs).
Proof.
  intros f g xs.
  induction xs as [| x xs IHx].
  + trivial.
  + simpl.
    rewrite IHx.
    trivial.
Qed.

Lemma ap_list_cons {X Y}: forall (f: X->Y)(fs: list (X->Y)),
  forall xs: list X,
    ap_list (f::fs) xs = map f xs ++ ap_list fs xs.
Proof. trivial. Qed.

Program Instance Applicative_list: Applicative list := {
  Applicative_Functor := Functor_list;
  pure := @pure_list;
  ap := @ap_list;
}.
Next Obligation.
  simpl.
  rewrite map_id.
  apply app_nil_r.
Defined.
Next Obligation.
  induction ff as [| f fs IHf].
  - trivial.
  - simpl.
    rewrite IHf.
    trivial.
Defined.
Next Obligation.
  induction fg as [| g gs IHg].
  - trivial.
  - rewrite ap_list_cons.
    rewrite <- IHg.
    simpl.
    rewrite ap_list_distr.
    f_equal; clear IHg gs.
    induction ff as [| f fs IHf].
    * trivial.
    * simpl.
      rewrite map_app.
      rewrite IHf.
      f_equal.
      apply map_compose.
Defined.

Next Obligation.
  extensionality l.
  rewrite app_nil_r.
  trivial.
Qed.

End Applicative_list.

Section Applicative_option.

Definition ap_option {X Y} (ff: option (X->Y)) (fx: option X): option Y :=
  match ff, fx with
  | Some f, Some x => Some (f x)
  | _,_ => None
  end.

Definition pure_option {X} (x: X): option X := Some x.

Program Instance Applicative_option: Applicative option := {
  Applicative_Functor := Functor_option;
  pure := @pure_option;
  ap := @ap_option;
}.
Next Obligation.
  destruct v; trivial.
Defined.
Next Obligation.
  destruct fg; destruct ff; destruct fx; trivial.
Defined.

End Applicative_option.

End ApplicativeInst.

Module ApplicativeProofs.

Import Functor.
Import Applicative.

End ApplicativeProofs.


Require Import Program.
Require Import Datatypes.
Require Import Arith.
Require Import List.
Require Import Contexts.
Require Import HOASCircuits.
Require Import MachineCircuits.
Require Import Omega.
Import ListNotations.
Open Scope list_scope.
Require Denotation.

Module M.

(*** Paper Examples ***)

(* Infix "↦" := m_box (at level 12, left associativity). *)
Notation "'gate' g 'on' l ; C" := (m_gate l g C) (at level 10, right associativity).
Notation "# l " := (length l) (at level 0).

Notation out l := (m_output l).
Open Scope circ_scope.

(* Basic Circuits *)

Definition id_circ l : Machine_Circuit #l #l := out l.

Definition new_discard : Machine_Circuit 0 0 :=
  gate new0 on [];
  gate discard on [0];
  out [].

Definition init_discard : Machine_Circuit 0 0 :=
  gate init0 on [];
  gate meas on [0];
  gate discard on [0];
  out [].

Definition hadamard_measure : Machine_Circuit 1 1 :=
  gate H on [0];
  gate meas on [0];
  out [0].

(* Repeated Unitaries *)

Definition repeat_hadamard : Machine_Circuit 1 1 :=
  gate H on [0];
  gate H on [0];
  out [0].

Definition U_U_trans_qubit (U : Unitary Qubit): Machine_Circuit 1 1 :=
  gate U on [0];
  gate (transpose U) on [0];
  out [0].

Definition U_U_trans {W} (U : Unitary W): Machine_Circuit (size_WType W) (size_WType W) :=
  let l := seq 0 (size_WType W) in
  gate U on l;
  gate (transpose U) on l;
  out l.

(* Deutsch's Algorithm *)

Parameter U_f : Unitary (Qubit ⊗ Qubit).
Definition deutsch : Machine_Circuit 0 1 :=
  gate init0 on [];
  gate H on [0];
  gate init1 on [];
  gate H on [1];
  gate U_f on [0;1];
  gate meas on [0];
  gate discard on [0];
  out [1].

(* Teleport *)

Definition init (b : bool) : Machine_Circuit 0 1:=
  if b then (gate init1 on []; out [0])
       else (gate init0 on []; out [0]).

(** Teleport **)

Definition bell00 : Machine_Circuit 0 2 :=
  gate init0 on [];
  gate init0 on [];
  gate H on [0];
  gate CNOT on [0;1];
  out [0;1].

Definition alice : Machine_Circuit 2 2 :=
  gate CNOT on [0;1];
  gate H on [0];
  gate meas on [0];
  gate meas on [1];
  out [0;1].

Definition bob : Machine_Circuit 3 1 :=
  gate (bit_ctrl σx) on [1;2];
  gate (bit_ctrl σz) on [0;2];
  gate discard on [1];
  gate discard on [0];
  out [2].

Definition teleport : Machine_Circuit 1 1 :=
  (* bell00 *) (* shifted from above *)
  gate init0 on [];
  gate init0 on [];
  gate H on [1];
  gate CNOT on [1;2];

  (* alice *)
  gate CNOT on [0;1];
  gate H on [0];
  gate meas on [0];
  gate meas on [1];

  (* bob *)
  gate (bit_ctrl σx) on [1;2];
  gate (bit_ctrl σz) on [0;2];
  gate discard on [1];
  gate discard on [0];
  out [0].

(* Coin Flip *)

Definition coin_flip : Machine_Circuit 0 1 :=
  gate init0 on [];
  gate H on [0];
  gate meas on [0];
  out [0].

(* Old teleport for IO-less circuits.
Definition teleport : Machine_Circuit := bell00 ↦ alice ↦ bob.

Print teleport.
Eval compute in teleport.
*)

Close Scope circ_scope.

(* *)

Import Denotation.

(* Verifying Properties of MachineExamples *)

(* Why can't I compose these? *)
Definition InitT := 〚M.init true〛 I1.

Lemma Ex : InitT = |1⟩⟨1|.
Proof.
  intros.
  unfold InitT, I1. simpl.
  unfold apply_new1. simpl.
  unfold compose_super, super.
  unfold swap_list, swap_list_aux, swap_two. simpl.
  Msimpl.
Qed.

Lemma had_meas_toss : 〚hadamard_measure〛 |0⟩⟨0| = even_toss.
Proof.
  simpl.
  repeat (unfold apply_U, apply_meas, swap_list, swap_two, pad; simpl).
  Msimpl.
  prep_matrix_equality.
  unfold compose_super, super, ket0, ket1, Mplus, Mmult, conj_transpose; simpl.
  Csimpl.
  destruct x, y; Csimpl; [ Csolve | Csolve | destruct_Csolve | destruct_Csolve].
Qed.

Definition FLIP : Square (2^1) := 〚coin_flip〛 I1.
Lemma flip_toss : 〚coin_flip〛 I1  = even_toss.
Proof.
  simpl.
  repeat (unfold apply_U, apply_meas, apply_new0, swap_list, swap_two, pad; simpl).
  Msimpl.
  prep_matrix_equality.
  unfold compose_super, super, ket0, ket1, Mplus, Mmult, conj_transpose.
  Csimpl.
  destruct x, y; Csimpl; [ Csolve | Csolve | destruct_Csolve | destruct_Csolve].
Qed.

Lemma unitary_trans_qubit_id : forall (U : Unitary Qubit) (ρ : Density (2^1)),
  WF_Matrix 2 2 ρ -> 〚U_U_trans_qubit U〛 ρ = ρ.
Proof.
  intros U ρ WF.
  simpl.
  specialize WF_unitary with U; intros wf.
  repeat (unfold apply_U, swap_list, swap_two, pad; simpl).
  Msimpl; auto.
  unfold compose_super, super. Msimpl.
  specialize (unitary_gate_unitary U). unfold is_unitary. simpl. intros [_ H].
  repeat rewrite <- Mmult_assoc.
  rewrite H.
  repeat rewrite Mmult_assoc.
  rewrite H.
  Msimpl.
Qed.

Lemma unitary_trans_id : forall W (U : Unitary W) (ρ : Density (2^〚W〛 )),
  WF_Matrix (2^〚W〛) (2^〚W〛) ρ -> 〚U_U_trans U〛 ρ = ρ.
Proof.
  intros W U ρ WF.
  simpl.
  unfold U_U_trans.
  rewrite leb_correct; try omega.
  rewrite leb_correct; try omega.
  unfold apply_U.
  replace (size_WType W + size_WType W - size_WType W)%nat with (size_WType W) by omega.
  rewrite swap_list_n_id.
  unfold pad.
  replace (size_WType W - size_WType W)%nat with O by omega.
  specialize (unitary_gate_unitary U). unfold is_unitary. simpl. intros [WFU H].
  Msimpl.
  unfold super, compose_super.
  rewrite conj_transpose_involutive.
  Msimpl.
  repeat rewrite <- Mmult_assoc.
  rewrite H.
  repeat rewrite Mmult_assoc.
  rewrite H.
  Msimpl.
Qed.

(* Corresponds to f(0) = 1, f(1) = 0. See Watrous p25. *)
Definition f10 : Matrix 2 2 := fun x y =>
  match x, y with
  | 0, 1 => 1
  | 1, 0 => 1
  | 2, 2 => 1
  | 3, 3 => 1
  | _, _ => 0
  end.

(*
Lemma deutsch_odd : denote_unitary U_f = f10 -> 〚deutsch〛(Id 1) = |1⟩⟨1| .
Proof.
  intros H.
  simpl.
  rewrite H. clear H.
  repeat (unfold apply_U, apply_discard, apply_meas, apply_new1, swap_list, swap_two, pad; simpl).
  Msimpl.
  prep_matrix_equality.
  unfold super, ket0, ket1. simpl.
  unfold Mplus, conj_transpose. simpl.
  unfold Mmult.
  simpl. (* Hangs *)
  destruct x, y; simpl.
  + Csolve.
  + destruct y; Csolve.
  + destruct x; Csolve.
  + destruct x. destruct y; Csolve.
    Csolve.
*)

End M.


From Coq Require Import Init.Nat Lia List.
From QuickChick Require Import QuickChick.
From mathcomp Require Import ssreflect ssreflect.eqtype ssrnat.
Import QcNotation. Import QcDefaultNotation.
Import ListNotations.

Require Import QuickChick.TacticsUtil ExtLib.Structures.Monads.
Open Scope monad_scope.
Open Scope qc_scope.
Open Scope nat_scope.

From Ltac2 Require Import Ltac2.

(* Inductive not_In {A: Type} : A -> list A -> Prop := *)
(* | In_nil: forall x, not_In x [] *)
(* | In_cons : forall x y l, *)
(*     x <> y -> not_In x l -> not_In x (y :: l).  *)

(* XXX Leo DEBUG params *)

(* This gives an unsound enum *)

(* Inductive not_In : nat -> list nat -> Prop := *)
(* | In_nil: forall x, not_In x [] *)
(* | In_cons : forall x y l, *)
(*     x <> y -> not_In x l -> not_In x (y :: l). *)

(* XXX Leo DEBUG *)

Inductive not_In : nat -> list nat -> Prop :=
| In_nil: forall x, not_In x []
| In_cons : forall x y l,
    not_In x l -> x <> y -> not_In x (y :: l).

Derive DecOpt for (not_In x l).

Instance not_In_SizeMonotonic x l : DecOptSizeMonotonic (not_In x l).
Proof. derive_mon (). Qed.

Instance not_In__sound x l : DecOptSoundPos (not_In x l).
Proof. derive_sound (). Qed.

Instance not_In_complete x l : DecOptCompletePos (not_In x l).
Proof. derive_complete (). Qed.

Derive EnumSizedSuchThat for (fun x => eq x n).

Instance EnumSizedSuchThateq_SizedMonotonic X {_ : Enum X} (n : X) :
  SizedMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThateq n)).
Proof. derive_enumST_SizedMonotonic (). Qed.

Instance EnumSizedSuchThateq_SizeMonotonic X `{_ : EnumMonotonic X} (n : X) :
  forall s, SizeMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThateq n) s).
Proof. derive_enumST_SizeMonotonic (). Qed.

Instance EnumSizedSuchThateq_Correct X `{_ : EnumMonotonicCorrect X} (n : X) :
  CorrectSizedST (fun m => eq n m) (@enumSizeST _ _ (EnumSizedSuchThateq n)).
Proof. derive_enumST_Correct (). Qed.

Derive EnumSizedSuchThat for (fun n => not_In n l).

Instance EnumSizedSuchThatnot_In_SizedMonotonic l :
  SizedMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThatnot_In l)).
Proof. derive_enumST_SizedMonotonic (). Qed.

Instance EnumSizedSuchThatnot_In_SizeMonotonic l :
    forall s, SizeMonotonicOpt (@enumSizeST _ _ (EnumSizedSuchThatnot_In l) s).
Proof. derive_enumST_SizeMonotonic (). Qed.

Instance EnumSizedSuchThatnot_In_Correct l :
    CorrectSizedST (fun n => not_In n l) (@enumSizeST _ _ (EnumSizedSuchThatnot_In l)).
Proof. derive_enumST_Correct (). Qed.