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


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** This module defines grouping by the domain of an association list
    and the derived equivalence relation, grouped_equiv.
    This equivalence allows elements with different keys to
    be freely rearranged.
 *)

Require Import List.
Require Import ListSet.
Require Import Bool.
Require Import Permutation.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Equivalence.
Require Import RelationClasses.
Require Import Lia.
Require Import CoqLibAdd.
Require Import Lift.
Require Import ListAdd.
Require Import Assoc.
Require Import Sublist.
Require Import Bag.

Section groupbydomain.

  (* There may be some relation here to groupby *)
  Fixpoint groupby_domain {A B} {dec: EqDec A eq} (l:list (A*B)): list (A*list B)
    := match l with
       | nil => nil
       | (a,b)::l' =>
         let rest := groupby_domain l' in
         match lookup dec rest a with
         | Some bs => update_first dec rest a (b::bs)
         | None => (a, (b::nil))::rest
         end
       end.

  Definition grouped_equiv {A B} {dec:EqDec A eq} (l1 l2 :list (A*B))
    := Permutation (groupby_domain l1) (groupby_domain l2).

  Definition list_unnest {A B} (l:list (A*list B)) : list (list (A*B))
    := map (fun x => map (fun y => (fst x, y)) (snd x)) l.

  Global Instance grouped_equiv_equiv {A B} {dec:EqDec A eq} : Equivalence (@grouped_equiv A B dec).
  Proof.
    unfold grouped_equiv.
    constructor; red; intros.
    - reflexivity.
    - symmetry; trivial.
    - etransitivity; eauto.
  Qed.

  Lemma groupby_domain_concat_list_unest_perm {A B} {dec: EqDec A eq} (l:list (A*B))
    : Permutation (concat (list_unnest (groupby_domain l))) l.
  Proof.
    induction l; simpl; trivial.
    destruct a.
    case_eq (lookup dec (groupby_domain l) a); simpl; intros.
    - destruct (in_update_break dec H (b::l0))
        as [l1 [l2 [eqq1 eqq2]]].
      rewrite eqq2.
      unfold list_unnest in *.
      rewrite eqq1 in *.
      rewrite map_app, concat_app in *.
      simpl in *.
      rewrite <- IHl.
      repeat rewrite Permutation_middle.
      reflexivity.
    - constructor; trivial.
  Qed.

  Global Instance grouped_equiv_perm {A B} {dec: EqDec A eq} :
    subrelation (@grouped_equiv A B dec) (@Permutation (A*B)).
  Proof.
    unfold grouped_equiv; intros l1 l2 perm.
    rewrite <- (groupby_domain_concat_list_unest_perm l1).
    rewrite <- (groupby_domain_concat_list_unest_perm l2).
    apply Permutation_concat.
    apply Permutation_map.
    trivial.
  Qed.

  Lemma groupby_domain_NoDup {A B} {dec: EqDec A eq} (l:list (A*B)) :
    NoDup (domain (groupby_domain l)).
  Proof.
    induction l; simpl.
    - constructor.
    - destruct a.
      match_option.
      + rewrite domain_update_first; trivial.
      + simpl; constructor; trivial.
        apply lookup_none_nin in eqq; trivial.
  Qed.

  Lemma groupby_domain_nnil {A B} {dec: EqDec A eq} (l:list (A*B)) :
    ~ In nil (codomain (groupby_domain l)).
  Proof.
    induction l; simpl.
    - tauto.
    - destruct a.
      match_option; simpl.
      + destruct (in_update_break dec eqq (b::l0))
          as [m1 [m2 [meqq mueqq]]].
        rewrite mueqq; simpl.
        rewrite meqq in IHl.
        rewrite codomain_app, in_app_iff in IHl |- *; simpl in *.
        intuition discriminate.
      + intuition discriminate.
  Qed.

  Lemma groupby_domain_concat_list_unest_equiv {A B} {dec: EqDec A eq} (l:list (A*B))
    : lookup_equiv (concat (list_unnest (groupby_domain l))) l.
  Proof.
    unfold lookup_equiv.
    induction l; simpl; trivial.
    destruct a.
    intros x.
    case_eq (lookup dec (groupby_domain l) a); simpl; intros.
    - generalize (groupby_domain_nnil l); intros nn.
      destruct (in_update_break_first dec H (b::l0))
        as [l1 [l2 [eqq1 [eqq2 nin]]]].
      rewrite eqq2.
      unfold list_unnest in *.
      rewrite eqq1 in *.
      rewrite map_app, concat_app in *.
      simpl in *.
      rewrite <- IHl.
      repeat (rewrite lookup_app; simpl).
      destruct (dec x a); unfold equiv, complement in *; trivial.
      subst.
      match_option.
      apply lookup_in in eqq.
      apply concat_In in eqq.
      destruct eqq as [? [inn1 inn2]].
      apply in_map_iff in inn1.
      destruct inn1 as [? [? inn1]]; subst.
      apply in_map_iff in inn2.
      destruct inn2 as [? [eqq inn2]].
      invcs eqq.
      destruct x0; apply in_dom in inn1.
      contradiction.
    - rewrite IHl; trivial.
  Qed.

  Lemma grouped_equiv_cons {A B} {dec: EqDec A eq} {l1 l2:list (A*B)} :
    grouped_equiv l1 l2 ->
    forall a, grouped_equiv (a::l1) (a::l2).
  Proof.
    unfold grouped_equiv; simpl; intros eqq1 a.
    destruct a.
    rewrite (lookup_equiv_perm_nodup (groupby_domain_NoDup l1) eqq1 a).
    match_option.
    - apply update_first_NoDup_perm_proper; trivial.
      apply (groupby_domain_NoDup l1).
    - eauto.
  Qed.

  Lemma grouped_equiv_cons_invs {A B} {dec: EqDec A eq} {a b b'} {l1 l2:list (A*B)} :
    grouped_equiv ((a,b)::l1) ((a,b')::l2) ->
    b = b' /\ grouped_equiv l1 l2.
  Proof.
    unfold grouped_equiv; simpl; intros eqq1.
    repeat match_option_in eqq1; try discriminate.
    - destruct (update_first_NoDup_perm_invs
                  (fun x => b::x) (fun y => b'::y)
                  (groupby_domain_NoDup l1) eqq1 eqq eqq0)
        as [perm2 [eqq21 eqq22]].
      + intros ? ? injeq.
        invcs injeq; trivial.
      + invcs eqq22; tauto.
    - destruct (in_update_break dec eqq (b::l))
        as [m1 [m2 [meqq mueqq]]].
      rewrite mueqq in eqq1.
      rewrite <- Permutation_middle in eqq1.
      assert (inn:In (a, b::l) ((a, b::l) :: m1 ++ m2)).
      { simpl; eauto. }
      rewrite eqq1 in inn.
      simpl in inn.
      destruct inn.
      + invcs H.
        elim (groupby_domain_nnil l1); trivial.
        rewrite meqq.
        rewrite codomain_app, in_app_iff; simpl; tauto.
      + apply in_dom in H; apply lookup_none_nin in eqq0.
        contradiction.
    - destruct (in_update_break dec eqq0 (b'::l))
        as [m1 [m2 [meqq mueqq]]].
      rewrite mueqq in eqq1.
      rewrite <- Permutation_middle in eqq1.
      assert (inn:In (a, b'::l) ((a, b'::l) :: m1 ++ m2)).
      { simpl; eauto. }
      rewrite <- eqq1 in inn.
      simpl in inn.
      destruct inn.
      + invcs H.
        elim (groupby_domain_nnil l2); trivial.
        rewrite meqq.
        rewrite codomain_app, in_app_iff; simpl; tauto.
      + apply in_dom in H; apply lookup_none_nin in eqq.
        contradiction.
    - assert (lo1:lookup dec ((a, (b::nil)) :: groupby_domain l1) a = Some (b::nil)).
      { simpl; match_destr; congruence. }
      assert (nd:NoDup (domain ((a, (b::nil)) :: groupby_domain l1))).
      { simpl; constructor.
        - apply lookup_none_nin in eqq; trivial.
        - apply groupby_domain_NoDup.
      }
      rewrite (lookup_equiv_perm_nodup nd eqq1 a) in lo1.
      simpl in lo1.
      match_destr_in lo1; [| congruence].
      invcs lo1.
      apply Permutation_cons_inv in eqq1.
      tauto.
  Qed.

  Lemma concat_list_unnest_lookup_none {A B} {dec:EqDec A eq} {l1:list (A*list B)} {a} :
    lookup dec l1 a = None ->
    lookup dec (concat (list_unnest l1)) a = None.
  Proof.
    intros lo.
    apply lookup_none_nin in lo.
    apply lookup_nin_none.
    unfold list_unnest, domain.
    rewrite concat_map.
    intros inn.
    apply concat_In in inn.
    destruct inn as [? [inn1 inn2]].
    rewrite map_map in inn1.
    apply in_map_iff in inn1.
    destruct inn1 as [? [? inn1]]; subst.
    rewrite map_map in inn2; simpl in inn2.
    apply in_map_iff in inn2.
    destruct inn2 as [? [? inn2]]; subst.
    destruct x0; apply in_dom in inn1.
    contradiction.
  Qed.

  Lemma concat_list_unnest_lookup_some {A B} {dec:EqDec A eq} {l1:list (A*list B)} {a b l'} :
    lookup dec l1 a = Some (b::l') ->
    lookup dec (concat (list_unnest l1)) a = Some b.
  Proof.
    intros lo.
    destruct (lookup_split dec lo) as [m1 [m2 [? nin]]]; subst.
    unfold list_unnest.
    rewrite map_app, concat_app, lookup_app; simpl.
    match_option.
    - apply lookup_in in eqq.
      apply concat_In in eqq.
      destruct eqq as [? [inn1 inn2]].
      apply in_map_iff in inn1.
      destruct inn1 as [? [? inn1]]; subst.
      apply in_map_iff in inn2.
      destruct inn2 as [? [eqq inn2]].
      invcs eqq.
      destruct x0; apply in_dom in inn1.
      contradiction.
    - match_destr.
      congruence.
  Qed.

  Lemma concat_list_unnest_lookup_equiv {A B} {dec:EqDec A eq} (l1 l2:list (A*list B)) :
    ~ In nil (codomain l1) ->
    lookup_equiv l1 l2 ->
    lookup_equiv (concat (list_unnest l1)) (concat (list_unnest l2)).
  Proof.
    intros nnil lo a.
    specialize (lo a).
    case_eq (lookup dec l1 a); [intros ? eqq1 | intros eqq1]
    ; rewrite eqq1 in *.
    - destruct l.
      + apply lookup_in in eqq1.
        apply in_codom in eqq1.
        contradiction.
      + rewrite (concat_list_unnest_lookup_some eqq1).
        rewrite (concat_list_unnest_lookup_some (symmetry lo)).
        trivial.
    - rewrite (concat_list_unnest_lookup_none eqq1).
      rewrite (concat_list_unnest_lookup_none (symmetry lo)).
      trivial.
  Qed.

  Global Instance grouped_equiv_lookup_equiv {A B} {dec:EqDec A eq} :
    subrelation (@grouped_equiv A B dec) lookup_equiv.
  Proof.
    intros l1 l2.
    unfold grouped_equiv.
    intros perm.
    apply lookup_equiv_perm_nodup in perm.
    - rewrite <- (groupby_domain_concat_list_unest_equiv l1).
      rewrite <- (groupby_domain_concat_list_unest_equiv l2).
      apply concat_list_unnest_lookup_equiv; trivial.
      apply groupby_domain_nnil.
    - apply groupby_domain_NoDup.
  Qed.

  Lemma groupby_domain_equivlist {A B} {dec:EqDec A eq} (l:list (A*B)):
    equivlist (domain (groupby_domain l)) (domain l).
  Proof.
    unfold equivlist.
    induction l; simpl; [tauto | ].
    destruct a; simpl.
    intros x.
    match_option.
    - rewrite domain_update_first.
      rewrite IHl.
      apply lookup_in_domain in eqq.
      rewrite IHl in eqq.
      intuition; congruence.
    - simpl; rewrite IHl; tauto.
  Qed.

  Lemma groupby_domain_update_first_some {A B} {dec:EqDec A eq} {l:list (A*B)} {v b l'} :
    lookup dec (groupby_domain l) v = Some (b::l') ->
    forall d,
      groupby_domain (update_first dec l v d) = update_first dec (groupby_domain l) v (d::l').
  Proof.
    revert b l'.
    induction l; intros b l' inn d; simpl; try discriminate.
    destruct a; simpl in inn.
    destruct (dec v a); unfold equiv, complement in *
    ; subst; simpl.
    - match_option
      ; rewrite eqq in inn.
      + apply lookup_update_eq in inn.
        invcs inn.
        rewrite update_first_update_first_eq; trivial.
      + simpl in *.
        match_destr; try congruence.
    - match_option_in inn.
      + generalize (@lookup_update_neq _ _ dec (groupby_domain l) a v (b0::l0)).
        unfold equiv_dec; intros re; rewrite re in inn by congruence; clear re.
        rewrite update_first_update_first_neq_swap by congruence.
        rewrite (IHl _ _ inn).
        generalize (@lookup_update_neq _ _ dec (groupby_domain l) v a (d::l')).
        unfold equiv_dec; intros re; rewrite re by congruence; clear re.
        rewrite eqq; trivial.
      + simpl in inn.
        match_destr_in inn; try congruence.
        rewrite (IHl _ _ inn).
        simpl.
        destruct (dec v a); try congruence.
        generalize (@lookup_update_neq _ _ dec (groupby_domain l) v a (d::l')).
        unfold equiv_dec; intros re; rewrite re by congruence; clear re.
        rewrite eqq; trivial.
  Qed.

  Lemma grouped_equiv_update_first {A B} {dec:EqDec A eq} (l1 l2:list (A*B)) v d :
    grouped_equiv l1 l2 ->
    grouped_equiv (update_first dec l1 v d) (update_first dec l2 v d).
  Proof.
    unfold grouped_equiv; intros.
    case_eq (lookup dec (groupby_domain l1) v); [intros ? inn1|intros eqq1].
    - destruct l.
      + elim (groupby_domain_nnil l1).
        apply lookup_in in inn1.
        apply in_codom in inn1; trivial.
      + generalize H; intros perm.
        apply lookup_equiv_perm_nodup in perm; [ | apply groupby_domain_NoDup].
        rewrite (groupby_domain_update_first_some inn1).
        rewrite perm in inn1.
        rewrite (groupby_domain_update_first_some inn1).
        apply update_first_NoDup_perm_proper; trivial.
        apply groupby_domain_NoDup.
    - repeat rewrite nin_update; trivial.
      + apply lookup_none_nin in eqq1.
        rewrite (dom_perm _ _ H) in eqq1.
        apply (lookup_nin_none dec) in eqq1.
        generalize (concat_list_unnest_lookup_none eqq1); intros inn1.
        rewrite groupby_domain_concat_list_unest_equiv in inn1; trivial.
      + generalize (concat_list_unnest_lookup_none eqq1); intros inn1.
        rewrite groupby_domain_concat_list_unest_equiv in inn1; trivial.
  Qed.

  Lemma grouped_equiv_singleton {A B} {dec:EqDec A eq} a (l:list (A*B)) :
    grouped_equiv (a::nil) l -> l = a::nil.
  Proof.
    destruct a.
    unfold grouped_equiv; simpl; intros ge.
    apply Permutation_length_1_inv in ge.
    generalize (groupby_domain_concat_list_unest_perm l).
    rewrite ge; simpl; intros perm.
    apply Permutation_length_1_inv in perm.
    trivial.
  Qed.

  Lemma groupby_domain_lookup_app_nin {A B} {dec:EqDec A eq} (l1 l2 l3 : list (A*B)) x :
    ~ In x (domain l2) ->
    lookup dec (groupby_domain (l1++l2++l3)) x =
    lookup dec (groupby_domain (l1++l3)) x.
  Proof.
    induction l2; simpl; trivial.
    intros nin.
    apply notand in nin.
    destruct nin.
    destruct a; simpl in *.
    rewrite <- (IHl2 H0).
    clear IHl2 H0.
    generalize (l2++l3); clear l2 l3; intros l2.
    induction l1; simpl in *.
    - match_option.
      + replace dec with (@equiv_dec _ _ _ dec) in * by trivial.
        rewrite lookup_update_neq; tauto.
      + simpl.
        match_destr; try congruence.
    - destruct a0; simpl in *.
      destruct (dec a0 x); unfold equiv, complement in *.
      + subst.
        rewrite IHl1.
        match_option; simpl.
        * replace dec with (@equiv_dec _ _ _ dec) in * by trivial.
          { repeat rewrite lookup_update_eq_in; trivial.
            - apply lookup_in_domain in eqq; trivial.
            - apply lookup_in_domain in eqq.
              rewrite groupby_domain_equivlist in *.
              rewrite domain_app, in_app_iff in *; simpl; tauto.
          }
        * match_destr.
      + match_option; simpl.
        * replace dec with (@equiv_dec _ _ _ dec) in * by trivial.
          rewrite lookup_update_neq by tauto.
          rewrite IHl1.
          { match_option.
            - repeat rewrite lookup_update_neq by tauto.
              trivial.
            - simpl.
              match_destr; congruence.
          }
        * destruct (dec x a0); try congruence.
          rewrite IHl1.
          { match_option.
            - replace dec with (@equiv_dec _ _ _ dec) in * by trivial.
              rewrite lookup_update_neq by tauto.
              trivial.
            -  simpl.
               match_destr; congruence.
          }
  Qed.

End groupbydomain.