Require Export RelDefinitions.
Require Export RelOperators.
Require Export Relators.
Require Import Delay.

(** ** The [monotonicity] tactic *)

(** The purpose of the [monotonicity] tactic is to automatically
  select and apply a theorem of the form [Monotonic ?m ?R] in order to
  make progress when the goal is an applied relation. Compared with
  setoid rewriting, [monotonicity] is less powerful, but more direct
  and simple. This means it is easier to debug, and it can seamlessly
  handle dependent types and heterogenous relations.

  The [monotonicity] tactic applies to a goal of the form
  [R (f x1 x2 ... xn) (g y1 y2 ... yn)]. The basic idea is to first
  locate a relational property declared by the user relating [f] and
  [g], namely an instance of [Related f g R'], then to locate and
  instance of [RElim] which will allow us to use [R' f g] to make
  progress on the current goal. Most of the time, [f] and [g] will be
  identical so that the corresponding relational property can be
  writted [Monotonic f R'].

  For instance, we can register the monotonicity of [plus] as an
  instance of [Monotonic plus (lt ++> lt ++> lt)]. Given an goal of
  the form [plus 5 6 < plus x 5], the monotonicity tactic will use
  that property and, using the [RElim] rule for [++>], construct an
  instance of
  [RElim (lt ++> lt ++> lt) plus plus (lt 5 7 -> lt x 5 -> lt (plus 5 6) (plus x 5))]
  to apply on the goal, leaving us with the subgoals [5 < 7] and
  [x < 5].

  While this basic principle is rather straightforward, there are some
  subtleties that we have to consider in order to build a reliable
  system: the relational property we need to use may be about a prefix
  [f x1 x2 ... xk] ([k] < [n]) of the application that still has some
  arguments applied; we want to be able to exploit [subrel]
  relationships to extend the applicability of the declared relational
  properties; we need to be need to be careful about how we treat
  existential variables. *)

(** *** Truncating applications *)

(** The first complication arises from the fact that [f] and [g] may
  themselves be partial applications, so the goal may in fact be of
  the form
  [R (f a1 a2 ... ak x1 x2 ... xn) (g b1 b2 ... bl y1 y2 ... yn)],
  with [k] ≠ [l], where the relational property to apply will be of
  the form [Related R' (f a1 a2 ... ak) (g b1 b2 ... bl)]. This is
  particularly relevant when [f] and [g] may have implicit typeclass
  arguments, or type arguments that cannot be covered by our dependent
  relators without causing universe inconsistency issues.

  Finding the head terms [f] and [g], then locating a property
  [Related R' f g] is rather straightforward, however in this case we
  must only drop the last [n] arguments from the applications before
  we look up the [Related] instance, with no way of guessing the
  correct value of [n]. We want to avoid having to peel off arguments
  one by one and performing a [Related] search at each step, so we ask
  the user to pitch in and declare instances of [Params f n] and
  [Params g n] to guide our search when partial applications with
  heads [f] and [g] are involved.

  Note that the term in the goal itself may only be partially
  applied. Suppose [f x1 x2 ... xn] is in expecting [p] more
  arguments, and that we find an instance of [Params f q]; then we
  should only drop [q - p] arguments to obtain the prefix
  [f x1 x2 ... x_(n+p-q)].

  The class [QueryParams m1 m2 n] asserts that the head terms of [m1]
  and [m2] have [Params] declarations that instruct us to remove [n]
  arguments from each of them before looking up a corresponding
  relational property. *)

Class QueryParams {A B} (m1: A) (m2: B) (n: nat).

(** If the head term on either side is an existential variable, we
  only check [Params] declarations for the other side. This auxiliary
  lemma is used to trigger this step; [p] should be the number of
  unapplied arguments in whichever term [m1] of [m2] we extracted the
  non-existential head term [h] from. *)

Lemma query_params_one {A B C} (h: A) p (m1: B) (m2: C) n:
  Params h (p + n) ->
  QueryParams m1 m2 n.
Proof.
  constructor.
Qed.

(** If neither head term is an existential variable, then the [Params]
  declarations for both should agree. *)

Lemma query_params_both {A B C D} (h1: A) (h2: B) p1 p2 (m1: C) (m2: D) n:
  Params h1 (p1 + n) ->
  Params h2 (p2 + n) ->
  QueryParams m1 m2 n.
Proof.
  constructor.
Qed.

(** Now we need to choose which one of these lemmas to apply in a
  given situation, and compute the appropriate values for [p].
  We compute [p] by essentially counting the products in the type of
  the related terms [m]. Note that we need to make sure we "open up"
  types such as [subrel] to expose the products, accomplished here by
  using [eval cbv]. *)

(** FIXME: [count_unapplied_params] fails if [m] has a dependent type,
  due to [t'] being a term under binders rather than a closed term.
  This means [monotonicity] can't handle goal where the related terms
  have dependent types if the corresponding relational property is
  about a partial application. *)

Ltac count_unapplied_params m :=
  let rec count t :=
    lazymatch t with
      | forall x, ?t' => let n := count t' in constr:(S n)
      | _ => constr:(O)
    end in
  let t := type of m in
  let t := eval cbv in t in
  count t.

Ltac query_params m1 m2 :=
  let rec head t := lazymatch t with ?t' _ => head t' | _ => t end in
  let h1 := head m1 in
  let p1 := count_unapplied_params m1 in
  let h2 := head m2 in
  let p2 := count_unapplied_params m2 in
  first
    [ not_evar h1; not_evar h2; eapply (query_params_both h1 h2 p1 p2)
    | not_evar h1; is_evar  h2; eapply (query_params_one h1 p1)
    | is_evar  h1; not_evar h2; eapply (query_params_one h2 p2) ].

Global Hint Extern 10 (QueryParams ?m1 ?m2 _) =>
  query_params m1 m2 : typeclass_instances.

(** Now that we can figure out how many parameters to drop, we use
  that information to construct the pair of prefixes we use to locate
  the relational property. We try the following (in this order):
    - the whole applications [f x1 ... xn] and [g y1 ... yn];
    - prefixes constructed as above from user-declared [Params] instances;
    - the smallest prefix we can obtain by dropping arguments from
      both applications simulataneously.

  Again, we need to take into account that either application could
  contain an eixstential variable. When we encounter an existential
  variable while chopping off arguments, we short-circuit the process
  and simply generate a new evar to serve as the shortened version. *)

Ltac pass_evar_to k :=
  let Av := fresh "A" in evar (Av : Type);
  let A := eval red in Av in clear Av;
  let av := fresh "a" in evar (av : A);
  let a := eval red in av in clear av;
  k a.

(** The class [RemoveParams] implements the concurrent removal of [n]
  parameters from applications [m1] and [m2]. *)

Class RemoveParams {A B C D} (n: nat) (m1: A) (m2: B) (f: C) (g: D).

Ltac remove_params_from n m k :=
  lazymatch n with
    | O => k m
    | S ?n' =>
      lazymatch m with
        | ?m' _ => remove_params_from n' m' k
        | _ => is_evar m; pass_evar_to k
      end
  end.

Ltac remove_params n m1 m2 f g :=
  remove_params_from n m1 ltac:(fun m1' => unify f m1';
    remove_params_from n m2 ltac:(fun m2' => unify g m2')).

Global Hint Extern 1 (RemoveParams ?n ?m1 ?m2 ?f ?g) =>
  remove_params n m1 m2 f g; constructor : typeclass_instances.

(** The class [RemoveAllParams] implements the concurrent removal of
  as many arguments as possible. *)

Class RemoveAllParams {A B C D} (m1: A) (m2: B) (f: C) (g: D).

Ltac remove_all_params_from m k :=
  lazymatch m with
    | ?m' _ => remove_all_params_from m' k
    | _ => not_evar m; k m
  end.

Ltac remove_all_params m1 m2 f g :=
  first
    [ is_evar m2;
      remove_all_params_from m1
        ltac:(fun m1' => unify f m1'; pass_evar_to ltac:(fun m2' => unify g m2'))
    | is_evar m1;
      remove_all_params_from m2
        ltac:(fun m2' => unify g m2'; pass_evar_to ltac:(fun m1' => unify f m1'))
    | lazymatch m1 with ?m1' _ =>
        lazymatch m2 with ?m2' _ =>
          remove_all_params m1' m2' f g
        end
      end
    | not_evar m1; unify f m1;
      not_evar m2; unify g m2 ].

Global Hint Extern 1 (RemoveAllParams ?m1 ?m2 ?f ?g) =>
  remove_all_params m1 m2 f g; constructor : typeclass_instances.

(** *** Selecting a relational property *)

(** With this machinery in place, we can implement the search for
  candidate relational properties to use in conjunction with a given
  goal [Q]. *)

Class CandidateProperty {A B} (R': rel A B) f g (Q: Prop) :=
  candidate_related: R' f g.

Instance as_is_candidate {A B} (R R': rel A B) m1 m2:
  Related m1 m2 R' ->
  CandidateProperty R' m1 m2 (R m1 m2) | 10.
Proof.
  firstorder.
Qed.

Instance remove_params_candidate {A B C D} R (m1: A) (m2: B) R' (f: C) (g: D) n:
  QueryParams m1 m2 n ->
  RemoveParams n m1 m2 f g ->
  Related f g R' ->
  CandidateProperty R' f g (R m1 m2) | 20.
Proof.
  firstorder.
Qed.

Instance remove_all_params_candidate {A B C D} R (m1:A) (m2:B) R' (f:C) (g:D):
  RemoveAllParams m1 m2 f g ->
  Related f g R' ->
  CandidateProperty R' f g (R m1 m2) | 30.
Proof.
  firstorder.
Qed.

(** We also attempt to use any matching hypothesis. This takes
  priority and bypasses any [Params] declaration. We assume that we
  will always want such hypotheses to be used, at least when the left-
  or right-hand side matches exactly. There is a possibility that this
  ends up being too broad for some applications, for which we'll want
  to restrict ourselves to [Related] instances explicitely defined by
  the user. If this turns out to be the case, we can introduce an
  intermediate class with more parameters to control the sources of
  the relational properties we use, and perhaps have some kind of
  normalization process akin to what is done in [Coq.Classes.Morphisms].

  We don't hesitate to instantiate evars in the goal or hypothesis; if
  the types or skeletons are compatible this is likely what we want.
  In one practical case where this is needed, my hypothesis is
  something like [R (f ?x1 ?y1 42) (f ?x2 ?y2 24)], and I want
  [?x1], [?x2], [?y1], [?y2] to be matched against the goal. In case
  the use of [unify] below is too broad, we could develop a strategy
  whereby at least one of the head terms [f], [g] should match exactly.

  We also consider the possibility that the relation's arguments may
  be flipped in the hypothesis. In that case we wrap the relation with
  [flip] to construct a corresponding [CandidateProperty]. This [flip]
  will most likely be handled at the [RElim] stage by [flip_relim].
  The hypothesis relation itself may be of the form [flip R]. In that
  case, the [CandidateProperty] will use [flip (flip R)] and
  [flip_relim] will simply be used twice. In more common and subtle
  variation, the hypothesis relation is not directly of this form, but
  should either be instantiated or refined (through [subrel]) into
  such a form. This is handled by [rimpl_flip_subrel].

  Such issues are especially common when solving a goal of the
  form [(R --> R') f g], or goals generated by the setoid rewriting
  system of the form [Proper (?R1 ==> ... ==> ?Rn ==> flip impl)],
  and where the [?Ri]s will generally need to be instantiated as
  [flip ?Ri']. We do not pursue a similar strategy when looking up
  candidates from the typeclass instance database, because we expect
  the user to normalize such properties before they declare them, for
  example declare an instance of [Related (R1 ++> R2 --> R3) g f]
  rather than an instance of [Related (R1 --> R2 ++> flip R3) f g].

  Note that it is important that we reduce the goal to [?R ?m ?n]
  before we use [eexact]: if the relation in the hypothesis is an
  existential variable, we don't want it unified against
  [CandidateProperty _ _ _ (_ ?m ?n)]. *)

Lemma flip_context_candidate {A B} (R: rel A B) x y : R y x -> flip R x y.
Proof.
  firstorder.
Qed.

Ltac context_candidate :=
  let rec is_prefix f m :=
    first
      [ unify f m
      | lazymatch m with ?n _ => is_prefix f n end ] in
  let rec is_prefixable f m :=
    first
      [ is_evar f
      | is_evar m
      | unify f m
      | lazymatch m with ?n _ => is_prefixable f n end ] in
  multimatch goal with
    | H: _ ?f ?g |- @CandidateProperty ?A ?B ?R ?x ?y (_ ?m ?n) =>
      red;
      once first
        [ is_prefix f m; is_prefixable g n
        | is_prefix g n; is_prefixable f m
        | is_prefix g m; is_prefixable f n; apply flip_context_candidate
        | is_prefix f n; is_prefixable g m; apply flip_context_candidate ];
      eexact H
  end.

Global Hint Extern 1 (CandidateProperty _ _ _ _) =>
  context_candidate : typeclass_instances.

(** *** Using [subrel] *)

(** It is not obvious at what point in the process [subrel] should be
  hooked in. One thing we crucially want to avoid is an open-ended
  [subrel] search enumerating all possibilities to be filtered later,
  with a high potential for exponential blow-up should the user be a
  little too liberal with the [subrel] instances they declare.

  Here I choose to have it kick in after a candidate property has been
  selected, and we know how to apply it to a goal. Then we use
  [subrel] to bridge any gap between that goal and the actual one,
  through the [RImpl] class below.

  This is a conservative solution which precludes many interesting
  usages of [subrel]. For instance, suppose we have a relational
  property alogn the lines of [Monotonic f ((R1 ++> R1) ∩ (R2 ++> R2))].
  We would want to be able to use it to show that [f] preserve [R1] or
  [R2] individually (because [subrel (R1 ++> R1) ((R1 ++> R1) ∩ (R2
  ++> R2))], but also together (because [subrel (R1 ∩ R2 ++> R1 ∩ R2)
  ((R1 ++> R1) ∩ (R2 ++> R2))]). This cannot be done using this
  approach, which does not act on the relational property itself but
  only the goal we're attempting to prove.

  Perhaps in the future we can extend this by acting at the level of
  [RElim]. In any case, we should provide explicit guidelines for when
  to declare [subrel] instances, and how. *)

Class RImpl (P Q: Prop): Prop :=
  rimpl: P -> Q.

(** While we give priority to [rimpl_refl] below, when it doesn't work
  we use [RAuto] to establish a [subrel] property. The [Monotonic]
  instances we declared alongside relators can be used conjunction
  with [Monotonicity] to break up [subrel] goals along the structure
  of the relations being considered. This may end up causing loops
  (especially in failure cases), so it may be necessary to add some
  flag in the context to prevent [rimpl_subrel] from being used when
  discharging the [subrel] goals themselves. *)

Global Instance rimpl_refl {A B} (R : rel A B) m n:
  RImpl (R m n) (R m n).
Proof.
  firstorder.
Qed.

Global Instance rimpl_subrel {A B} (R R': rel A B) m n:
  NonDelayed (RAuto (subrel R R')) ->
  RImpl (R m n) (R' m n).
Proof.
  firstorder.
Qed.

Global Instance rimpl_flip_subrel {A B} R R' (x: A) (y: B):
  NonDelayed (RAuto (subrel R (flip R'))) ->
  RImpl (R x y) (R' y x) | 2.
Proof.
  firstorder.
Qed.

(** *** Main tactic *)

(** With these components, defining the [monotonicity] tactic is
  straightforward: identify a candidate property, then figure out a
  way to apply it to the goal [Q] using the [RElim] class. We first
  define a [Monotonicity] typeclass that captures this behavior with
  full backtracking ability. *)

Class Monotonicity (P Q: Prop): Prop :=
  monotonicity: P -> Q.

Global Instance apply_candidate {A B} (R: rel A B) m n P Q Q':
  CandidateProperty R m n Q ->
  RElim R m n P Q' ->
  RImpl Q' Q ->
  Monotonicity P Q.
Proof.
  firstorder.
Qed.

(** The Ltac tactic simply applies [monotonicity]; typeclass
  resolution will do the rest. Note that using [apply] naively is too
  lenient because in a goal of type [A -> B], it will end up unifying
  [A] with [P] and [B] with [Q] instead of setting [Q := A -> B] and
  generating a new subgoal for [P] as expected. On the other hand,
  using [refine] directly is too restrictive because it will not unify
  the type of [monotonicity] against the goal if existential variables
  are present in one or the other. Hence we constrain apply just
  enough, so as to handle both of these cases. *)

Ltac monotonicity :=
  lazymatch goal with |- ?Q => apply (monotonicity (Q:=Q)) end;
  Delay.split_conjunction.

(** Another way to use [Monotonicity] is to hook it as an [RStep]
  instance. *)

Global Instance monotonicity_rstep {A B} (P: Prop) (R: rel A B) m n:
  PolarityResolved R ->
  Monotonicity P (R m n) ->
  RStep P (R m n) | 50.
Proof.
  firstorder.
Qed.

(** *** [subrel] constraint as a subgoal *)

(** When [monotonicity] fails it can be hard to figure out what is
  going wrong, especially if the problem occurs in the [subrel] goal
  of [rimpl_subrel]. The following tactic emits this constraint as a
  subgoal instead of solving it with [RAuto], so that the user can
  figure out what's broken and/or prove it manually in contexts where
  an automatic resolution is tricky.  *)

Class SubrelMonotonicity (P Q: Prop): Prop :=
  subrel_monotonicity: P -> Q.

Global Instance apply_candidate_subrel {A B C D} (R: rel A B) m n P Rc Rg x y:
  CandidateProperty R m n (Rg x y) ->
  RElim R m n P (Rc x y) ->
  SubrelMonotonicity (@subrel C D Rc Rg /\ P) (Rg x y).
Proof.
  firstorder.
Qed.

Ltac subrel_monotonicity :=
  lazymatch goal with |- ?Q => apply (subrel_monotonicity (Q:=Q)) end;
  Delay.split_conjunction.

(** ** Generic instances *)

(** When all else fail, we would like to fall back on a behavior
  similar to that of [f_equal]. To that end, we add a default
  [CandidateProperty] that identifies the longest common prefix of the
  applications in the goal and asserts that they are equal. *)

Class CommonPrefix {A B C} (m1: A) (m2: B) (f: C).

Ltac common_prefix m1 m2 f :=
  first
    [ not_evar m1; not_evar m2;
      unify m1 m2; unify f m1
    | lazymatch m1 with ?m1' _ =>
        lazymatch m2 with ?m2' _ =>
          common_prefix m1' m2' f
        end
      end
    | unify m1 m2; unify f m1 ].

Global Hint Extern 1 (CommonPrefix ?m1 ?m2 ?f) =>
  common_prefix m1 m2 f; constructor : typeclass_instances.

Global Instance eq_candidate {A B C} R (m1: A) (m2: B) (f: C):
  CommonPrefix m1 m2 f ->
  CandidateProperty eq f f (R m1 m2) | 100.
Proof.
  firstorder.
Qed.

(** Then, we can use the following [RElim] instance to obtain the
  behavior of the [f_equal] tactic.

  In practice, I find that [f_equal_relim] is too broadly applicable.
  In situations where a relational property is missing or inapplicable
  for some reason, we would like [repeat rstep] to leave us in a
  situation where we can examine what is going wrong, or do a manual
  proof when necessary. If we use [f_equal]-like behavior as a
  default, we will instead be left several step further, where it is
  no longer obvious which function is involved, and where the goal may
  not be provable anymore.

  With that said, if you would like to switch [f_equal] on, you can
  register [f_equal_elim] as an instance with the following hint:
<<
    Hint Extern 1 (RElim (@eq (_ -> _)) _ _ _ _) =>
      eapply f_equal_relim : typeclass_instances.
>> *)

Lemma f_equal_relim {A B} f g m n P Q:
  RElim eq (f m) (g n) P Q ->
  RElim (@eq (A -> B)) f g (m = n /\ P) Q.
Proof.
  intros Helim Hf [Hmn HP].
  apply Helim; eauto.
  congruence.
Qed.

(** Note that thanks to [eq_subrel], this will also apply to a goal
  that uses a [Reflexive] relation, not just a goal that uses [eq].
  In fact, this subsumes the [reflexivity] tactic as well, which
  corresponds to the special case where all arguments are equal;
  in that case [relim_base] can be used directly and [f_equal_elim] is
  not necessary. *)


(************************************************************************)
(*  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        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Ensembles.
Require Export Constructive_sets.
Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Partial_Order.
Require Export Cpo.
Require Export Powerset.
Require Export Powerset_facts.
Require Export Classical_Type.
Require Export Classical_sets.

Section Sets_as_an_algebra.

  Variable U : Type.

  Lemma sincl_add_x :
    forall (A B:Ensemble U) (x:U),
      ~ In U A x ->
      Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B.
  Proof.
    intros A B x H' H'0; red in |- *.
    lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets.
    clear H'0; intro H'0; split.
    apply incl_add_x with (x := x); tauto.
    elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2.
    intros x0 H'0.
    red in |- *; intro H'2.
    elim H'0; clear H'0.
    rewrite <- H'2; auto with sets.
  Qed.

  Lemma incl_soustr_in :
    forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X.
  Proof.
    intros X x H'; red in |- *.
    intros x0 H'0; elim H'0; auto with sets.
  Qed.

  Lemma incl_soustr :
    forall (X Y:Ensemble U) (x:U),
      Included U X Y -> Included U (Subtract U X x) (Subtract U Y x).
  Proof.
    intros X Y x H'; red in |- *.
    intros x0 H'0; elim H'0.
    intros H'1 H'2.
    apply Subtract_intro; auto with sets.
  Qed.

  Lemma incl_soustr_add_l :
    forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X.
  Proof.
    intros X x; red in |- *.
    intros x0 H'; elim H'; auto with sets.
    intro H'0; elim H'0; auto with sets.
    intros t H'1 H'2; elim H'2; auto with sets.
  Qed.

  Lemma incl_soustr_add_r :
    forall (X:Ensemble U) (x:U),
      ~ In U X x -> Included U X (Subtract U (Add U X x) x).
  Proof.
    intros X x H'; red in |- *.
    intros x0 H'0; try assumption.
    apply Subtract_intro; auto with sets.
    red in |- *; intro H'1; apply H'; rewrite H'1; auto with sets.
  Qed.
  Hint Resolve incl_soustr_add_r: sets v62.

  Lemma add_soustr_2 :
    forall (X:Ensemble U) (x:U),
      In U X x -> Included U X (Add U (Subtract U X x) x).
  Proof.
    intros X x H'; red in |- *.
    intros x0 H'0; try assumption.
    elim (classic (x = x0)); intro K; auto with sets.
    elim K; auto with sets.
  Qed.

  Lemma add_soustr_1 :
    forall (X:Ensemble U) (x:U),
      In U X x -> Included U (Add U (Subtract U X x) x) X.
  Proof.
    intros X x H'; red in |- *.
    intros x0 H'0; elim H'0; auto with sets.
    intros y H'1; elim H'1; auto with sets.
    intros t H'1; try assumption.
    rewrite <- (Singleton_inv U x t); auto with sets.
  Qed.

  Lemma add_soustr_xy :
    forall (X:Ensemble U) (x y:U),
      x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x.
  Proof.
    intros X x y H'; apply Extensionality_Ensembles.
    split; red in |- *.
    intros x0 H'0; elim H'0; auto with sets.
    intro H'1; elim H'1.
    intros u H'2 H'3; try assumption.
    apply Add_intro1.
    apply Subtract_intro; auto with sets.
    intros t H'2 H'3; try assumption.
    elim (Singleton_inv U x t); auto with sets.
    intros u H'2; try assumption.
    elim (Add_inv U (Subtract U X y) x u); auto with sets.
    intro H'0; elim H'0; auto with sets.
    intro H'0; rewrite <- H'0; auto with sets.
  Qed.

  Lemma incl_st_add_soustr :
    forall (X Y:Ensemble U) (x:U),
      ~ In U X x ->
      Strict_Included U (Add U X x) Y -> Strict_Included U X (Subtract U Y x).
  Proof.
    intros X Y x H' H'0; apply sincl_add_x with (x := x); auto using add_soustr_1 with sets.
    split.
    elim H'0.
    intros H'1 H'2.
    generalize (Inclusion_is_transitive U).
    intro H'4; red in H'4.
    apply H'4 with (y := Y); auto using add_soustr_2 with sets.
    red in H'0.
    elim H'0; intros H'1 H'2; try exact H'1; clear H'0. (* PB *)
    red in |- *; intro H'0; apply H'2.
    rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
  Qed.

  Lemma Sub_Add_new :
    forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x.
  Proof.
    auto using incl_soustr_add_l with sets.
  Qed.

  Lemma Simplify_add :
    forall (X X0:Ensemble U) (x:U),
      ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0.
  Proof.
    intros X X0 x H' H'0 H'1; try assumption.
    rewrite (Sub_Add_new X x); auto with sets.
    rewrite (Sub_Add_new X0 x); auto with sets.
    rewrite H'1; auto with sets.
  Qed.

  Lemma Included_Add :
    forall (X A:Ensemble U) (x:U),
      Included U X (Add U A x) ->
      Included U X A \/ (exists A' : _, X = Add U A' x /\ Included U A' A).
  Proof.
    intros X A x H'0; try assumption.
    elim (classic (In U X x)).
    intro H'1; right; try assumption.
    exists (Subtract U X x).
    split; auto using incl_soustr_in, add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
    red in H'0.
    red in |- *.
    intros x0 H'2; try assumption.
    lapply (Subtract_inv U X x x0); auto with sets.
    intro H'3; elim H'3; intros K K'; clear H'3.
    lapply (H'0 x0); auto with sets.
    intro H'3; try assumption.
    lapply (Add_inv U A x x0); auto with sets.
    intro H'4; elim H'4;
      [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
    elim K'; auto with sets.
    intro H'1; left; try assumption.
    red in H'0.
    red in |- *.
    intros x0 H'2; try assumption.
    lapply (H'0 x0); auto with sets.
    intro H'3; try assumption.
    lapply (Add_inv U A x x0); auto with sets.
    intro H'4; elim H'4;
      [ intro H'5; try exact H'5; clear H'4 | intro H'5; clear H'4 ].
    absurd (In U X x0); auto with sets.
    rewrite <- H'5; auto with sets.
  Qed.

  Lemma setcover_inv :
    forall A x y:Ensemble U,
      covers (Ensemble U) (Power_set_PO U A) y x ->
      Strict_Included U x y /\
      (forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y).
  Proof.
    intros A x y H'; elim H'.
    unfold Strict_Rel_of in |- *; simpl in |- *.
    intros H'0 H'1; split; [ auto with sets | idtac ].
    intros z H'2 H'3; try assumption.
    elim (classic (x = z)); auto with sets.
    intro H'4; right; try assumption.
    elim (classic (z = y)); auto with sets.
    intro H'5; try assumption.
    elim H'1.
    exists z; auto with sets.
  Qed.

  Theorem Add_covers :
    forall A a:Ensemble U,
      Included U a A ->
      forall x:U,
	In U A x ->
	~ In U a x -> covers (Ensemble U) (Power_set_PO U A) (Add U a x) a.
  Proof.
    intros A a H' x H'0 H'1; try assumption.
    apply setcover_intro; auto with sets.
    red in |- *.
    split; [ idtac | red in |- *; intro H'2; try exact H'2 ]; auto with sets.
    apply H'1.
    rewrite H'2; auto with sets.
    red in |- *; intro H'2; elim H'2; clear H'2.
    intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
    lapply (Strict_Included_inv U a z); auto with sets; clear H'3.
    intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5.
    intros x0 H'2; elim H'2.
    intros H'5 H'6; try assumption.
    generalize H'4; intro K.
    red in H'4.
    elim H'4; intros H'8 H'9; red in H'8; clear H'4.
    lapply (H'8 x0); auto with sets.
    intro H'7; try assumption.
    elim (Add_inv U a x x0); auto with sets.
    intro H'15.
    cut (Included U (Add U a x) z).
    intro H'10; try assumption.
    red in K.
    elim K; intros H'11 H'12; apply H'12; clear K; auto with sets.
    rewrite H'15.
    red in |- *.
    intros x1 H'10; elim H'10; auto with sets.
    intros x2 H'11; elim H'11; auto with sets.
  Qed.

  Theorem covers_Add :
    forall A a a':Ensemble U,
      Included U a A ->
      Included U a' A ->
      covers (Ensemble U) (Power_set_PO U A) a' a ->
      exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x.
  Proof.
    intros A a a' H' H'0 H'1; try assumption.
    elim (setcover_inv A a a'); auto with sets.
    intros H'6 H'7.
    clear H'1.
    elim (Strict_Included_inv U a a'); auto with sets.
    intros H'5 H'8; elim H'8.
    intros x H'1; elim H'1.
    intros H'2 H'3; try assumption.
    exists x.
    split; [ try assumption | idtac ].
    clear H'8 H'1.
    elim (H'7 (Add U a x)); auto with sets.
    intro H'1.
    absurd (a = Add U a x); auto with sets.
    red in |- *; intro H'8; try exact H'8.
    apply H'3.
    rewrite H'8; auto with sets.
    auto with sets.
    red in |- *.
    intros x0 H'1; elim H'1; auto with sets.
    intros x1 H'8; elim H'8; auto with sets.
    split; [ idtac | try assumption ].
    red in H'0; auto with sets.
  Qed.

  Theorem covers_is_Add :
    forall A a a':Ensemble U,
      Included U a A ->
      Included U a' A ->
      (covers (Ensemble U) (Power_set_PO U A) a' a <->
	(exists x : _, a' = Add U a x /\ In U A x /\ ~ In U a x)).
  Proof.
    intros A a a' H' H'0; split; intro K.
    apply covers_Add with (A := A); auto with sets.
    elim K.
    intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1.
    apply Add_covers; intuition.
  Qed.

  Theorem Singleton_atomic :
    forall (x:U) (A:Ensemble U),
      In U A x ->
      covers (Ensemble U) (Power_set_PO U A) (Singleton U x) (Empty_set U).
  Proof.
    intros x A H'.
    rewrite <- (Empty_set_zero' U x).
    apply Add_covers; auto with sets.
  Qed.

  Lemma less_than_singleton :
    forall (X:Ensemble U) (x:U),
      Strict_Included U X (Singleton U x) -> X = Empty_set U.
  Proof.
    intros X x H'; try assumption.
    red in H'.
    lapply (Singleton_atomic x (Full_set U));
      [ intro H'2; try exact H'2 | apply Full_intro ].
    elim H'; intros H'0 H'1; try exact H'1; clear H'.
    elim (setcover_inv (Full_set U) (Empty_set U) (Singleton U x));
      [ intros H'6 H'7; try exact H'7 | idtac ]; auto with sets.
    elim (H'7 X); [ intro H'5; try exact H'5 | intro H'5 | idtac | idtac ];
      auto with sets.
    elim H'1; auto with sets.
  Qed.

End Sets_as_an_algebra.

Hint Resolve incl_soustr_in: sets v62.
Hint Resolve incl_soustr: sets v62.
Hint Resolve incl_soustr_add_l: sets v62.
Hint Resolve incl_soustr_add_r: sets v62.
Hint Resolve add_soustr_1 add_soustr_2: sets v62.
Hint Resolve add_soustr_xy: sets v62.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This files implements a type [natmap A] of finite maps whose keys range
over Coq's data type of unary natural numbers [nat]. The implementation equips
a list with a proof of canonicity. *)
From prelude Require Import fin_maps mapset.

Notation natmap_raw A := (list (option A)).
Definition natmap_wf {A} (l : natmap_raw A) :=
  match last l with None => True | Some x => is_Some x end.
Instance natmap_wf_pi {A} (l : natmap_raw A) : ProofIrrel (natmap_wf l).
Proof. unfold natmap_wf. case_match; apply _. Qed.

Lemma natmap_wf_inv {A} (o : option A) (l : natmap_raw A) :
  natmap_wf (o :: l) → natmap_wf l.
Proof. by destruct l. Qed.
Lemma natmap_wf_lookup {A} (l : natmap_raw A) :
  natmap_wf l → l ≠ [] → ∃ i x, mjoin (l !! i) = Some x.
Proof.
  intros Hwf Hl. induction l as [|[x|] l IH]; simpl; [done| |].
  { exists 0. simpl. eauto. }
  destruct IH as (i&x&?); eauto using natmap_wf_inv; [|by exists (S i), x].
  intros ->. by destruct Hwf.
Qed.

Record natmap (A : Type) : Type := NatMap {
  natmap_car : natmap_raw A;
  natmap_prf : natmap_wf natmap_car
}.
Arguments NatMap {_} _ _.
Arguments natmap_car {_} _.
Arguments natmap_prf {_} _.
Lemma natmap_eq {A} (m1 m2 : natmap A) :
  m1 = m2 ↔ natmap_car m1 = natmap_car m2.
Proof.
  split; [by intros ->|intros]; destruct m1 as [t1 ?], m2 as [t2 ?].
  simplify_eq/=; f_equal; apply proof_irrel.
Qed.
Global Instance natmap_eq_dec `{∀ x y : A, Decision (x = y)}
    (m1 m2 : natmap A) : Decision (m1 = m2) :=
  match decide (natmap_car m1 = natmap_car m2) with
  | left H => left (proj2 (natmap_eq m1 m2) H)
  | right H => right (H ∘ proj1 (natmap_eq m1 m2))
  end.

Instance natmap_empty {A} : Empty (natmap A) := NatMap [] I.
Instance natmap_lookup {A} : Lookup nat A (natmap A) := λ i m,
  let (l,_) := m in mjoin (l !! i).

Fixpoint natmap_singleton_raw {A} (i : nat) (x : A) : natmap_raw A :=
  match i with 0 => [Some x]| S i => None :: natmap_singleton_raw i x end.
Lemma natmap_singleton_wf {A} (i : nat) (x : A) :
  natmap_wf (natmap_singleton_raw i x).
Proof. unfold natmap_wf. induction i as [|[]]; simplify_eq/=; eauto. Qed.
Lemma natmap_lookup_singleton_raw {A} (i : nat) (x : A) :
  mjoin (natmap_singleton_raw i x !! i) = Some x.
Proof. induction i; simpl; auto. Qed.
Lemma natmap_lookup_singleton_raw_ne {A} (i j : nat) (x : A) :
  i ≠ j → mjoin (natmap_singleton_raw i x !! j) = None.
Proof. revert j; induction i; intros [|?]; simpl; auto with congruence. Qed.
Hint Rewrite @natmap_lookup_singleton_raw : natmap.

Definition natmap_cons_canon {A} (o : option A) (l : natmap_raw A) :=
  match o, l with None, [] => [] | _, _ => o :: l end.
Lemma natmap_cons_canon_wf {A} (o : option A) (l : natmap_raw A) :
  natmap_wf l → natmap_wf (natmap_cons_canon o l).
Proof. unfold natmap_wf, last. destruct o, l; simpl; eauto. Qed.
Lemma natmap_cons_canon_O {A} (o : option A) (l : natmap_raw A) :
  mjoin (natmap_cons_canon o l !! 0) = o.
Proof. by destruct o, l. Qed.
Lemma natmap_cons_canon_S {A} (o : option A) (l : natmap_raw A) i :
  natmap_cons_canon o l !! S i = l !! i.
Proof. by destruct o, l. Qed.
Hint Rewrite @natmap_cons_canon_O @natmap_cons_canon_S : natmap.

Definition natmap_alter_raw {A} (f : option A → option A) :
    nat → natmap_raw A → natmap_raw A :=
  fix go i l {struct l} :=
  match l with
  | [] =>
     match f None with
     | Some x => natmap_singleton_raw i x | None => []
     end
  | o :: l =>
     match i with
     | 0 => natmap_cons_canon (f o) l | S i => natmap_cons_canon o (go i l)
     end
  end.
Lemma natmap_alter_wf {A} (f : option A → option A) i l :
  natmap_wf l → natmap_wf (natmap_alter_raw f i l).
Proof.
  revert i. induction l; [intro | intros [|?]]; simpl; repeat case_match;
    eauto using natmap_singleton_wf, natmap_cons_canon_wf, natmap_wf_inv.
Qed.
Instance natmap_alter {A} : PartialAlter nat A (natmap A) := λ f i m,
  let (l,Hl) := m in NatMap _ (natmap_alter_wf f i l Hl).
Lemma natmap_lookup_alter_raw {A} (f : option A → option A) i l :
  mjoin (natmap_alter_raw f i l !! i) = f (mjoin (l !! i)).
Proof.
  revert i. induction l; intros [|?]; simpl; repeat case_match; simpl;
    autorewrite with natmap; auto.
Qed.
Lemma natmap_lookup_alter_raw_ne {A} (f : option A → option A) i j l :
  i ≠ j → mjoin (natmap_alter_raw f i l !! j) = mjoin (l !! j).
Proof.
  revert i j. induction l; intros [|?] [|?] ?; simpl;
    repeat case_match; simpl; autorewrite with natmap; auto with congruence.
  rewrite natmap_lookup_singleton_raw_ne; congruence.
Qed.

Definition natmap_omap_raw {A B} (f : A → option B) :
    natmap_raw A → natmap_raw B :=
  fix go l :=
  match l with [] => [] | o :: l => natmap_cons_canon (o ≫= f) (go l) end.
Lemma natmap_omap_raw_wf {A B} (f : A → option B) l :
  natmap_wf l → natmap_wf (natmap_omap_raw f l).
Proof. induction l; simpl; eauto using natmap_cons_canon_wf, natmap_wf_inv. Qed.
Lemma natmap_lookup_omap_raw {A B} (f : A → option B) l i :
  mjoin (natmap_omap_raw f l !! i) = mjoin (l !! i) ≫= f.
Proof.
  revert i. induction l; intros [|?]; simpl; autorewrite with natmap; auto.
Qed.
Hint Rewrite @natmap_lookup_omap_raw : natmap.
Global Instance natmap_omap: OMap natmap := λ A B f m,
  let (l,Hl) := m in NatMap _ (natmap_omap_raw_wf f _ Hl).

Definition natmap_merge_raw {A B C} (f : option A → option B → option C) :
    natmap_raw A → natmap_raw B → natmap_raw C :=
  fix go l1 l2 :=
  match l1, l2 with
  | [], l2 => natmap_omap_raw (f None ∘ Some) l2
  | l1, [] => natmap_omap_raw (flip f None ∘ Some) l1
  | o1 :: l1, o2 :: l2 => natmap_cons_canon (f o1 o2) (go l1 l2)
  end.
Lemma natmap_merge_wf {A B C} (f : option A → option B → option C) l1 l2 :
  natmap_wf l1 → natmap_wf l2 → natmap_wf (natmap_merge_raw f l1 l2).
Proof.
  revert l2. induction l1; intros [|??]; simpl;
    eauto using natmap_omap_raw_wf, natmap_cons_canon_wf, natmap_wf_inv.
Qed.
Lemma natmap_lookup_merge_raw {A B C} (f : option A → option B → option C)
    l1 l2 i : f None None = None →
  mjoin (natmap_merge_raw f l1 l2 !! i) = f (mjoin (l1 !! i)) (mjoin (l2 !! i)).
Proof.
  intros. revert i l2. induction l1; intros [|?] [|??]; simpl;
    autorewrite with natmap; auto;
    match goal with |- context [?o ≫= _] => by destruct o end.
Qed.
Instance natmap_merge: Merge natmap := λ A B C f m1 m2,
  let (l1, Hl1) := m1 in let (l2, Hl2) := m2 in
  NatMap (natmap_merge_raw f l1 l2) (natmap_merge_wf _ _ _ Hl1 Hl2).

Fixpoint natmap_to_list_raw {A} (i : nat) (l : natmap_raw A) : list (nat * A) :=
  match l with
  | [] => []
  | None :: l => natmap_to_list_raw (S i) l
  | Some x :: l => (i,x) :: natmap_to_list_raw (S i) l
  end.
Lemma natmap_elem_of_to_list_raw_aux {A} j (l : natmap_raw A) i x :
  (i,x) ∈ natmap_to_list_raw j l ↔ ∃ i', i = i' + j ∧ mjoin (l !! i') = Some x.
Proof.
  split.
  - revert j. induction l as [|[y|] l IH]; intros j; simpl.
    + by rewrite elem_of_nil.
    + rewrite elem_of_cons. intros [?|?]; simplify_eq.
      * by exists 0.
      * destruct (IH (S j)) as (i'&?&?); auto.
        exists (S i'); simpl; auto with lia.
    + intros. destruct (IH (S j)) as (i'&?&?); auto.
      exists (S i'); simpl; auto with lia.
  - intros (i'&?&Hi'). subst. revert i' j Hi'.
    induction l as [|[y|] l IH]; intros i j ?; simpl.
    + done.
    + destruct i as [|i]; simplify_eq/=; [left|].
      right. rewrite <-Nat.add_succ_r. by apply (IH i (S j)).
    + destruct i as [|i]; simplify_eq/=.
      rewrite <-Nat.add_succ_r. by apply (IH i (S j)).
Qed.
Lemma natmap_elem_of_to_list_raw {A} (l : natmap_raw A) i x :
  (i,x) ∈ natmap_to_list_raw 0 l ↔ mjoin (l !! i) = Some x.
Proof.
  rewrite natmap_elem_of_to_list_raw_aux. setoid_rewrite Nat.add_0_r.
  naive_solver.
Qed.
Lemma natmap_to_list_raw_nodup {A} i (l : natmap_raw A) :
  NoDup (natmap_to_list_raw i l).
Proof.
  revert i. induction l as [|[?|] ? IH]; simpl; try constructor; auto.
  rewrite natmap_elem_of_to_list_raw_aux. intros (?&?&?). lia.
Qed.
Instance natmap_to_list {A} : FinMapToList nat A (natmap A) := λ m,
  let (l,_) := m in natmap_to_list_raw 0 l.

Definition natmap_map_raw {A B} (f : A → B) : natmap_raw A → natmap_raw B :=
  fmap (fmap f).
Lemma natmap_map_wf {A B} (f : A → B) l :
  natmap_wf l → natmap_wf (natmap_map_raw f l).
Proof.
  unfold natmap_map_raw, natmap_wf. rewrite fmap_last.
  destruct (last l). by apply fmap_is_Some. done.
Qed.
Lemma natmap_lookup_map_raw {A B} (f : A → B) i l :
  mjoin (natmap_map_raw f l !! i) = f <$> mjoin (l !! i).
Proof.
  unfold natmap_map_raw. rewrite list_lookup_fmap. by destruct (l !! i).
Qed.
Instance natmap_map: FMap natmap := λ A B f m,
  let (l,Hl) := m in NatMap (natmap_map_raw f l) (natmap_map_wf _ _ Hl).

Instance: FinMap nat natmap.
Proof.
  split.
  - unfold lookup, natmap_lookup. intros A [l1 Hl1] [l2 Hl2] E.
    apply natmap_eq. revert l2 Hl1 Hl2 E. simpl.
    induction l1 as [|[x|] l1 IH]; intros [|[y|] l2] Hl1 Hl2 E; simpl in *.
    + done.
    + by specialize (E 0).
    + destruct (natmap_wf_lookup (None :: l2)) as (i&?&?); auto with congruence.
    + by specialize (E 0).
    + f_equal. apply (E 0). apply IH; eauto using natmap_wf_inv.
      intros i. apply (E (S i)).
    + by specialize (E 0).
    + destruct (natmap_wf_lookup (None :: l1)) as (i&?&?); auto with congruence.
    + by specialize (E 0).
    + f_equal. apply IH; eauto using natmap_wf_inv. intros i. apply (E (S i)).
  - done.
  - intros ?? [??] ?. apply natmap_lookup_alter_raw.
  - intros ?? [??] ??. apply natmap_lookup_alter_raw_ne.
  - intros ??? [??] ?. apply natmap_lookup_map_raw.
  - intros ? [??]. by apply natmap_to_list_raw_nodup.
  - intros ? [??] ??. by apply natmap_elem_of_to_list_raw.
  - intros ??? [??] ?. by apply natmap_lookup_omap_raw.
  - intros ????? [??] [??] ?. by apply natmap_lookup_merge_raw.
Qed.

Fixpoint strip_Nones {A} (l : list (option A)) : list (option A) :=
  match l with None :: l => strip_Nones l | _ => l end.

Lemma list_to_natmap_wf {A} (l : list (option A)) :
  natmap_wf (reverse (strip_Nones (reverse l))).
Proof.
  unfold natmap_wf. rewrite last_reverse.
  induction (reverse l) as [|[]]; simpl; eauto.
Qed.
Definition list_to_natmap {A} (l : list (option A)) : natmap A :=
  NatMap (reverse (strip_Nones (reverse l))) (list_to_natmap_wf l).
Lemma list_to_natmap_spec {A} (l : list (option A)) i :
  list_to_natmap l !! i = mjoin (l !! i).
Proof.
  unfold lookup at 1, natmap_lookup, list_to_natmap; simpl.
  rewrite <-(reverse_involutive l) at 2. revert i.
  induction (reverse l) as [|[x|] l' IH]; intros i; simpl; auto.
  rewrite reverse_cons, IH. clear IH. revert i.
  induction (reverse l'); intros [|?]; simpl; auto.
Qed.

(** Finally, we can construct sets of [nat]s satisfying extensional equality. *)
Notation natset := (mapset natmap).
Instance natmap_dom {A} : Dom (natmap A) natset := mapset_dom.
Instance: FinMapDom nat natmap natset := mapset_dom_spec.

(* Fixpoint avoids this definition from being unfolded *)
Fixpoint of_bools (βs : list bool) : natset :=
  let f (β : bool) := if β then Some () else None in
  Mapset $ list_to_natmap $ f <$> βs.
Definition to_bools (sz : nat) (X : natset) : list bool :=
  let f (mu : option ()) := match mu with Some _ => true | None => false end in
  resize sz false $ f <$> natmap_car (mapset_car X).

Lemma of_bools_unfold βs :
  let f (β : bool) := if β then Some () else None in
  of_bools βs = Mapset $ list_to_natmap $ f <$> βs.
Proof. by destruct βs. Qed.
Lemma elem_of_of_bools βs i : i ∈ of_bools βs ↔ βs !! i = Some true.
Proof.
  rewrite of_bools_unfold; unfold elem_of, mapset_elem_of; simpl.
  rewrite list_to_natmap_spec, list_lookup_fmap.
  destruct (βs !! i) as [[]|]; compute; intuition congruence.
Qed.
Lemma of_bools_union βs1 βs2 :
  length βs1 = length βs2 →
  of_bools (βs1 ||* βs2) = of_bools βs1 ∪ of_bools βs2.
Proof.
  rewrite <-Forall2_same_length; intros Hβs.
  apply elem_of_equiv_L. intros i. rewrite elem_of_union, !elem_of_of_bools.
  revert i. induction Hβs as [|[] []]; intros [|?]; naive_solver.
Qed.
Lemma to_bools_length (X : natset) sz : length (to_bools sz X) = sz.
Proof. apply resize_length. Qed.
Lemma lookup_to_bools_ge sz X i : sz ≤ i → to_bools sz X !! i = None.
Proof. by apply lookup_resize_old. Qed.
Lemma lookup_to_bools sz X i β :
  i < sz → to_bools sz X !! i = Some β ↔ (i ∈ X ↔ β = true).
Proof.
  unfold to_bools, elem_of, mapset_elem_of, lookup at 2, natmap_lookup; simpl.
  intros. destruct (mapset_car X) as [l ?]; simpl.
  destruct (l !! i) as [mu|] eqn:Hmu; simpl.
  { rewrite lookup_resize, list_lookup_fmap, Hmu
      by (rewrite ?fmap_length; eauto using lookup_lt_Some).
    destruct mu as [[]|], β; simpl; intuition congruence. }
  rewrite lookup_resize_new by (rewrite ?fmap_length;
    eauto using lookup_ge_None_1); destruct β; intuition congruence.
Qed.
Lemma lookup_to_bools_true sz X i :
  i < sz → to_bools sz X !! i = Some true ↔ i ∈ X.
Proof. intros. rewrite lookup_to_bools by done. intuition. Qed.
Lemma lookup_to_bools_false sz X i :
  i < sz → to_bools sz X !! i = Some false ↔ i ∉ X.
Proof. intros. rewrite lookup_to_bools by done. naive_solver. Qed.
Lemma to_bools_union sz X1 X2 :
  to_bools sz (X1 ∪ X2) = to_bools sz X1 ||* to_bools sz X2.
Proof.
  apply list_eq; intros i; rewrite lookup_zip_with.
  destruct (decide (i < sz)); [|by rewrite !lookup_to_bools_ge by lia].
  apply option_eq; intros β.
  rewrite lookup_to_bools, elem_of_union by done; intros.
  destruct (decide (i ∈ X1)), (decide (i ∈ X2)); repeat first
    [ rewrite (λ X H, proj2 (lookup_to_bools_true sz X i H)) by done
    | rewrite (λ X H, proj2 (lookup_to_bools_false sz X i H)) by done];
    destruct β; naive_solver.
Qed.
Lemma to_of_bools βs sz : to_bools sz (of_bools βs) = resize sz false βs.
Proof.
  apply list_eq; intros i. destruct (decide (i < sz));
    [|by rewrite lookup_to_bools_ge, lookup_resize_old by lia].
  apply option_eq; intros β.
  rewrite lookup_to_bools, elem_of_of_bools by done.
  destruct (decide (i < length βs)).
  { rewrite lookup_resize by done.
    destruct (lookup_lt_is_Some_2 βs i) as [[]]; destruct β; naive_solver. }
  rewrite lookup_resize_new, lookup_ge_None_2 by lia. destruct β; naive_solver.
Qed.

(** A [natmap A] forms a stack with elements of type [A] and possible holes *)
Definition natmap_push {A} (o : option A) (m : natmap A) : natmap A :=
  let (l,Hl) := m in NatMap _ (natmap_cons_canon_wf o l Hl).

Definition natmap_pop_raw {A} (l : natmap_raw A) : natmap_raw A := tail l.
Lemma natmap_pop_wf {A} (l : natmap_raw A) :
  natmap_wf l → natmap_wf (natmap_pop_raw l).
Proof. destruct l; simpl; eauto using natmap_wf_inv. Qed.
Definition natmap_pop {A} (m : natmap A) : natmap A :=
  let (l,Hl) := m in NatMap _ (natmap_pop_wf _ Hl).

Lemma lookup_natmap_push_O {A} o (m : natmap A) : natmap_push o m !! 0 = o.
Proof. by destruct o, m as [[|??]]. Qed.
Lemma lookup_natmap_push_S {A} o (m : natmap A) i :
  natmap_push o m !! S i = m !! i.
Proof. by destruct o, m as [[|??]]. Qed.
Lemma lookup_natmap_pop {A} (m : natmap A) i : natmap_pop m !! i = m !! S i.
Proof. by destruct m as [[|??]]. Qed.
Lemma natmap_push_pop {A} (m : natmap A) :
  natmap_push (m !! 0) (natmap_pop m) = m.
Proof.
  apply map_eq. intros i. destruct i.
  - by rewrite lookup_natmap_push_O.
  - by rewrite lookup_natmap_push_S, lookup_natmap_pop.
Qed.
Lemma natmap_pop_push {A} o (m : natmap A) : natmap_pop (natmap_push o m) = m.
Proof. apply natmap_eq. by destruct o, m as [[|??]]. Qed.


(*
(C) Copyright 2010, COQTAIL team

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

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

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

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

Require Import Rinterval Ranalysis_def.
Require Import Rpser_def Rpser_base_facts Rpser_cv_facts Rpser_sums.
Require Import Rpow_facts.
Require Import Rsequence_def Rsequence_facts.
Require Import Rseries_def Rseries_facts.
Require Import RFsequence_facts.

Require Import Cpow Cpser_def Cpser_base_facts.
Require Import CFsequence CFsequence_facts.
Require Import Csequence Csequence_def Csequence_facts.
Require Import Cmet Cnorm Ctacfield.
Require Import Cprop_base.

Require Import Canalysis_def.
Require Import Canalysis_cont.
Require Import Canalysis_deriv.
Require Import Canalysis_basic_facts.

Local Open Scope C_scope.

Lemma Rseq_norm_abs_Cre :
forall (An : nat -> C), {l | Rseq_cv (fun n => sum_f_R0 (fun n =>(Cnorm (An n))) n) l} ->
{l | Rseq_cv (fun n => sum_f_R0 (fun n =>(Rabs (Cre (An n))))n) l}.
Proof.
intros An H.
apply Rseries_CV_comp with (fun n0 : nat => Cnorm (An n0)) .
intros n. split.
apply Rabs_pos.
apply Cre_le_Cnorm.
exact H.
Qed.

Lemma Rseq_norm_abs_Cim :
forall (An : nat -> C), {l | Rseq_cv (fun n => sum_f_R0 (fun n =>(Cnorm (An n)))n) l} ->
{l | Rseq_cv (fun n => sum_f_R0 (fun n =>(Rabs (Cim (An n))))n) l}.
Proof.
intros An H.
apply Rseries_CV_comp with (fun n0 : nat => Cnorm (An n0)) .
intros n. split.
apply Rabs_pos.
apply Cim_le_Cnorm.
exact H.
Qed.

Lemma Cseq_norm_Rseq :
forall (An : nat -> C), {l | Rseq_cv (fun n => sum_f_R0 (fun n =>(Cnorm (An n)))n) l} ->
{l | Cseq_cv (fun n => sum_f_C0 (fun n =>((An n)))n) l}.
Proof.
intros An H.
generalize (Rseq_norm_abs_Cim An H).
generalize (Rseq_norm_abs_Cre An H).
intros Hre Him.
assert ( H1 : {l : R |
      Rseq_cv
        (fun n : nat => sum_f_R0 (fun n0 : nat => Cim (An n0)) n) l}).
apply (Rser_abs_cv_cv  (fun n0 : nat => Cim (An n0))).
unfold Rser_abs_cv.
unfold Rseq_abs.
apply Him.
assert ( H2 : {l : R |
      Rseq_cv
        (fun n : nat => sum_f_R0 (fun n0 : nat => Cre (An n0)) n) l}).
apply (Rser_abs_cv_cv  (fun n0 : nat => Cre (An n0))).
unfold Rser_abs_cv.
unfold Rseq_abs.
apply Hre.
destruct H1 as (lim, H1).
destruct H2 as (lre, H2).
exists (lre +i lim).
apply <- Cseq_Rseq_Rseq_equiv.
split. simpl.
assert ((fun n : nat => Cre (sum_f_C0 (fun n0 : nat => An n0) n)) ==
(fun n : nat => sum_f_R0 (fun n0 : nat => Cre (An n0)) n)).
unfold "==".
intros n. rewrite <- sum_f_C0_Cre_compat. reflexivity.
apply (Rseq_cv_eq_compat (fun n : nat => sum_f_R0 (fun n0 : nat => Cre (An n0)) n)
(fun n : nat => Cre (sum_f_C0 (fun n0 : nat => An n0) n))).
apply Rseq_eq_sym. assumption.
assumption.
assert ((fun n : nat => Cim (sum_f_C0 (fun n0 : nat => An n0) n)) ==
(fun n : nat => sum_f_R0 (fun n0 : nat => Cim (An n0)) n)).
unfold "==".
intros n. rewrite <- sum_f_C0_Cim_compat. reflexivity.
apply (Rseq_cv_eq_compat (fun n : nat => sum_f_R0 (fun n0 : nat => Cim (An n0)) n)
(fun n : nat => Cim (sum_f_C0 (fun n0 : nat => An n0) n))).
apply Rseq_eq_sym. assumption.
assumption.
Qed.

Lemma Cpser_abel : forall (An : nat -> C) (r : R),
     Cv_radius_weak An r -> forall x, Cnorm x < r -> {l | Cpser An x l}.
Proof.
intros An r Rho x x_ub.
 case (Req_or_neq r) ; intro r_0.
 exists 0 ; apply False_ind ; rewrite r_0 in x_ub ; assert (0 <= Cnorm x). apply Cnorm_pos. lra.
assert (Hrew_abs : (Cnorm (x / r) = Cnorm x / r)%R).
 unfold Cdiv, Rdiv ; rewrite Cnorm_Cmult ; apply Rmult_eq_compat_l ;
 replace (/r) with (IRC (/r)). rewrite Cnorm_IRC_Rabs.
 apply Rabs_right.
 left ; apply Rinv_0_lt_compat ; apply Rle_lt_trans with (Cnorm x) ;
 [apply Cnorm_pos | assumption].
 CusingR_f ; assumption.
assert (Rabsx_r_lt_1 : Cnorm x / r < 1).
 apply Rle_lt_trans with (Cnorm x / r * (r / r))%R.
 right ; field ; assumption.
 replace 1%R with (r / r)%R by (field ; assumption).
 unfold Rdiv ; rewrite <- Rmult_assoc.
 apply Rmult_lt_compat_r.
 apply Rinv_0_lt_compat ; apply Rle_lt_trans with (Cnorm x) ;
 [apply Cnorm_pos | assumption].
 rewrite Rmult_assoc ; rewrite Rinv_l ; [| assumption] ; rewrite Rmult_1_r ; assumption.

 assert (Rho' : Rpser_def.Cv_radius_weak (fun n : nat => Cnorm (An n)) r).
 destruct Rho as [M HM] ; exists M.
 intros u [n Hn] ; rewrite Hn ; unfold gt_abs_pser, Rpser_def.gt_pser,
 Rseq_abs, Rseq_mult. unfold gt_norm_pser, gt_pser, Cseq_norm, Cseq_mult in HM.
 replace (Rabs (Cnorm (An n) * r ^ n))%R with (Cnorm (An n * r ^ n))%R.
 apply HM ; exists n ; reflexivity.
 rewrite Rabs_mult ; replace (Rabs (r ^ n))%R with (Rabs (Cnorm r ^ n))%R.
 rewrite <- Rabs_mult, <- Cnorm_pow, <- Cnorm_Cmult, Rabs_Cnorm ; reflexivity.
 rewrite <- Cnorm_pow, IRC_pow_compat, Cnorm_IRC_Rabs, Rabs_Rabsolu ;
 reflexivity.
 rewrite <- Rabs_Cnorm in x_ub.
 assert (Cnorm_cauchy := Cauchy_crit_Rseq_pps
    (fun n => Cnorm (An n)) r Rho' (Cnorm x) x_ub).

assert (T : Rseries.Cauchy_crit (sum_f_R0 (fun n : nat => Cnorm (An n * x ^ n)))).
 intros eps eps_pos ; destruct (Cnorm_cauchy eps eps_pos) as [N HN] ;
 exists N ; intros m n m_lb n_lb.

assert (Hrew : forall An x n, sum_f_R0 (fun n0 : nat => Cnorm (An n0 * x ^ n0)) n
      = sum_f_R0 (Rpser_def.gt_pser (fun n0 : nat => Cnorm (An n0)) (Cnorm x)) n).
 clear ; intros An x n ; induction n.
 unfold Rpser_def.gt_pser ; simpl ; rewrite Cnorm_Cmult, Cnorm_C1 ;
 reflexivity.
 simpl sum_f_R0 ; rewrite IHn ; apply Rplus_eq_compat_l ;
 unfold Rpser_def.gt_pser ; simpl ; repeat rewrite Cnorm_Cmult ;
 rewrite Cnorm_pow ; reflexivity.
repeat rewrite Hrew ; rewrite R_dist_sym ; apply HN ; assumption.

 destruct (Cseq_norm_Rseq (fun n => An n * x ^ n) (R_complete _ T)) as [l Hl] ;
 exists l ; apply Hl.
Qed.

(** Definition of the sum of a power serie (0 outside the cv-disc) *)

Definition weaksum_r : forall (An : nat -> C) (r : R) (Pr : Cv_radius_weak An r), C -> C.
Proof.
intros An r Rho x.
 case (Rlt_le_dec (Cnorm x) r) ; intro x_bd.
 elim (Cpser_abel _ _ Rho _ x_bd) ; intros y Hy ; exact y.
 exact 0.
Defined.

Definition sum_r : forall (An : nat -> C) (r : R) (Pr : finite_cv_radius An r), C -> C.
Proof.
intros An r Pr x.
 case (Rlt_le_dec (Cnorm x) r) ; intro x_bd.
  assert (rho : Cv_radius_weak An (middle (Cnorm x) r)).
  apply Pr; split.
  apply Rle_trans with (Cnorm x).
   apply Cnorm_pos.
   left ; apply (proj1 (middle_is_in_the_middle _ _ x_bd)).
   apply (proj2 (middle_is_in_the_middle _ _ x_bd)).
 apply (weaksum_r An (middle (Cnorm x) r) rho x).
 exact 0.
Defined.

Definition sum : forall (An : nat -> C) (Pr : infinite_cv_radius An), C -> C.
Proof.
intros An Pr r.
 apply (weaksum_r An (Cnorm r +1) (Pr (Cnorm r + 1)%R) r).
Defined.

(** Establishing the link between these functions and the sum *)

Lemma weaksum_r_sums : forall (An : nat -> C) (r : R) (Pr : Cv_radius_weak An r) (x : C),
      Cnorm x < r -> Cpser An x (weaksum_r An r Pr x).
Proof.
intros An r Pr x x_bd.
 unfold weaksum_r ; case (Rlt_le_dec (Cnorm x) r) ; intro s.
 destruct (Cpser_abel An r Pr x s) as (l,Hl) ; simpl ; assumption.
 apply False_ind ; lra.
Qed.

Lemma sum_r_sums : forall (An : nat -> C) (r : R) (Pr : finite_cv_radius An r),
      forall x, Cnorm x < r -> Cpser An x (sum_r An r Pr x).
Proof.
intros An r Pr x x_ub.
 unfold sum_r ; destruct (Rlt_le_dec (Cnorm x) r) as [x_bd | x_nbd].
 apply weaksum_r_sums.
 apply (proj1 (middle_is_in_the_middle _ _ x_bd)).
  apply False_ind ; lra.
Qed.

Lemma sum_sums : forall (An : nat -> C) (Pr : infinite_cv_radius An),
      forall x, Cpser An x (sum An Pr x).
Proof.
intros An Pr x.
 apply weaksum_r_sums ; intuition.
Qed.

(** Proof that the sum is unique *)

Lemma weaksum_r_unique : forall (An : nat -> C) (r : R) (Pr1 Pr2 : Cv_radius_weak An r) (x : C),
     Cnorm x < r -> weaksum_r An r Pr1 x = weaksum_r An r Pr2 x.
Proof.
intros An r Pr1 Pr2 x x_bd ;
 assert (T1 := weaksum_r_sums _ _ Pr1 _ x_bd) ;
 assert (T2 := weaksum_r_sums _ _ Pr2 _ x_bd) ;
 eapply Pser_unique ; eassumption.
Qed.

Lemma weaksum_r_unique_strong : forall (An : nat -> C) (r1 r2 : R) (Pr1 : Cv_radius_weak An r1)
     (Pr2 : Cv_radius_weak An r2) (x : C), Cnorm x < r1 -> Cnorm x < r2 ->
     weaksum_r An r1 Pr1 x = weaksum_r An r2 Pr2 x.
Proof.
intros An r1 r2 Pr1 Pr2 x x_bd1 x_bd2.
  assert (T1 := weaksum_r_sums _ _ Pr1 _ x_bd1) ;
  assert (T2 := weaksum_r_sums _ _ Pr2 _ x_bd2) ;
 eapply Pser_unique ; eassumption.
Qed.

Lemma sum_r_unique : forall (An : nat -> C) (r : R) (Pr1 Pr2 : finite_cv_radius An r) (x : C),
     Cnorm x < r -> sum_r An r Pr1 x = sum_r An r Pr2 x.
Proof.
intros An r Pr1 Pr2 x x_bd ;
 assert (T1 := sum_r_sums _ _ Pr1 _ x_bd) ;
 assert (T2 := sum_r_sums _ _ Pr2 _ x_bd) ;
 eapply Pser_unique ; eassumption.
Qed.

Lemma sum_r_unique_strong : forall (An : nat -> C) (r1 r2 : R) (Pr1 : finite_cv_radius An r1)
     (Pr2 : finite_cv_radius An r2) (x : C), Cnorm x < r1 -> Cnorm x < r2 ->
     sum_r An r1 Pr1 x = sum_r An r2 Pr2 x.
Proof.
intros An r1 r2 Pr1 Pr2 x x_bd1 x_bd2 ;
 assert (T1 := sum_r_sums _ _ Pr1 _ x_bd1) ;
 assert (T2 := sum_r_sums _ _ Pr2 _ x_bd2) ;
 eapply Pser_unique ; eassumption.
Qed.

Lemma sum_unique : forall (An : nat -> C) (Pr1 Pr2 : infinite_cv_radius An) (x : C),
      sum An Pr1 x = sum An Pr2 x.
Proof.
intros An Pr1 Pr2 x ;
 assert (T1 := sum_sums  _ Pr1 x) ;
 assert (T2 := sum_sums  _ Pr2 x) ;
 eapply Pser_unique ; eassumption.
Qed.

(** Abel's lemma : Normal convergence of the power serie *)

Lemma Cpser_abel2_prelim : forall (An : nat -> C) (r : R),
     Cv_radius_weak An r -> forall x, Cnorm x < r ->
     { l | Cpser_norm An x l}.
Proof.
intros An r Rho x x_bd.
 assert (Rho' : Rpser_def.Cv_radius_weak (fun n => Cnorm (An n)) r).
  destruct Rho as [B HB] ; exists B ; intros u [n Hn] ; rewrite Hn ; apply HB ;
  exists n ; unfold_gt ; unfold gt_abs_pser, Rpser_def.gt_pser, Rseq_mult, Rseq_abs.
  rewrite Rabs_mult, Cnorm_Cmult, Rabs_Cnorm ; apply Rmult_eq_compat_l ;
  rewrite IRC_pow_compat, Cnorm_IRC_Rabs ; reflexivity.
 rewrite <- Rabs_Cnorm in x_bd ; pose (l := Rpser_sums.weaksum_r _ _ Rho' (Cnorm x)) ;
 exists l ; unfold Cpser_norm, Pser, infinite_sum.
 assert (Hl := Rpser_sums.weaksum_r_sums _ _ Rho' (Cnorm x) x_bd) ;
 unfold Rseries.Pser, Rfunctions.infinite_sum in Hl.

 assert (Hrew : forall n, IRC (sum_f_R0 (fun n0 : nat => (Cnorm (An n0) * Cnorm x ^ n0)%R) n) =
                  sum_f_C0 (fun n0 : nat => Cnorm (An n0 * x ^ n0)) n).
 clear ; intro n ; induction n.
  simpl ; rewrite Cmult_1_r, Rmult_1_r ; reflexivity.
  simpl ; rewrite <- IHn.
  rewrite Cadd_IRC_Rplus ; apply Cadd_eq_compat_l.
  repeat rewrite Cnorm_Cmult ; repeat rewrite Cmult_IRC_Rmult ;
  apply Cmult_eq_compat_l ; rewrite Cnorm_pow ; reflexivity.
  intros eps eps_pos ; destruct (Hl _ eps_pos) as [N HN] ;
  exists N ; intros n n_lb ; simpl ; unfold C_dist.
  unfold_gt.
 rewrite <- Hrew, <- Cminus_IRC_Rminus, Cnorm_IRC_Rabs ;
  apply HN ; assumption.
Qed.

Lemma Cpser_abel2 : forall (An : nat -> C) (r : R),
     Cv_radius_weak An r -> forall r0 : posreal, r0 < r ->
     CVN_r (fun n x => gt_pser An x n) r0.
Proof.
intros An r Pr r0 r0_ub.
 destruct r0 as (a,a_pos).
 assert (a_bd : Rabs a < r).
  rewrite Rabs_right ; [| apply Rgt_ge ; apply Rlt_gt] ; assumption.
 assert (r_pos : 0 < r).
  apply Rlt_trans with a ; assumption.
 assert (r'_bd : Rabs ((a + r) / 2) < r).
  rewrite Rabs_right.
  assert (Hrew : r = ((r+r)/2)%R) by field ; rewrite Hrew at 2; unfold Rdiv ;
  apply Rmult_lt_compat_r ; [apply Rinv_0_lt_compat ; intuition |] ;
  apply Rplus_lt_compat_r ; rewrite Rabs_right in a_bd ; intuition.
  apply Rle_ge ; unfold Rdiv ; replace 0%R with (0 * /2)%R by field ;
  apply Rmult_le_compat_r ; lra.
 assert (r'_bd2 : Cnorm (Rabs ((a + r) / 2)) < r).
 rewrite Cnorm_IRC_Rabs, Rabs_Rabsolu ; assumption.
 assert (Pr' := Cv_radius_weak_Cnorm_compat2 _ _ Pr).
 exists (gt_abs_pser (fun n => Cnorm (An n)) ((a+r)/2)).
 exists (Rpser_sums.weaksum_r (fun n => Cnorm (An n)) r Pr' (Rabs ((a+r)/2))) ; split.
 rewrite Cnorm_IRC_Rabs in r'_bd2 ;
 assert (H := Rpser_sums.weaksum_r_sums (fun n => Cnorm (An n)) r Pr' (Rabs ((a + r) / 2)) r'_bd2).
 unfold Rpser in H.
 intros eps eps_pos ; destruct (H eps eps_pos) as (N, HN) ; exists N.
  assert (Hrew : forall k, Cnorm (gt_abs_pser (fun n => Cnorm (An n)) ((a + r) / 2) k)
  = Rpser_def.gt_pser (fun n0 : nat => Cnorm (An n0)) (Rabs ((a + r) / 2)) k).
   intro k ; unfold gt_abs_pser, Rpser_def.gt_pser, Rseq_mult, Rseq_abs.
   rewrite Cnorm_IRC_Rabs, Rabs_Rabsolu, Rabs_mult, <- RPow_abs, Rabs_Cnorm ;
   reflexivity.
 assert (Temp : forall n, sum_f_R0 (fun k : nat =>
             Cnorm (gt_abs_pser (fun n0 : nat => Cnorm (An n0)) ((a + r) / 2) k)) n
            = sum_f_R0 (Rpser_def.gt_pser (fun n0 : nat => Cnorm (An n0)) (Rabs ((a + r) / 2))) n).
   intros n ; clear -Hrew ; induction n ; simpl ; rewrite Hrew ; [| rewrite IHn] ; reflexivity.
  intros n n_lb ; rewrite Temp ; apply HN ; assumption.
 intros n y Hyp ; unfold_gt ; unfold gt_abs_pser, Rpser_def.gt_pser, Rseq_abs, Rseq_mult.
 rewrite Rabs_mult, Rabs_Cnorm ; repeat rewrite Cnorm_Cmult, Cnorm_IRC_Rabs,
 Rabs_mult, Rabs_right.
 apply Rmult_le_compat_l.
 apply Cnorm_pos.
 rewrite Rabs_Rabsolu.
 rewrite <- Cnorm_IRC_Rabs ; rewrite <- IRC_pow_compat ;
 repeat rewrite Cnorm_pow ; apply pow_incr ; split ; [apply Cnorm_pos |].
 unfold Boule in Hyp ; simpl in Hyp ; unfold C_dist in Hyp ;
 rewrite Cnorm_minus_sym, Cminus_0_r in Hyp.
 apply Rle_trans with a ; [left ; assumption |].
 rewrite Cnorm_IRC_Rabs, Rabs_right.
 apply Rle_trans with ((a + a) / 2)%R ; [right ; field | unfold Rdiv ;
 apply Rmult_le_compat_r ; [lra | apply Rplus_le_compat_l ; left ; assumption]].
 unfold Rdiv ; apply Rle_ge ; apply Rle_mult_inv_pos ; lra.
 apply Rle_ge ; apply Cnorm_pos.
Qed.

Lemma Rminus_Rlt : forall a b, 0 < a - b -> b < a.
Proof.
intros a b H.
 replace b with (b + 0)%R by ring.
 replace a with (b + (a - b))%R by ring.
 apply Rplus_lt_compat_l ; assumption.
Qed.

Lemma Cpser_alembert_prelim : forall (An : nat -> C) (M : R),
       0 < M -> (forall n : nat, An n <> C0) ->
       Cseq_bound (fun n => (An (S n) / An n)) M -> forall r,
       Rabs r < / M -> Cv_radius_weak An r.
Proof.
intros An M M_pos An_neq An_frac_ub r r_bd.
 assert (r_lb := Rabs_pos r) ; case r_lb ; clear r_lb ; intro rabs_lb.
 assert (my_lam : 0 < /Rabs r - M).
 apply Rgt_minus ; rewrite <- Rinv_involutive.
 apply Rinv_lt_contravar.
 apply Rmult_lt_0_compat ; [| apply Rlt_trans with (Rabs r)] ; assumption.
 assumption.
 apply Rgt_not_eq ; assumption.
 exists (Cnorm (An 0%nat)) ; intros x Hyp ;
  elim Hyp ; intros n Hn ; rewrite Hn ;
  unfold_gt ; rewrite Cnorm_Cmult.
  clear Hn ; induction n.
  simpl ; rewrite Cnorm_C1 ; rewrite Rmult_1_r ; right ; reflexivity.
  apply Rle_trans with (Cnorm (An (S n) / (An n)) * Cnorm (An n) * Cnorm (r ^ S n))%R.
  right ; repeat rewrite <- Cnorm_Cmult ; apply Cnorm_eq_compat ;
  field ; apply An_neq.
  apply Rle_trans with (M * Cnorm (An n) * Cnorm (r ^ S n))%R.
  repeat apply Rmult_le_compat_r ; [| | apply An_frac_ub] ; apply Cnorm_pos.
  simpl ; rewrite Cnorm_Cmult.
  apply Rle_trans with (M * Cnorm (An n) * (/M * Cnorm (r ^ n)))%R.
  repeat rewrite <- Rmult_assoc ; apply Rmult_le_compat_r ; [apply Cnorm_pos |
  repeat rewrite Rmult_assoc ; repeat apply Rmult_le_compat_l].
  left ; assumption.
  apply Cnorm_pos.
  rewrite Cnorm_IRC_Rabs ; left ; assumption.
  apply Rle_trans with (Cnorm (An n) * Cnorm (r ^ n))%R ; [right ; field ;
  apply Rgt_not_eq |] ; assumption.
 exists (Cnorm (An 0%nat)).
  intros x Hx ; destruct Hx as (n,Hn) ; rewrite Hn ;
   unfold_gt ; destruct n.
  right ; apply Cnorm_eq_compat ; ring.
  destruct (Req_dec r 0) as [Hr | Hf].
  rewrite Hr ; unfold gt_norm_pser ; rewrite Cnorm_Cmult, Cnorm_pow,
  Cnorm_IRC_Rabs, RPow_abs, pow_i, Rabs_R0, Rmult_0_r ;
  [apply Cnorm_pos | intuition].
  apply False_ind ; assert (T := Rabs_no_R0 _ Hf) ;
  apply T ; symmetry ; assumption.
Qed.

Lemma Cpser_alembert_prelim2 : forall (An : nat -> C) (M : R),
       0 < M -> (forall n : nat, An n <> C0) ->
       Cseq_eventually (fun Un => Cseq_bound Un M) (fun n => (An (S n) / An n)) ->
       forall r, Rabs r < / M -> Cv_radius_weak An r.
Proof.
intros An M M_pos An_neq An_frac_event r r_bd.
destruct An_frac_event as [N HN].
 assert (Rho : Cv_radius_weak (fun n => (An (N + n)%nat)) r).
  apply Cpser_alembert_prelim with M.
  assumption.
  intro n ; apply An_neq.
  intro n ; replace (N + S n)%nat with (S (N + n)) by intuition ; apply HN.
  assumption.
 apply Cv_radius_weak_padding_neg_compat with N ;
 destruct Rho as [T HT] ; exists T ; intros u Hu ; destruct Hu as [n Hn] ;
 rewrite Hn ; unfold_gt ; rewrite plus_comm ; apply HT ;
 exists n ; reflexivity.
Qed.

Lemma Cpser_alembert_prelim3 : forall (An : nat -> C) (lambda : C),
       0 < Cnorm (lambda) -> (forall n : nat, An n <> C0) ->
       Rseq_cv (fun n : nat => Cnorm (An (S n) / An n)) (Cnorm lambda) -> forall r,
       Rabs r < / (Cnorm lambda) -> Cv_radius_weak An r.
Proof.
intros An lam lam_pos An_neq An_frac_cv r r_bd.
 assert (middle_lb := proj1 (middle_is_in_the_middle _ _ r_bd)).
 assert (middle_ub := proj2 (middle_is_in_the_middle _ _ r_bd)).
 assert (middle_pos : 0 < middle (Rabs r) (/Cnorm lam)).
  apply Rle_lt_trans with (Rabs r) ; [apply Rabs_pos | assumption].
 pose (eps := (/ (middle (Rabs r) (/ Cnorm lam)) - Cnorm lam)%R).
 assert (eps_pos : 0 < eps).
  apply Rgt_minus ; rewrite <- Rinv_involutive.
  apply Rinv_lt_contravar.
  apply Rmult_lt_0_compat ; [| apply Rinv_0_lt_compat] ; assumption.
  assumption.
  apply Rgt_not_eq ; assumption.
 apply Cpser_alembert_prelim2 with (Cnorm lam + eps)%R.
 lra.
 apply An_neq.
 destruct (An_frac_cv (/ (middle (Rabs r) (/ Cnorm lam)) - Cnorm lam))%R as [N HN].
 assumption.
 exists N ; intro n.
 apply Rle_trans with (Cnorm lam + (Cnorm (An (S (N + n)) / An (N + n)%nat)
      - Cnorm lam))%R.
 right ; ring.
 apply Rplus_le_compat_l ; apply Rle_trans with
   (R_dist (Cnorm (An (S (N + n)) / An (N + n)%nat)) (Cnorm lam))%R.
 apply RRle_abs.
 left ; apply HN ; intuition.
 replace (Cnorm lam + eps)%R with (/ (middle (Rabs r) (/ Cnorm lam)))%R.
 rewrite Rinv_involutive ; [| apply Rgt_not_eq] ; assumption.
 unfold eps ; ring.
Qed.

Lemma Cpser_alembert_prelim4 : forall (An : nat -> C),
       (forall n : nat, An n <> C0) ->
       Rseq_cv (fun n : nat => Cnorm (An (S n) / An n)) R0 ->
       infinite_cv_radius An.
Proof.
intros An An_neq An_frac_0 r.
 assert (eps_pos : 0 < /(Rabs r + 1)).
  apply Rinv_0_lt_compat ; apply Rplus_le_lt_0_compat ; [apply Rabs_pos |
  apply Rlt_0_1].
 apply Cpser_alembert_prelim2 with (/(Rabs r + 1))%R.
 assumption.
 apply An_neq.
 destruct (An_frac_0 (/ (Rabs r + 1))%R eps_pos) as [N HN] ; exists N ; intro n.
 apply Rle_trans with (R_dist (Cnorm (An (S (N + n)) / An (N + n)%nat)) 0) ; [right |].
 unfold R_dist in |-* ; rewrite Rminus_0_r, Rabs_right ; [reflexivity | apply Rle_ge ;
 apply Cnorm_pos].
 left ; apply HN ; intuition.
 rewrite Rinv_involutive ; [lra |] ; apply Rgt_not_eq ;
 apply Rplus_le_lt_0_compat ; [apply Rabs_pos | apply Rlt_0_1].
Qed.

Lemma Cpser_bound_criteria : forall (An : nat -> C) (z l : C),
    Cpser An z l -> Cv_radius_weak An (Cnorm z).
Proof.
intros An z l Hzl.
 destruct Hzl with R1 as (N, HN) ; [lra |].
 assert (H1 : forall n :  nat, (n >= S N)%nat -> gt_norm_pser An z n
    <= Rmax 2 (Cnorm (An 0%nat) + 1)).
  intros n Hn ; case_eq n ; unfold_gt.
  intro H ; simpl ; rewrite Cmult_1_r ; apply Rle_trans with (Cnorm (An 0%nat) +1)%R ;
   [intuition | apply RmaxLess2].
   intros m Hrew ; replace (Cnorm (An (S m) * z ^ S m)) with
         (Cnorm ((sum_f_C0 (fun n0 : nat => An n0 * z ^ n0) (S m) - l) +
         (l - sum_f_C0 (fun n0 : nat => An n0 * z ^ n0) m))).
    apply Rle_trans with (Rplus (Cnorm (sum_f_C0 (fun n0 : nat => An n0 * z ^ n0)%C (S m) - l))
          (Cnorm (l - sum_f_C0 (fun n0 : nat => An n0 * z ^ n0) m))).
  apply Cnorm_triang.
   apply Rle_trans with 2 ; [|apply RmaxLess1] ; apply Rlt_le ; apply Rplus_lt_compat ;
   [| rewrite Cnorm_minus_sym].
   apply Rle_lt_trans with (dist C_met (sum_f_C0 (fun n0 : nat => An n0 * z ^ n0)
         (S m)) l).
  right ; simpl ; unfold C_dist ; reflexivity.
  simpl (dist C_met) ;unfold C_dist ; unfold Cseq_sum, gt_pser, Cseq_mult in HN ;
  apply HN ; intuition.
  apply Rle_lt_trans with (dist C_met (sum_f_C0 (fun n0 : nat => An n0 * z ^ n0) m) l).
  right ; simpl ; unfold C_dist ; reflexivity.
  simpl (dist C_met) ;unfold C_dist ; unfold Cseq_sum, gt_pser, Cseq_mult in HN ;
  apply HN ; intuition.
   simpl sum_f_C0 ; apply Cnorm_eq_compat.
   simpl ; ring.
   destruct (Cseq_partial_bound (gt_pser An z) (S N)) as (B,HB).
   exists (Rmax B (Rmax 2 (Cnorm (An 0%nat) + 1))).
   intros y Hy ; destruct Hy as [u Hu] ; rewrite Hu.
   case (le_lt_dec u (S N)) ; intro Hu_b.
   apply Rle_trans with B.
   unfold_gt ; rewrite Cnorm_Cmult, Cnorm_pow, Cnorm_invol.
   rewrite <- Cnorm_pow. rewrite <- Cnorm_Cmult.
   apply HB ; assumption.
   apply RmaxLess1.
   unfold_gt ; rewrite Cnorm_Cmult.
   rewrite Cnorm_pow, Cnorm_invol, <- Cnorm_pow, <- Cnorm_Cmult.
   apply Rle_trans with (Rmax 2 (Cnorm (An 0%nat) + 1)) ; [apply H1 | apply RmaxLess2] ; intuition.
Qed.

(** A sufficient condition for the radius of convergence*)
Lemma Cpser_finite_cv_radius_caracterization : forall (An : nat -> C) (z l : C),
   Cpser An z l -> (forall l' : R, ~ Cpser_norm An z l')  -> finite_cv_radius An (Cnorm z).
Proof.
intros An z l Hcv Hncv.
split; intros x Hx.

 apply Cv_radius_weak_le_compat with (Cnorm z).
 rewrite Rabs_Cnorm ; rewrite Rabs_right ; intuition.

  apply (Cpser_bound_criteria _ _ l Hcv).

 intro Hf.
 destruct (Cpser_abel2_prelim An x Hf z) as [l' Hl'].
 assumption.
 apply (Hncv (Cnorm l')).
Abort.

Lemma Cpser_infinite_cv_radius_caracterization :
  forall An, (forall x, {l | Cpser An x l}) ->
  infinite_cv_radius An.
Proof.
intros An weaksum r ; destruct (weaksum r) as (l, Hl).
 assert (H := Cpser_bound_criteria An r l Hl).
 rewrite Cnorm_IRC_Rabs in H.
 apply Cv_radius_weak_le_compat with (Rabs r).
 rewrite Rabs_Rabsolu ; right ; reflexivity.
 assumption.
Qed.

Lemma Cv_radius_weak_derivable_compat : forall An r,
         Cv_radius_weak An r -> forall r', Rabs r' < Rabs r ->
         Cv_radius_weak (An_deriv An) r'.
Proof.
intros An r rho r' r'_bd.
 assert (Rabsr_pos : 0 < Rabs r).
  apply Rle_lt_trans with (Rabs r') ; [apply Rabs_pos | assumption].
 assert (x_lt_1 : Rabs (r'/ r) < 1).
  unfold Rdiv ; rewrite Rabs_mult ; rewrite Rabs_Rinv.
  replace 1%R with (Rabs r *  / Rabs r)%R.
  apply Rmult_lt_compat_r ; [apply Rinv_0_lt_compat |] ; assumption.
  apply Rinv_r ; apply Rgt_not_eq ; assumption.
  intro Hf ; rewrite Hf, Rabs_R0 in Rabsr_pos ; apply (Rlt_irrefl _ Rabsr_pos).
  destruct rho as (B,HB).
  case (Req_or_neq r') ; intro r'_lb.
  exists (Cnorm (An 1%nat)) ; intros x Hx ; destruct Hx as (i, Hi) ;
 rewrite Hi ; unfold An_deriv, Cseq_shift ; unfold_gt.
 destruct i.
 simpl ; rewrite Cmult_1_l, Cmult_1_r ; apply Rle_refl.
 rewrite r'_lb ; rewrite IRC_pow_compat, pow_i ; [| intuition] ;
 repeat rewrite Cmult_0_r, Cnorm_C0 ; apply Cnorm_pos.
 assert (Rabsr'_pos : 0 < Rabs r') by (apply Rabs_pos_lt ; assumption).
 destruct (Rpser_cv_speed_pow_id (r' / r) x_lt_1 (Rabs r') Rabsr'_pos) as (N, HN).
 destruct (Rseq_partial_bound (gt_norm_pser (An_deriv An) r') N) as (B2, HB2).
 exists (Rmax B B2) ; intros x Hx ; destruct Hx as (i, Hi) ;
 rewrite Hi ; unfold gt_norm_pser, gt_pser, Cseq_norm, Cseq_mult in * ;
  case (le_lt_dec i N) ; intro H.
 apply Rle_trans with B2 ; [rewrite <- Rabs_Cnorm ; apply HB2 | apply RmaxLess2] ;
 assumption.
 apply Rle_trans with (Cnorm (/r' * (INC (S i) * (r' / r) ^ S i) * An (S i) * r ^ S i)).
 right ; apply Cnorm_eq_compat ; unfold An_deriv, Cseq_shift, Cseq_mult ; field_simplify.
 unfold Cdiv ; repeat (rewrite Cmult_assoc) ; repeat (apply Cmult_eq_compat_l).
  rewrite Cpow_mul_distr_l.
 try (rewrite Cinv_1 ; rewrite Cmult_1_r).
 rewrite Cmult_assoc.
 replace ((/ r) ^ S i * (r ^ S i * / r')) with (/ r').
 simpl ; field ; auto with complex.
 assert (r_neq : r <> 0%R).
  intro Hf ; rewrite Hf, Rabs_R0 in Rabsr_pos ; elim (Rlt_irrefl _ Rabsr_pos).
 rewrite <- Cpow_inv.
 rewrite <- Cmult_assoc.
 field ; split.
 auto with complex.
 apply Cpow_neq_compat ; auto with complex.
  auto with complex.
 auto with complex.
 apply Rle_trans with (Cnorm (/ r' * (INC (S i) * (r' / r) ^ S i)) * B)%R.
 rewrite Cmult_assoc, Cnorm_Cmult ; apply Rmult_le_compat_l ;
 [apply Cnorm_pos |] ; apply HB ; exists (S i) ; reflexivity.
 apply Rle_trans with (1*B)%R ; [| rewrite Rmult_1_l ; apply RmaxLess1].
 apply Rmult_le_compat_r.
 apply Rle_trans with (Cnorm (An 0%nat * r ^ 0)) ; [apply Cnorm_pos |] ;
 apply HB ; exists 0%nat ; reflexivity.
 rewrite Cnorm_Cmult ; apply Rle_trans with (Cnorm (/r') * Cnorm r')%R.
 apply Rmult_le_compat_l.
 apply Cnorm_pos.
 apply Rle_trans with (Cnorm ((INC (S i) * (r' / r) ^ S i) - 0)).
 right ; rewrite Cminus_0_r ; reflexivity.
 apply Rle_trans with (R_dist (INR (S i) * (r' / r) ^ S i) 0)%R.
 right ; unfold R_dist ; rewrite <- Cnorm_IRC_Rabs ; apply Cnorm_eq_compat.
 rewrite Cminus_IRC_Rminus ; unfold Rminus ; apply Cadd_eq_compat_r.
 rewrite Cmult_IRC_Rmult, IRC_INR_INC ; apply Cmult_eq_compat_l.
 rewrite <- IRC_pow_compat, Cdiv_IRC_Rdiv.
 reflexivity.
  intro Hf ; rewrite Hf, Rabs_R0 in Rabsr_pos ; elim (Rlt_irrefl _ Rabsr_pos).
  rewrite Cnorm_IRC_Rabs ; left ; apply HN ; intuition.
 rewrite <- Cnorm_Cmult ; rewrite Cinv_l ; [| auto with complex] ; rewrite Cnorm_C1 ; right ; trivial.
Qed.

(** Derivability of partial sums *)

Definition Cpser_partial_sum_derive An n x := match n with
     | 0%nat => C0
     | S _      => sum_f_C0 (gt_pser (An_deriv An) x) (pred n)
end.

Lemma Cpser_derive_finite_sum : forall An n x,
       derivable_pt_lim (fun x => sum_f_C0 (gt_pser An x) n) x (Cpser_partial_sum_derive An n x).
Proof.
intros An n x ;
 unfold Cpser_partial_sum_derive, gt_pser, An_deriv ;
 apply (derivable_pt_lim_partial_sum An x n).
Qed.

(** * Sum of the formal derivative *)

Definition weaksum_r_derive : forall (An : nat -> C) (r : R) (Rho : Cv_radius_weak An r) (z : C), C.
Proof.
intros An r Rho z ; case (Rlt_le_dec (Cnorm z) r) ; intro z_bd.
 pose (r' := middle (Cnorm z)  (Rabs r)).
 assert (r_pos : Rabs r = r).
  apply Rabs_right ; left ; apply Rle_lt_trans with (Cnorm z) ;
  [apply Cnorm_pos | assumption].
 assert (r'_bd : Rabs r' < Rabs r).
  assert (H := proj2 (middle_is_in_the_middle _ _ z_bd)).
  rewrite <- r_pos in H.
  apply Rle_lt_trans with r'.
  right ; apply Rabs_right ; apply Rle_ge ; apply Rle_trans with (Cnorm z) ;
  rewrite <- r_pos in z_bd ;  [apply Cnorm_pos | left ;
  apply (proj1 (middle_is_in_the_middle _ _ z_bd))].
  apply H.
 apply (weaksum_r (An_deriv An) r'
      (Cv_radius_weak_derivable_compat An r Rho r' r'_bd) z).
apply C0.
Defined.

Definition sum_r_derive : forall (An : nat -> C) (r : R) (Rho : finite_cv_radius An r) (z : C), C.
Proof.
intros An r Rho z.
 destruct (Rlt_le_dec (Cnorm z) r) as [z_bd | z_gt].
 assert (H : 0 <= middle (Cnorm z) r < r).
  split.
  left ; apply middle_le_lt_pos_lt ; [| apply Rle_lt_trans with (Cnorm z) ; [| assumption]] ;
  apply Cnorm_pos.
  apply (middle_is_in_the_middle _ _ z_bd).
 apply (weaksum_r_derive _ _ (proj1 Rho (middle (Cnorm z) r) H) z).
 apply C0.
Defined.

Definition sum_derive : forall (An : nat -> C) (Rho : infinite_cv_radius An) (z : C), C.
Proof.
 intros An Rho z ; apply (weaksum_r_derive _ _ (Rho (Cnorm z + 1)%R) z).
Defined.

(** Proof that it is really the sum *)

Lemma weaksum_r_derive_sums : forall (An : nat -> C) (r : R) (Pr : Cv_radius_weak An r) (z : C),
      Cnorm z < r -> Cpser (An_deriv An) z (weaksum_r_derive An r Pr z).
Proof.
intros An r Pr z z_bd.
 unfold weaksum_r_derive ; case (Rlt_le_dec (Cnorm z) r) ; intro s.
 rewrite <- Rabs_right in z_bd.
 apply weaksum_r_sums ; apply (proj1 (middle_is_in_the_middle _ _ z_bd)).
 apply Rle_ge ; apply Rle_trans with (Cnorm z) ; [apply Cnorm_pos | left ; assumption].
 assert (H : Cnorm z < Cnorm z) by (apply Rlt_le_trans with r ; assumption) ;
 elim (Rlt_irrefl _ H).
Qed.

Lemma sum_r_derive_sums : forall (An : nat -> C) (r : R) (Pr : finite_cv_radius An r) (z : C),
      Cnorm z < r -> Cpser (An_deriv An) z (sum_r_derive An r Pr z).
Proof.
intros An r Pr z z_bd ; unfold sum_r_derive ;
 destruct (Rlt_le_dec (Cnorm z) r) as [z_bd2 | Hf].
 apply weaksum_r_derive_sums ; apply (middle_is_in_the_middle _ _ z_bd).
 assert (F : r < r) by (apply Rle_lt_trans with (Cnorm z) ; assumption) ;
 destruct (Rlt_irrefl _ F).
Qed.

Lemma sum_derive_sums : forall (An : nat -> C) (Pr : infinite_cv_radius An) (z : C),
      Cpser (An_deriv An) z (sum_derive An Pr z).
Proof.
intros An Pr z ; unfold sum_derive ; apply weaksum_r_derive_sums ; intuition.
Qed.

(** Proof that the sum is unique *)

Lemma weaksum_r_derive_unique : forall (An : nat -> C) (r : R) (Pr1 Pr2 : Cv_radius_weak An r) (z : C),
      Cnorm z < r -> weaksum_r_derive An r Pr1 z = weaksum_r_derive An r Pr2 z .
Proof.
intros An r Pr1 Pr2 z z_bd ;
 assert (T1 := weaksum_r_derive_sums _ _ Pr1 _ z_bd) ;
 assert (T2 := weaksum_r_derive_sums _ _ Pr2 _ z_bd).
 eapply Pser_unique ; eassumption.
Qed.

Lemma sum_r_derive_unique : forall (An : nat -> C) (r : R) (Pr1 Pr2 : finite_cv_radius An r) (z : C),
      Cnorm z < r -> sum_r_derive An r Pr1 z = sum_r_derive An r Pr2 z .
Proof.
intros An r Pr1 Pr2 z z_bd ;
 assert (T1 := sum_r_derive_sums _ _ Pr1 _ z_bd) ;
 assert (T2 := sum_r_derive_sums _ _ Pr2 _ z_bd).
 eapply Pser_unique ; eassumption.
Qed.

Lemma sum_derive_unique : forall (An : nat -> C) (Pr1 Pr2 : infinite_cv_radius An) (z : C),
      sum_derive An Pr1 z = sum_derive An Pr2 z .
Proof.
intros An Pr1 Pr2 z ;
 assert (T1 := sum_derive_sums _ Pr1 z) ;
 assert (T2 := sum_derive_sums _ Pr2 z).
 eapply Pser_unique ; eassumption.
Qed.

(** * Derivability of a power serie within its disc of convergence *)

Lemma derivable_pt_lim_weaksum_r : forall (An:nat->C) (r:R) (Pr : Cv_radius_weak An r) z,
      Cnorm z < r -> derivable_pt_lim (weaksum_r An r Pr) z (weaksum_r_derive An r Pr z).
Proof.
intros An r rho z z_bd.
 assert (r_pos : 0 < r) by (apply Rle_lt_trans with (Cnorm z) ; [apply Cnorm_pos | assumption]).
 pose (midd := middle (Cnorm z) r) ; assert (midd_pos : 0 < midd).
  unfold midd ; apply middle_le_lt_pos_lt ; [apply Cnorm_pos | assumption].
 pose (r' := mkposreal midd midd_pos).
 assert (z_bd' : Cnorm z < midd).
  apply (middle_is_in_the_middle _ _ z_bd).
 assert (r'_ub : r' < r).
  apply (proj2 (middle_is_in_the_middle _ _ z_bd)).

 pose (fn := fun N z => sum_f_C0 (gt_pser An z) N) ;
 pose (fn' := fun N z => Cpser_partial_sum_derive An N z) ;
 pose (f := weaksum_r An r rho) ;
 pose (g := weaksum_r_derive An r rho).

 assert (z_in : Boule 0 r' z).
  unfold Boule ; simpl ; unfold C_dist ; rewrite Cnorm_minus_sym,
   Cminus_0_r ; assumption.

 assert (fn_deriv : forall (x : C) (n : nat), Boule 0 r' x -> derivable_pt_lim (fn n) x (fn' n x)).
  intros ; apply Cpser_derive_finite_sum.

 assert (fn_cv : CFseq_cv_boule fn f 0 r').
  intros a a_in.
   assert (a_bd : Cnorm a < r).
    unfold Boule in a_in ; simpl in a_in ; unfold C_dist in a_in ;
    rewrite Cnorm_minus_sym, Cminus_0_r in a_in.
    apply Rlt_trans with midd ; assumption.
  assert (H := weaksum_r_sums An r rho a a_bd).
  intros eps eps_pos ; destruct (H eps eps_pos) as [N HN] ; exists N ;
  intros n n_lb ; unfold fn, f ; simpl in HN ; unfold C_dist in HN.
  apply HN ; assumption.

assert (cv : forall z : C, Boule 0 r' z ->  {l : C |  Cseq_cv (fun N : nat =>
                    CFpartial_sum (fun n : nat => (fun (n0 : nat) (z0 : C) =>
                        gt_pser (An_deriv An) z0 n0) n z) N) l}).
  intros a a_in.
   exists (weaksum_r_derive An r rho a).
   apply Pser_Cseqcv_link ; apply weaksum_r_derive_sums.
   apply Rlt_trans with r' ; [unfold Boule in a_in ; simpl in a_in ; unfold C_dist in a_in ;
   rewrite Cminus_0_l, Cnorm_opp in a_in ; apply a_in | assumption].

  assert (r''_comp : Rabs (middle r' r) < Rabs r).
  rewrite Rabs_right ; [rewrite Rabs_right |].
  apply (proj2 (middle_is_in_the_middle _ _ r'_ub)).
  left ; assumption.
  left ; apply middle_le_lt_pos_lt.
  left ; unfold r' ; apply middle_le_lt_pos_lt ; [apply Cnorm_pos | assumption].
  assumption.

  assert (rho_An' := Cv_radius_weak_derivable_compat An r rho (middle r' r) r''_comp).
  assert (cvn_r : CVN_r (fun (n : nat) (z : C) => gt_pser (An_deriv An) z n) r').
   apply Cpser_abel2 with (middle r' r).
   assumption.
   apply (proj1 (middle_is_in_the_middle _ _  r'_ub)).
 assert (fn'_cvu := CVN_CVU_boule (fun n z => gt_pser (An_deriv An) z n) r' cv cvn_r).
 assert (fn'_cvu2 : CFseq_cvu fn' g 0 r').
 unfold fn', g.
 intros eps eps_pos ; destruct (fn'_cvu _ eps_pos) as [N HN] ; exists (S N) ;
 clear fn'_cvu fn_deriv rho_An' ; intros n y n_lb y_bd.
 assert (H : n = S (pred n)) by intuition ; rewrite H ; clear H ; simpl.
 unfold CFseq_cvu, SFL_interv, CFpartial_sum in HN.
 assert (predn_lb : (N <= pred n)%nat) by intuition.
 assert (Temp := HN (pred n) y predn_lb y_bd).
 destruct (Rlt_le_dec (Cnorm (0 - y)) r') as [H | Hf].
 destruct (cv y H) as [l Hl].
 assert (Hrew : l = weaksum_r_derive An r rho y).
  eapply Cseq_cv_unique ; [apply Hl |] ;
  apply Pser_Cseqcv_link ; apply weaksum_r_derive_sums.
  apply Rlt_trans with r' ; [rewrite Cminus_0_l, Cnorm_opp in H |] ;
  assumption.
  rewrite <- Hrew ; assumption.
  clear - y_bd Hf ; assert (Hf2 : Cnorm (0 - y) < Cnorm (0 - y)) by
  (apply Rlt_le_trans with r' ; assumption) ; elim (Rlt_irrefl _ Hf2).

 assert (g_cont : (forall x : C, Boule 0 r' x -> continuity_pt g x)).
  intros a a_in ; apply CVU_continuity_boule with fn' C0 r'.
  apply fn'_cvu2.
  intros N y y_in ; unfold fn'.
  unfold Cpser_partial_sum_derive ; induction N.
  apply continuity_pt_const ; unfold constant ; intros ; trivial.
  destruct N ; simpl ; [unfold gt_pser, An_deriv |].
  intros eps eps_pos ; exists R1 ; split ; [apply Rlt_0_1 |] ; intros x [_ Hx] ;
  simpl ; unfold C_dist ; repeat rewrite Cpow_0.
  unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ; assumption.
  apply continuity_pt_add ; [assumption |].
  unfold gt_pser.
  apply continuity_pt_mult.
  apply continuity_pt_const.
  intros r1 r2 ; unfold An_deriv ; reflexivity.
  apply derivable_continuous ; apply derivable_Cpow.
  assumption.

 exact (CFseq_cvu_derivable fn fn' f g z 0 r' z_in fn_deriv fn_cv fn'_cvu2 g_cont).
Qed.

Lemma derivable_pt_lim_sum_r : forall (An:nat->C) (r:R) (Pr : finite_cv_radius An r) z,
      Cnorm z < r -> derivable_pt_lim (sum_r An r Pr) z (sum_r_derive An r Pr z).
Proof.
intros An r Pr z z_bd eps eps_pos.
 assert (H : 0 <= middle (Cnorm z) r < r).
  split.
  left ; apply middle_le_lt_pos_lt ; [| apply Rle_lt_trans with (Cnorm z) ; [| assumption]] ;
  apply Cnorm_pos.
  apply (middle_is_in_the_middle _ _ z_bd).
 destruct (derivable_pt_lim_weaksum_r _ _ (proj1 Pr (middle (Cnorm z) r) H) _
 (proj1 (middle_is_in_the_middle _ _ z_bd)) _ eps_pos) as [delta Hdelta].
 pose (delta' := Rmin delta (((middle (Cnorm z) r) - Cnorm z) / 2)%R) ;
 assert (delta'_pos : 0 < delta').
  apply Rmin_pos.
   apply delta.
   apply ub_lt_2_pos with (middle (Cnorm z) (middle (Cnorm z) r)) ;
   apply (middle_is_in_the_middle _ _ (proj1 (middle_is_in_the_middle _ _ z_bd))).
  exists (mkposreal delta' delta'_pos) ; intros h h_neq h_bd.

 replace (sum_r An r Pr (z + h)) with (weaksum_r An (middle (Cnorm z) r)
               (proj1 Pr (middle (Cnorm z) r) H) (z + h)).
 replace (sum_r An r Pr z) with (weaksum_r An (middle (Cnorm z) r)
               (proj1 Pr (middle (Cnorm z) r) H) z).
 replace (sum_r_derive An r Pr z) with (weaksum_r_derive An (middle (Cnorm z) r)
              (proj1 Pr (middle (Cnorm z) r) H) z).
 apply Hdelta ; [assumption | apply Rlt_le_trans with delta'] ;
 [assumption | apply Rmin_l].

 unfold sum_r_derive ; destruct (Rlt_le_dec (Cnorm z) r) as [z_bd2 | Hf].
 apply weaksum_r_derive_unique ; apply (middle_is_in_the_middle _ _ z_bd).
 assert (F : r < r) by (apply Rle_lt_trans with (Cnorm z) ; assumption) ;
 destruct (Rlt_irrefl _ F).

 unfold sum_r ; destruct (Rlt_le_dec (Cnorm z) r) as [z_bd2 | Hf].
 apply weaksum_r_unique ; apply (middle_is_in_the_middle _ _ z_bd).
 assert (F : r < r) by (apply Rle_lt_trans with (Cnorm z) ; assumption) ;
 destruct (Rlt_irrefl _ F).

 unfold sum_r ; destruct (Rlt_le_dec (Cnorm (z + h)) r) as [z_bd2 | Hf].
 apply weaksum_r_unique_strong.
 apply Rle_lt_trans with (Cnorm z + Cnorm h)%R.
 apply Cnorm_triang.
 apply Rlt_le_trans with (Cnorm z + ((middle (Cnorm z) r - Cnorm z) / 2))%R.
 apply Rplus_lt_compat_l ; apply Rlt_le_trans with delta' ; [assumption | apply Rmin_r].
 unfold Rminus ; field_simplify ; unfold Rdiv ; try (rewrite Rinv_1, Rmult_1_r).
 left ; do 2 eapply middle_is_in_the_middle ; assumption.
 eapply middle_is_in_the_middle ; assumption.
 assert (F : r < r).
  apply Rlt_trans with (middle (Cnorm z) r).
  apply Rle_lt_trans with (Cnorm (z + h)).
  assumption.
  apply Rle_lt_trans with (Cnorm z + Cnorm h)%R.
  apply Cnorm_triang.
  apply Rlt_trans with (Cnorm z + ((middle (Cnorm z) r - Cnorm z) / 2))%R.
  apply Rplus_lt_compat_l ; apply Rlt_le_trans with delta' ; [intuition | apply Rmin_r].
  unfold middle ; field_simplify.
  apply Rlt_le_trans with ((2 * Cnorm z + r + r) / 4)%R.
  unfold Rdiv ; apply Rmult_lt_compat_r ; [lra |].
  apply Rplus_lt_compat_r.
  apply Rle_lt_trans with (2 * Cnorm z + Cnorm z)%R.
  right ; ring.
  apply Rplus_lt_compat_l ; assumption.
  right ; field.
  eapply middle_is_in_the_middle ; assumption.
  destruct (Rlt_irrefl _ F).
Qed.

Lemma derivable_pt_lim_sum : forall (An:nat->C) (Pr : infinite_cv_radius An) z,
      derivable_pt_lim (sum An Pr) z (sum_derive An Pr z).
Proof.
intros An Pr z eps eps_pos.
 assert (H : 0 <= Cnorm z < Cnorm z + 1).
  split ; [apply Cnorm_pos |] ; intuition.
 destruct (derivable_pt_lim_weaksum_r _ _ (Pr (Cnorm z + 1)%R) z (proj2 H) _ eps_pos) as [delta Hdelta].

 pose (delta' := Rmin delta 1) ; assert (delta'_pos : 0 < delta').
  apply Rmin_pos ; [apply delta | apply Rlt_0_1].
 exists (mkposreal _ delta'_pos) ; intros h h_neq h_bd.

 replace (sum An Pr (z + h)) with (weaksum_r An (Cnorm z + 1) (Pr (Cnorm z + 1)%R) (z + h)).
 apply Hdelta.
 assumption.
 apply Rlt_le_trans with delta' ; [assumption | apply Rmin_l].

 unfold sum.
 apply weaksum_r_unique_strong.
 apply Rle_lt_trans with (Cnorm z + Cnorm h)%R.
 apply Cnorm_triang.
 apply Rplus_lt_compat_l ; apply Rlt_le_trans with delta' ;
 [intuition | apply Rmin_r].
 intuition.
Qed.