Require Import List String.
Require Import ExtLib.Structures.CoMonad.

Set Implicit Arguments.
Set Strict Implicit.

Inductive type : Type :=
| Self : type
| Inj : Type -> type.

Definition product := list type.
Definition variant := list product.

Section denote.
  Variable M : Type.

  Definition typeD (t : type) : Type :=
    match t with
      | Self => M
      | Inj t => t
    end.

  Definition func (T : Type) (v : product) : Type :=
    fold_right (fun x acc => typeD x -> acc) T v.

  Definition data (v : product) : Type :=
    fold_right (fun x acc => typeD x * acc)%type unit v.

  Definition matchD (T : Type) (v : variant) : Type :=
    fold_right (fun x acc => func T x -> acc)%type T v.

  Definition dataD (v : variant) : Type :=
    fold_right (fun x acc => data x + acc)%type Empty_set v.

  Definition recD (T : Type) (c : Type -> Type) (v : variant) : Type :=
    fold_right (fun x acc =>
      fold_right (fun x acc =>
        match x with
          | Inj t => t
          | Self => c T
        end -> acc) (c T) x -> acc) (M -> T) v.

End denote.

Class Data (T : Type) : Type :=
{ repr  : variant
; into  : dataD T repr -> T
; outof : T -> forall A, matchD T A repr
; rec   : forall c {_ : CoMonad c}, forall A, recD T A c repr
}.

Local Open Scope string_scope.

Global Instance Data_nat : Data nat :=
{ repr := nil :: (Self :: nil) :: nil
; outof := fun x _ z s =>
  match x with
    | 0 => z
    | S n => s n
  end
; into := fun d =>
  match d with
    | inl tt => 0
    | inr (inl (n, tt)) => n
    | inr (inr x) => match x with end
  end
; rec := fun c _ A z s d =>
  extract ((fix recur (d : nat) {struct d} : c A :=
    match d with
      | 0 => z
      | S n => s (recur n)
    end) d)
}.

Global Instance Data_list {A} : Data (list A) :=
{ repr := (nil) :: (Inj A :: Self :: nil) :: nil
; outof := fun x _ n c =>
  match x with
    | nil => n
    | x :: xs => c x xs
  end
; into := fun d =>
  match d with
    | inl tt => nil
    | inr (inl (x, (xs, tt))) => x :: xs
    | inr (inr x) => match x with end
  end
; rec := fun c _ T n co d =>
  extract ((fix recur (ds : list A) {struct ds} : c T :=
    match ds with
      | nil => n
      | d :: ds => co d (recur ds)
    end) d)
}.

(** Example of deriving Show from Data **)
Require Import ExtLib.Programming.Show.
Require Import ExtLib.Data.Monads.IdentityMonad.
Require Import ExtLib.Structures.Monads.

Global Instance Comoand_Id : CoMonad id :=
{ extract := fun _ x => x
; extend := fun _ _ x f => x f
}.

(*
Inductive AllResolve (C : Type -> Type) : list type -> Type :=
| AllResolve_nil  : AllResolve C nil
| AllResolve_Self : forall ls, AllResolve C ls -> AllResolve C (Self :: ls)
| AllResolve_Inj  : forall t ls, C t -> AllResolve C ls -> AllResolve C (Inj t :: ls).

Existing Class AllResolve.
*)

Definition ProductResolve (C : Type -> Type) (r : product) : Type :=
  fold_right (fun t acc =>
    match t with
      | Inj t => C t * acc
      | Self => acc
    end)%type unit r.

Definition VariantResolve (C : Type -> Type) (r : variant) : Type :=
  fold_right (fun p acc => ProductResolve C p * acc)%type unit r.

Existing Class VariantResolve.
Ltac all_resolve :=
  simpl VariantResolve; simpl ProductResolve;
    repeat match goal with
             | |- unit => apply tt
             | |- (unit * _)%type => constructor; [ apply tt | ]
             | |- (_ * _)%type => constructor
             | |- _ => solve [ eauto with typeclass_instances ]
           end.

#[global]
Hint Extern 0 (ProductResolve _ _) => all_resolve : typeclass_instances.
#[global]
Hint Extern 0 (VariantResolve _ _) => all_resolve : typeclass_instances.

Definition comma_before (b : bool) (s : showM) : showM :=
  if b then
    cat (show_exact ",") s
  else
    s.

Fixpoint show_product (first : bool) (r : list type) {struct r} :
  ProductResolve Show r ->
  (showM -> showM) ->
  (fold_right
     (fun (x : type) (acc : Type) =>
      match x with
      | Self => showM
      | Inj t => t
      end -> acc) (showM) r).
refine (
     match r as r
       return
       ProductResolve Show r ->
       (showM -> showM) ->
       (fold_right
         (fun (x : type) (acc : Type) =>
           match x with
             | Self => showM
             | Inj t => t
           end -> acc) (showM) r)
       with
       | nil => fun _ f => f empty
       | Self :: rs => fun a f s =>
         @show_product false rs a (fun s' => f (cat s (comma_before first s')))
       | Inj t :: rs => fun a f x => @show_product false rs (snd a) (fun s' => f (cat ((fst a) x) (comma_before first s')))
     end); simpl in *.
Defined.

Global Instance Show_data (T : Type) (d : Data T) (AS : VariantResolve Show repr) : Show T :=
{ show :=
  (fix recur (repr : variant) : VariantResolve Show repr -> recD T showM id repr -> T -> showM :=
    match repr as repr return
      VariantResolve Show repr -> recD T showM id repr -> T -> showM
      with
      | nil => fun _ x => x
      | r :: rs => fun a k' =>
        recur rs (snd a) (k' (show_product true _ (fst a)
          (fun s' => cat (show_exact "-") (cat (show_exact "(") (cat s' (show_exact ")"))))))
    end) repr AS (rec (c := id) showM)
}.

Eval compute in
  to_string (M := Show_data _ _) (5 :: 6 :: 7 :: nil).


(** Adapted from "Elements of Set Theory" Chapter 6 **)
(** Coq coding by choukh, Oct 2020 **)

Require Import ZFC.Lib.FuncFacts.
Require Import ZFC.Lib.WosetMin.
Require Import ZFC.Lib.IndexedFamilyUnion.
Require Import ZFC.Lib.ChoiceFacts.
Require Import ZFC.Lib.Choice.
Require Export ZFC.Elements.EX6_2.

(*** EST第六章5：可数集，可数多个可数集的并是可数集 ***)

(* 可数集 *)
Definition countable : set → Prop := λ A, A ≼ ω.
(* 不可数集 *)
Definition uncountable : set → Prop := λ A, ¬countable A.

(* 集合是可数集当且仅当它是有限集或可数无限集 *)
Lemma countable_iff :
  ∀ A, countable A ↔ finite A ∨ A ≈ ω.
Proof with auto.
  split.
  - intros Hdm. destruct (classic (finite A))... right.
    apply infinite_set_dominated_by_ω_eqnum_ω...
  - intros [[n [Hn [f [Hi [Hd Hr]]]]]|[f Hf]].
    + exists f. split... split... rewrite Hr.
      apply trans_sub... apply ω_trans.
    + exists f. apply bijection_is_injection...
Qed.

(* 有限集是是可数集 *)
Lemma countableI1 : ∀ A, finite A → countable A.
Proof. intros. apply countable_iff. now left. Qed.

(* 可数无限集是是可数集 *)
Lemma countableI2 : ∀ A, A ≈ ω → countable A.
Proof. intros. apply countable_iff. now right. Qed.

(* 集合是不可数集当且仅当它是无限集且不与ω等势 *)
Lemma uncountable_iff :
  ∀ A, uncountable A ↔ infinite A ∧ A ≉ ω.
Proof.
  intros. unfold uncountable, infinite.
  rewrite countable_iff. tauto.
Qed.

(* 集合是可数集当且仅当其基数小于等于阿列夫零 *)
Lemma countable_iff_cardLe_aleph0 : ∀ A, countable A ↔ |A| ≤ ℵ₀.
Proof. split; apply cardLe_iff; auto. Qed.

(* 空集是可数集 *)
Lemma empty_cnt : countable ∅.
Proof. apply countableI1, empty_finite. Qed.

(* 可数集的子集仍是可数集 *)
Lemma subset_of_cnt : ∀ A B,
  B ⊆ A → countable A → countable B.
Proof with auto.
  intros * Hsub [f [Hi [Hd Hr]]].
  exists (f ↾ B). split. apply restr_injective...
  split. apply restr_dom. destruct Hi... rewrite Hd...
  eapply sub_trans. apply restr_ran_included. apply Hr.
Qed.

(* 集合是可数集如果它被ω满射 *)
Lemma countable_if_mapped_onto_by_ω :
  ∀ A F, F: ω ⟹ A → countable A.
Proof. exact dominated_by_ω_if_mapped_onto_by_ω. Qed.

(* 非空集合是可数集蕴含它被ω满射 *)
Lemma countable_impl_mapped_onto_by_ω :
  ∀ A, ⦿ A → countable A → ∃ F, F: ω ⟹ A.
Proof. exact dominated_by_ω_impl_mapped_onto_by_ω. Qed.

(* 非空集合是可数集当且仅当它被ω满射 *)
Fact countable_iff_mapped_onto_by_ω :
  ∀ A, ⦿ A → (∃ F, F: ω ⟹ A) ↔ countable A.
Proof. exact dominated_by_ω_iff_mapped_onto_by_ω. Qed.

(* ==需要选择公理== *)
(* 可数多个可数集的并是可数集 *)
Theorem countable_union_of_coutable_set : AC_II →
  ∀ 𝒜, countable 𝒜 → (∀A ∈ 𝒜, countable A) → countable (⋃ 𝒜).
Proof with eauto; try congruence.
  intros AC2 𝒜 Hcnt HcntA.
  set {A ∊ 𝒜 | ⦿ A} as 𝒜'.
  assert (Hsub: 𝒜' ⊆ 𝒜). {
    intros x Hx. apply SepE1 in Hx...
  }
  assert (Hequ: ⋃ 𝒜 = ⋃ 𝒜'). {
    ext Hx.
    - apply UnionAx in Hx as [A [HA Hx]].
      destruct (classic (A = ∅)). subst A. exfalso0.
      apply EmptyNE in H. apply UnionAx.
      exists A. split... apply SepI...
    - apply UnionAx in Hx as [A [HA Hx]]. apply UnionAx.
      exists A. split...
  }
  apply (subset_of_cnt _ 𝒜') in Hcnt...
  rewrite Hequ. clear Hequ.
  destruct (classic (𝒜' = ∅)) as [Heq|Hne]. {
    rewrite Heq, union_empty. apply empty_cnt.
  }
  apply EmptyNE in Hne.
  apply countable_impl_mapped_onto_by_ω in Hcnt as [g Hg]...
  assert (Hgm: ∀m ∈ ω, g[m] ∈ 𝒜'). {
    intros m Hm. eapply ap_ran... apply surjection_is_func...
  }
  set (Func ω 𝒫 (ω ⟶ ⋃ 𝒜') (λ m,
    {f ∊ ω ⟶ ⋃ 𝒜' | f: ω ⟹ g[m]}
  )) as h.
  assert (Hh: h: ω ⇒ 𝒫 (ω ⟶ ⋃ 𝒜')). {
    apply meta_function. intros m Hm. apply PowerAx.
    intros x Hx. apply SepE1 in Hx...
  }
  assert (Hneh: ∀m ∈ ω, ⦿ h[m]). {
    intros m Hm. apply Hgm in Hm as Hgma.
    apply SepE in Hgma as [Hgma Hnegm]. apply HcntA in Hgma.
    apply countable_iff_mapped_onto_by_ω in Hgma as [f Hf]...
    exists f. unfold h. rewrite meta_func_ap... apply SepI...
    destruct Hf as [Hf [Hd Hr]].
    apply arrow_iff. split... split... intros x Hx.
    apply UnionAx. exists (g[m]). split. apply SepI...
    rewrite <- Hr. eapply ranI. apply func_correct...
  }
  apply AC2 in Hneh as [F HF]. apply SepE in HF as [_ HF].
  assert (HFm: ∀m ∈ ω, F[m]: ω ⟹ g[m]). {
    intros m Hm. apply HF in Hm as HFm. unfold h in HFm.
    rewrite meta_func_ap in HFm... apply SepE2 in HFm...
  }
  set (Func (ω × ω) ⋃ 𝒜' (λ p, F[π2 p][π1 p])) as f.
  assert (Hf: f: ω × ω ⟹ ⋃ 𝒜'). {
    apply meta_surjection.
    - intros p Hp.
      apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]].
      subst p. zfc_simple. apply UnionAx.
      exists (g[b]). split. apply Hgm... apply (ap_ran ω)...
      apply surjection_is_func. apply HFm...
    - intros y Hy. apply UnionAx in Hy as [A [HA Hy]].
      destruct Hg as [Hfg [Hdg Hrg]]. rewrite <- Hrg in HA.
      apply ranE in HA as [b Hgb]. apply domI in Hgb as Hb.
      apply func_ap in Hgb... rewrite Hdg in Hb.
      pose proof (HFm b Hb) as [HfF [HdF HrF]].
      rewrite <- Hgb, <- HrF in Hy. apply ranE in Hy as [a HFb].
      apply domI in HFb as Ha. apply func_ap in HFb...
      exists <a, b>. split. apply CPrdI... zfc_simple.
  }
  destruct ω_eqnum_ω_cp_ω as [i Hi].
  apply (countable_if_mapped_onto_by_ω _ (f ∘ i)).
  eapply compo_surjection... apply bijection_is_surjection...
Qed.

(* ==需要选择公理== *)
(* 可数多个可数无穷集的并是可数无穷集 *)
Theorem countable_union_of_cntinf : AC_II →
  ∀ 𝒜, ⦿ 𝒜 → countable 𝒜 → (∀A ∈ 𝒜, |A| = ℵ₀) → |⋃ 𝒜| = ℵ₀.
Proof with eauto; try congruence.
  intros AC2 𝒜 Hne Hcnt Hinf.
  symmetry. apply CardAx1. apply Schröeder_Bernstein. {
    destruct Hne as [A HA]. apply Hinf in HA as Hqn.
    symmetry in Hqn. apply CardAx1 in Hqn as [f [Hi [Hd Hr]]].
    exists f. split... split... intros y Hy. rewrite Hr in Hy.
    apply UnionAx. exists A...
  }
  apply countable_impl_mapped_onto_by_ω in Hcnt as [g Hg]...
  assert (Hgm: ∀m ∈ ω, g[m] ∈ 𝒜). {
    intros m Hm. eapply ap_ran... apply surjection_is_func...
  }
  set (Func ω 𝒫 (ω ⟶ ⋃ 𝒜) (λ m,
    {f ∊ ω ⟶ ⋃ 𝒜 | f: ω ⟹ g[m]}
  )) as h.
  assert (Hh: h: ω ⇒ 𝒫 (ω ⟶ ⋃ 𝒜)). {
    apply meta_function. intros m Hm. apply PowerAx.
    intros x Hx. apply SepE1 in Hx...
  }
  assert (Hneh: ∀m ∈ ω, ⦿ h[m]). {
    intros m Hm. apply Hgm in Hm as Hgma.
    apply Hinf in Hgma. symmetry in Hgma.
    apply CardAx1 in Hgma as [f Hf].
    apply bijection_is_surjection in Hf as [Hf _].
    exists f. unfold h. rewrite meta_func_ap... apply SepI...
    destruct Hf as [Hf [Hd Hr]].
    apply arrow_iff. split... split... intros x Hx.
    apply UnionAx. exists (g[m]). split...
    rewrite <- Hr. eapply ranI. apply func_correct...
  }
  apply AC2 in Hneh as [F HF]. apply SepE in HF as [_ HF].
  assert (HFm: ∀m ∈ ω, F[m]: ω ⟹ g[m]). {
    intros m Hm. apply HF in Hm as HFm. unfold h in HFm.
    rewrite meta_func_ap in HFm... apply SepE2 in HFm...
  }
  set (Func (ω × ω) ⋃ 𝒜 (λ p, F[π2 p][π1 p])) as f.
  assert (Hf: f: ω × ω ⟹ ⋃ 𝒜). {
    apply meta_surjection.
    - intros p Hp.
      apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]].
      subst p. zfc_simple. apply UnionAx.
      exists (g[b]). split. apply Hgm... apply (ap_ran ω)...
      apply surjection_is_func. apply HFm...
    - intros y Hy. apply UnionAx in Hy as [A [HA Hy]].
      destruct Hg as [Hfg [Hdg Hrg]]. rewrite <- Hrg in HA.
      apply ranE in HA as [b Hgb]. apply domI in Hgb as Hb.
      apply func_ap in Hgb... rewrite Hdg in Hb.
      pose proof (HFm b Hb) as [HfF [HdF HrF]].
      rewrite <- Hgb, <- HrF in Hy. apply ranE in Hy as [a HFb].
      apply domI in HFb as Ha. apply func_ap in HFb...
      exists <a, b>. split. apply CPrdI... zfc_simple.
  }
  destruct ω_eqnum_ω_cp_ω as [i Hi].
  apply (dominated_by_ω_if_mapped_onto_by_ω _ (f ∘ i)).
  eapply compo_surjection... apply bijection_is_surjection...
Qed.

(* ==可以不用选择公理== (用算术基本定理直接建立双射) *)
(* 所有自然数到ω的函数空间的并是可数集 *)
Fact ifunion_arrow_ω_cnt :
  countable ⋃ᵢ λ i, i ⟶ ω.
Proof with neauto.
  apply countable_union_of_coutable_set.
  - apply ac2.
  - apply countableI2.
    apply eqnum_repl. reflexivity. intros n Hn m Hm Heq.
    set (Func n ω (λ x, x)) as f.
    assert (Hf: f ∈ n ⟶ ω). {
      apply SepI. apply PowerAx.
      intros p Hp. apply SepE1 in Hp...
      apply meta_function. intros x Hx. eapply ω_trans...
    }
    apply arrow_iff in Hf as Hfn. destruct Hfn as [_ [Hdn _]].
    rewrite Heq in Hf. apply arrow_iff in Hf as [_ [Hdm _]].
    congruence.
  - intros A HA. apply ReplAx in HA as [n [Hn Hqn]]. subst A.
    apply countable_iff.
    destruct (classic (n = 0)).
    + left. subst n. rewrite arrow_from_empty. apply nat_finite...
    + right. eapply Equivalence_Transitive.
      * apply cardExp_well_defined. apply CardAx0. reflexivity.
      * apply CardAx1. apply cardExp_aleph0_n...
Qed.

(* 有限序列集 *)
Definition FiniteSequences : set → set := λ A,
  {f ∊ 𝒫 (ω × A) | ∃n ∈ ω, f: n ⇒ A}.
Notation 𝗦𝗾 := FiniteSequences.

(* 空集的有限序列等于1 *)
Fact sq_empty : 𝗦𝗾 ∅ = 1.
Proof with nauto.
  ext Hx.
  - apply SepE in Hx as [Hx _].
    rewrite cprd_0_r, power_empty, <- one in Hx...
  - rewrite one in Hx. apply SingE in Hx. subst. apply SepI.
    + rewrite cprd_0_r, power_empty. apply SingI.
    + exists 0. split... apply injection_is_func.
      apply empty_injection.
Qed.

(* 任意集合被自身的有限序列集支配 *)
Lemma dominated_by_sq : ∀ A, A ≼ 𝗦𝗾 A.
Proof with neauto.
  intros. set (Func A (𝗦𝗾 A) (λ x, Func 1 A (λ _, x))) as f.
  exists f. apply meta_injection.
  + intros x Hx. apply SepI.
    * apply PowerAx. intros p Hp. apply SepE in Hp as [Hp _].
      apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]].
      subst p. apply CPrdI... eapply ω_trans...
    * exists 1. split... apply meta_function. intros _ _...
  + intros x1 Hx1 x2 Hx2 Heq.
    assert (<∅, x1> ∈ Func 1 A (λ _, x1)). {
      apply SepI. apply CPrdI... apply suc_has_0... zfc_simple.
    }
    rewrite Heq in H. apply SepE in H as [_ H]. zfc_simple.
Qed.

(* 有限序列集是函数空间的并的子集 *)
Lemma sq_sub_ifunion_arrow : ∀ A, 𝗦𝗾 A ⊆ ⋃ᵢ λ i, i ⟶ A.
Proof with eauto.
  intros A f Hf.
  apply SepE in Hf as [_ [n [Hn Hf]]].
  eapply IFUnionI... apply arrowI...
Qed.

(* ω的有限序列集与自身等势 *)
Fact ω_eqnum_sq_ω : ω ≈ 𝗦𝗾 ω.
Proof.
  apply Schröeder_Bernstein. apply dominated_by_sq.
  eapply dominate_trans. apply dominate_sub.
  apply sq_sub_ifunion_arrow.
  apply ifunion_arrow_ω_cnt.
Qed.

Fact sq_cnt : ∀ A, countable A → countable (𝗦𝗾 A).
Proof with eauto; try congruence.
  intros A [g Hg].
  eapply dominate_trans; revgoals. {
    apply eqnum_dominate. now rewrite ω_eqnum_sq_ω.
  }
  set (Func (𝗦𝗾 A) (𝗦𝗾 ω) (λ f,
    Func (dom f) ω (λ n, g[f[n]])
  )) as F.
  exists F. apply meta_injection.
  - intros f Hf. apply SepE in Hf as [_ [n [Hn Hf]]].
    assert (Hf' := Hf). destruct Hf' as [_ [Hdf _]].
    apply SepI.
    + apply PowerAx. intros p Hp. apply SepE in Hp as [Hp _].
      apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]].
      subst p. apply CPrdI... eapply ω_trans...
    + exists n. split... rewrite Hdf.
      apply meta_function. intros x Hx. eapply ap_ran.
      apply injection_is_func... eapply ap_ran...
  - intros f1 H1 f2 H2 Heq.
    apply SepE in H1 as [_ [n1 [Hn1 [Hf1 [Hdf1 Hrf1]]]]].
    apply SepE in H2 as [_ [n2 [Hn2 [Hf2 [Hdf2 Hrf2]]]]].
    assert (Hf1x: ∀x ∈ dom f1, f1[x] ∈ A). {
      intros x Hx. eapply ap_ran... split...
    }
    assert (Hf2x: ∀x ∈ dom f2, f2[x] ∈ A). {
      intros x Hx. eapply ap_ran... split...
    }
    assert (H1: ∀x ∈ dom f1, g[f1[x]] ∈ ω). {
      intros x Hx. eapply ap_ran.
      apply injection_is_func... apply Hf1x...
    }
    assert (H2: ∀x ∈ dom f2, g[f2[x]] ∈ ω). {
      intros x Hx. eapply ap_ran.
      apply injection_is_func... apply Hf2x...
    }
    apply func_ext_elim in Heq as [Heq1 Heq2]; [|apply func_is_func..].
    rewrite meta_dom, meta_dom in Heq1...
    rewrite meta_dom in Heq2...
    apply func_ext_intro...
    intros x Hx. apply Heq2 in Hx as Heq.
    rewrite meta_func_ap, meta_func_ap in Heq; revgoals...
    apply meta_function... apply meta_function...
    destruct Hg as [Hi [Hd Hr]].
    eapply injectiveE; eauto; rewrite Hd.
    apply Hf1x... apply Hf2x...
Qed.

(* “定理：可数多个可数集的并是可数集“的推广 *)
Theorem cardLe_union : AC_I →
  ∀ 𝒜, ∀𝜅 ⋵ 𝐂𝐃, (∀A ∈ 𝒜, |A| ≤ 𝜅) → |⋃ 𝒜| ≤ |𝒜| ⋅ 𝜅.
Proof with auto; try congruence.
  intros AC1 𝒜 𝜅 [K HK] Hle.
  set {A ∊ 𝒜 | ⦿ A} as 𝒜'.
  assert (Hle': |𝒜'| ≤ |𝒜|). {
    apply cardLe_sub. intros x Hx. apply SepE1 in Hx...
  }
  assert (Hequ: ⋃ 𝒜 = ⋃ 𝒜'). {
    ext Hx.
    - apply UnionAx in Hx as [A [HA Hx]].
      destruct (classic (A = ∅)). subst A. exfalso0.
      apply EmptyNE in H. apply UnionAx.
      exists A. split... apply SepI...
    - apply UnionAx in Hx as [A [HA Hx]]. apply UnionAx.
      exists A. split... apply SepE1 in HA...
  }
  rewrite HK, Hequ in *. clear HK 𝜅 Hequ.
  eapply cardLe_trans; revgoals.
  apply cardMul_preserve_le. apply Hle'.
  apply cardLe_iff.
  eapply dominate_rewrite_r. {
    apply cardMul_well_defined. apply CardAx0. apply CardAx0.
  }
  set (Func 𝒜' 𝒫 (K ⟶ ⋃ 𝒜') (λ A,
    {f ∊ K ⟶ ⋃ 𝒜' | f: K ⟹ A}
  )) as h.
  assert (Hh: h: 𝒜' ⇒ 𝒫 (K ⟶ ⋃ 𝒜')). {
    apply meta_function. intros m Hm. apply PowerAx.
    intros x Hx. apply SepE1 in Hx...
  }
  assert (Hneh: ∀A ∈ 𝒜', ⦿ h[A]). {
    intros A HA. assert (HA' := HA).
    apply SepE in HA as [HA HneA].
    apply Hle in HA. apply cardLe_iff in HA.
    apply dominated_impl_mapped_onto in HA as [f Hf]...
    exists f. unfold h. rewrite meta_func_ap... apply SepI...
    destruct Hf as [Hf [Hd Hr]].
    apply arrow_iff. split... split... intros x Hx.
    apply UnionAx. exists A. split...
    rewrite <- Hr. eapply ranI. apply func_correct...
  }
  pose proof (AC_I_to_II AC1) as AC2.
  apply AC2 in Hneh as [F HF]. apply SepE in HF as [_ HF].
  assert (HFA: ∀A ∈ 𝒜', F[A]: K ⟹ A). {
    intros A HA. apply HF in HA as HFA. unfold h in HFA.
    rewrite meta_func_ap in HFA... apply SepE2 in HFA...
  }
  set (Func (𝒜' × K) ⋃ 𝒜' (λ p, F[π1 p][π2 p])) as f.
  assert (Hf: f: 𝒜' × K ⟹ ⋃ 𝒜'). {
    apply meta_surjection.
    - intros p Hp.
      apply CPrdE1 in Hp as [A [HA [k [Hk Hp]]]].
      subst p. zfc_simple. apply UnionAx.
      exists A. split... apply (ap_ran K)...
      apply surjection_is_func. apply HFA...
    - intros a Ha. apply UnionAx in Ha as [A [HA Ha]].
      pose proof (HFA A HA) as [HfF [HdF HrF]].
      rewrite <- HrF in Ha. apply ranE in Ha as [k HFAk].
      apply domI in HFAk as Ha. apply func_ap in HFAk...
      exists <A, k>. split. apply CPrdI... zfc_simple.
  }
  eapply domain_of_surjection_dominate_range... apply Hf.
Qed.

Fact sq_dominated_by_ω_arrow : ∀ A, 2 ≤ |A| → 𝗦𝗾 A ≼ ω ⟶ A.
Proof with neauto; try congruence.
  intros A Hle.
  eapply dominate_rewrite_r. {
    apply cardExp_well_defined; symmetry; apply CardAx0.
  }
  cut (|𝗦𝗾 A| ≤ |A| ^ ℵ₀). { apply cardLe_iff. }
  rewrite <- cardMul_aleph0_expAleph0...
  apply cardLe_iff.
  eapply dominate_rewrite_r. {
    apply cardMul_well_defined. apply CardAx0.
    eapply Equivalence_Transitive; revgoals. apply CardAx0.
    apply cardExp_well_defined; apply CardAx0.
  }
  assert (Hne: ⦿ A). {
    apply EmptyNE. intros H. apply card_eq_0 in H.
    rewrite H in Hle. apply fin_cardLe_iff_le in Hle...
    apply le_iff_sub in Hle... apply sub_empty in Hle.
    eapply (nat_irrefl 2)... rewrite Hle at 1.
    apply suc_has_0. apply ω_inductive...
  }
  destruct Hne as [a Ha].
  set (λ f, Func ω A (λ x,
    match (ixm (x ∈ dom f)) with
      | inl _ => f[x]
      | inr _ => a
    end
  )) as G.
  set (Func (𝗦𝗾 A) (ω ⟶ A) (λ f, G f)) as g.
  set (Func (𝗦𝗾 A) (ω × (ω ⟶ A)) (λ f, <dom f, g[f]>)) as F.
  assert (HGp: ∀f ∈ 𝗦𝗾 A, G f ∈ 𝒫 (ω × A)). {
    intros f Hf. apply PowerAx. intros p Hp.
    apply SepE1 in Hp...
  }
  assert (HG: ∀f ∈ 𝗦𝗾 A, G f : ω ⇒ A). {
    intros f Hf.
    apply SepE in Hf as [_ [n [Hn [Hf [Hd Hr]]]]].
    apply meta_function.
    intros x Hx. destruct (ixm (x ∈ dom f))...
    eapply ap_ran... split...
  }
  assert (Hg: g: 𝗦𝗾 A ⇒ (ω ⟶ A)). {
    apply meta_function. intros f Hf.
    apply SepI. apply HGp... apply HG...
  }
  exists F. apply meta_injection.
  - intros f Hf. apply CPrdI.
    apply SepE in Hf as [_ [n [Hn [_ [Hd _]]]]]...
    apply SepI; unfold g; rewrite meta_func_ap...
  - intros f1 H1 f2 H2 Heq.
    apply op_iff in Heq as [Heqd Heqg].
    unfold g in Heqg.
    do 2 rewrite meta_func_ap in Heqg...
    assert (H1' := H1). assert (H2' := H2).
    apply SepE in H1' as [_ [n [Hn [Hf1 [Hd _]]]]].
    apply SepE in H2' as [_ [_ [_ [Hf2 _]]]].
    apply func_ext... split... intros x Hx.
    assert (Hxw: x ∈ ω). { eapply ω_trans... }
    assert (Heq: (G f1)[x] = (G f2)[x]) by congruence.
    unfold G in Heq.
    do 2 rewrite meta_func_ap in Heq; auto; [|apply HG..]...
    rewrite <- Heqd in Heq. destruct (ixm (x ∈ dom f1))...
Qed.


(** * A box to encrypt data (part of TCB) *)
Require Import Coq.Program.Basics Coq.Strings.String.
Require Import FunctionApp EncryptionInterface.

Local Open Scope program_scope.

Set Implicit Arguments.

(** ** Summary

    We implement a box that encrypts data:

<<
                   System │   ^
               Randomness │   │ Request System Randomness
                          V   │
                        ┌─────────┐
    unencrypted data in │         │
    ------------------> │         │ encrypted data out
                        │ Encrypt │ ------------------>
    set master key      │   Box   │
    ------------------> │         │
                        │         │
                        └─────────┘

>> *)

Module TrustedEncryptBox (DataTypes : EncryptionDataTypes) (Algorithm : EncryptionAlgorithm DataTypes).
  Import DataTypes.

  Section trustedEncryptBox.
    (** Because the box is asynchronous, we enable tagging data with
        identifiers.  The identifiers are passed unchanged with the
        encrypted data.

        Because system randomness is asynchronous, we tag the request
        with the data to encrypt.  Thus, the system randomness handler
        MUST NOT allow the tag to escape the application. *)

    Variable dataTagT : Type.

    Record EncryptBoxState :=
      { masterKey : option { key : masterKeyT | Algorithm.isValidMasterKey key = true } }.

    Inductive ebInput :=
    | ebSetMasterKey (key : masterKeyT)
    | ebSystemRandomness (randomness : systemRandomnessT) (tag : rawDataT * dataTagT)
    | ebEncrypt (unencryptedData : rawDataT) (tag : dataTagT).

    Inductive ebErrorOutput :=
    | ebErrorNotEnoughRandomness (howMuchWanted : systemRandomnessHintT) (randomnessGiven : systemRandomnessT)
    | ebErrorInvalidMasterKey (key : masterKeyT) (pf : Algorithm.isValidMasterKey key = false)
    | ebErrorNoMasterKey.

    Inductive ebEventOutput :=
    | ebRequestSystemRandomness (howMuch : systemRandomnessHintT) (tag : rawDataT * dataTagT)
    | ebEncrypted (data : encryptedDataT) (tag : dataTagT).

    Definition ebOutput := (ebErrorOutput + ebEventOutput)%type.

    Context (world : Type)
            (handle : ebOutput -> action world).

    Definition initState : EncryptBoxState :=
      {| masterKey := None |}.

    Definition encryptBoxLoopPreBody
               (st : EncryptBoxState)
    : ebInput -> option ebOutput * EncryptBoxState
      := fun i =>
           match i with

             | ebSetMasterKey key
               => match Sumbool.sumbool_of_bool (Algorithm.isValidMasterKey key) with
                    | left pf => (None,
                                  {| masterKey := Some (exist _ key pf) |})
                    | right pf => (Some (inl (@ebErrorInvalidMasterKey key pf)),
                                   {| masterKey := None |})
                  end

             | ebSystemRandomness randomness (rawData, tag)
               => (match st.(masterKey) with
                     | None => Some (inl ebErrorNoMasterKey)
                     | Some (exist key pf)
                       => match Algorithm.encrypt randomness key pf rawData with
                            | inl enc
                              => Some (inr (ebEncrypted enc tag))
                            | inr (NotEnoughRandomness howMuchWanted randomnessGiven)
                              => Some (inl (ebErrorNotEnoughRandomness howMuchWanted randomnessGiven))
                          end
                   end,
                   st)

             | ebEncrypt rawData tag
               => let hint := Algorithm.randomnessHint rawData in
                  (Some (inr (ebRequestSystemRandomness hint (rawData, tag))), st)
           end.

    Definition encryptBoxLoopBody {T}
               (encryptBoxLoop : EncryptBoxState -> T)
               (st : EncryptBoxState)
    : ebInput -> action world * T
      := fun i => let outs := fst (encryptBoxLoopPreBody st i) in
                  (match outs with
                     | None => id
                     | Some out => handle out
                   end,
                   encryptBoxLoop (snd (encryptBoxLoopPreBody st i))).

    CoFixpoint encryptBoxLoop (st : EncryptBoxState) :=
      Step (encryptBoxLoopBody encryptBoxLoop st).

    Definition encryptBox : process _ _ := encryptBoxLoop initState.
  End trustedEncryptBox.
End TrustedEncryptBox.


(** * Various examples of using notations and conversion to the shallow embedding *)

From ConCert Require Import Ast Notations PCUICTranslate PCUICtoTemplate.
From Coq Require Import Basics String List.

Definition expr_to_tc Σ := compose trans (expr_to_term Σ).
Definition type_to_tc := compose trans type_to_term.
Definition global_to_tc := compose trans_minductive_entry trans_global_dec.

Import ListNotations.
Import BaseTypes.
Import StdLib.

Definition x := "x".
Definition y := "y".
Definition z := "z".

Check [| ^0 |].

Check [| \x : Nat => y |].

Definition id_f_syn :=  [| (\x : Nat => ^0) 1 |].

Make Definition id_f_one := (expr_to_tc Σ id_f_syn).
Example id_f_eq : id_f_one = 1. Proof. reflexivity. Qed.

(* The same as [id_f_syn], but with named vars *)
Definition id_f_with_vars := [| (\x : Nat => x) 1 |].

Make Definition id_f_one' := (expr_to_tc Σ (indexify [] id_f_with_vars)).
Example id_f_eq' : id_f_one' = 1. Proof. reflexivity. Qed.

Definition simple_let_syn :=
  [|
   \x : Nat =>
     let y : Nat := 1 in ^0
   |].

Make Definition simple_let := (expr_to_tc Σ simple_let_syn).
Example simple_let_eq : simple_let 1 = 1. Proof. reflexivity. Qed.

Definition simple_let_with_vars_syn :=
  [|
   \x : Nat =>
     let y : Nat := 1 in y
   |].

Make Definition simple_let' := (expr_to_tc Σ (indexify [] simple_let_with_vars_syn)).
Example simple_let_eq' : simple_let' 0 = 1. Proof. reflexivity. Qed.

Definition negb_syn :=
  [|
   \x : Bool =>
          case x : Bool return Bool of
          | True -> False
          | False -> True
  |].

Make Definition negb' := (expr_to_tc Σ (indexify [] negb_syn)).

Example negb'_correct : forall b, negb' b = negb b.
Proof.
  destruct b;easy.
Qed.

Definition myplus_syn :=
  [| \x : Nat => \y : Nat => x + y |].

Make Definition myplus := (expr_to_tc Σ (indexify [] myplus_syn)).

Definition stupid_case :=
  fun y : Set => fun x : y => fun z : list y =>
                match z with
                | [] => x
                | _ => x
                end.

Quote Definition q_stupid_case := Eval compute in stupid_case.
Quote Recursively Definition q_stupid_case_rec := stupid_case.
Quote Definition cons_syn := (fun A : Set => cons A).

Definition case_ex :=
  [| \\y  => \x : 'y =>  \z : "list" 'y =>
         case z : "list" 'y return 'y of
         | Nil -> x
         | Cons "hd" "tl" -> x |].

Compute (expr_to_tc Σ (indexify [] case_ex)).

Make Definition case_ex_def :=  (expr_to_tc Σ (indexify [] case_ex)).

Definition case_ex1 :=
  [| \\y  => \"w" : 'y => \x : 'y =>  \z : "list" 'y =>
         case z : "list" 'y return "prod" 'y 'y of
         | Nil -> {eConstr "prod" "pair"} {eTy (tyVar y)} {eTy (tyVar y)} x x
         | Cons "hd" "tl" -> {eConstr "prod" "pair"} {eTy (tyVar y)} {eTy (tyVar y)} "hd" x |].

Compute (expr_to_tc Σ (indexify [] case_ex1)).

Make Definition case_ex_def1 :=  (expr_to_tc Σ (indexify [] case_ex1)).

Definition case_ex2 :=
  [| \\y => case ({eConstr "list" "nil"} "y") : "list" 'y return "list" 'y of
            | Nil -> {eConstr "list" "nil"} "y"
            | Cons "hd" "tl" -> {eConstr "list" "nil"} "y" |].

Compute indexify [] case_ex2.
Compute (expr_to_tc Σ (indexify [] case_ex2)).

Make Definition case_ex_def2 :=  (expr_to_tc Σ (indexify [] case_ex2)).

Make Definition ex_type_def := (type_to_tc (indexify_type [] example_type)).

Definition map_syn :=
gdInd "AMap" 2 [("ANil", []);
                  ("ACons", [(None,tyRel 1);(None,tyRel 0);
                               (None,(tyApp (tyApp (tyInd "AMap") (tyRel 1)) (tyRel 0)))])] false.

Make Inductive (global_to_tc map_syn).

Definition single_field_record_syn :=
  [\ record "sfrec" := "mkRec" {"fld" : Nat } \].

Make Inductive (global_to_tc single_field_record_syn).


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rplus.
Require Export XR_Rplus_0_l.
Require Export XR_Rplus_comm.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rplus_0_r : forall r, r + R0 = r.
Proof.
  intro x.
  rewrite Rplus_comm.
  rewrite Rplus_0_l.
  reflexivity.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Combine the definition of variables and its proofs.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.
Require Export NatLemmas.
Require Export VariablesFunDef.
Require Export NonceSigDef.

Set Implicit Arguments.

Module EVarNonce : NonceSig.
End EVarNonce.
Module EVar := VariablesProofsFun(EVarNonce).


Require Import compiler.util.Common.
(*
Require Import compiler.FlattenExprDef. (* Only imported for testing UseImmediate *)
Require Import compiler.StringNameGen. (* Only imported for testing UseImmediate *) *)
Require Import compiler.FlatImp.
Require Import Coq.Lists.List. Import ListNotations.
Require Import bedrock2.Syntax.
Require Import coqutil.Tactics.fwd.
Require Import String.
(* Open Scope string_scope. (* Only used for examples. *) *)
Open Scope Z_scope.

Section WithArgs.
  Context (is5BitImmediate : Z -> bool).
  Context (is12BitImmediate: Z -> bool).

  Fixpoint useImmediate(s: stmt string) : stmt string :=
    match s with
    | SIf c s1 s2 => SIf c (useImmediate s1) (useImmediate s2)
    | SLoop s1 c s2 => SLoop (useImmediate s1) c (useImmediate s2)
    | SStackalloc v1 sz1 s => SStackalloc v1 sz1 (useImmediate s)
    | SSeq s1 s2 =>
        let default := SSeq (useImmediate s1) (useImmediate s2) in
        match s1, s2 with
        (*
        | SSkip, _ => used2
        | _, SSkip => used1 *)
        | SLit v1 l1, SOp v2 op v2a (Var v2b) =>

            match op with
            | Syntax.bopname.add
            | Syntax.bopname.and
            | Syntax.bopname.or
            | Syntax.bopname.xor => if (is12BitImmediate l1) then
                                      if eqb v1 v2b then
                                        SSeq s1 (SOp v2 op v2a (Const l1))
                                      else if eqb v1 v2a then
                                             SSeq s1 (SOp v2 op v2b (Const l1))
                                           else default
                                    else default
            | Syntax.bopname.ltu
            | Syntax.bopname.lts => if (is12BitImmediate l1) then
                                      if eqb v1 v2b then
                                        SSeq s1 (SOp v2 op v2a (Const l1))
                                      else default
                                    else default
            | Syntax.bopname.srs
            | Syntax.bopname.sru
            | Syntax.bopname.slu => if (is5BitImmediate l1) then
                                      if eqb v1 v2b then
                                        SSeq s1 (SOp v2 op v2a (Const l1))
                                      else default
                                    else default
            | Syntax.bopname.sub => if (is12BitImmediate (-l1)) then
                                      if eqb v1 v2b then
                                        SSeq s1 (SOp v2 Syntax.bopname.add v2a (Const (-l1)))
                                      else default
                                    else default
            | _ => default
            end
        (*
        | SLit v1 l1, SSeq (SLit v1b l1b) (SOp v2 op v2a (Var v2b)) =>
            if (eqb v1 v1b) then default
            else match op with
            | Syntax.bopname.add
            | Syntax.bopname.and
            | Syntax.bopname.or
            | Syntax.bopname.xor => if (is12BitImmediate l1) then
                                      if eqb v1 v2b then
                                        SSeq (SLit v1b l1b) (SOp v2 op v2a (Const l1))
                                      else if eqb v1 v2a then
                                             SSeq (SLit v1b l1b) (SOp v2 op v2b (Const l1))
                                           else default
                                    else default
            | _ => default
            end *)
        | _, _ => default
        end
    | _ => s
    end.
End WithArgs.

(*
Following are examples for how UseImmediateDef works. Commented out for readability of compilation output. For now not using `Goal useImmediate (flatten_function ex_i) = expected_output because don't want to constrain expected output, what's more important is that whatever the output is is "correct" by semantics which would be shown by the proof in UseImmediate.v. To try out examples locally, uncomment here and in the imports at the start of the file.

Definition ex0 := (["a"], [] : list string, Syntax.cmd.set "a" (Syntax.expr.op bopname.add (Syntax.expr.literal 1) (Syntax.expr.literal 16))).
Definition ex1 := (["b"], ["a"], Syntax.cmd.set "b" (Syntax.expr.op bopname.slu (Syntax.expr.var "a") (Syntax.expr.literal 16))).
Definition ex2 := (["b"], ["a"], Syntax.cmd.set "b" (Syntax.expr.op bopname.add (Syntax.expr.literal 1) (Syntax.expr.var "a"))).
Definition ex3 := (["b"], ["a"], Syntax.cmd.set "b" (Syntax.expr.op bopname.ltu (Syntax.expr.var "a") (Syntax.expr.literal 16))).

Definition sourceExs := [ex0; ex1; ex2; ex3].
Definition unwrappedFlattenExs := let tmp :=  List.all_success (map flatten_function sourceExs) in
                                  match tmp with
                                  | Success l => l
                                  | _ => []
                                  end.
Compute unwrappedFlattenExs.

Definition useImmOnFlats (t: (list string * list string * stmt string)) : (list string * list string * stmt string)
  := match t with
     | (targs, trets, tstmt) => (targs, trets, (useImmediate (fun x => true) (fun x => true) tstmt))
     end.

Definition immediateExs := map useImmOnFlats unwrappedFlattenExs.

(* Check that is5BitImmediate is used. *)
Definition useImmOnFlats' (t: (list string * list string * stmt string)) : (list string * list string * stmt string)
  := match t with
     | (targs, trets, tstmt) => (targs, trets, (useImmediate (fun x => Z.ltb x 16) (fun x => true) tstmt))
     end.

Definition immediateExs' := map useImmOnFlats' unwrappedFlattenExs.

(* Check that is12BitImmediate is used. *)
Definition useImmOnFlats'' (t: (list string * list string * stmt string)) : (list string * list string * stmt string)
  := match t with
     | (targs, trets, tstmt) => (targs, trets, (useImmediate (fun x => true) (fun x => Z.ltb x 16) tstmt))
     end.

Definition immediateExs'' := map useImmOnFlats'' unwrappedFlattenExs.

Compute unwrappedFlattenExs.
(* For now, ex2 shouldn't be touched by this optimization, but could be touched after an earlier pass where superfluous SSkip's are removed. *)
Compute immediateExs. (* All constants are small enough. *)
Compute immediateExs'. (* is5BitImmediate is true only for < 16. *)
Compute immediateExs''. (* is12BitImmediate is true only for < 16. *)

*)


Require Import RelationClasses.
From ExtLib.Structures Require Import Functor Monad.
From ExtLib.Data Require Import Nat Fin.
From ITree Require Import
     ITree
     Events.Dependent
     Eq.Eq
     Interp.InterpFacts
     Interp.RecursionFacts
     Interp.TranslateFacts.
Import Monads.
Import MonadNotation.
Open Scope monad_scope.

From Paco Require paco2 paconotation.
From Equations Require Import Equations.

Set Primitive Projections.

From OGS Require Import Utils.

(* ======================================= *)
(* Terms, contexts, substitution, renaming *)
(* ======================================= *)

Variant termF (X : Type) : Type :=
| VarF : nat -> termF X
| AppF : X -> X -> termF X
| LamF : X -> termF X
.

Arguments VarF {X}.
Arguments AppF {X}.
Arguments LamF {X}.

Equations tmap {X Y} (f : X -> Y) (t : termF X) : termF Y :=
  tmap f (VarF i) := VarF i;
  tmap f (AppF u v) := AppF (f u) (f v);
  tmap f (LamF u) := LamF (f u).

Inductive term : Type := T : termF term -> term.

Notation Var i := (T (VarF i)).
Notation App u v := (T (AppF u v)).
Notation Lam u := (T (LamF u)).

Inductive t_ctx (X : Type) : Type :=
| CHole : t_ctx X
| CApp_l : X -> t_ctx X -> t_ctx X
| CApp_r : t_ctx X -> X -> t_ctx X
| CLam : t_ctx X -> t_ctx X
.

(* /!\ not capture avoiding, rename beforehand or use t_subst *)
Equations plug (C : t_ctx term) (x : term) : term :=
  plug CHole        t := t ;  (* dumb *)
  plug (CApp_l u C) t := App u (plug C t) ;
  plug (CApp_r C u) t := App (plug C t) u ;
  plug (CLam C)     t := Lam (plug C t).

(* multi-renaming *)
Equations t_rename (f : nat -> nat) (t : term) : term :=
  t_rename f (Var i)   := Var (f i) ;
  t_rename f (App u v) := App (t_rename f u) (t_rename f v) ;
  t_rename f (Lam u)   := Lam (t_rename f' u)
    where f' : nat -> nat := {
          f' O     := O ;
          f' (S i) := S (f i) }.

(* multi-substitution *)
Equations t_subst (f : nat -> term) (t : term) : term :=
  t_subst f (Var i)   := f i ;
  t_subst f (App u v) := App (t_subst f u) (t_subst f v) ;
  t_subst f (Lam u)   := Lam (t_subst f' u)
    where f' : nat -> term := {
          f' O     := Var O ;
          f' (S i) := t_rename S (f i) }.

Equations env1 (u : term) : nat -> term :=
  env1 u O     := u ;
  env1 u (S i) := Var i.

(* mono-substitution *)
Definition t_subst1 u v := t_subst (env1 v) u.

(* 'app_many t [u_0, u_1, ... u_n]' == 't u_n ... u_1 u_0' *)
Equations app_many : term -> list term -> term :=
  app_many a nil         := a ;
  app_many a (cons x xs) := App (app_many a xs) x.

Section normal_cbv.

(* =============================== *)
(* evaluation to normal form (CBV) *)
(* =============================== *)

Variant normF (X : Type) : Type :=
| NLamF : X -> normF X
| NAppF : nat -> list X -> normF X.
Arguments NLamF {X}.
Arguments NAppF {X}.

Inductive nf : Type := N : normF nf -> nf.
Notation NLam u := (N (NLamF u)).
Notation NApp i xs := (N (NAppF i xs)).

Equations term_of_nf (u : nf) : term :=
  term_of_nf (NLam u)    := Lam (term_of_nf u) ;
  term_of_nf (NApp i xs) := app_many (Var i) (List.map term_of_nf xs).

Equations eval_nf' (t : term) : itree (callE term nf +' void1) nf :=
  eval_nf' (Var i) := ret (NApp i nil) ;
  eval_nf' (App u v) :=
    u' <- call u ;;
    v' <- call v ;;
    match u' with
    | NLam w => call (t_subst1 (term_of_nf w) (term_of_nf v'))
    | NApp i xs => ret (NApp i (cons v' xs))
    end ;
  eval_nf' (Lam u) := u' <- call u ;; ret (NLam u').

Definition eval_nf : term -> itree void1 nf := rec eval_nf'.

Definition eutt_bind_eq {E R U} (t1 t2 : itree E U) (k : U -> itree E R)
             (h : t1 ≈ t2) : t1 >>= k ≈ t2 >>= k.
  eapply eutt_clo_bind.
  exact h.
  intros ? ? e; rewrite e; reflexivity.
Qed.

#[local] Transparent plug.
#[local] Transparent eval_nf'.

Lemma eval_nf_congr (s t : term) (p : eval_nf s ≈ eval_nf t) (C : t_ctx term)
  : eval_nf (plug C s) ≈ eval_nf (plug C t).
  induction C; cbn.
  + (* CHole *) exact p.
  + (* CApp_l x C *)
    unfold eval_nf; rewrite 2 rec_as_interp; cbn.
    rewrite 2 interp_bind; apply eutt_eq_bind; intro u.
    rewrite 2 interp_bind; eapply eutt_bind_eq.
    rewrite 2 interp_recursive_call; exact IHC.
  + (* CApp_r C x *)
    unfold eval_nf; rewrite 2 rec_as_interp; cbn.
    rewrite 2 interp_bind; eapply eutt_bind_eq.
    rewrite 2 interp_recursive_call; exact IHC.
  + (* CLam C *)
    unfold eval_nf; rewrite 2 rec_as_interp; cbn.
    rewrite 2 interp_bind; eapply eutt_bind_eq.
    rewrite 2 interp_recursive_call; exact IHC.
Qed.
End normal_cbv.

Section eager_lassen.

(* =============================================== *)
(* eager normal form bisimulation, ie Lassen trees *)
(* =============================================== *)

Inductive value : Type :=
| VVar : nat -> value
| VLam : term -> value
.

Equations term_of_value (v : value) : term :=
  term_of_value (VVar i) := Var i ;
  term_of_value (VLam t) := Lam t .

Definition val_app_fresh (v : value) : term :=
  App (t_rename S (term_of_value v)) (Var O).

Inductive eager_ctx : Type :=
| ECHole : eager_ctx
| ECApp_l : term -> eager_ctx -> eager_ctx
| ECApp_r : eager_ctx -> value -> eager_ctx
.

Equations ec_plug (C : eager_ctx) (t : term) : term :=
  ec_plug ECHole t := t ;
  ec_plug (ECApp_l u C) t := App u (ec_plug C t) ;
  ec_plug (ECApp_r C v) t := App (ec_plug C t) (term_of_value v) .

(* fill the hole (metavar) with a fresh variable *)
Equations ec_fresh (C : eager_ctx) : term :=
  ec_fresh ECHole        := Var 0;
  ec_fresh (ECApp_l t C) := App (t_rename S t) (ec_fresh C) ;
  ec_fresh (ECApp_r C v) := App (ec_fresh C) (t_rename S (term_of_value v)).

(* decomposition of a term as either a value or E[v1 v2] *)
Inductive eager_term : Type :=
| EValue : value -> eager_term
| ERedex : eager_ctx -> value -> value -> eager_term
.
Derive NoConfusion for eager_term.

Equations term_of_eterm (e : eager_term) : term :=
  term_of_eterm (EValue v)       := term_of_value v ;
  term_of_eterm (ERedex C v0 v1) :=
    ec_plug C (App (term_of_value v0) (term_of_value v1)) .

Equations ectx_split (t : term) : eager_term :=
  ectx_split (Var i)   := EValue (VVar i) ;
  ectx_split (Lam u)   := EValue (VLam u) ;
  ectx_split (App u v) with ectx_split v := {
    | EValue v0 with ectx_split u := {
      | EValue u0 := ERedex ECHole u0 v0 ;
      | ERedex C u0 u1 := ERedex (ECApp_r C v0) u0 u1 } ;
    | ERedex C v0 v1 := ERedex (ECApp_l u C) v0 v1 }.
#[local] Transparent ectx_split.

Lemma ectx_split_val (v : value) : ectx_split (term_of_value v) = EValue v.
  destruct v; auto.
Qed.

Lemma ectx_split_app u v : { C : _ & { v0 : _ & { v1 : _ & ectx_split (App u v) = ERedex C v0 v1 }}}.
  cbn; destruct (ectx_split v) eqn:d1;
  cbn; [destruct (ectx_split u) eqn:d2|];
  cbn; repeat econstructor; auto.
Qed.

#[local] Transparent term_of_eterm.
#[local] Transparent term_of_value.
#[local] Transparent ec_plug.
Lemma ectx_split_correct (t : term) : term_of_eterm (ectx_split t) = t.
  funelim (ectx_split t);
  intros; cbn; repeat f_equal;
  first [ rewrite Heq in Hind;   exact Hind
        | rewrite Heq0 in Hind0; exact Hind0 ].
Qed.

Lemma ectx_split_coherent (t : eager_term) : ectx_split (term_of_eterm t) = t.
funelim (term_of_eterm t).
+ exact (ectx_split_val v).
+ revert v0 v1.
  induction e; intros v0 v1; cbn.
  destruct (ectx_split (term_of_value v1)) eqn:?; cbn;
    rewrite (ectx_split_val v1) in Heqe;
    try (discriminate Heqe);
    injection Heqe as H; rewrite H.
  - destruct (ectx_split (term_of_value v0)) eqn:?; cbn;
      rewrite (ectx_split_val v0) in Heqe;
      try (discriminate Heqe).
    injection Heqe as H0.
    rewrite H0; reflexivity.
  - rewrite (IHe v0 v1); reflexivity.
  - destruct (ectx_split (term_of_value v)) eqn:He; cbn;
      rewrite (ectx_split_val v) in He;
      try (discriminate He).
    injection He as H; rewrite H.
    rewrite (IHe v0 v1); reflexivity.
Qed.

Lemma ectx_split_unique {x y} : x = term_of_eterm y <-> ectx_split x = y.
  econstructor; intro p.
  rewrite<- (ectx_split_coherent y); f_equal; exact p.
  rewrite<- (ectx_split_correct x); f_equal; exact p.
Qed.

Lemma ectx_split_inj {x y} (p : ectx_split x = ectx_split y) : x = y.
  rewrite<- ectx_split_correct, ectx_split_unique.
  exact p.
Qed.

Equations ec_compose (C D : eager_ctx) : eager_ctx :=
  ec_compose ECHole        D := D ;
  ec_compose (ECApp_l t C) D := ECApp_l t (ec_compose C D) ;
  ec_compose (ECApp_r C v) D := ECApp_r (ec_compose C D) v .
#[local] Transparent ec_compose.

Equations ec_plug_e (C : eager_ctx) (x : eager_term) : eager_term :=
  ec_plug_e C (EValue v)        := ectx_split (ec_plug C (term_of_value v)) ;
  ec_plug_e C (ERedex C' v0 v1) := ERedex (ec_compose C C') v0 v1.
#[local] Transparent ec_plug_e.

Lemma ec_plug_e_hole {x} : ec_plug_e ECHole x = x.
  destruct x.
  exact (ectx_split_val _).
  auto.
Qed.

Lemma ectx_split_plug (C : eager_ctx) (t : term) : ectx_split (ec_plug C t) = ec_plug_e C (ectx_split t).
destruct (ectx_split t) eqn:He; cbn; rewrite<- ectx_split_unique in He.
- rewrite He; reflexivity.
- rewrite<- ectx_split_unique.
  induction C; cbn; try (f_equal; f_equal); auto.
Qed.

Lemma ec_plug_e_inv_val {C x v} (p : ec_plug_e C x = EValue v) : C = ECHole /\ x = EValue v.
  rewrite<- (@ectx_split_coherent x) in p.
  rewrite<- ectx_split_plug in p.
  rewrite<- ectx_split_unique in p; cbn in p.
  induction C; try (destruct v; cbn in p; discriminate p).
  cbn in p; symmetry in p; rewrite ectx_split_unique in p.
  rewrite ectx_split_val in p.
  rewrite p; auto.
Qed.

(*Lemma ec_plug_e_inv_red {C x C' i v} (p : ec_plug_e C x = ERedex C' i v) :*)

Variant enf : Type :=
| ENValue : value -> enf
| ENRedex : eager_ctx -> nat -> value -> enf.

Equations term_of_enf (e : enf) : term :=
  term_of_enf (ENValue v)     := term_of_value v ;
  term_of_enf (ENRedex C i v) := ec_plug C (App (Var i) (term_of_value v)) .

Equations eval_enf' (t : term) : itree (callE term enf +' void1) enf :=
  eval_enf' t with ectx_split t := {
    | EValue v            := ret (ENValue v) ;
    | ERedex C (VVar i) v := ret (ENRedex C i v) ;
    | ERedex C (VLam u) v := call (ec_plug C (t_subst1 u (term_of_value v)))
  }.
Definition eval_enf : term -> itree void1 enf := rec eval_enf'.

Lemma eval_enf_congr (C : eager_ctx) {t1 t2} (p : eval_enf t1 ≈ eval_enf t2)
  : eval_enf (ec_plug C t1) ≈ eval_enf (ec_plug C t2).
Admitted.

Inductive enfE : Type -> Type :=
| ENValE : enfE T1
| ENRedexE : nat -> enfE T2.

(* helpers for lassen-tree events *)
Definition ENValT {X} (t : itree enfE X) : itree enfE X :=
  Vis ENValE (fun x : T1 => match x with t1_0 => t end).
Definition ENRedexT {X} (i : nat) (t0 t1 : itree enfE X) : itree enfE X :=
  Vis (ENRedexE i) (fun x : T2 => match x with t2_0 => t0 | t2_1 => t1 end).

Definition lassen_val (v : value) : itree enfE (term + T0) :=
  ENValT (ret (inl (App (t_rename S (term_of_value v)) (Var O)))) .

Equations lassen_enf (t : enf) : itree enfE (term + T0) :=
  lassen_enf (ENValue v)     := lassen_val v ;
  lassen_enf (ENRedex C i v) := ENRedexT i (ret (inl (ec_fresh C))) (lassen_val v).

Definition eval_lassen : term -> itree enfE T0 :=
  ITree.iter (fun t => translate elim_void1 (eval_enf t) >>= lassen_enf).

Definition eqv_lassen (x y : term) : Prop := eval_lassen x ≈ eval_lassen y.

(* ============================= *)
(* representing values as leaves *)
(* ============================= *)

Inductive enfE_v : Type -> Type := ENRedexE_v : nat -> enfE_v T2.
Definition ENRedexT_v {X} (i : nat) (t0 t1 : itree enfE_v X) : itree enfE_v X :=
  Vis (ENRedexE_v i) (fun x : T2 => match x with t2_0 => t0 | t2_1 => t1 end).

Equations enfE_v_inj {X} : enfE_v X -> enfE X :=
  enfE_v_inj (ENRedexE_v i) := ENRedexE i.
Definition lassen_v_inj {X} : itree enfE_v X -> itree enfE X :=
  @translate _ _ (@enfE_v_inj) X.

Equations lassen_enf_v (t : enf) : itree enfE_v (term + value) :=
  lassen_enf_v (ENValue v)     := Ret (inr v) ;
  lassen_enf_v (ENRedex C i v) := ENRedexT_v i (Ret (inl (ec_fresh C)))
                                               (Ret (inr v)).

Definition eval_lassen_v : term -> itree enfE_v value :=
  ITree.iter (fun t => translate elim_void1 (eval_enf t) >>= lassen_enf_v).

(* unfold leaves by coinductively eta-expanding values *)
Definition expand_v : itree enfE_v value -> itree enfE T0 :=
  ITree.iter (fun t => v <- lassen_v_inj t ;;
                       Ret (inl (eval_lassen_v (val_app_fresh v)))).
  (*cofix expand_ t := ITree.bind (lassen_v_inj t)
                                (tau # expand_ # eval_lassen_v # val_app_fresh).*)

Equations _expand_v : itree' enfE_v value -> itree enfE T0 :=
  _expand_v (RetF r) := Tau (expand_v (eval_lassen_v (val_app_fresh r))) ;
  _expand_v (TauF t) := Tau (expand_v t) ;
  _expand_v (VisF e k) := Vis (enfE_v_inj e) (fun r => expand_v (k r)).

Lemma unfold_expand_v (x : itree enfE_v value) : expand_v x ≅ _expand_v (observe x).
  unfold expand_v ; rewrite unfold_iter; cbn.
  change (ITree.iter _) with (expand_v).
  unfold lassen_v_inj.
  rewrite unfold_translate.
  rewrite unfold_bind.
  destruct (observe x) eqn:?; cbn.
  + reflexivity.
  + unfold expand_v; change (translate _ _) with (lassen_v_inj t); cbn.
    rewrite<- (unfold_iter (fun t => ITree.bind (lassen_v_inj t) _)).
    change (ITree.iter _ t) with (expand_v t).
    reflexivity.
  + rewrite _expand_v_equation_3.
    apply eqit_Vis; intro r.
    unfold expand_v; change (translate _ _) with (lassen_v_inj (k r)); cbn.
    rewrite<- (unfold_iter (fun t => ITree.bind (lassen_v_inj t) _) (k r)).
    reflexivity.
Qed.

Lemma eval_lassen_v_lem (x : term) : eval_lassen x ≈ expand_v (eval_lassen_v x).
  Admitted.

(* LassenV trees are bisimilar and coinductively, leaves (values) applied to
   a fresh variable have bisimilar lassen' trees. *)
Definition eqv_lassen_v : term -> term -> Prop :=
  paco2.paco2 (fun R x y => eutt (fun v1 v2 => R (val_app_fresh v1) (val_app_fresh v2))
                           (eval_lassen_v x)
                           (eval_lassen_v y))
        paconotation.bot2.

Lemma eqv_lassen_v_lem (x y : term) :
  eqv_lassen_v x y <-> expand_v (eval_lassen_v x) ≈ expand_v (eval_lassen_v y).
Admitted.

Lemma eqv_lassen_v_correct (x y : term) : eqv_lassen_v x y <-> eqv_lassen x y.
  unfold eqv_lassen; rewrite 2 eval_lassen_v_lem.
  exact (eqv_lassen_v_lem x y).
Qed.

End eager_lassen.

Section OGS.
  Variable idx : Type.           (* contexte de typage des configurations *)
  Variable conf : idx -> Type.    (* configurations *)
  Variable PA : idx -> Type.      (* actions joueur *)
  Variable OA : idx -> Type.      (* actions opposant *)
  Variable Pnxt : forall i, PA i -> idx.  (* évolution du contexte de typage, joueur *)
  Variable Onxt : forall i, OA i -> idx.  (* évolution du contexte de typage, opposant *)

  Definition NEXT i : Type := { pa : PA i & conf (Pnxt i pa) }.

  (* stratégie: étant donné une configuration et une action opposant,
     donner un calcul ([itree void1]) retournant une action joueur ainsi
     qu'une nouvelle configuration *)
  Definition STRAT : Type :=
    forall {i} (c : conf i) (oa : OA i), itree void1 (NEXT (Onxt i oa)).

  Variant ogsE : Type -> Type :=
  | StepE i (pa : PA i) : ogsE (OA (Pnxt i pa)).
  (*| StepP : PA -> ogsE T1.*)

  Definition eval_ogs (f : STRAT) : { i & (conf i * OA i)%type } -> itree ogsE T0.
  refine (rec (fun c => _ )).
  destruct c as [i [c o]].
  refine (x <- translate elim_void1 (f i c o) ;; _).
  refine (Vis (inr1 (StepE _ (projT1 x))) (fun o' => _)).
  refine (call (existT _ _ ((projT2 x) , o'))).
  Defined.
End OGS.

Section OGS_cbv.

Variant K_ty : Type := KCtx | KVal.
Equations kty_e : K_ty -> Type :=
  kty_e KCtx := eager_ctx ;
  kty_e KVal := value.
Variant PA_cbv : Type := PVal | PRed (i : nat).

Definition idx_cbv : Type := list K_ty.
Definition conf_cbv : idx_cbv -> Type := dvec kty_e.

Definition OA_cbv (c : idx_cbv) : Type := fin (length c).
Equations nxt_cbv i (oa : OA_cbv i) : PA_cbv -> idx_cbv :=
  nxt_cbv xs _ PVal     := cons KVal xs ;
  nxt_cbv xs _ (PRed i) := cons KCtx (cons KVal xs).
#[local] Transparent nxt_cbv.

(*
Definition ogsE_cbv := ogsE idx_cbv OA_cbv PA_cbv.
Definition STRAT_cbv := STRAT _ conf_cbv OA_cbv PA_cbv nxt_cbv.
Definition NEXT_cbv {i} oa := @NEXT _ conf_cbv OA_cbv PA_cbv nxt_cbv i oa.

Equations strat_enf {i} (c : conf_cbv i) oa : enf -> @NEXT_cbv i oa :=
  strat_enf c _ (ENValue v)     := {| N_play := PVal ; N_conf := _ |} ;
  strat_enf c _ (ENRedex C i v) := {| N_play := (PRed i) ; N_conf := _ |}.
Obligation 1.
unfold conf_cbv; rewrite dvec_equation_2.
exact (v , c).
Defined.
Obligation 2.
unfold conf_cbv. rewrite 2 dvec_equation_2.
exact (C , (v , c)).
Defined.

Definition strat_cbv : STRAT _ conf_cbv OA_cbv PA_cbv nxt_cbv.
  unfold STRAT; intros; unfold OA_cbv in oa.
  destruct (l_get i oa) eqn:H; set (x := d_get i c oa); rewrite H in x.
  + exact (ITree.map (strat_enf c oa) (eval_enf (ec_fresh x))).
  + exact (ITree.map (strat_enf c oa) (eval_enf (App (t_rename S (term_of_value x))
                                                     (Var O)))).
Defined.

Definition eval_ogs_cbv (t : term) : itree ogsE_cbv T0.
  refine (ITree.bind (translate elim_void1 (eval_enf t)) (fun e => _)).
  refine (eval_ogs _ _ _ _ _ strat_cbv _).
  destruct e eqn:?.
  + exact (existT _ (cons KVal nil) (v , t1_0)).
  + refine (existT _ (cons KCtx (cons KVal xs))).
  destruct (@strat_enf nil e).

bad
*)
End OGS_cbv.
(* ================ *)

Variant FreeF (E : Type -> Type) (A : Type) (X : Type) : Type :=
| FRetF : forall (r : X), FreeF E A X
| FVisF : forall {R} (e : E R) (k : R -> A), FreeF E A X
.
Arguments FRetF {_} {_} {_}.
Arguments FVisF {_} {_} {_} {_}.

Inductive Free (E : Type -> Type) (X : Type) : Type :=
| F : FreeF E (Free E X) X -> Free E X
.
Arguments F {_} {_}.
Notation FRet r := (F (FRetF r)).
Notation FVis e k := (F (FVisF e k)).

Definition unfold1 {E X} : itree E X -> itree void1 (FreeF E (itree E X) X) :=
  cofix _unfold x :=
    match observe x with
    | RetF r => Ret (FRetF r)
    | TauF t => Tau (_unfold t)
    | VisF e k => Ret (FVisF e k)
    end.

(*Definition explore {E}*)

(* ============== *)
(* old left-overs *)
(* ============== *)

(** comment until EOF

(* Weak Head Normal Form *)
Variant whnf : Type := W : normF term -> whnf.
Notation WLam u := (W (NLamF u)).
Notation WApp i xs := (W (NAppF i xs)).

(* boehm tree encoded as itrees *)
Variant boehmE : Type -> Type :=
| BLamE : boehmE T1
| BAppE : forall i j : nat, boehmE (fin j).

Definition boehm_tree := itree boehmE T0.

Definition BLam {X} u : itree boehmE X :=
  Vis BLamE (fun x => match x with t1_0 => u end).
Definition BApp {X} i xs : itree boehmE X :=
  Vis (BAppE i (length xs)) (l_get xs).

Equations term_of_whnf (w : whnf) : term :=
  term_of_whnf (WLam u) := Lam u ;
  term_of_whnf (WApp i xs) := app_many (Var i) xs.

(* Non-total function computing the whnf of a term by CBN reduction *)
Equations eval_whnf' (t : term) : itree (callE term whnf +' void1) whnf :=
  eval_whnf' (Var i) := ret (WApp i nil) ;
  eval_whnf' (App u v) :=
    u' <- call u ;;
    match u' with
    | WLam w => call (t_subst1 w v)
    | WApp i xs => ret (WApp i (cons v xs))
    end ;
  eval_whnf' (Lam u) := ret (WLam u).

Definition eval_whnf : term -> itree void1 whnf := rec eval_whnf'.

(* w_inj k (W x) := wrap (F2E (fmap k x)) *)
(* this is because normF == [ boehmE ]e *)
Equations w_inj {X} : (term -> itree boehmE X) -> whn -> itree boehmE X :=
  w_inj k (WLam u) := Vis BLamC (fun x => match x with t1_0 => k u end);
  w_inj k (WApp i xs) := Vis (BAppC i (length xs)) (k # l_get xs).

(* magic :D *)
Definition lassen' (t : term) : itree boehmE (term + T0) :=
  ITree.bind (translate elim_void1 (ev_whn t)) (w_inj (ret # inl)).
Definition lassen : term -> normT := iter lassen'.

Variant eqv_whn : whn -> whn -> Prop :=
  | Eqv_wlam : forall u v, eutt eq (lassen u) (lassen v) -> eqv_whn (WLam u) (WLam v)
  | Eqv_wapp : forall i n f g, (forall j, eutt eq (lassen (f j)) (lassen (g j)))
             -> eqv_whn (WApp i (l_acc n f)) (WApp i (l_acc n g))
.

Equations elim_r {T} (x : T + T0) : T := elim_r (inl t) := t.

(*
Lemma boehmE'_cong {C : t_ctx term} (s t : term) (p : lassen s ≈ lassen t)
  : eutt (fun a b => lassen (elim_r a) ≈ lassen (elim_r b))
         (lassen' (plug C s))
         (lassen' (plug C t)).
  induction C.
  + rewrite 2 plug_equation_1.
*)

Lemma boehmE_cong {C : t_ctx term} (s t : term) (p : lassen s ≈ lassen t)
  : lassen (plug C s) ≈ lassen (plug C t).
  induction C.
  + rewrite 2 plug_equation_1.
    exact p.
  + rewrite 2 plug_equation_2.
    reflexivity.
  + rewrite 2 plug_equation_3.
    unfold lassen, ";;", iter, MonadIter_itree; simpl.
    rewrite 2 unfold_iter.
    eapply eutt_clo_bind.
    * unfold lassen', ev_whn.
      rewrite 2 rec_as_interp.
      eapply eutt_clo_bind.
      - eapply eutt_translate'.
        rewrite 2 ev_whn'_equation_2; unfold ";;"; simpl.
        rewrite 2 interp_bind.
        eapply eutt_clo_bind.
          reflexivity.
          intros u1 u2 e.
          rewrite 2 interp_bind.
          eapply eutt_clo_bind.
          rewrite 2 interp_recursive_call.
          fold ev_whn.

      eapply eutt_clo_bind.
      - rewrite 2 interp_bind.
        Search translate.
        eapply eutt_translate'.
      Search translate.
  unfold lassen, ";;", iter, MonadIter_itree; simpl.
  rewrite 2 unfold_iter.
  rewrite 2 bind_bind.
  +
  Search ITree.iter.
  induction C.
    Search ITree.iter.
    rewrite 2 unfold_iter.
    rewrite 2 bind_bind; simpl.

  + rewrite plug_equation_1,plug_equation_1.
    exact (@RelationClasses.reflexivity _ _ (Reflexive_eqit eq _ _ _) _).
  + rewrite plug_equation_2,plug_equation_2.
    compute [lassen].
    rewrite unfold_iter,unfold_iter.
    Search ITree.iter.

**)


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.

                    From adtind Require Import goal49.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero Nil).
Definition lfind_example_2  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_3  := ( Cons (Succ (Succ Zero))         (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))).
Definition lfind_example_4  := ( Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_5  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_6  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_7  := ( Cons Zero         (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons Zero Nil)))).
Definition lfind_example_8  := ( Cons (Succ Zero)         (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ (Succ Zero))) Nil))).
Definition lfind_example_9  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_10  := ( Cons (Succ Zero) Nil).
Definition lfind_example_11  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_12  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_13  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_14  := ( Cons Zero Nil).
Definition lfind_example_15  := ( Cons Zero Nil).
Definition lfind_example_16  := ( Cons Zero Nil).
Definition lfind_example_17  := ( Cons (Succ Zero) Nil).
Definition lfind_example_18  := ( Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) Nil))).
Definition lfind_example_19  := ( Cons (Succ Zero) Nil).
Definition lfind_example_20  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_21  := ( Cons (Succ Zero) Nil).
Definition lfind_example_22  := ( Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero Nil)).
Definition lfind_example_23  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_24  := ( Cons Zero (Cons Zero (Cons Zero Nil))).
Definition lfind_example_25  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_26  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_27  := ( Cons (Succ Zero)         (Cons Zero (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)))).
Definition lfind_example_28  := ( Cons (Succ Zero) Nil).
Definition lfind_example_29  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_30  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_31  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_32  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_33  := ( Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil))).
Definition lfind_example_34  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) (Cons Zero Nil)))).
Definition lfind_example_35  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_36  := ( Cons (Succ (Succ (Succ (Succ Zero)))) Nil).
Definition lfind_example_37  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal49_mem_insort_113_mem_cons/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 lfind_example_34 lfind_example_35 lfind_example_36 lfind_example_37 .


(***************************************************************************
* Safety for STLC with References - Infrastructure                         *
* Arthur Chargueraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN STLC_Ref_Definitions.

(* ********************************************************************** *)
(** ** Additional Definitions used in the Proofs *)

(** Computing free variables of a term. *)

Fixpoint fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs t1    => (fv t1)
  | trm_app t1 t2 => (fv t1) \u (fv t2)
  | trm_unit      => \{}
  | trm_loc l     => \{}
  | trm_ref t1    => (fv t1)
  | trm_get t1    => (fv t1)
  | trm_set t1 t2 => (fv t1) \u (fv t2)
  end.

(** Substitution for names *)

Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs t1    => trm_abs (subst z u t1)
  | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2)
  | trm_unit      => trm_unit
  | trm_loc l     => trm_loc l
  | trm_ref t1    => trm_ref (subst z u t1)
  | trm_get t1    => trm_get (subst z u t1)
  | trm_set t1 t2 => trm_set (subst z u t1) (subst z u t2)
  end.

Notation "[ z ~> u ] t" := (subst z u t) (at level 68).

(** Definition of the body of an abstraction *)

Definition body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(* ********************************************************************** *)
(** ** Instanciation of Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : env => dom x) in
  let D := gather_vars_with (fun x : trm => fv x) in
  constr:(A \u B \u C \u D).

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; autos*.

Hint Constructors term sto_ok value red.

(* ********************************************************************** *)
(** ** Properties of substitution *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ;
  simpl in *; inversion* Equ; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_rec_term : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; f_equal*. unfolds open.
  pick_fresh x. apply* (@open_rec_term_core t1 0 (trm_fvar x)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_fresh : forall x t u,
  x \notin fv t ->  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; f_equal*. case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ ([x ~> u]t2).
Proof.
  intros. unfold open. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. case_var*. apply* open_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_open_var : forall x y u t, y <> x -> term u ->
  ([x ~> u]t) ^ y = [x ~> u] (t ^ y).
Proof.
  introv Neq Wu. rewrite* subst_open.
  simpl. case_var*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_intro : forall x t u,
  x \notin (fv t) -> term u ->
  t ^^ u = [x ~> u](t ^ x).
Proof.
  introv Fr Wu. rewrite* subst_open.
  rewrite* subst_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Lemma subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpls*.
  case_var*.
  apply_fresh term_abs as y. rewrite* subst_open_var.
Qed.

Hint Resolve subst_term.

(* ********************************************************************** *)
(** ** Terms are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> body t1.
Proof.
  intros. unfold body. inversion* H.
Qed.

Lemma body_to_term_abs : forall t1,
  body t1 -> term (trm_abs t1).
Proof.
  intros. inversion* H.
Qed.

Hint Resolve term_abs_to_body body_to_term_abs.

(** ** Opening a body with a term gives a term *)

Lemma open_term : forall t u,
  body t -> term u -> term (t ^^ u).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro y).
Qed.

Hint Resolve open_term.

(* ********************************************************************** *)
(** ** Well-formedness of store *)

Lemma sto_ok_binds : forall mu l t,
   sto_ok mu -> binds l t mu -> term t.
Proof.
  introv. gen mu. (*todo remove: applys env_ind; [ introv Ok B | introv IH Ok B ].*)
  induction mu as [|mu l1 t1] using env_ind; introv Ok B.
  false* binds_empty_inv.
  inverts Ok. false* empty_push_inv.
   forwards (?&?&?): (eq_push_inv (rm H)). subst.
   binds_cases B; subst~. (* todo: could simplify *)
Qed.

Hint Resolve sto_ok_binds.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** A typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

Lemma typing_regular : forall E P e T,
  typing E P e T -> ok E /\ term e.
Proof.
  split; induction H; autos*.
  pick_fresh y; forwards~ K: (H0 y).
Qed.

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall e,
  value e -> term e.
Proof.
  induction 1; autos*.
Qed.

(** A reduction relation only holds only on well-formed objects. *)

Lemma red_regular : forall c c',
  red c c' ->
     (term (fst c) /\ term (fst c'))
  /\ (sto_ok (snd c) /\ sto_ok (snd c')).
Proof.
  lets: value_regular. induction 1; simpl; jauto.
Qed.

(** Automation for reasoning on well-formedness. *)

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: typing E _ _ _ |- _ => apply (proj1 (typing_regular H))
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ _ t _ |- _ => apply (proj2 (typing_regular H))
  | H: red (t,_) _ |- _ => apply (proj1 (proj1 (red_regular H)))
  | H: red _ (t,_) |- _ => apply (proj2 (proj1 (red_regular H)))
  | H: value t |- _ => apply (value_regular H)
  end.

Hint Extern 1 (sto_ok ?mu) =>
  match goal with
  | H: red (_,mu) _ |- _ => apply (proj1 (proj2 (red_regular H)))
  | H: red _ (_,mu) |- _ => apply (proj2 (proj2 (red_regular H)))
  | H: sto_typing _ mu |- _ => apply (proj1 H)
  end.


Require Import FunctionalExtensionality Program Setoid.

Set Implicit Arguments.

Local Open Scope program_scope.

Class Monad (m : Type -> Type)
            (mequiv : forall {T : Type}, m T -> m T -> Prop)
            (ret : forall {A : Type}, A -> m A)
            (bind : forall {A B : Type}, m A -> (A -> m B) -> m B) : Prop := {
  (** Three laws that a monad instance must obey.
    Law 1:  return x >>= f ~ f x
    Law 2:  m >>= return ~ m
    Law 3:  (m >>= f) >>= g ~ m >>= (fun x -> f x >>= g) *)
  left_id :
    forall (A B : Type) (x : A) (f : A -> m B),
      mequiv (bind (ret x) f) (f x);

  right_id :
    forall (A : Type) (x : m A),
      mequiv (bind x ret) x;

  bind_assoc :
    forall (A B C : Type) (n : m A) (f : A -> m B) (g : B -> m C),
      mequiv (bind (bind n f) g) (bind n (fun x => bind (f x) g));

  equivalence :
    forall T, Equivalence (@mequiv T);

  congruence :
    forall {A B : Type} n (f g : A -> m B),
      (forall x, mequiv (f x) (g x)) -> mequiv (bind n f) (bind n g);
}.

Section MonadProperties.
  Generalizable All Variables.
  Context `{Monad m mequiv ret bind}.

  Infix "=~" := mequiv (at level 60, no associativity).
  Infix ">>=" := bind (at level 50, left associativity).

  Instance mequivEquivlence :
    forall T, Equivalence (@mequiv T).
  Proof.
    apply equivalence.
  Qed.

  Definition fmap {A B : Type} (f : A -> B) (n : m A) : m B :=
    n >>= (@ret B) ∘ f.

  Definition join {A : Type} (n : m (m A)) : m A :=
    n >>= id.

  Ltac revealer := unfold join, fmap, compose, id; intros.
  Ltac f_equal := apply congruence; intros.

  Theorem fmap_compose_join_eq_bind :
    forall (A B : Type) (n : m A) (f : A -> m B),
      n >>= f =~ join (fmap f n).
  Proof.
    revealer.
    rewrite bind_assoc. f_equal.
    rewrite left_id. reflexivity.
  Qed.

  (** Properties for Monad as a Functor. *)
  Theorem fmap_id :
    forall (A : Type) (n : m A),
      fmap id n =~ n.
  Proof.
    revealer.
    rewrite right_id. reflexivity.
  Qed.

  Theorem fmap_associativity :
    forall (A B C : Type) (f : A -> B) (g : B -> C) (n : m A),
      fmap (g ∘ f) n =~ fmap g (fmap f n).
  Proof.
    revealer.
    rewrite bind_assoc. f_equal.
    rewrite left_id. reflexivity.
  Qed.

  (** https://en.wikipedia.org/wiki/Monad_(functional_programming)#fmap_and_join *)
  Theorem return_property :
    forall (A B : Type) (f : A -> B) (x : A),
      ret (f x) =~ fmap f (ret x).
  Proof.
    revealer.
    rewrite left_id. reflexivity.
  Qed.

  Theorem join_property1 :
    forall (A : Type) (x : m (m (m A))),
      join (fmap join x) =~ join (join x).
  Proof.
    intros. rewrite <- fmap_compose_join_eq_bind.
    revealer.
    rewrite bind_assoc. reflexivity.
  Qed.

  Theorem join_property2 :
    forall (A : Type) (x : m A),
      join (fmap (@ret A) x) =~ x.
  Proof.
    intros. rewrite <- fmap_compose_join_eq_bind.
    rewrite right_id. reflexivity.
  Qed.

  Theorem join_property3 :
    forall (A : Type) (x : m A),
      join (ret x) =~ x.
  Proof.
    revealer.
    rewrite left_id. reflexivity.
  Qed.

  Theorem join_property4 :
    forall (A B : Type) (f : A -> B) (x : m (m A)),
      join (fmap (fmap f) x) =~ fmap f (join x).
  Proof.
    intros. rewrite <- fmap_compose_join_eq_bind.
    revealer.
    rewrite bind_assoc. reflexivity.
  Qed.
End MonadProperties.


(*
(C) Copyright 2010, COQTAIL team

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

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

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

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

(** Properties of real functions sequences. *)

Require Import Rsequence.
Require Import Ranalysis_def.
Require Import Rsequence_cv_facts.
Require Import Rsequence_tactics.
Require Import MyRIneq.
Require Import Canalysis_def.
Require Import Canalysis_deriv.
Require Import Cfunctions.
Require Import Csequence.
Require Import Csequence_facts.
Require Import CFsequence.
Require Import Cnorm.
Require Import Cprop_base.
Require Import Ctacfield.
Require Import Fourier.
Require Import Max.

Open Scope C_scope.

Lemma CFseq_cvu_derivable : forall (fn fn' : nat -> C -> C) (f g : C -> C) (z c : C) (r : posreal)
      (z_in : Boule c r z),
      (forall (x:C) (n:nat), Boule c r x -> derivable_pt_lim (fn n) x (fn' n x)) ->
      (CFseq_cv_boule fn f c r) ->
      (CFseq_cvu fn' g c r) ->
      (forall (x:C), Boule c r x -> continuity_pt g x) ->
      derivable_pt_lim f z (g z).
Proof.
intros fn fn' f g z c r z_in Dfn_eq_fn' fn_cv_f fn'_cvu_g g_cont eps eps_pos.
 assert (eps_8_pos : 0 < eps / 8) by fourier.
 destruct (g_cont z z_in (eps/8)%R eps_8_pos) as [delta1 H] ; clear g_cont ; destruct H as [delta1_pos g_cont].
 assert (delta_pos : 0 < Rmin ((r - (Cnorm (z - c))) / 2) delta1).
  apply Rmin_pos ; [| assumption].
  unfold middle, Rdiv ; apply Rlt_mult_inv_pos ; [| fourier].
  apply Rlt_Rminus ; rewrite Cnorm_minus_sym ; apply z_in.

 pose (delta := mkposreal (Rmin ((r - (Cnorm (z - c))) / 2) delta1) (delta_pos)).
 exists delta ; intros h h_neq h_ub.
 pose (eps' :=  ((Cnorm h) * eps / 4)%R).
 assert (eps'_pos : 0 < eps').
  unfold eps', Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat ;
  [apply Cnorm_pos_lt ; assumption | fourier].
 destruct (fn_cv_f z z_in eps' eps'_pos) as [Nz fnz_cv_fz].

assert (zh_in : Boule c r (z + h)).
 unfold Boule ; simpl ; unfold C_dist.
  unfold Cminus ; rewrite Copp_add_distr ; unfold Cminus ; rewrite <- Cadd_assoc ;
  apply Rle_lt_trans with (Cnorm (c - z) + Cnorm (-h))%R.
  apply Cnorm_triang.
  rewrite Cnorm_opp, Cnorm_minus_sym.
  apply Rlt_le_trans with (Cnorm (z - c) + delta)%R.
  apply Rplus_lt_compat_l ; assumption.
  apply Rle_trans with (Cnorm (z - c) + ((r - (Cnorm (z - c))) / 2))%R.
  apply Rplus_le_compat_l ; unfold delta ; apply Rmin_l.
  apply Rle_trans with ((Cnorm (z - c) + r) / 2)%R.
  right ; field.
  apply Rle_trans with ((r + r) / 2)%R.
  unfold Rdiv ; apply Rmult_le_compat_r ; [fourier |] ; apply Rplus_le_compat_r ;
  rewrite Cnorm_minus_sym ; left ; apply z_in.
  right ; field.

 destruct (fn_cv_f (z + h) zh_in eps' eps'_pos) as [Nzh fnzh_cv_fzh] ; clear fn_cv_f.

 destruct (fn'_cvu_g (eps/8)%R eps_8_pos) as [Ng fn'c_cvu_gc] ; clear fn'_cvu_g.

 pose (N := max (max Nz Nzh) Ng).
 assert (Main : Cnorm ((f (z+h) - fn N (z+h)) - (f z - fn N z) + (fn N (z+h) - fn N z - h * (g z))) < (Cnorm h)*eps).
 apply Rle_lt_trans with (Rplus (Cnorm (f (z + h) - fn N (z + h) - (f z - fn N z))) (Cnorm ((fn N (z + h) - fn N z - h * g z)))).
 apply Cnorm_triang.
 apply Rle_lt_trans with (Rplus (Rplus (Cnorm (f (z + h) - fn N (z + h))) (Cnorm (- (f z - fn N z))))
                                                            (Cnorm (fn N (z + h) - fn N z - h * g z))).
 apply Rplus_le_compat_r ; apply Cnorm_triang.
 rewrite Cnorm_opp.

apply Rlt_le_trans with (Rplus (Rplus eps' (Cnorm (f z - fn N z)))  (Cnorm (fn N (z + h) - fn N z - h * g z))).
 do 2 apply Rplus_lt_compat_r ; rewrite Cnorm_minus_sym ; apply fnzh_cv_fzh.
 unfold ge ; apply le_trans with (max Nz Nzh)%nat ; [apply le_max_r | apply le_max_l].

apply Rle_trans with (Rplus (Rplus eps' eps') (Cnorm (fn N (z + h) - fn N z - h * g z))).
 apply Rplus_le_compat_r ; apply Rplus_le_compat_l ; left ; rewrite Cnorm_minus_sym ;
 apply fnz_cv_fz ; unfold ge ; apply le_trans with (max Nz Nzh)%nat ; apply le_max_l.

apply Rle_trans with (Cnorm h * eps / 2 + Cnorm h * eps / 2)%R.
 apply Rle_trans with (Cnorm h * eps / 4 + Cnorm h * eps / 4 + Cnorm h * eps / 2)%R.
 apply Rplus_le_compat_l.

 assert (Interval_to_boule : forall (t: R), interval 0 1 t -> Boule c r (z + t * h)).
  intros t t_in ; unfold Boule ; simpl ; unfold C_dist.
  replace (c - (z + t * h)) with ((c - z) + - (t*h)).
  apply Rle_lt_trans with (Rplus (Cnorm (c - z)) (Cnorm (- (t*h)))) ;
  [apply Cnorm_triang | rewrite Cnorm_opp, Cnorm_Cmult].
  apply Rle_lt_trans with (Rplus (Cnorm (c - z)) (Cnorm h)).
  apply Rplus_le_compat_l ; rewrite <- Rmult_1_l ; apply Rmult_le_compat_r ;
  [apply Cnorm_pos | rewrite Cnorm_IRC_Rabs].
  clear -t_in ; destruct t_in as [t_lb [t_eq | t_ub]].
  left ; apply Rabs_def1 ; [| apply Rlt_le_trans with R0] ; fourier.
  subst ; rewrite Rabs_R1 ; right ; reflexivity.
  apply Rlt_le_trans with (Rplus (Cnorm (c - z)) delta) ;
  [apply Rplus_lt_compat_l ; assumption |].
  apply Rle_trans with (Rplus (Cnorm (c - z)) ((r - Cnorm (z - c)) / 2)) ;
  [apply Rplus_le_compat_l ; unfold delta ; apply Rmin_l |].
  rewrite Cnorm_minus_sym.
  field_simplify ; unfold Rdiv ; rewrite Rinv_1, Rmult_1_r.
  unfold Boule in z_in ; simpl in z_in ; unfold C_dist in z_in ;
  left ; rewrite Cnorm_minus_sym ;
 apply (proj2 (middle_is_in_the_middle _ _ z_in)).
 unfold Cminus ; rewrite Copp_add_distr ;
 rewrite Cadd_assoc ; reflexivity.

 assert (fn_deriv : forall t : R, interval 0 1 t -> derivable_pt (fn N) (z + t * h)).
  intros ; exists (fn' N (z + t * h)) ; apply Dfn_eq_fn'.
  apply Interval_to_boule ; assumption.

 destruct (MVT_Cre (fn N) z h fn_deriv h_neq) as [u [u_in_I Hu_bd]].
 destruct (MVT_Cim (fn N) z h fn_deriv h_neq) as [v [v_in_I Hv_bd]].

 apply Rle_trans with (Rmult (Cnorm h) (Rmult (Cnorm (fn N (z + h) - fn N z - h * g z)) (/ Cnorm h))).
 right ; field ; apply Cnorm_no_R0 ; assumption.

 unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_le_compat_l ;
 [apply Cnorm_pos |] ; rewrite <- Cnorm_inv, <- Cnorm_Cmult ; [| assumption].
 rewrite Cmult_minus_distr_r ; replace (h * g z * / h) with (g z) ; [| field ; assumption].
 rewrite <- Cproj_right with ((fn N (z + h) - fn N z) * / h), <- Cproj_right with (g z).
 apply Rle_trans with (Cnorm (Rminus (Cre ((fn N (z + h) - fn N z) * / h))  (Cre (g z)),
                                                    Rminus (Cim ((fn N (z + h) - fn N z) * / h)) (Cim (g z)))).
  right ; apply Cnorm_eq_compat ; CusingR.

apply Rle_trans with (Rplus (Cnorm ((Cre ((fn N (z + h)%C - fn N z) * / h) - Cre (g z))%R, R0))
        (Cnorm ((R0 , (Cim ((fn N (z + h)%C - fn N z) * / h) - Cim (g z))%R)))).
 apply Rle_trans with (Cnorm (((Cre ((fn N (z + h)%C - fn N z) * / h) - Cre (g z))%R, R0)
   + (R0, (Cim ((fn N (z + h)%C - fn N z) * / h) - Cim (g z))%R))).
  right ; apply Cnorm_eq_compat ; CusingR.
  apply Cnorm_triang.
 rewrite Cnorm_Cre_simpl, Cnorm_Cim_simpl.
 unfold Cdiv in Hu_bd, Hv_bd ; rewrite Hu_bd, Hv_bd.

apply Rle_trans with (eps/4 + Rabs (Cim (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I)) - Cim (g z)))%R.
apply Rplus_le_compat_r.
apply Rle_trans with (Rabs ((Cre (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I)) - Cre (g (z + u * h)))
                                                      +  (Cre (g (z + u * h)) - Cre (g z)))).
 right ; apply Rabs_eq_compat ; ring.
 apply Rle_trans with (Rplus (Rabs (Cre (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I)) - Cre (g (z + u * h))))
                                (Rabs (Cre (g (z + u * h)) - Cre (g z)))) ; [apply Rabs_triang |].
 do 2 rewrite Cre_minus_compat.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I) - g (z + u * h)))
                                (Rabs (Cre (g (z + u * h) - g z)))).
 apply Rplus_le_compat_r ; apply Cre_le_Cnorm.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I) - g (z + u * h)))
                                (Cnorm (g (z + u * h) - g z))).
 apply Rplus_le_compat_l ; apply Cre_le_Cnorm.

apply Rle_trans with (Rplus (eps / 8) (Cnorm (g (z + u * h) - g z))).
apply Rplus_le_compat_r.

assert (zuh_in : Boule c r (z + u *h)).
 apply Interval_to_boule ; assumption.
 rewrite (derive_pt_eq_0 _ _ _ (fn_deriv u u_in_I) (Dfn_eq_fn' _ N zuh_in)).
 unfold C_dist in fn'c_cvu_gc ; left ; apply fn'c_cvu_gc ;
 [unfold N ; apply le_max_r |] ; assumption.

apply Rle_trans with (eps / 8 + eps / 8)%R ; [apply Rplus_le_compat_l | right ; field].

destruct (proj1 u_in_I) as [u_neq | u_eq].

left ; simpl in g_cont ; unfold C_dist in g_cont ; apply g_cont ; split.
unfold Cderiv.D_x, no_cond ; split ; [trivial |].
 clear - u_neq h_neq.
 intro Hf ; symmetry in Hf ; generalize Hf ; clear Hf ; apply Cadd_neq_compat_l.
 apply  Cmult_integral_contrapositive_currified ;
 [apply IRC_neq_compat ; apply Rgt_not_eq |] ; assumption.

 replace (z + u * h - z) with (u * h).
 rewrite Cnorm_Cmult ; apply Rlt_le_trans with (1 * delta)%R.
 apply Rlt_le_trans with (Cnorm u * delta)%R.
 apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; apply IRC_neq_compat ;
 apply Rgt_not_eq |] ; assumption.
 apply Rmult_le_compat_r ; [left ; assumption |].
 rewrite Cnorm_IRC_Rabs.
  clear -u_in_I ; destruct u_in_I as [u_lb [u_eq | u_ub]].
  left ; apply Rabs_def1 ; [| apply Rlt_le_trans with R0] ; fourier.
  subst ; rewrite Rabs_R1 ; right ; reflexivity.
  rewrite Rmult_1_l ; unfold delta ; apply Rmin_r.

 ring.

subst ; rewrite Cmult_0_l, Cadd_0_r ; unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ;
 left ; assumption.

apply Rle_trans with (eps / 4 +  eps/4)%R ; [apply Rplus_le_compat_l | right ; field].

apply Rle_trans with (Rabs ((Cim (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I)) - Cim (g (z + v * h)))
                                                      +  (Cim (g (z + v * h)) - Cim (g z)))).
 right ; apply Rabs_eq_compat ; ring.
 apply Rle_trans with (Rplus (Rabs (Cim (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I)) - Cim (g (z + v * h))))
                                (Rabs (Cim (g (z + v * h)) - Cim (g z)))) ; [apply Rabs_triang |].
 do 2 rewrite Cim_minus_compat.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I) - g (z + v * h)))
                                (Rabs (Cim (g (z + v * h) - g z)))).
 apply Rplus_le_compat_r ; apply Cim_le_Cnorm.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I) - g (z + v * h)))
                                (Cnorm (g (z + v * h) - g z))).
 apply Rplus_le_compat_l ; apply Cim_le_Cnorm.

apply Rle_trans with (Rplus (eps / 8) (Cnorm (g (z + v * h) - g z))).
apply Rplus_le_compat_r.

assert (zvh_in : Boule c r (z + v *h)).
 apply Interval_to_boule ; assumption.
 rewrite (derive_pt_eq_0 _ _ _ (fn_deriv v v_in_I) (Dfn_eq_fn' _ N zvh_in)).
 unfold C_dist in fn'c_cvu_gc ; left ; apply fn'c_cvu_gc ;
 [unfold N ; apply le_max_r |] ; assumption.

apply Rle_trans with (eps / 8 + eps / 8)%R ; [apply Rplus_le_compat_l | right ; field].

destruct (proj1 v_in_I) as [v_neq | v_eq].

left ; simpl in g_cont ; unfold C_dist in g_cont ; apply g_cont ; split.
unfold Cderiv.D_x, no_cond ; split ; [trivial |].
 clear - v_neq h_neq.
 intro Hf ; symmetry in Hf ; generalize Hf ; clear Hf ; apply Cadd_neq_compat_l.
 apply  Cmult_integral_contrapositive_currified ;
 [apply IRC_neq_compat ; apply Rgt_not_eq |] ; assumption.

 replace (z + v * h - z) with (v * h).
 rewrite Cnorm_Cmult ; apply Rlt_le_trans with (1 * delta)%R.
 apply Rlt_le_trans with (Cnorm v * delta)%R.
 apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; apply IRC_neq_compat ;
 apply Rgt_not_eq |] ; assumption.
 apply Rmult_le_compat_r ; [left ; assumption |].
 rewrite Cnorm_IRC_Rabs.
  clear -v_in_I ; destruct v_in_I as [v_lb [v_eq | v_ub]].
  left ; apply Rabs_def1 ; [| apply Rlt_le_trans with R0] ; fourier.
  subst ; rewrite Rabs_R1 ; right ; reflexivity.
  rewrite Rmult_1_l ; unfold delta ; apply Rmin_r.

 ring.

subst ; rewrite Cmult_0_l, Cadd_0_r ; unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ;
 left ; assumption.

right ; field.
right ; field.

apply Rle_lt_trans with (Rmult (Cnorm ((f (z + h)  - f z) - h * g z)) (/ Cnorm h)).
rewrite <- Cnorm_inv, <- Cnorm_Cmult ; [| assumption] ; right ; apply Cnorm_eq_compat ;
 field ; assumption.

apply Rle_lt_trans with (Rmult (Cnorm (f (z + h) - fn N (z + h) - (f z - fn N z) +
          (fn N (z + h) - fn N z - h * g z))) (/ Cnorm h)).
right ; apply Rmult_eq_compat_r ; apply Cnorm_eq_compat ; ring.

apply Rlt_le_trans with ((Cnorm h * eps) * / Cnorm h)%R.
apply Rmult_lt_compat_r ; [rewrite <- Cnorm_inv ; [apply Cnorm_pos_lt ;
 apply Cinv_neq_0_compat |] |] ; assumption.

 right ; field ; apply Cnorm_no_R0 ; assumption.
Qed.

Definition SFL_interv (fn:nat -> C -> C) (r:posreal)
  (cv : forall z : C, Boule 0 r z -> {l:C | Cseq_cv (fun N:nat => CFpartial_sum (fun n => fn n z) N) l }) (y:C) : C.
Proof.
intros fn r cv z.
 destruct (Rlt_le_dec (Cnorm (0 - z)) r) as [z_bd | z_lb].
 unfold Boule in cv ; simpl in cv ; unfold C_dist in cv ;
 destruct (cv _ z_bd) as (l, _) ; apply l.
 exact 0.
Defined.

Lemma SFL_interv_right : forall fn r cv y, Boule 0 r y ->
     Cseq_cv (fun N:nat => CFpartial_sum (fun n => fn n y) N) (SFL_interv fn r cv y).
Proof.
intros fn r cv z z_bd ; unfold SFL_interv ;
 destruct (Rlt_le_dec (Cnorm (0 - z)) r) as [z_bd2 | z_lb].
 destruct (cv z z_bd2) as [l Hl] ; assumption.
 assert (Hf : Cnorm (0 - z) < Cnorm (0 - z)).
  apply Rlt_le_trans with r ; unfold Boule in * ; assumption.
 elim (Rlt_irrefl _ Hf).
Qed.

Lemma Rlt_minus_exchange : forall a b c, a - b < c -> a - c < b.
Proof.
intros a b c H ; fourier.
Qed.

Lemma Rlt_plus_exchange : forall a b c,  a - b < c  -> a < b + c.
Proof.
intros a b c H ; fourier.
Qed.

Lemma sum_cv_maj : forall (An : nat -> R) (fn : nat -> C -> C) (z l1 : C) (l2 : R),
       Cseq_cv (fun n : nat => CFpartial_sum (fun n => fn n z) n) l1 ->
       Rseq_cv (fun n : nat => sum_f_R0 An n) l2 ->
       (forall n : nat, Cnorm (fn n z) <= An n) -> Cnorm l1 <= l2.
Proof.
intros An fn z l1 l2 fn_cv An_cv fn_bd.
 destruct (Rle_lt_dec (Cnorm l1) l2) as [H | Hf].
  assumption.
  pose (eps := ((Cnorm l1 - l2) / 4)%R) ;
  assert (eps_pos : 0 < eps).
   unfold eps, Rdiv ; apply Rlt_mult_inv_pos ; fourier.
  destruct (fn_cv _ eps_pos) as [Nfn Hfn] ;
  destruct (An_cv _ eps_pos) as [NAn HAn].
  pose (N := max Nfn NAn).
  assert (Main : Cnorm l1 - eps < l2 + eps).
   apply Rlt_trans with (Cnorm (CFpartial_sum (fun n : nat => fn n z) N)).
   apply Rlt_minus_exchange ; apply Rle_lt_trans with (Cnorm (CFpartial_sum (fun n : nat => fn n z) N - l1)) ;
   [apply Cnorm_triang_rev_r | apply Hfn ;  apply le_max_l].
   apply Rle_lt_trans with (Rabs (sum_f_R0 An N)).
   apply Rle_trans with (sum_f_R0 (fun n => Cnorm (fn n z)) N).
   unfold CFpartial_sum ; apply sum_f_C0_triang.
   clear - fn_bd ; induction N.
   simpl ; rewrite Rabs_right ; [| apply Rle_ge ; apply Rle_trans with (Cnorm (fn O z)) ;
   [apply Cnorm_pos |] ] ; apply fn_bd.
   simpl ; rewrite Rabs_right.
   apply Rle_trans with (Rplus (sum_f_R0 An N) (Cnorm (fn (S N) z))) ;
   [apply Rplus_le_compat_r ; rewrite <- Rabs_right ; [apply IHN |] |
   apply Rplus_le_compat_l ; apply fn_bd].
   apply Rle_ge ; apply cond_pos_sum.
   intro n ; apply Rle_trans with (Cnorm (fn n z)) ; [apply Cnorm_pos | apply fn_bd].
   rewrite <- tech5 ; apply Rle_ge ; apply cond_pos_sum.
   intro n ; apply Rle_trans with (Cnorm (fn n z)) ; [apply Cnorm_pos | apply fn_bd].
   apply Rlt_plus_exchange.
   apply Rle_lt_trans with (R_dist (sum_f_R0 An N) l2).
   apply Rle_trans with (Rminus (Rabs (sum_f_R0 An N)) (Rabs l2)).
   replace (Rabs l2) with l2.
   right ; reflexivity.
   symmetry ; apply Rabs_right.
   apply Rle_ge ; apply Rseq_limit_comparison with (fun _ => R0)  (fun n : nat => sum_f_R0 An n).
   intros n ; apply cond_pos_sum ; intro n' ; apply Rle_trans with (Cnorm (fn n' z)) ;
   [apply Cnorm_pos | apply fn_bd].
   intros ; exists O ; intros ; simpl ; unfold R_dist ; rewrite Rminus_0_r, Rabs_R0 ; assumption.
   assumption.
   unfold R_dist ; apply Rabs_triang_inv.
   apply HAn ; apply le_max_r.
   assert (Cnorm l1 < Cnorm l1).
   apply Rlt_trans with (l2 + 2 * eps)%R.
   fourier.
   unfold eps.
   apply Rle_lt_trans with ((Cnorm l1 + l2) / 2)%R.
   right ; field.
   rewrite Rplus_comm ; apply (middle_is_in_the_middle _ _ Hf).
   elim (Rlt_irrefl _ H).
Qed.

Definition Csigma f low high := sum_f_C0 (fun n : nat => f (low + n)%nat) (high - low).

Lemma   Csigma_split : forall (f : nat -> C) (low high k : nat),
       (low <= k)%nat ->  (k < high)%nat ->
       Csigma f low high = (Csigma f low k + Csigma f (S k) high).
Proof.
intros f low high k l_le_k k_lt_h.
 unfold Csigma.
 apply (proj1 (Ceq _ _)) ; split.
 rewrite <- Cre_add_compat ; do 3 rewrite <- sum_f_C0_Cre_compat.
 assert (H := sigma_split (fun n => Cre (f n))  l_le_k k_lt_h) ;
 unfold sigma in H ; assumption.
 rewrite <- Cim_add_compat ; do 3 rewrite <- sum_f_C0_Cim_compat.
 assert (H := sigma_split (fun n => Cim (f n))  l_le_k k_lt_h) ;
 unfold sigma in H ; assumption.
Qed.

Lemma sum_maj1 : forall (fn : nat -> C -> C) (An : nat -> R) (x l1: C) (l2 : R) (N : nat),
       Cseq_cv (fun n : nat => CFpartial_sum (fun n => fn n x) n) l1 ->
       Rseq_cv (fun n : nat => sum_f_R0 An n) l2 ->
       (forall n : nat, Cnorm (fn n x) <= An n) ->
       Cnorm (l1 - CFpartial_sum (fun n => fn n x) N) <= l2 - sum_f_R0 An N.
Proof.
  intros fn An x l1 l2 N fn_cv An_cv fn_bd ;
    cut { l:C | Cseq_cv (fun n => sum_f_C0 (fun l => fn (S N + l)%nat x) n) l }.
  intro X;
    cut { l:R | Rseq_cv (fun n => sum_f_R0 (fun l => An (S N + l)%nat) n) l }.
  intro X0; elim X; intros l1N H2.
  elim X0; intros l2N H3.
  cut (l1 - CFpartial_sum (fun n => fn n x) N = l1N).
  intro Temp; cut (Rminus l2 (sum_f_R0 An N) = l2N).
  intro Temp2; rewrite Temp, Temp2.
  apply sum_cv_maj with (fun n => An (S N + n)%nat) (fun I => fn (S N + I)%nat) x.
  assumption.
  assumption.
  intro n ; apply fn_bd.
  symmetry ; eapply Rseq_cv_unique.
  apply H3.
  unfold Rseq_cv in An_cv |-* ; intros eps eps_pos ; destruct (An_cv _ eps_pos)
  as [N' HN'] ; exists N' ; intros n n_lb.
  unfold R_dist ;
    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))%R
    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2)%R;
      [| ring ].
  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n)%R with
  (sum_f_R0 An (S (N + n)))%R.
  apply HN' ; intuition.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := sigma_split An N_pos N_ub) ; unfold sigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (sum_f_R0 An (S (N + n))) with
  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition.
  rewrite Hrew in H.
  apply H.
  apply sum_eq; intros ;  reflexivity.
  apply sum_eq; intros ;  reflexivity.
  symmetry ; eapply Cseq_cv_unique.
  apply H2.
  unfold Rseq_cv in fn_cv |-* ; intros eps eps_pos ; destruct (fn_cv _ eps_pos)
  as [N' HN'] ; exists N' ; intros n n_lb.
  unfold R_dist ;
    replace (sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n - (l1 -  CFpartial_sum (fun n0 : nat => fn n0 x) N))
    with ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n) - l1);
      [| ring ].
      replace ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n))
      with (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)%nat).
  apply HN' ; intuition.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := Csigma_split (fun n => fn n x) O (S (N + n)) N N_pos N_ub) ; unfold Csigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)) with
  (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) (S (N + n))).
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) N) with (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition.
  rewrite Hrew in H.
  apply H.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.

  exists (l2 - sum_f_R0 An N)%R.
   unfold Rseq_cv in An_cv |-* ; intros eps eps_pos ; destruct (An_cv _ eps_pos)
  as [N' HN'] ; exists N' ; intros n n_lb.
  unfold R_dist ;
    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))%R
    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2)%R;
      [| ring ].
  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n)%R with
  (sum_f_R0 An (S (N + n)))%R.
  apply HN' ; intuition.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := sigma_split An N_pos N_ub) ; unfold sigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (sum_f_R0 An (S (N + n))) with
  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition.
  rewrite Hrew in H.
  apply H.
  apply sum_eq; intros ;  reflexivity.
  apply sum_eq; intros ;  reflexivity.

  exists (l1 - CFpartial_sum (fun n => fn n x) N).

 intros eps eps_pos ; destruct (fn_cv _ eps_pos) as [N' HN'] ; exists N' ; intros n n_lb.

    replace (sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n - (l1 -  CFpartial_sum (fun n0 : nat => fn n0 x) N))
    with ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n) - l1);
      [| ring ].
      replace ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n))
      with (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)%nat).
  apply HN' ; intuition.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := Csigma_split (fun n => fn n x) O (S (N + n)) N N_pos N_ub) ; unfold Csigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)) with
  (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) (S (N + n))).
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) N) with (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition.
  rewrite Hrew in H.
  apply H.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.
Qed.

Lemma CVN_CVU_boule :forall (fn : nat -> C -> C) (r : posreal)
       (cv : forall z : C,  Boule 0 r z -> {l : C | Cseq_cv (fun N : nat => CFpartial_sum (fun n => fn n z) N) l}),
       CVN_r fn r ->
       CFseq_cvu (fun N  z => CFpartial_sum (fun n => fn n z) N) (SFL_interv fn r cv) 0 r.
Proof.
intros fn r cv cvn eps eps_pos.

 destruct cvn as [An [l [sum_cv fn_bd]]] ;
 destruct (sum_cv eps eps_pos) as [N HN] ;
 exists N ; intros n y n_lb y_bd.
 unfold SFL_interv.
 destruct (Rlt_le_dec (Cnorm (0 - y)) r) as [y_bd2 | y_lb].

  destruct (cv y y_bd2) as [l2 Hl2] ; unfold C_dist.

 apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k => Cnorm (An k)) n - l)).
  rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Cnorm (An k)) n - l));
    rewrite Ropp_minus_distr';
      rewrite (Rabs_right (l - sum_f_R0 (fun k:nat => Cnorm (An k)) n)).
  rewrite Cnorm_minus_sym ; eapply sum_maj1.
  apply Hl2.
  apply sum_cv.
  intros ; apply fn_bd ; assumption.
  apply Rge_minus ; apply Rle_ge ; apply sum_incr.
  assumption.
  intros ; apply Cnorm_pos.
  unfold R_dist in HN ; apply HN ; assumption.

unfold Boule in y_bd ; simpl in y_bd ; unfold C_dist in y_bd.
 assert (Hf : Cnorm (0 - y) < Cnorm (0 - y)).
  apply Rlt_le_trans with r ; assumption.
 destruct (Rlt_irrefl _ Hf).
Qed.

Lemma CVU_continuity_boule :forall (fn : nat -> C -> C) (f : C -> C) (c : C) (r : posreal),
       CFseq_cvu fn f c r ->
       (forall n z, Boule c r z -> continuity_pt (fn n) z) ->
       forall z, Boule c r z -> continuity_pt f z.
Proof.
intros fn f c r fn_cvu fn_cont z z_in.
 intros eps eps_pos ; assert (eps_3_pos : 0 < (eps / 3)%R) by fourier ;
 destruct (fn_cvu _ eps_3_pos) as [N HN] ;
 destruct (fn_cont N z z_in _ eps_3_pos) as [delta1 [delta1_pos Hdelta]].
 pose (delta := Rmin delta1 ((r - Cnorm (c - z))/2)) ;
 assert (delta_pos : 0 < delta).
  unfold delta ; apply Rmin_pos.
  assumption.
  unfold Rdiv ; apply Rlt_mult_inv_pos ; [apply Rlt_Rminus ; apply z_in | fourier].
  exists delta ; split ; [assumption | intros x [_  Hx]].
  simpl ; unfold C_dist.
  apply Rle_lt_trans with (Cnorm (f x - fn N x) + Cnorm (fn N x - fn N z) + Cnorm (fn N z  - f z))%R.
  replace (f x - f z)%C with ((f x - fn N x) + (fn N x - fn N z) + (fn N z - f z))%C by ring.
  apply Rle_trans with (Cnorm ((f x - fn N x) + (fn N x - fn N z)) + Cnorm (fn N z - f z))%R ;
  [| apply Rplus_le_compat_r] ;  apply Cnorm_triang.
  apply Rlt_trans with (Cnorm (f x - fn N x) + Cnorm (fn N x - fn N z) + (eps/3))%R.
  apply Rplus_lt_compat_l ; apply HN ; trivial.
  apply Rlt_trans with (eps/3 + Cnorm (fn N x - fn N z) + eps / 3)%R.
  do 2 apply Rplus_lt_compat_r ; rewrite Cnorm_minus_sym ; apply HN ; trivial.
 unfold Boule in * ; simpl in * ; unfold C_dist in *.
 replace (c - x)%C with ((c - z) + - (x - z))%C by ring.
 apply Rle_lt_trans with (Cnorm (c - z) + Cnorm (- (x - z)))%R ;
 [apply Cnorm_triang | rewrite Cnorm_opp].
 apply Rlt_trans with (Cnorm (c - z) + delta)%R ;
 [apply Rplus_lt_compat_l ; assumption |].
 apply Rle_lt_trans with (Cnorm (c - z) +  (r - Cnorm (c - z))/2)%R ;
 [apply Rplus_le_compat_l ; apply Rmin_r |].
 field_simplify ; unfold Rdiv ; rewrite Rinv_1, Rmult_1_r.
 apply (middle_is_in_the_middle _ _ z_in).
 destruct (Ceq_dec x z) as [eq | neq].
 subst ; unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ; fourier.
 apply Rlt_le_trans with (eps/3 + eps/3 + eps/3)%R ; [| right ; field].
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l ; simpl in Hdelta ; apply Hdelta ; split.
 unfold Cderiv.D_x, no_cond ; split ; auto.
 apply Rlt_le_trans with delta ; [apply Hx | unfold delta ; apply Rmin_l].
Qed.