(************************************************************************)
(*    This is part of RelationAlgebra, it is distributed under the      *)
(*      terms of the GNU Lesser General Public License version 3        *)
(*                (see file LICENSE for more details)                   *)
(*                                                                      *)
(*  Copyright 2012-2013: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(************************************************************************)

(** * imp: a formalisation of the IMP programming language on top of KAT *)

(* We formalise the IMP language (whose programs are also known as
   "while programs"). We give a big step semantics as an inductive
   predicate, and using KAT, and we show that the two versions
   actually coincide.

   We then use the [kat] tactic to prove some simple program
   equivalences, and to derive all rules of corresponding Hoare logic
   for partial correctness. *)

Require Import kat prop rel comparisons kat_tac.

Section s.
(** identifiers for memory locations  *)
Variable loc: Set.
(** abstract state (or memory) *)
Variable state: Set.
(** updating the state *)
Variable update: loc -> nat -> state -> state.

(** * Definition of the languague *)

(** programs *)

Inductive prog :=
| skp
| aff (x: loc) (e: state -> nat)
| seq (p q: prog)
| ite (t: dset state) (p q: prog)
| whl (t: dset state) (p: prog).

(** notations *)
Bind Scope imp_scope with prog.
Delimit Scope imp_scope with imp.
Notation "x  <- y" := (aff x y) (at level 90): imp_scope.
Notation "p  ;; q" := (seq p%imp q%imp) (left associativity, at level 101): imp_scope.
Arguments ite _%ra _%imp _%imp.
Arguments whl _%ra _%imp.

(** * Big step semantics *)

(** corresponding functional relation *)
Notation upd x e := (frel (fun s => update x (e s) s)).

(** ** using KAT expressions in the model of relations

   the semantics can then be given by induction on the program, using
   a simple fixpoint *)

Fixpoint bstep (p: prog): rel state state :=
  match p with
    | skp => 1
    | aff x e => upd x e
    | seq p q => bstep p * bstep q
    | ite b p q => [b] * bstep p + [!b] * bstep q
    | whl b p => ([b] * bstep p)^*  *  [!b]
  end.

(** ** using an inductive predicate, as in standard textbooks *)

Inductive bstep': prog -> rel state state :=
| s_skp: forall s, bstep' skp s s
| s_aff: forall x e s, bstep' (x <- e) s (update x (e s) s)
| s_seq: forall p q s s' s'', bstep' p s s' -> bstep' q s' s'' -> bstep' (p ;; q) s s''
| s_ite_ff: forall (b: dset state) p q s s', b s = false -> bstep' q s s' -> bstep' (ite b p q) s s'
| s_ite_tt: forall (b: dset state) p q s s', b s = true -> bstep' p s s' -> bstep' (ite b p q) s s'
| s_whl_ff: forall (b: dset state) p s, b s = false -> bstep' (whl b p) s s
| s_whl_tt: forall (b: dset state) p s s', b s = true -> bstep' (p ;; whl b p) s s' -> bstep' (whl b p) s s'.

(** ** equivalence between the two definitions *)

Lemma bstep_eq p: bstep' p == bstep p.
Proof.
  apply antisym.
  - intros s s'. induction 1.
     reflexivity.
     reflexivity.
     eexists; eassumption.
     right. eexists. split. reflexivity. simpl; now rewrite H. assumption.
     left. eexists. split. reflexivity. assumption. assumption.
     exists s. apply (str_refl ([b] * bstep p)). reflexivity.
      simpl. unfold rel_inj. simpl. now rewrite H.
     destruct IHbstep' as [t ? [t' ? ?]]. exists t'. 2: assumption.
     apply (str_cons ([b] * bstep p)). exists t. 2: assumption.
     eexists; eauto. now split.
  - induction p; unfold bstep; fold bstep.
     intros ? ? <-. constructor.
     intros ? ? ->. constructor.
     intros ? ? [? H1 H2]. econstructor. apply IHp1, H1. apply IHp2, H2.
     intros ? ? [[? [<- H] H']|[? [<- H] H']].
      apply s_ite_tt. assumption. apply IHp1, H'.
      apply s_ite_ff. now apply Bool.negb_true_iff. apply IHp2, H'.
     apply str_ind_l'.
      intros ? ? [<- H]. apply s_whl_ff. now apply Bool.negb_true_iff.
      rewrite <-dotA. intros s s'' [? [<- H] [s' H' H'']]. apply s_whl_tt. assumption.
      econstructor. apply IHp, H'. assumption.
Qed.

(** * Some program equivalences *)

(** two programs are said to be equivalent if they have the same semantics *)
Notation "p ~ q" := (bstep p == bstep q) (at level 80).

(** ad-hoc simplification tactic *)
Ltac simp := unfold bstep; fold bstep.

(** ** denesting nested loops *)
Lemma two_loops b p:
  whl b (whl b p)  ~  whl b p.
Proof. simp. kat. Qed.

(** ** folding a loop *)
Lemma fold_loop b p:
  whl b (p ;; ite b p skp)  ~
  whl b p.
Proof. simp. kat. Qed.

(** ** eliminating deadcode *)
Lemma dead_code b p q r:
  (whl b p ;; ite b q r)  ~
  (whl b p ;; r).
Proof. simp. kat. Qed.

Lemma dead_code' a b p q r:
  (whl (a \cup b) p ;; ite b q r)  ~
  (whl (a \cup b) p ;; r).
Proof. simp. kat. Qed.

(** * Reasoning about assignations *)

(** (higher-order style) substitution in formulas and expressions *)
Definition subst x v (A: dset state): dset state :=
  fun s => A (update x (v s) s).
Definition esubst x v (e: state -> nat): state -> nat :=
  fun s => e (update x (v s) s).

(** is [x] fresh in the expression e *)
Definition fresh x (e: state -> nat) := forall v s, e (update x v s) = e s.

Hypothesis update_twice: forall x i j s, update x j (update x i s) = update x j s.
Hypothesis update_comm: forall x y i j s, x<>y -> update x i (update y j s) = update y j (update x i s).

(** ** stacking assignations *)

Lemma aff_stack x e f:
  (x <- e ;; x <- f)  ~
  (x <- esubst x e f).
Proof.
  simp. rewrite frel_comp.
  apply frel_weq; intro s.
  apply update_twice.
Qed.

(** ** removing duplicates *)

Lemma aff_idem x e: fresh x e -> (x <- e ;; x <- e)  ~  (x <- e).
Proof.
  intro. rewrite aff_stack.
  intros s s'. cbv. rewrite (H (e s)). tauto.
Qed.

(** ** commuting assignations *)

Lemma aff_comm x y e f: x<>y  -> fresh y e ->
  (x <- e ;; y <- f)  ~ (y <- esubst x e f ;; x <- e).
Proof.
  intros Hx Hy. simp. rewrite 2frel_comp. apply frel_weq; intro s.
  rewrite update_comm by congruence.
  now rewrite (Hy _).
Qed.

(** ** delaying choices *)

(** in the above example, we cannot exploit KAT since this is just
   about assignations. In the following example, we show how to
   perform a mixed proof: once we assert that the test [t] somehow
   commutes with the assignation [x<-e], [hkat] can make use of this
   assumption to close the goal *)

Lemma aff_ite x e t p q:
  (x <- e ;; ite t p q)
  ~
  (ite (subst x e t) (x <- e ;; p) (x <- e ;; q)).
Proof.
  simp.
  assert (H: upd x e * [t] == [subst x e t] * upd x e)
   by (cbv; firstorder; subst; eauto).
  hkat.
Qed.

(** * Embedding Hoare logic for partial correctness *)

(** Hoare triples for partial correctness can be expressed really
   easily using KAT: *)
Notation Hoare A p B := ([A] * bstep p * [!B] <== 0).

(** ** correspondence w.r.t. the standard interpretation of Hoare triples  *)
Lemma Hoare_eq A p B:
  Hoare A p B <->
  forall s s', A s -> bstep p s s' -> B s'.
Proof.
  split.
  - intros H s s' HA Hp. case_eq (B s'). reflexivity. intro HB.
    destruct (H s s'). exists s'. exists s.
    now split. assumption. split. reflexivity. simpl. now rewrite HB.
  - intros H s s' [? [? [<- HA] Hp] [-> HB]]. simpl in HB.
    rewrite (H _ _ HA Hp) in HB. discriminate.
Qed.

(** ** deriving Hoare logic rules using the [hkat] tactic *)

(** Hoare triples are encoded as propositions of the shape [x <== 0] ;
   therefore, they can always be eliminated by [hkat], so that all
   rules of Hoare logic can be proved automatically (except for the
   assignation rule, of course)

   This idea come from the following paper:
   Dexter Kozen. On Hoare logic and Kleene algebra with tests.
   Trans. Computational Logic, 1(1):60-76, July 2000.

   The fact that we have an automatic tactic makes it trivial to
   formalise it. *)

Lemma weakening (A A' B B': dset state) p:
  A' <== A -> Hoare A p B -> B <== B' -> Hoare A' p B'.
Proof. hkat. Qed.

Lemma rule_skp A: Hoare A skp A.
Proof. simp. kat. Qed.

Lemma rule_seq A B C p q:
  Hoare A p B ->
  Hoare B q C ->
  Hoare A (p;;q) C.
Proof. simp. hkat. Qed.

Lemma rule_ite A B t p q:
  Hoare (A \cap t) p B ->
  Hoare (A \cap !t) q B ->
  Hoare A (ite t p q) B.
Proof. simp. hkat. Qed.

Lemma rule_whl A t p:
  Hoare (A \cap t) p A ->
  Hoare A (whl t p) (A \cap neg t).
Proof. simp. hkat. Qed.

Lemma rule_aff x v (A: dset state): Hoare (subst x v A) (x <- v) A.
Proof.
  rewrite Hoare_eq. intros s s' HA H.
  now inversion_clear H.
Qed.

Lemma wrong_rule_whl A t p:
  Hoare (A \cap !t) p A ->
  Hoare A (whl t p) (A \cap !t).
Proof. simp. Fail hkat. Abort.

Lemma rule_whl' (I A: dset state) t p:
  Hoare (I \cap t) p I ->
  I \cap !t <== A ->
  Hoare I (whl t p) A.
Proof. eauto 3 using weakening, rule_whl. Qed.

End s.


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

(*i $Id: Ranalysis1.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

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.


Inductive susp (A: Type): Type :=
| F : A -> susp A.

Implicit Arguments F [A].

Definition force {A} (x: susp A): A :=
  match x with
  | F a => a
  end.

Inductive StreamCell (A: Type): Type :=
| Nil : StreamCell A
| Cons : A -> susp (StreamCell A) -> StreamCell A.

Implicit Arguments Nil [A].
Implicit Arguments Cons [A].

Definition Stream (A: Type): Type := susp (StreamCell A).

Definition FNil {A}: Stream A := F Nil.
Definition FCons {A} (x: A) (s: Stream A): Stream A := F (Cons x s).
Infix "::" := FCons (at level 60, right associativity).

Definition length {A} (s: Stream A): nat :=
  (fix length' (c: StreamCell A): nat :=
    match c with
    | Nil => 0
    | Cons _ xs => S (length' (force xs))
    end
  ) (force s).

Fixpoint take_cps {A B} (n: nat) (s: Stream A) (cont: Stream A -> B): B :=
  match n, s with
  | _, F Nil => cont FNil
  | 0, _ => cont FNil
  | S m, F (Cons x xs) => take_cps m xs (fun s' => cont (x :: s'))
  end.

Definition insertBy_cps {A B} (cmp: A -> A -> comparison) (a: A) (s: Stream A) (cont: Stream A -> B): B :=
  (fix insertBy' (c: StreamCell A) (cont': Stream A -> B): B :=
    match c with
    | Nil => cont' (a :: FNil)
    | Cons x xs => match cmp a x with
      | Eq | Lt => cont' (a :: F c)
      | Gt => insertBy' (force xs) (fun s' => cont' (x :: s'))
      end
    end
  ) (force s) cont.

Definition foldr_cps {A B C} (f: A -> B -> B) (b: B) (s: Stream A) (cont: B -> C): C :=
  (fix foldr' (c: StreamCell A) (cont': B -> C): C :=
    match c with
    | Nil => cont' b
    | Cons x xs => foldr' (force xs) (fun b' => cont' (f x b'))
    end
  ) (force s) cont.

(* つかってみる *)

Definition I {A} (a: A) := a.

Definition isort {A} (cmp: A -> A -> comparison) (s: Stream A): Stream A :=
  foldr_cps (fun a s => insertBy_cps cmp a s I) FNil s I.

Require Import Arith.

(* TODO: 計算コスト関数を定義する *)

Definition d_take_cost {A} (n m: nat) (s: Stream A): nat :=
  let take_cont := length in
  take_cps m s (fun s' => take_cps n s take_cont).

Definition isort_ord {A} (cmp: A -> A -> comparison) (s: Stream A): nat :=
  let ins_cont := I in
  let fold_cont := length in
  foldr_cps (fun a s' => insertBy_cps cmp a s' ins_cont) FNil s fold_cont.


(* "especially useful" *)

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Arguments nil {X}.
Arguments cons {X}.

Fixpoint app {X : Type} (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.
Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.
Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).
Arguments pair {X} {Y}.
Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.
Fixpoint even (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => even n'
  end.
Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.
Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Fixpoint map {X Y : Type} (f : X -> Y) (l : list X) : list Y :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

(* exercise *)
Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)  :=
  match l with
  | [] => []
  | h :: t => (f h) ++ (flat_map f t)
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.


Require Import stlcott.
Require Import List.

Lemma combine_map_fst_snd : forall (X Y : Type) (l : list (X * Y)),
  l = combine (map (@fst X Y) l) (map (@snd X Y) l).
Proof.
  intros. induction l as [| h t]; simpl.
    reflexivity.
    rewrite <- IHt. f_equal. apply surjective_pairing.
Qed.

Lemma split_list : forall {X Y : Type} (l : list (X * Y)),
  exists l1, exists l2, l = combine l1 l2 /\ length l1 = length l2.
Proof.
  intros. exists (map (@fst X Y) l). exists (map (@snd X Y) l). split.
    apply combine_map_fst_snd.
    rewrite map_length. rewrite map_length. reflexivity.
Qed.

Lemma fst_cruft_disappears : forall (X Y : Type) (l1 : list X) (l2 : list Y),
  length l1 = length l2 ->
  map (fun x => match x with (a,b) => a end) (combine l1 l2) = l1.
Proof.
  intros. generalize dependent l2.
  induction l1 as [| h1 t1]; destruct l2 as [| h2 t2]; intros;
      simpl in H; inversion H.
    reflexivity.
    simpl. apply IHt1 in H1. rewrite H1. reflexivity.
Qed.

Lemma snd_cruft_disappears : forall (X Y : Type) (l1 : list X) (l2 : list Y),
  length l1 = length l2 ->
  map (fun x => match x with (a,b) => b end) (combine l1 l2) = l2.
Proof.
  intros. generalize dependent l2.
  induction l1 as [| h1 t1]; destruct l2 as [| h2 t2]; intros;
      simpl in H; inversion H.
    reflexivity.
    simpl. apply IHt1 in H1. rewrite H1. reflexivity.
Qed.

Lemma both_cruft_disappears : forall (X Y : Type) (l1 : list X) (l2 : list Y),
  length l1 = length l2 ->
  map (fun x => match x with (a,b) => (a,b) end) (combine l1 l2) = (combine l1 l2).
Proof.
  intros. generalize dependent l2.
  induction l1 as [| h1 t1]; destruct l2 as [| h2 t2]; intros;
      simpl in H; inversion H.
    reflexivity.
    simpl. apply IHt1 in H1. rewrite H1. reflexivity.
Qed.

Ltac remove_cruft a b et :=
  set (ex2 := split_list et) in *; inversion ex2 as [a ex1]; inversion ex1 as [b conj];
  inversion conj as [comb lengths]; rewrite comb in *; rewrite fst_cruft_disappears in *;
  rewrite snd_cruft_disappears in *; rewrite both_cruft_disappears in *;
  try apply lengths; clear ex2 ex1 conj comb.

Tactic Notation "remove" "cruft" "from" constr(et) "as" ident(es) "," ident(ts) :=
  remove_cruft es ts et.


Set Warnings "-notation-overridden".

Require Import Coq.Program.Basics.

From Equations Require Import Equations.
Unset Equations With Funext.

Require Import Category.Lib.
Require Import Category.Theory.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Definition magma (A : Type) := A -> A -> A.

Class Idempotent {A} (f : magma A) :=
  idempotency : forall (x : A), f x x = x.

(* Search "Commutative". *)
Class Commutative {A} (f : magma A) :=
  commutativity : forall a b, f a b = f b a.

(* Search "Associative". *)
Class Associative {A} (f : magma A) :=
  associativity : forall a b c : A, f (f a b) c = f a (f b c).

(* Search "Absorptive". *)
Class Absorptive {A} (f g : magma A) :=
  absorptivity : forall a b : A, f a (g a b) = a.

(* x ∧ (y ∨ c) = (x ∧ y) ∨ (x ∧ c). *)
Class Distributive {A} (f g : magma A) :=
  distributivity : forall a b c : A, f a (g b c) = g (f a b) (f a c).

Reserved Infix "⊓" (at level 40, left associativity).
Reserved Infix "⊔" (at level 36, left associativity).

Class Lattice (A : Type) := {
  lmeet : A -> A -> A where "x ⊓ y" := (lmeet x y);
  ljoin : A -> A -> A where "x ⊔ y" := (ljoin x y);

  lmeet_commutative : Commutative lmeet;
  lmeet_associative : Associative lmeet;
  lmeet_absorptive  : Absorptive lmeet ljoin;
  lmeet_idempotent  : Idempotent lmeet;

  ljoin_commutative : Commutative ljoin;
  ljoin_associative : Associative ljoin;
  ljoin_absorptive  : Absorptive ljoin lmeet;
  ljoin_idempotent  : Idempotent ljoin
}.

Program Instance magma_unit_Idempotent (f : magma ()) :
  Idempotent f := { idempotency := _ }.
Next Obligation.
destruct x.
refine (unit_ind (fun xs => xs = ()) _ (f () ())).
reflexivity.
Defined.

Program Instance magma_unit_Commutative (f : magma ()) :
  Commutative f := { commutativity := _ }.

Program Instance magma_unit_Associative (f : magma ()) :
  Associative f := { associativity := _ }.
Next Obligation.
refine (unit_ind (fun xs => xs = f a (f b c)) _ (f (f a b) c)).
refine (unit_ind (fun xs => () = xs) _ (f a (f b c))).
reflexivity.
Defined.

Program Instance magma_unit_Absorptive (f : magma ()) (g : magma ()) :
  Absorptive f g := { absorptivity := _ }.
Next Obligation.
destruct a, b.
refine (unit_ind (fun xs => xs = ()) _ (f () (g () ()))).
reflexivity.
Defined.

Program Instance magma_unit_Distributive (f : magma ()) (g : magma ()) :
  Distributive f g := { distributivity := _ }.
Next Obligation.
refine (unit_ind (fun xs => f a (g b c) = xs) _ (g (f a b) (f a c))).
refine (unit_ind (fun xs => xs = ()) _ (f a (g b c))).
reflexivity.
Defined.

Program Instance magma_unit_Lattice (f g : magma ()) : Lattice () := {
  lmeet := f;
  ljoin := g;

  lmeet_commutative := magma_unit_Commutative _;
  lmeet_associative := magma_unit_Associative _;
  lmeet_absorptive  := magma_unit_Absorptive _ _;
  lmeet_idempotent  := magma_unit_Idempotent _;

  ljoin_commutative := magma_unit_Commutative _;
  ljoin_associative := magma_unit_Associative _;
  ljoin_absorptive  := magma_unit_Absorptive _ _;
  ljoin_idempotent  := magma_unit_Idempotent _
}.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Tactics to reason about list inclusion. *)

(** This file (contributed by Laurence Rideau) defines a tactic [in_tac]
  to reason over list inclusion.  It expects goals of the following form:
<<
  id : In x l1
  ============================
     In x l2
>>
and succeeds if it can prove that [l1] is included in [l2].
The lists [l1] and [l2] must belong to the following sub-language [L]
<<
  L ::= L++L | E | E::L
>>
The tactic uses no extra fact.

A second tactic, [incl_tac], handles goals of the form
<<
  =============================
    incl l1 l2
>>
*)

Require Import List.
Require Import Bool.
Require Import ArithRing.

Ltac all_app e :=
  match e with
  | cons ?x nil => constr:(cons x nil)
  | cons ?x ?tl =>
      let v := all_app tl in constr:(app (cons x nil) v)
  | app ?e1 ?e2 =>
    let v1 := all_app e1 with v2 := all_app e2 in
    constr:(app v1 v2)
  | _ => e
  end.

(** This data type, [flatten], [insert_bin], [sort_bin] and a few theorem
  are taken from the CoqArt book, chapt. 16. *)

Inductive bin : Type := node : bin->bin->bin | leaf : nat->bin.

Fixpoint flatten_aux (t fin:bin){struct t} : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten_aux t2 fin)
  | x => node x fin
  end.

Fixpoint flatten (t:bin) : bin :=
  match t with
  | node t1 t2 => flatten_aux t1 (flatten t2)
  | x => x
  end.

Fixpoint nat_le_bool (n m:nat){struct m} : bool :=
  match n, m with
  | O, _ => true
  | S _, O => false
  | S n, S m => nat_le_bool n m
  end.

Fixpoint insert_bin (n:nat)(t:bin){struct t} : bin :=
  match t with
  | leaf m =>
    if nat_le_bool n m then
       node (leaf n)(leaf m)
    else
       node (leaf m)(leaf n)
  | node (leaf m) t' =>
    if nat_le_bool n m then node (leaf n) t else node (leaf m)(insert_bin n t')
  | t => node (leaf n) t
  end.

Fixpoint sort_bin (t:bin) : bin :=
  match t with
  | node (leaf n) t' => insert_bin n (sort_bin t')
  | t => t
  end.

Section assoc_eq.
 Variables (A : Type)(f : A->A->A).
 Hypothesis assoc : forall x y z:A, f x (f y z) = f (f x y) z.

 Fixpoint bin_A (l:list A)(def:A)(t:bin){struct t} : A :=
   match t with
   | node t1 t2 => f (bin_A l def t1)(bin_A l def t2)
   | leaf n => nth n l def
   end.

 Theorem flatten_aux_valid_A :
  forall (l:list A)(def:A)(t t':bin),
   f (bin_A l def t)(bin_A l def t') = bin_A l def (flatten_aux t t').
 Proof.
  intros l def t; elim t; simpl; auto.
  intros t1 IHt1 t2 IHt2 t';  rewrite <- IHt1; rewrite <- IHt2.
  symmetry; apply assoc.
 Qed.

 Theorem flatten_valid_A :
  forall (l:list A)(def:A)(t:bin),
    bin_A l def t = bin_A l def (flatten t).
 Proof.
  intros l def t; elim t; simpl; trivial.
  intros t1 IHt1 t2 IHt2; rewrite <- flatten_aux_valid_A; rewrite <- IHt2.
  trivial.
 Qed.

End assoc_eq.

Ltac compute_rank l n v :=
  match l with
  | (cons ?X1 ?X2) =>
    let tl := constr:X2 in
    match constr:(X1 = v) with
    | (?X1 = ?X1) => n
    | _ => compute_rank tl (S n) v
    end
  end.

Ltac term_list_app l v :=
  match v with
  | (app ?X1 ?X2) =>
    let l1 := term_list_app l X2 in term_list_app l1 X1
  | ?X1 => constr:(cons X1 l)
  end.

Ltac model_aux_app l v :=
  match v with
  | (app ?X1 ?X2) =>
    let r1 := model_aux_app l X1 with r2 := model_aux_app l X2 in
      constr:(node r1 r2)
  | ?X1 => let n := compute_rank l 0 X1 in constr:(leaf n)
  | _ => constr:(leaf 0)
  end.

Theorem In_permute_app_head :
  forall A:Type, forall r:A, forall x y l:list A,
   In r (x++y++l) -> In r (y++x++l).
intros A r x y l; generalize r; change (incl (x++y++l)(y++x++l)).
repeat rewrite ass_app; auto with datatypes.
Qed.

Theorem insert_bin_included :
  forall x:nat, forall t2:bin,
  forall (A:Type) (r:A) (l:list (list A))(def:list A),
     In r (bin_A (list A) (app (A:=A)) l def (insert_bin x t2)) ->
     In r (bin_A (list A) (app (A:=A)) l def (node (leaf x) t2)).
intros x t2; induction t2.
intros A r l def.
destruct t2_1 as [t2_11 t2_12|y].
simpl.
repeat rewrite app_ass.
auto.
simpl; repeat rewrite app_ass.
simpl; case (nat_le_bool x y); simpl.
auto.
intros H; apply In_permute_app_head.
elim in_app_or with (1:= H); clear H; intros H.
apply in_or_app; left; assumption.
apply in_or_app; right;apply (IHt2_2 A r l);assumption.
intros A r l def; simpl.
case (nat_le_bool x n); simpl.
auto.
intros H.
rewrite (app_nil_end (nth x l def)) in H.
rewrite (app_nil_end (nth n l def)).
apply In_permute_app_head; assumption.
Qed.

Theorem in_or_insert_bin :
  forall (n:nat) (t2:bin) (A:Type)(r:A)(l:list (list A)) (def:list A),
  In r (nth n l def) \/ In r (bin_A (list A)(app (A:=A)) l def t2) ->
  In r (bin_A (list A)(app (A:=A)) l def (insert_bin n t2)).
intros n t2 A r l def; induction t2.
destruct t2_1 as [t2_11 t2_12| y].
simpl; apply in_or_app.
simpl; case (nat_le_bool n y); simpl.
intros H.
apply in_or_app.
exact H.
intros [H|H].
apply in_or_app; right; apply IHt2_2; auto.
elim in_app_or with (1:= H);clear H; intros H; apply in_or_app; auto.
simpl; intros [H|H]; case (nat_le_bool n n0); simpl; apply in_or_app; auto.
Qed.

Theorem sort_included :
  forall t:bin, forall (A:Type)(r:A)(l:list(list A))(def:list A),
    In r (bin_A (list A) (app (A:=A)) l def (sort_bin t)) ->
    In r (bin_A (list A) (app (A:=A)) l def t).
induction t.
destruct t1.
simpl;intros; assumption.
intros A r l def H; simpl in H; apply insert_bin_included.
generalize (insert_bin_included _ _ _ _ _ _ H); clear H; intros H.
simpl in H.
elim in_app_or with (1 := H);clear H; intros H;
apply in_or_insert_bin; auto.
simpl;intros;assumption.
Qed.

Theorem sort_included2 :
  forall t:bin, forall (A:Type)(r:A)(l:list(list A))(def:list A),
    In r (bin_A (list A) (app (A:=A)) l def t) ->
    In r (bin_A (list A) (app (A:=A)) l def (sort_bin t)).
induction t.
destruct t1.
simpl; intros; assumption.
intros A r l def H; simpl in H.
simpl; apply in_or_insert_bin.
elim in_app_or with (1:= H); auto.
simpl; auto.
Qed.

Theorem in_remove_head :
  forall (A:Type)(x:A)(l1 l2 l3:list A),
  In x (l1++l2) -> (In x l2 -> In x l3) -> In x (l1++l3).
intros A x l1 l2 l3 H H1.
elim in_app_or with (1:= H);clear H; intros H; apply in_or_app; auto.
Qed.

Fixpoint check_all_leaves (n:nat)(t:bin) {struct t} : bool :=
  match t with
    leaf n1 => nateq n n1
  | node t1 t2 => andb (check_all_leaves n t1)(check_all_leaves n t2)
  end.

Fixpoint remove_all_leaves (n:nat)(t:bin){struct t} : bin :=
  match t with
    leaf n => leaf n
  | node (leaf n1) t2 =>
    if nateq n n1 then remove_all_leaves n t2 else t
  | _ => t
  end.

Fixpoint test_inclusion (t1 t2:bin) {struct t1} : bool :=
  match t1 with
    leaf n => check_all_leaves n t2
  | node (leaf n1) t1' =>
     check_all_leaves n1 t2 || test_inclusion t1' (remove_all_leaves n1 t2)
  | _ => false
  end.

Theorem check_all_leaves_sound :
  forall x t2,
    check_all_leaves x t2 = true ->
    forall (A:Type)(r:A)(l:list(list A))(def:list A),
    In r (bin_A (list A) (app (A:=A)) l def t2) ->
    In r (nth x l def).
intros x t2; induction t2; simpl.
destruct (check_all_leaves x t2_1);
destruct (check_all_leaves x t2_2); simpl; intros Heq; try discriminate.
intros A r l def H; elim in_app_or with (1:= H); clear H; intros H; auto.
intros Heq A r l def; rewrite (nateq_prop x n); auto.
rewrite Heq; unfold Is_true; auto.
Qed.

Theorem remove_all_leaves_sound :
  forall x t2,
  forall (A:Type)(r:A)(l:list(list A))(def:list A),
  In r (bin_A (list A) (app(A:=A)) l def t2) ->
  In r (bin_A (list A) (app(A:=A)) l def (remove_all_leaves x t2)) \/
  In r (nth x l def).
intros x t2; induction t2; simpl.
destruct t2_1.
simpl; auto.
intros A r l def.
generalize (refl_equal (nateq x n)); pattern (nateq x n) at -1;
 case (nateq x n); simpl; auto.
intros Heq_nateq.
assert (Heq_xn : x=n).
apply nateq_prop; rewrite Heq_nateq;unfold Is_true;auto.
rewrite Heq_xn.
intros H; elim in_app_or with (1:= H); auto.
clear H; intros H.
rewrite Heq_xn in IHt2_2; auto.
auto.
Qed.

Theorem test_inclusion_sound :
  forall t1 t2:bin,
  test_inclusion t1 t2 = true ->
  forall (A:Type)(r:A)(l:list(list A))(def:list A),
  In r (bin_A (list A)(app(A:=A)) l def t2) ->
  In r (bin_A (list A)(app(A:=A)) l def t1).
intros t1; induction t1.
destruct t1_1 as [t1_11 t1_12|x].
simpl; intros; discriminate.
simpl; intros t2 Heq A r l def H.
assert
 (check_all_leaves x t2 = true \/
  test_inclusion t1_2 (remove_all_leaves x t2) = true).
destruct (check_all_leaves x t2);
destruct (test_inclusion t1_2 (remove_all_leaves x t2));
simpl in Heq; try discriminate Heq; auto.
elim H0; clear H0; intros H0.
apply in_or_app; left; apply check_all_leaves_sound with (1:= H0); auto.
elim remove_all_leaves_sound with (x:=x)(1:= H); intros H'.
apply in_or_app; right; apply IHt1_2 with (1:= H0); auto.
apply in_or_app; auto.
simpl; apply check_all_leaves_sound.
Qed.

Theorem inclusion_theorem :
  forall t1 t2 : bin,
    test_inclusion (sort_bin (flatten t1)) (sort_bin (flatten t2)) = true ->
    forall (A:Type)(r:A)(l:list(list A))(def:list A),
    In r (bin_A (list A) (app(A:=A)) l def t2) ->
    In r (bin_A (list A) (app(A:=A)) l def t1).
intros t1 t2 Heq A r l def H.
rewrite flatten_valid_A with (t:= t1)(1:= (ass_app (A:= A))).
apply sort_included.
apply test_inclusion_sound with (t2 := sort_bin (flatten t2)).
assumption.
apply sort_included2.
rewrite <- flatten_valid_A with (1:= (ass_app (A:= A))).
assumption.
Qed.

Ltac in_tac :=
  match goal with
  | id : In ?x nil |- _ => elim id
  | id : In ?x ?l1 |- In ?x ?l2 =>
    let t := type of x in
    let v1 := all_app l1 in
    let v2 := all_app l2 in
    (let l := term_list_app (nil (A:=list t)) v2 in
     let term1 := model_aux_app l v1 with
         term2 := model_aux_app l v2 in
        (change (In x (bin_A (list t) (app(A:=t)) l (nil(A:=t)) term2));
        apply inclusion_theorem with (t2:= term1);[apply refl_equal|exact id]))
  end.

Ltac incl_tac :=
  match goal with
  |- incl _ _ => intro; intro; in_tac
  end.

(* Usage examples.

Theorem ex1 : forall x y z:nat, forall l1 l2 : list nat,
   In x (y::l1++l2) -> In x (l2++z::l1++(y::nil)).
intros.
in_tac.
Qed.

Fixpoint mklist (f:nat->nat)(n:nat){struct n} : list nat :=
 match n with 0 => nil | S p => mklist f p++(f p::nil) end.

(* At the time of writing these lines, this example takes about 5 seconds
     for 40 elements and 22 seconds for 60 elements.
   A variant to the example is to replace mklist f p++(f p::nil) with
   f p::mklist f p, in this case the time is 6 seconds for 40 elements and
   35 seconds for 60 elements. *)

Theorem ex2 :
  forall x : nat, In x (mklist (fun y => y) 40) ->
     In x (mklist (fun y => (40 - 1) - y) 40).
lazy beta iota zeta delta [mklist minus].
intros.
in_tac.
Qed.

(* The tactic could be made more efficient by using binary trees and
   numbers of type positive instead of lists and natural numbers. *)

*)


(*
 * Coq code for "Certified Assembly Programming with Embedded Code Pointers"
 *
 * type list
 *
 * (for Coq version 8)
 *)

Inductive TyList : Type :=
  | tO : TyList
  | tS : Type -> TyList -> TyList.

Fixpoint tplus (L L' : TyList) {struct L} : TyList :=
  match L with
  | tO => L'
  | tS A L => tS A (tplus L L')
  end.

Lemma eq_tS_head : forall A A' L L', tS A L = tS A' L' -> A = A'.
intros.
inversion H.
auto.
Defined.

Lemma eq_tS_tail : forall A A' L L', tS A L = tS A' L' -> L = L'.
intros.
inversion H.
auto.
Defined.

Lemma eq_tS : forall A L L', L = L' -> tS A L = tS A L'.
intros.
inversion H.
auto.
Defined.

Lemma eq_tS_head_eq : forall A A' L, A = A' -> tS A L = tS A' L.
intros.
rewrite H.
auto.
Defined.

Lemma eq_tplus : forall L L' L'', L = L' -> tplus L L'' = tplus L' L''.
intros.
rewrite H.
auto.
Defined.

Lemma eq_tplus_tail : forall L L' L'', L = L' -> tplus L'' L = tplus L'' L'.
intros.
rewrite H.
auto.
Defined.

Lemma eq_tplus_tO : forall L, L = tplus tO L.
simpl in |- *.
auto.
Defined.

Lemma eq_tplus_tO_tail : forall L, L = tplus L tO.
simple induction L.
 simpl in |- *.
   auto.
 simpl in |- *.
   intros.
   rewrite H.
   simpl in |- *.
   rewrite <- H.
   rewrite <- H.
   auto.
Defined.

Lemma eq_tS_tplus : forall A L L', tS A (tplus L L') = tplus (tS A L) L'.
simpl in |- *.
auto.
Defined.

Lemma eq_tplus_tS :
 forall A L L', tplus L (tS A L') = tplus (tplus L (tS A tO)) L'.
intros.
induction  L as [| T L HrecL].
 simpl in |- *.
   auto.
 simpl in |- *.
   rewrite HrecL.
   auto.
Defined.

Lemma eq_tplus_tplus :
 forall L L' L'', tplus (tplus L L') L'' = tplus L (tplus L' L'').
intros.
induction  L as [| T L HrecL].
 simpl in |- *.
   auto.
 simpl in |- *.
   rewrite HrecL.
   auto.
Defined.

Lemma eq_tS_tplus_eq : forall A L, tS A L = tplus (tS A tO) L.
simpl in |- *.
auto.
Defined.