Require Import Coq.Logic.FunctionalExtensionality.
Require Import Eqdep_dec.
Require Import ProofIrrelevance.

Require Import foltl.
Require Import dec.
Require Import finite.
Require Import set.
Require Import env.
Require Import varset.
Require Import fosem.
Require Import vars.

  Fixpoint getEx `{Sg: Sig} (f: formula Sg): VarSet Sg :=
  match f with
  | Ex _ s v f => vsAdd _ v (getEx f)
  | _ => vsEmpty _
  end.

  Fixpoint getAll `{Sg: Sig} (f: formula Sg): VarSet Sg :=
  match f with
  | All _ s v f => vsAdd _ v (getAll f)
  | _ => vsEmpty _
  end.

  Fixpoint EX `{Sg: Sig} (f: formula Sg): formula Sg :=
  match f with
  | Ex _ s v f => EX f
  | _ => f
  end.

  Fixpoint ALL `{Sg: Sig} (f: formula Sg): formula Sg :=
  match f with
  | All _ s v f => ALL f
  | _ => f
  end.

  Definition EX_ALL `{Sg: Sig} (f: formula Sg): formula Sg :=
    ALL (EX f).

  Program Definition mkEx `{Sg: Sig} (vs: VarSet Sg) (f: formula Sg) :=
    IEx Sg (vsFinite Sg vs) (fun k => projT1 k) (fun k => projT2 k) f.

  Program Definition mkAll `{Sg: Sig} (vs: VarSet Sg) (f: formula Sg) :=
    IAll Sg (vsFinite Sg vs) (fun k => projT1 k) (fun k => projT2 k) f.

  Ltac psemTac :=
    match goal with
      H:psem _ _ ?sa |- psem _ _ ?sa' => assert (sa' = sa) as ae;
          try (rewrite ae; assumption); (apply functional_extensionality_dep; intros)
    end.

  Lemma iaddEmpty: forall `{Sg: Sig} (D: Dom Sg) sk vk dk (env: Env Sg D),
    iadd Sg (vsFinite Sg (vsEmpty Sg)) sk vk dk env = env.
  Proof.
    intros.
    apply functional_extensionality_dep; intro s.
    apply functional_extensionality_dep; intro v.
    unfold iadd; simpl.
    match goal with |- match ?cnd with _=>_ end =_=> destruct cnd; simpl; auto end.
    destruct s0; simpl in *.
    destruct x.
    destruct e; tauto.
  Qed.

  Lemma foldl_empty: forall `(T: EqDec) R (f: R -> T -> R) (a: R) (l: list T),
    SV.is_empty l -> List.fold_left f l a = a.
  Proof.
    intros.
    destruct l; simpl; auto.
    exfalso; apply (H e); simpl; auto.
  Qed.

  Lemma foldr_empty: forall `(T: EqDec) R (f: T -> R -> R) (a: R) (l: list T),
    SV.is_empty l -> List.fold_right f a l = a.
  Proof.
    intros.
    destruct l; simpl; auto.
    exfalso; apply (H e); simpl; auto.
  Qed.

  Lemma addlEmpty: forall `{Sg: Sig} (D: Dom Sg) sk vk dk (env: Env Sg D),
    addl Sg (vsFinite Sg (vsEmpty Sg)) sk vk dk env = env.
  Proof.
    intros.
    unfold addl.
    apply functional_extensionality_dep; intro s.
    apply functional_extensionality_dep; intro v.
    destruct (last_dec
     (fun k : vsFinite Sg (vsEmpty Sg) => isEq2 (sk k) (vk k) s v)); auto.
    destruct s0 as [[k h1] h2].
    destruct h1.
    destruct s0.
  Qed.

  Lemma addrEmpty: forall `{Sg: Sig} (D: Dom Sg) sk vk dk (env: Env Sg D),
    addr Sg (vsFinite Sg (vsEmpty Sg)) sk vk dk env = env.
  Proof.
    intros.
    unfold addr.
    apply functional_extensionality_dep; intro s.
    apply functional_extensionality_dep; intro v.
    destruct (first_dec
     (fun k : vsFinite Sg (vsEmpty Sg) => isEq2 (sk k) (vk k) s v)); auto.
    destruct s0 as [[k h1] h2].
    destruct h1.
    destruct s0.
  Qed.

  Ltac fm_semTac :=
    match goal with
      H: fm_sem _ ?e1 ?f ?t |- fm_sem _ ?e2 ?f ?t => assert (e1 = e2) as eeq;
        try (rewrite eeq in H; assumption);
        apply functional_extensionality_dep; intro;
        apply functional_extensionality_dep; intro
    end.

  Lemma tm_iaddEmpty: forall `{Sg: Sig} {D: Dom Sg} (Itp: Interp D) {s} (tm: term Sg s) sk vk dk (env: Env _ D),
    tm_sem Sg
      (iadd Sg (vsFinite Sg (vsEmpty Sg))
         sk vk dk env) tm = tm_sem Sg env tm.
  Proof.
    intros.
    rewrite (iaddEmpty D); auto.
  Qed.

  Lemma tm_addlEmpty: forall `{Sg: Sig} {D: Dom Sg} (Itp: Interp D) {s} (tm: term Sg s) sk vk dk (env: Env _ D),
    tm_sem Sg
      (addl Sg (vsFinite Sg (vsEmpty Sg))
         sk vk dk env) tm = tm_sem Sg env tm.
  Proof.
    intros.
    rewrite (addlEmpty D); auto.
  Qed.

  Lemma tm_addrEmpty: forall `{Sg: Sig} {D: Dom Sg} (Itp: Interp D) {s} (tm: term Sg s) sk vk dk (env: Env _ D),
    tm_sem Sg
      (addr Sg (vsFinite Sg (vsEmpty Sg))
         sk vk dk env) tm = tm_sem Sg env tm.
  Proof.
    intros.
    rewrite (addrEmpty D); auto.
  Qed.

  Lemma at_iaddEmpty: forall `{Sg: Sig} {D: Dom Sg} (Itp: Interp D) sk vk dk (env: Env _ D) (a: atom Sg) t,
    at_sem Sg
      (iadd Sg (vsFinite Sg (vsEmpty Sg))
         sk vk dk env) a t <-> at_sem Sg env a t.
  Proof.
    intros.
    rewrite (iaddEmpty D); reflexivity.
  Qed.

  Lemma at_laddEmpty: forall `{Sg: Sig} {D: Dom Sg} (Itp: Interp D) sk vk dk (env: Env _ D) (a: atom Sg) t,
    at_sem Sg
      (addl Sg (vsFinite Sg (vsEmpty Sg))
         sk vk dk env) a t <-> at_sem Sg env a t.
  Proof.
    intros.
    rewrite (addlEmpty D); reflexivity.
  Qed.

  Lemma at_raddEmpty: forall `{Sg: Sig} {D: Dom Sg} (Itp: Interp D) sk vk dk (env: Env _ D) (a: atom Sg) t,
    at_sem Sg
      (addr Sg (vsFinite Sg (vsEmpty Sg))
         sk vk dk env) a t <-> at_sem Sg env a t.
  Proof.
    intros.
    rewrite (addrEmpty D); reflexivity.
  Qed.

  Lemma fm_iaddEmpty: forall `{Sg: Sig} {D: Dom Sg} (Itp: Interp D) sk vk dk (f: formula Sg) (env: Env _ D)  t,
    fm_sem Sg
      (iadd Sg (vsFinite Sg (vsEmpty Sg))
         sk vk dk env) f t <-> fm_sem Sg env f t.
  Proof.
    intros.
    rewrite (iaddEmpty D); reflexivity.
  Qed.

  Lemma fm_addlEmpty: forall `{Sg: Sig} {D: Dom Sg} (Itp: Interp D) sk vk dk (f: formula Sg) (env: Env _ D)  t,
    fm_sem Sg
      (addl Sg (vsFinite Sg (vsEmpty Sg))
         sk vk dk env) f t <-> fm_sem Sg env f t.
  Proof.
    intros.
    rewrite (addlEmpty D); reflexivity.
  Qed.

  Lemma fm_addrEmpty: forall `{Sg: Sig} {D: Dom Sg} (Itp: Interp D) sk vk dk (f: formula Sg) (env: Env _ D)  t,
    fm_sem Sg
      (addr Sg (vsFinite Sg (vsEmpty Sg))
         sk vk dk env) f t <-> fm_sem Sg env f t.
  Proof.
    intros.
    rewrite (addrEmpty D); reflexivity.
  Qed.

  Lemma IEx_empty: forall `{Sg: Sig} (D: Dom Sg) (Itp: Interp D) sk vk f (env: Env Sg D) t,
    fm_sem Sg env (IEx Sg (vsFinite Sg (vsEmpty Sg)) sk vk f) t <-> fm_sem Sg env f t.
  Proof.
    intros; simpl; split; intros; auto.
    apply IEx_sem in H.
    destruct H as [dk H].
    rewrite (addlEmpty D) in H; auto.

    apply IEx_sem.
    exists (fun (k : {x : Sort & {_ : variable x | False}}) =>
      match proj2_sig (projT2 k) with end); auto.
   rewrite (addlEmpty D); auto.
  Qed.

  Lemma not_not: forall (P:Prop), ~ (~ P) <-> P.
  Proof.
    intros.
    tauto.
  Qed.

  Lemma Not_mkAll: forall `{Sg: Sig} e (f: formula Sg),
    Not Sg (mkAll e f) = mkEx e (Not _ f).
  Proof.
    unfold mkAll, mkEx.
    induction f; simpl; intros; auto; apply (Not_IAll Sg).
  Qed.

  Lemma Not_ALL: forall `{Sg: Sig} (f: formula Sg),
    (Not Sg (ALL f)) = EX (Not _ f).
  Proof.
    induction f; simpl; intros; auto.
  Qed.

  Lemma getEx_Not: forall `{Sg: Sig} (f: formula Sg),
    getEx (Not Sg f) = getAll f.
  Proof.
    induction f; simpl; intros; auto.
    rewrite IHf; auto.
  Qed.

  Definition getExAll `{Sg: Sig} (f: formula Sg) := let g := EX f in (getEx f, getAll g).

  Lemma getEx_equiv: forall `{Sg: Sig} (D: Dom Sg) (Itp: Interp D) e,
    forall (f1 f2: formula Sg), (forall env t, fm_sem Sg env f1 t <-> fm_sem Sg env f2 t) ->
      (forall env t, fm_sem Sg env (mkEx e f1) t <-> fm_sem Sg env (mkEx e f2) t).
  Proof.
    unfold mkEx; simpl; intros; split; intros.
    apply IEx_sem in H0; apply IEx_sem.
    destruct H0 as [dk H0].
    exists dk.
    revert H0; apply H.
    apply IEx_sem in H0; apply IEx_sem.
    destruct H0 as [dk H0].
    exists dk.
    revert H0; apply H.
  Qed.

  Lemma isAll_Prop: forall `{Sg: Sig} (f: formula Sg),
    isAll _ f -> isProp _ (ALL f).
  Proof.
    induction f; simpl; intros; auto.
  Qed.

  Lemma isExAll_Prop: forall `{Sg: Sig} (f: formula Sg),
    isExAll _ f -> isProp _ (EX_ALL f).
  Proof.
    induction f; simpl; intros; auto.
    unfold EX_ALL in *; simpl in *; auto.
    apply isAll_Prop; auto.
  Qed.

  Lemma mkAll_sem: forall `{Sg: Sig} (D: Dom Sg) (Itp: Interp D) (f: formula Sg) vars t,
    (forall env, fm_sem Sg env (mkAll vars f) t) <-> (forall env, fm_sem Sg env f t).
  Proof.
    intros.
    split; intros.

    unfold mkAll in H; simpl in H.
    set (dk (k: {x : Sort & {x0 : variable x | SV.set_In x0 (vars x)}}) :=
      match k return ssem (projT1 k) with
        existT _ s (exist _ v h) => env s v
      end).
    simpl in dk.
    setoid_rewrite IAll_sem in H.
    specialize H with env dk.
    revert H; apply fm_sem_equiv; intros; auto.
    unfold addl; simpl.
    match goal with |- _=match ?cnd with _=>_ end => destruct cnd; auto end.
    destruct s0; auto.
    simpl in d.
    destruct x; simpl in *.
    destruct e; simpl in *.
    injection d; intros; subst.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst; auto.
    rewrite (proof_irrelevance _ d eq_refl); auto.

    unfold mkAll.
    apply IAll_sem; intros.
    apply H.
  Qed.

  Lemma semAll_intro: forall `{Sg: Sig} (D: Dom Sg) env (Itp: Interp D) (f: formula Sg) (V: VarSet Sg) t,
    (forall pe:pEnv D V,  fm_sem Sg (pAdd env pe) f t) ->
      fm_sem Sg env (mkAll V f) t.
  Proof.
    intros.
    unfold mkAll; simpl; intros.
    apply IAll_sem; intros.
    unfold addl; simpl.
    set (pe := fun s v h => dk (existT _ s (exist _ v h))).
    simpl in pe; specialize H with pe.
    revert H; apply fm_sem_equiv; intros; auto.
    match goal with |- match ?cnd with _=>_ end=_ => destruct cnd end.
    destruct s0; simpl in *; auto.
    destruct x as [s0 [w h]]; simpl in *.
    injection d; intros; subst s0.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst w.
    rewrite (proof_irrelevance _ d eq_refl).
    unfold pAdd.
    destruct (SV.set_In_dec v (V s)); try tauto.
    unfold pe.
    rewrite (proof_irrelevance _ i h); reflexivity.

    generalize (fun k => n k (fin_all k)); clear n; intro n.

    simpl in *.
    unfold pAdd.
    destruct (SV.set_In_dec v (V s)); auto.
    specialize n with (existT (fun x => {x0 : variable x | SV.set_In x0 (V x)}) s (exist (fun x0 => SV.set_In x0 (V s)) v i)).
    simpl in n.
    exfalso; apply n; intros; auto.
  Qed.

  Lemma semAll_elim: forall `{Sg: Sig} (D: Dom Sg) env (Itp: Interp D) (f: formula Sg) (V: VarSet Sg) t,
    fm_sem Sg env (mkAll V f) t ->
      (forall pe:pEnv D V,  fm_sem Sg (pAdd env pe) f t).
  Proof.
    intros.
    unfold mkAll in H; simpl in H; intros.
    unfold addl in H; simpl in H.
    set (dk k := match k return ssem (projT1 k) with
        existT _ s (exist _ v h) => pe s v h end).
    setoid_rewrite IAll_sem in H.
    simpl in dk; specialize H with dk.
    revert H; apply fm_sem_equiv; intros; auto.
    unfold addl.
    match goal with |- _=match ?cnd with _=>_ end => destruct cnd end.
    destruct s0; simpl in *; auto.
    destruct x as [s0 [w h]]; simpl in *.
    injection d; intros; subst s0.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst.
    rewrite (proof_irrelevance _ d eq_refl).
    unfold pAdd.
    destruct (SV.set_In_dec v (V s)); try tauto.
    rewrite (proof_irrelevance _ i h); reflexivity.

    generalize (fun k => n k (fin_all k)); clear n; intro n.
    simpl in *.
    unfold pAdd.
    destruct (SV.set_In_dec v (V s)); auto.
    specialize n with (existT (fun s => {x0 : variable s | SV.set_In x0 (V s)}) s (exist (fun x0 => SV.set_In x0 (V s)) v i)).
    simpl in n.
    tauto.
  Qed.

  Lemma semEx_intro: forall `{Sg: Sig} (D: Dom Sg) env (Itp: Interp D) (f: formula Sg) (V: VarSet Sg) t,
    (exists pe:pEnv D V,  fm_sem Sg (pAdd env pe) f t) ->
      fm_sem Sg env (mkEx V f) t.
  Proof.
    intros.
    unfold mkEx; simpl; intros.
    destruct H as [pe H].
    set (dk k := match k return ssem (projT1 k) with
        existT _ s (exist _ v h) => pe s v h end).
    apply IEx_sem.
    simpl in dk; exists dk.
    revert H; apply fm_sem_equiv; intros; auto.
    unfold addl.
    match goal with |- match ?cnd with _=>_ end=_ => destruct cnd end.
    destruct s0; simpl in *; auto.
    destruct x as [s0 [w h]]; simpl in *.
    injection d; intros; subst s0.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst.
    rewrite (proof_irrelevance _ d eq_refl).
    unfold pAdd.
    destruct (SV.set_In_dec v (V s)); try tauto.
    rewrite (proof_irrelevance _ i h); reflexivity.

    generalize (fun k => n k (fin_all k)); clear n; intro n.
    simpl in *.
    unfold pAdd.
    destruct (SV.set_In_dec v (V s)); auto.
    specialize n with (existT (fun x => {x0 : variable x | SV.set_In x0 (V x)}) s (exist (fun x0 => SV.set_In x0 (V s)) v i)).
    simpl in n; tauto.
  Qed.

  Lemma semEx_elim: forall `{Sg: Sig} (D: Dom Sg) env (Itp: Interp D) (f: formula Sg) (V: VarSet Sg) t,
    fm_sem Sg env (mkEx V f) t ->
      exists pe:pEnv D V,  fm_sem Sg (pAdd env pe) f t.
  Proof.
    intros.
    unfold mkEx in H; simpl in H; intros.
    apply IEx_sem in H.
    destruct H as [dk H].
    unfold addl in H; simpl in H.
    set (pe := fun s v h => dk (existT _ s (exist _ v h))).
    simpl in pe; exists pe.
    revert H; apply fm_sem_equiv; intros; auto.
    match goal with |- _=match ?cnd with _=>_ end => destruct cnd end.
    destruct s0; simpl in *; auto.
    destruct x as [s0 [w h]]; simpl in *.
    injection d; intros; subst s0.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst.
    rewrite (proof_irrelevance _ d eq_refl).
    unfold pAdd.
    destruct (SV.set_In_dec v (V s)); try tauto.
    unfold pe.
    rewrite (proof_irrelevance _ i h); reflexivity.

    generalize (fun k => n k (fin_all k)); clear n; intro n.
    simpl in *.
    unfold pAdd.
    destruct (SV.set_In_dec v (V s)); auto.
    specialize n with (existT (fun x => {x0 : variable x | SV.set_In x0 (V x)}) s (exist (fun x0 => SV.set_In x0 (V s)) v i)).
    simpl in n.
    tauto.
  Qed.

  Lemma mkEx_intro: forall `{Sg: Sig} (D: Dom Sg) (Itp: Interp D) (f: formula Sg) env vars t,
    fm_sem Sg env f t -> fm_sem Sg env (mkEx vars f) t.
  Proof.
    intros.
    apply semEx_intro.
    exists (fun s v h => env s v).
    revert H; apply fm_sem_equiv; intros; auto.
    unfold pAdd.
    destruct (SV.set_In_dec v (vars s)); auto.
  Qed.

  Lemma ALL_IAll: forall `{Sg: Sig} `(K: Finite) sk (vk: forall k, variable (sk k)) (f: formula Sg) , ALL (IAll Sg K sk vk f) = ALL f.
  Proof.
    induction f; simpl; intros; auto;
      try (unfold IAll; induction fin_set; simpl; intros; tauto).
  Qed.

  Lemma EX_IEx: forall `{Sg: Sig} `(K: Finite) sk (vk: forall k, variable (sk k)) (f: formula Sg) , EX (IEx Sg K sk vk f) = EX f.
  Proof.
    induction f; simpl; intros; auto;
      try (unfold IEx; induction fin_set; simpl; intros; tauto).
  Qed.

  Lemma ALL_mkAll: forall `{Sg: Sig} (f: formula Sg) (V: VarSet Sg),
    ALL (mkAll V f) = ALL f.
  Proof.
    intros.
    apply ALL_IAll.
  Qed.

  Lemma EX_mkEX: forall `{Sg: Sig} (f: formula Sg) (V: VarSet Sg),
    EX (mkEx V f) = EX f.
  Proof.
    intros; apply EX_IEx.
  Qed.

  Lemma EX_EX: forall `{Sg: Sig} (f: formula Sg), EX (EX f) = EX f.
  Proof.
    induction f; simpl; intros; auto.
  Qed.

  Definition empty_pEnv `{Sg: Sig} (D: Dom Sg) : pEnv D (vsEmpty Sg).
    repeat intro.
    destruct H.
  Defined.

  Lemma mkAll_empty: forall `{Sg: Sig} (D: Dom Sg) (Itp: Interp D) (f: formula Sg) env t,
    fm_sem Sg env (mkAll (vsEmpty Sg) f) t <-> fm_sem Sg env f t.
  Proof.
    intros.
    split; intro.

    apply (semAll_elim D) with (pe := empty_pEnv D) in H.
    revert H; apply fm_sem_equiv; intros; now auto.

    apply semAll_intro; intro.
    revert H; apply fm_sem_equiv; intros; now auto.
  Qed.

  Lemma mkEx_free: forall `{Sg: Sig} (D: Dom Sg) env (Itp: Interp D) (f: formula Sg) (V: VarSet Sg) t,
    fm_sem Sg env (mkEx V f) t <->
      fm_sem Sg env (mkEx (vsInter Sg V (free Sg f)) f) t.
  Proof.
    intros.
    split; intro.
    apply semEx_elim in H.
    destruct H as [pe H].
    apply semEx_intro.
    exists (fun s v (h: SV.set_In v (vsInter Sg V (free Sg f) s)) => pe s v (proj1 (vsInter_elim _ h))).
    revert H; apply fm_sem_equiv; intros.
    unfold pAdd; simpl.
    destruct (SV.set_In_dec v (vsInter Sg V (free Sg f) s)).
    destruct (SV.set_In_dec v (V s)).
    rewrite (proof_irrelevance _ _ i0); auto.
    exfalso; apply vsInter_elim in i; tauto.
    destruct (SV.set_In_dec v (V s)); auto.
    exfalso; apply n; clear n; apply vsInter_intro; tauto.

    apply semEx_elim in H.
    destruct H as [pe H].
    apply semEx_intro.
    set (pe' := fun s v (h: SV.set_In v (V s)) =>
      match SV.set_In_dec v (free Sg f s) with
        left h' => pe s v (vsInter_intro _ h h')
      | right h' => neDom s
      end).
    exists pe'.

    revert H; apply fm_sem_equiv; intros.
    unfold pAdd, pe'; simpl.
    destruct (SV.set_In_dec v (vsInter Sg V (free Sg f) s)).
    destruct (SV.set_In_dec v (V s)).
    destruct (SV.set_In_dec v (free Sg f s)); try tauto.
    rewrite (proof_irrelevance _ _ i); auto.
    exfalso; apply vsInter_elim in i; tauto.
    destruct (SV.set_In_dec v (V s)); auto.
    destruct (SV.set_In_dec v (free Sg f s)); try tauto.
    exfalso; apply n; clear n; apply vsInter_intro; tauto.
  Qed.

   Lemma vsUnionCases: forall `{Sg: Sig} `{K:Finite} {sk:K->Sort} {vk: forall k, variable (sk k)} {V: VarSet _} {s} {v:variable s},
    SV.set_In v (vsUnion Sg (vsVars Sg vk) V s) ->
    ~ SV.set_In v (V s) ->
    (forall k : K, ~ (isEq2 (U:=variable) (sk k) (vk k) s v)) ->
    False.
  Proof.
    intros.
    apply vsUnion_elim in H; destruct H.
    apply vsVars_elim in H.
    destruct H as [k H].
    specialize H1 with k.
    apply H1; clear H1.
    apply H.
    apply (H0 H).
  Qed.

   Lemma vsAddCases: forall `{Sg: Sig} {e: VarSet Sg} {s s'} {x: variable s} {v:variable s'},
    vsIn Sg v (vsAdd Sg x e) ->
    ~ vsIn Sg v e ->
    (~ isEq2 (U:=variable) s x s' v) ->
    False.
  Proof.
    intros.
    apply vsAdd_elim in H; destruct H.
    unfold isEq2 in *; simpl in *.
    symmetry in H; tauto.
    apply (H0 H).
  Qed.

  Lemma pAdd_iadd: forall `{Sg: Sig} (D: Dom Sg) (env: Env Sg D) `(K: Finite) sk vk (V: VarSet Sg) (pe: pEnv D (vsUnion Sg (vsVars Sg vk) V)) s' v',
  pAdd env pe s' v' =
  pAdd
  (iadd Sg K sk vk
     (fun k => pe (sk k) (vk k) (vsUnion_l Sg (vsVars_intro Sg vk k))) env)
     (fun (s : Sort) (v : variable s) (h : SV.set_In v (V s))
      => pe s v (vsUnion_r Sg h)) s' v'.
  Proof.
    intros.
    unfold pAdd, iadd.
    destruct (SV.set_In_dec v' (V s')).
    destruct (SV.set_In_dec v' (vsUnion Sg (vsVars Sg vk) V s')).
    f_equal; apply proof_irrelevance.
    exfalso; apply n; clear n.
    apply vsUnion_r; auto.

    destruct (ex_dec (fun k : K => isEq2 (sk k) (vk k) s' v')).
    destruct s.
    simpl in d.
    injection d; intros; subst s'.
    generalize d; intro d'.
    apply inj_pair2_eq_dec in d; try apply eq_dec; subst v'.
    rewrite (proof_irrelevance _ d' eq_refl).
    destruct (SV.set_In_dec (vk x) (vsUnion Sg (vsVars Sg vk) V (sk x))).
    f_equal; apply proof_irrelevance.

    exfalso; apply n0.
    apply vsUnion_l.
    apply vsVars_intro.

    destruct (SV.set_In_dec v' (vsUnion Sg (vsVars Sg vk) V s')); auto.
    exfalso; apply vsUnion_elim in i.
    destruct i.
    apply vsVars_elim in H.
    destruct H as [k H].
    apply (n0 k H).
    apply (n H).
  Qed.

  Lemma pAdd_addl: forall `(Sg: Sig) (D: Dom Sg) (env: Env Sg D) `(K: Finite) sk vk (V: VarSet Sg) (pe: pEnv D (vsUnion Sg (vsVars Sg vk) V)) s' v',
  pAdd env pe s' v' =
  pAdd
  (addl Sg K sk vk
     (fun k => pe (sk k) (vk k) (vsUnion_l Sg (vsVars_intro Sg vk k))) env)
     (fun (s : Sort) (v : variable s) (h : SV.set_In v (V s))
      => pe s v (vsUnion_r Sg h)) s' v'.
  Proof.
    intros.
    unfold pAdd, addl.
    destruct (SV.set_In_dec v' (V s')).
    destruct (SV.set_In_dec v' (vsUnion Sg (vsVars Sg vk) V s')).
    f_equal; apply proof_irrelevance.
    exfalso; apply n; clear n.
    apply vsUnion_r; auto.

    destruct (last_dec (fun k : K => isEq2 (sk k) (vk k) s' v')).
    destruct s.
    simpl in d.
    injection d; intros; subst s'.
    generalize d; intro d'.
    apply inj_pair2_eq_dec in d; try apply eq_dec; subst v'.
    rewrite (proof_irrelevance _ d' eq_refl).
    destruct (SV.set_In_dec (vk x) (vsUnion Sg (vsVars Sg vk) V (sk x))).
    f_equal; apply proof_irrelevance.

    exfalso; apply n0.
    apply vsUnion_l.
    apply vsVars_intro.

    destruct (SV.set_In_dec v' (vsUnion Sg (vsVars Sg vk) V s')); auto.
    exfalso; apply vsUnion_elim in i.
    destruct i.
    apply vsVars_elim in H.
    destruct H as [k H].
    apply (n0 k (fin_all k) H).
    apply (n H).
  Qed.

  Lemma pAdd_iadd2: forall `{Sg: Sig} (D: Dom Sg) V env (pe: pEnv D V) `(K: Finite) sk vk dk s' v',
  pAdd (iadd Sg K sk vk dk env) pe s' v' =
  pAdd env
  (fun (s : Sort) (v : variable s)
     (h : SV.set_In v (vsUnion Sg (vsVars Sg vk) V s)) =>
   match SV.In_dec v (V s) with
   | left h1 => pe s v h1
   | right h2 =>
       match ex_dec (fun k : K => isEq2 (U:=variable) (sk k) (vk k) s v) with
       | inleft (exist _ k hk) =>
           match inj_pairT1 hk in (_ = s') return (ssem s') with
           | eq_refl => dk k
           end
       | inright nh =>
           match vsUnionCases h h2 nh return (ssem s) with
           end
       end
   end) s' v'.
  Proof.
    intros.
    unfold pAdd, iadd.
    destruct (SV.set_In_dec v' (vsUnion Sg (vsVars Sg vk) V s')); auto.
    unfold SV.set_In_dec, SV.In_dec.
    destruct (List.in_dec eq_dec v' (V s')); auto.
    destruct (ex_dec (fun k : K => isEq2 (sk k) (vk k) s' v')); auto.
    destruct s; auto.
    match goal with
      |- _=match ?cnd with _=>_ end => destruct cnd; auto
    end.
    generalize d; intro d'.
    apply inj_pair2_eq_dec in d; try apply eq_dec; subst v'; auto.
    rewrite (proof_irrelevance _ d' eq_refl); auto.
    destruct (vsUnionCases i n n0).

    destruct (SV.set_In_dec v' (V s')); auto.
    exfalso; apply n; clear n.
    apply vsUnion_r; auto.

    destruct (ex_dec (fun k : K => isEq2 (sk k) (vk k) s' v')); auto.
    destruct s; auto.
    assert (sk x = s').
    injection d; intro; subst; auto.
    subst s'.
    assert (vk x = v').
    apply inj_pair2_eq_dec in d; try apply eq_dec; subst; auto.
    subst v'.
    exfalso; apply n.
    apply vsUnion_l.
    apply vsVars_intro.
  Qed.

  Lemma pAdd_addl2: forall `{Sg: Sig} (D: Dom Sg) V env (pe: pEnv D V) `(K: Finite) sk vk dk s' v',
  pAdd (addl Sg K sk vk dk env) pe s' v' =
  pAdd env
  (fun (s : Sort) (v : variable s)
     (h : SV.set_In v (vsUnion Sg (vsVars Sg vk) V s)) =>
   match SV.In_dec v (V s) with
   | left h1 => pe s v h1
   | right h2 =>
       match last_dec (fun k : K => isEq2 (U:=variable) (sk k) (vk k) s v) with
       | inleft (exist _ k hk) =>
           match inj_pairT1 hk in (_ = s') return (ssem s') with
           | eq_refl => dk k
           end
       | inright nh =>
           match vsUnionCases h h2 (fun k => nh k (fin_all k)) return (ssem s) with
           end
       end
   end) s' v'.
  Proof.
    intros.
    unfold pAdd, addl.
    destruct (SV.set_In_dec v' (vsUnion Sg (vsVars Sg vk) V s')); auto.
    unfold SV.set_In_dec, SV.In_dec.
    destruct (List.in_dec eq_dec v' (V s')); auto.
    destruct (last_dec (fun k : K => isEq2 (sk k) (vk k) s' v')); auto.
    destruct s; auto.
    match goal with
      |- _=match ?cnd with _=>_ end => destruct cnd; auto
    end.
    generalize d; intro d'.
    apply inj_pair2_eq_dec in d; try apply eq_dec; subst v'; auto.
    rewrite (proof_irrelevance _ d' eq_refl); auto.
    destruct (vsUnionCases i n (fun k => n0 k (fin_all k))).

    destruct (SV.set_In_dec v' (V s')); auto.
    exfalso; apply n; clear n.
    apply vsUnion_r; auto.

    destruct (last_dec (fun k : K => isEq2 (sk k) (vk k) s' v')); auto.
    destruct s; auto.
    assert (sk x = s').
    injection d; intro; subst; auto.
    subst s'.
    assert (vk x = v').
    apply inj_pair2_eq_dec in d; try apply eq_dec; subst; auto.
    subst v'.
    exfalso; apply n.
    apply vsUnion_l.
    apply vsVars_intro.
  Qed.

  Lemma EX_sem_elim: forall `{Sg: Sig} (D: Dom Sg) f,
    forall Itp env t, fm_sem Sg (Itp:=Itp) env (mkEx (getEx f) (EX f)) t -> fm_sem Sg (Itp:=Itp) env f t.
  Proof.
    induction f; intros; auto;
    match goal with
      |- fm_sem _ _ (Ex _ _ _ _) _  => idtac
    | _ => revert H; apply IEx_empty
    end.

    change (EX (Ex Sg s e f)) with (EX f) in H.
    apply semEx_elim in H.
    destruct H as [pe H].
    simpl.
    simpl in pe.
    exists (pe s e (vsAdd_l _ _ _)).
    apply IHf; clear IHf.
    apply semEx_intro.
    exists (fun s v h => pe s v (vsAdd_r _ _ _ h)).
    revert H; apply fm_sem_equiv; intros.

    unfold pAdd.
    simpl.
    destruct (SV.set_In_dec v (getEx f s0)).
    destruct (SV.set_In_dec v (vsAdd Sg e (getEx f) s0)).
    rewrite (proof_irrelevance _ _ i0); now auto.
    exfalso; apply n; apply vsAdd_r; now auto.
    destruct (SV.set_In_dec v (vsAdd Sg e (getEx f) s0)).
    destruct (vsAdd_elim _ _ _ i); intros.
    injection H0; intros; subst s0.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst e.
    unfold add.
    destruct (eq_dec s s); try tauto.
    rewrite (proof_irrelevance _ _ eq_refl).
    destruct (eq_dec v v); try tauto.
    rewrite (proof_irrelevance _ _ i); now auto.
    tauto.
    rewrite add_ne2; auto.
    intro.
    injection H0; intros; subst s0.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst e.
    apply n0; apply vsAdd_l.
  Qed.

  Lemma EX_sem_intro: forall `{Sg: Sig} (D: Dom Sg) f,
    forall Itp env t, fm_sem Sg (Itp:=Itp) env f t -> fm_sem Sg (Itp:=Itp) env (mkEx (getEx f) (EX f)) t.
  Proof.
    induction f; intros;
    match goal with
      H: fm_sem _ _ (Ex _ _ _ _) _ |- _ => idtac
    | _ => revert H; apply IEx_empty
    end.

    change (EX (Ex Sg s e f)) with (EX f).
    apply semEx_intro.
    simpl in H.
    destruct H as [d H].
    apply IHf in H; clear IHf.
    apply semEx_elim in H.
    destruct H as [pe H].
    simpl.
    exists (fun s' (v: variable (Tv:=Tv) s') (h: vsIn Sg v (vsAdd Sg e (getEx f))) =>
      match SV.In_dec v (getEx f s') with
        left h1 => pe s' v h1
      | right h2 =>
        match @dc_dec (isEq2 (U:=variable) s e s' v) with
          left hk =>
            match (inj_pairT1 hk) in _=s' return ssem s' with eq_refl => d end
        | right nh => match (vsAddCases h h2 nh) with end
        end
      end).
    revert H; apply fm_sem_equiv; intros; auto.

    unfold pAdd.
    destruct (SV.set_In_dec v (vsAdd Sg e (getEx f) s0)).
    destruct (vsAdd_elim _ _ _ i).
    injection H0; intros; subst s0.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst e.
    destruct (SV.In_dec v (getEx f s)); auto.
    destruct (SV.set_In_dec v (getEx f s)); try tauto.
    rewrite (proof_irrelevance _ i0 s0); now auto.
    destruct ( SV.set_In_dec v (getEx f s)); simpl in *; try tauto.
    destruct (dec.isEq2_obligation_1 _ Sort _ (fun x : Sort => variable x) s v s v); try tauto.
    destruct (vsAddCases i n n0).
    destruct (  dec.isEq2_obligation_1 _ Sort _ (fun x : Sort => variable x) s v s v); try tauto.
    rewrite (proof_irrelevance _ _ eq_refl).
    rewrite add_eq; now auto.
    destruct (vsAddCases i n n1).
    simpl in *.
    destruct (SV.In_dec v (getEx f s0)); try tauto.
    destruct (SV.set_In_dec v (getEx f s0)); try tauto.
    rewrite (proof_irrelevance _ s1 i0); now auto.
    destruct (n H0).
    destruct (SV.set_In_dec v (getEx f s0)).
    exfalso; apply n.
    apply vsAdd_r; tauto.
    rewrite add_ne2; auto.
    intro.
    injection H0; intros; subst s0.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst e.
    apply n; apply vsAdd_l.
  Qed.

  Lemma EX_sem: forall `{Sg: Sig} (D: Dom Sg) f,
    forall Itp env t, fm_sem Sg (Itp:=Itp) env (mkEx (getEx f) (EX f)) t <-> fm_sem Sg (Itp:=Itp) env f t.
  Proof.
    intros.
    split; intro.
    apply EX_sem_elim in H; auto.
    apply EX_sem_intro; auto.
  Qed.

  Lemma ALL_sem: forall `{Sg: Sig} (D: Dom Sg) f,
    forall Itp env t, fm_sem Sg (Itp:=Itp) env (mkAll (getAll f) (ALL f)) t <-> fm_sem Sg (Itp:=Itp) env f t.
  Proof.
    intros.
    match goal with |- ?p1 <-> ?p2 => generalize (@not_iff_compat (not p1) (not p2)); intro end.
    repeat rewrite not_not in H.
    apply H; clear H.
    do 2 rewrite <-Not_sem.
    rewrite Not_mkAll.
    rewrite Not_ALL.
    rewrite <-getEx_Not.
    apply EX_sem.
  Qed.

  Lemma EX_free: forall `{Sg: Sig} (f: formula Sg), forall s, SV.subset (free _ (EX f) s) (vsUnion Sg (free _ f) (getEx f) s).
  Proof.
    induction f; simpl; intros; auto; try apply SV.empty_subset;
      try apply SV.subset_union_l.
    repeat intro.
    apply IHf in H; clear IHf.
    apply vsUnion_elim in H; destruct H; auto.
    destruct (@dc_dec (isEq2 (U:=variable) s e s0 v)).
    apply vsUnion_r.
    injection d; intros; subst s0.
    apply inj_pair2_eq_dec in d; try apply eq_dec; subst e.
    apply vsAdd_l.
    apply vsUnion_l.
    apply vsInRemove_intro; now auto.
    apply vsUnion_r.
    apply vsAdd_r; now auto.
  Qed.

  Lemma ALL_free: forall `{Sg: Sig} (f: formula Sg), forall s, SV.subset (free _ (ALL f) s) (vsUnion Sg (free _ f) (getAll f) s).
  Proof.
    induction f; simpl; intros; auto; try apply SV.empty_subset;
      try apply SV.subset_union_l.
    repeat intro.
    apply IHf in H; clear IHf.
    apply vsUnion_elim in H; destruct H; auto.
    destruct (@dc_dec (isEq2 (U:=variable) s e s0 v)).
    apply vsUnion_r.
    injection d; intros; subst s0.
    apply inj_pair2_eq_dec in d; try apply eq_dec; subst e.
    apply vsAdd_l.
    apply vsUnion_l.
    apply vsInRemove_intro; now auto.
    apply vsUnion_r.
    apply vsAdd_r; now auto.
  Qed.

  Lemma close_EXALL: forall `{Sg: Sig} {f: formula Sg},
    (forall s, SV.is_empty (free Sg f s)) ->
    (forall s : Sort,
      SV.subset (free Sg (EX_ALL f) s)
                (SV.union (getEx f s) (getAll (EX f) s))).
  Proof.
    repeat intro.
    unfold EX_ALL in H0.
    apply ALL_free in H0.
    apply vsUnion_elim in H0; destruct H0.
    apply EX_free in H0.
    apply vsUnion_elim in H0; destruct H0.
    apply H in H0; destruct H0.
    apply vsUnion_l; auto.
    apply vsUnion_r; auto.
  Qed.

  Lemma getEx_nfree: forall `{Sg: Sig} (f: formula Sg) s, SV.disjoint (getEx f s) (free Sg f s).
  Proof.
    induction f; simpl; intros; auto;
      try (repeat intro; destruct H; destruct H);
      try (repeat intro; destruct H0; destruct H0).
    repeat intro.
    destruct H.
    apply vsAdd_elim in H; destruct H.
    unfold removeVars in H0.
    apply vsInRemove_elim in H0; destruct H0.
    apply (H1 (sym_eq H)).
    apply vsInRemove_elim in H0.
    destruct H0.
    apply (IHf s0 v (conj H H0)).
  Qed.

  Lemma getAll_nfree: forall `{Sg: Sig} (f: formula Sg) s, SV.disjoint (getAll f s) (free Sg f s).
  Proof.
    induction f; simpl; intros; auto;
      try (repeat intro; destruct H; destruct H);
      try (repeat intro; destruct H0; destruct H0).
    repeat intro.
    destruct H.
    apply vsAdd_elim in H; destruct H.
    unfold removeVars in H0.
    apply vsInRemove_elim in H0; destruct H0.
    apply (H1 (sym_eq H)).
    apply vsInRemove_elim in H0.
    destruct H0.
    apply (IHf s0 v (conj H H0)).
  Qed.

  Definition getExF `{Sg: Sig} (f: formula Sg) := vsInter Sg (getEx f) (free Sg (EX f)).

  Lemma close_EXfALL: forall `{Sg: Sig} {f: formula Sg},
    (forall s, SV.is_empty (free Sg f s)) ->
    (forall s : Sort,
      SV.subset (free Sg (EX_ALL f) s)
                (SV.union (getExF f s) (getAll (EX f) s))).
  Proof.
    repeat intro.
    unfold EX_ALL in H0.
    apply ALL_free in H0.
    apply vsUnion_elim in H0; destruct H0.
    apply vsUnion_l; apply vsInter_intro; auto.
    apply EX_free in H0.
    apply vsUnion_elim in H0; destruct H0; auto.
    apply H in H0; destruct H0.

    apply vsUnion_r; auto.
  Qed.

  Lemma mkEx_getExF: forall `{Sg: Sig} (f: formula Sg) (D: Dom Sg) (Itp: Interp D) env t,
    fm_sem Sg env f t <-> fm_sem Sg env (mkEx (getExF f) (EX f)) t.
  Proof.
    intros.
    split; intro; auto.
    apply EX_sem_intro in H; auto.
    apply semEx_elim in H.
    destruct H as [pe H].
    apply semEx_intro.
    exists (fun s v h => pe s v (proj1 (vsInter_elim _ h))).
    revert H; apply fm_sem_equiv; intros.
    unfold pAdd.

    destruct (SV.set_In_dec v (getEx f s)).
    destruct (SV.set_In_dec v (getExF f s)); auto.
    rewrite (proof_irrelevance _ _ i); now auto.
    exfalso.
    apply n; clear n; apply vsInter_intro; auto.

    destruct (SV.set_In_dec v (getExF f s)); auto.
    exfalso; apply vsInter_elim in i; tauto.

    apply EX_sem_elim.
    apply semEx_elim in H.
    destruct H as [pe H].
    apply semEx_intro.
    exists (fun s v h =>
      match SV.set_In_dec v (free Sg (EX f) s) with
        left h' => pe s v (vsInter_intro _ h h')
      | right _ => env s v
      end).
    revert H; apply fm_sem_equiv; intros.
    unfold pAdd.
    destruct (SV.set_In_dec v (free Sg (EX f) s)); try tauto.
    clear H.
    destruct (SV.set_In_dec v (getEx f s)).
    destruct (SV.set_In_dec v (getExF f s)); auto.
    rewrite (proof_irrelevance _ _ i1); now auto.
    exfalso; apply n; clear n; apply vsInter_intro; tauto.
    destruct (SV.set_In_dec v (getExF f s)); auto.
    exfalso; apply vsInter_elim in i0; tauto.
  Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Require Import ssralg matrix.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope nat_scope.
Local Open Scope ring_scope.

Section TestMx.

Variable R : ringType.
Variable M : 'M[R]_2.

Goal 1%:M = M.
Proof.
Set Printing All.
rewrite [(1%:M : 'M_(1+1)%N)]scalar_mx_block.
(* Success with 1.2 *)
(* With ssreflect 1.3, fails with error : *)
(* Toplevel input, characters 0-44: *)
(* Error: pattern (1%:M) does not match LHS of scalar_mx_block *)
Admitted.

Goal 1%:M = M.
Proof.
rewrite [1%:M](scalar_mx_block 1%N 1%N).
(* Success in both ssr 1.2 and 1.3 *)
Admitted.

End TestMx.


Require Export Structure.

Section Terminal.
Context (S: Category) (T: TopCategory).

Definition FunOne: Functor S T := {|
  fobj _ := 1;
  fmap _ _ _ := id 1;
  fmap_id _ := eq_refl;
  fmap_comp _ _ _ _ _ := eq_sym (comp_id_l (id 1));
|}.

Program Definition Fun_to_one (F: Functor S T): F ~> FunOne := {|
  transform x := !;
|}.
Next Obligation.
  apply to_one_eq.
Qed.

Lemma Fun_to_one_unique {F: Functor S T} (η: F ~> FunOne): Fun_to_one F = η.
Proof.
  natural_eq x.
  apply to_one_unique.
Qed.

Definition TopFun_mixin: TopCategory.mixin_of (Fun S T) :=
  TopCategory.Mixin (Fun S T) FunOne Fun_to_one (@Fun_to_one_unique).

Canonical TopFun: TopCategory :=
  TopCategory.Pack (Fun S T) TopFun_mixin.

End Terminal.

Section Initial.
Context (S: Category) (T: BotCategory).

Definition FunZero: Functor S T := {|
  fobj _ := 0;
  fmap _ _ _ := id 0;
  fmap_id _ := eq_refl;
  fmap_comp _ _ _ _ _ := eq_sym (comp_id_l (id 0));
|}.

Program Definition Fun_from_zero (F: Functor S T): FunZero ~> F := {|
  transform x := ¡;
|}.
Next Obligation.
  apply from_zero_eq.
Qed.

Lemma Fun_from_zero_unique {F: Functor S T} (η: FunZero ~> F): Fun_from_zero F = η.
Proof.
  natural_eq x.
  apply from_zero_unique.
Qed.

Definition BotFun_mixin: BotCategory.mixin_of (Fun S T) :=
  BotCategory.Mixin (Fun S T) FunZero Fun_from_zero (@Fun_from_zero_unique).

Canonical BotFun: BotCategory :=
  BotCategory.Pack (Fun S T) BotFun_mixin.

End Initial.

Section Product.
Context (S: Category) (T: ProdCategory).

Program Definition FunProd (F G: Functor S T): Functor S T := {|
  fobj x := F x × G x;
  fmap x y f := fmap F f (×) fmap G f;
|}.
Next Obligation.
  rewrite <- fprod_id.
  f_equal.
  all: apply fmap_id.
Qed.
Next Obligation.
  rewrite <- fprod_comp.
  f_equal.
  all: apply fmap_comp.
Qed.

Program Definition Fun_fork {F G H: Functor S T} (η: F ~> G) (ϵ: F ~> H): F ~> FunProd G H := {|
  transform x := ⟨η x, ϵ x⟩;
|}.
Next Obligation.
  rewrite fork_comp, fprod_fork.
  f_equal.
  all: apply naturality.
Qed.

Program Definition Fun_pi1 (F G: Functor S T): FunProd F G ~> F := {|
  transform x := π₁;
|}.
Next Obligation.
  apply pi1_fork.
Qed.

Program Definition Fun_pi2 (F G: Functor S T): FunProd F G ~> G := {|
  transform x := π₂;
|}.
Next Obligation.
  apply pi2_fork.
Qed.

Lemma Fun_fork_pi {F G H: Functor S T} (η: F ~> G) (ϵ: F ~> H) (ρ: F ~> FunProd G H): ρ = Fun_fork η ϵ <-> Fun_pi1 G H ∘ ρ = η /\ Fun_pi2 G H ∘ ρ = ϵ.
Proof.
  split.
  + intros e.
    subst ρ.
    split.
    all: natural_eq x.
    apply pi1_fork.
    apply pi2_fork.
  + intros [e1 e2].
    subst η ϵ.
    natural_eq x.
    symmetry.
    apply fork_eta.
Qed.

Definition ProdFun_mixin: ProdCategory.mixin_of (Fun S T) :=
  ProdCategory.Mixin (Fun S T) FunProd (@Fun_fork) Fun_pi1 Fun_pi2 (@Fun_fork_pi).

Canonical ProdFun: ProdCategory :=
  ProdCategory.Pack (Fun S T) ProdFun_mixin.

End Product.

Section Coproduct.
Context (S: Category) (T: CoprodCategory).

Program Definition FunCoprod (F G: Functor S T): Functor S T := {|
  fobj x := F x + G x;
  fmap x y f := fmap F f (+) fmap G f;
|}.
Next Obligation.
  rewrite <- fcoprod_id.
  f_equal.
  all: apply fmap_id.
Qed.
Next Obligation.
  rewrite <- fcoprod_comp.
  f_equal.
  all: apply fmap_comp.
Qed.

Program Definition Fun_merge {F G H: Functor S T} (η: F ~> H) (ϵ: G ~> H): FunCoprod F G ~> H := {|
  transform x := [η x, ϵ x];
|}.
Next Obligation.
  rewrite merge_comp, merge_fcoprod.
  f_equal.
  all: apply naturality.
Qed.

Program Definition Fun_in1 (F G: Functor S T): F ~> FunCoprod F G := {|
  transform x := in1;
|}.
Next Obligation.
  symmetry.
  apply merge_in1.
Qed.

Program Definition Fun_in2 (F G: Functor S T): G ~> FunCoprod F G := {|
  transform x := in2;
|}.
Next Obligation.
  symmetry.
  apply merge_in2.
Qed.

Lemma Fun_merge_in {F G H: Functor S T} (η: F ~> H) (ϵ: G ~> H) (ρ: FunCoprod F G ~> H): ρ = Fun_merge η ϵ <-> ρ ∘ Fun_in1 F G = η /\ ρ ∘ Fun_in2 F G = ϵ.
Proof.
  split.
  + intros e.
    subst ρ.
    split.
    all: natural_eq x.
    apply merge_in1.
    apply merge_in2.
  + intros [e1 e2].
    subst η ϵ.
    natural_eq x.
    symmetry.
    apply merge_eta.
Qed.

Definition CoprodFun_mixin: CoprodCategory.mixin_of (Fun S T) :=
  CoprodCategory.Mixin (Fun S T) FunCoprod (@Fun_merge) Fun_in1 Fun_in2 (@Fun_merge_in).

Canonical CoprodFun: CoprodCategory :=
  CoprodCategory.Pack (Fun S T) CoprodFun_mixin.

End Coproduct.

Section Cartisian.
Context (S: Category) (T: CartCategory).

Canonical CartFun: CartCategory :=
  CartCategory.Pack (Fun S T) (CartCategory.Class (Fun S T) (TopFun_mixin S T) (ProdFun_mixin S T)).

End Cartisian.

Section SProduct.
Context (S: Category) (T: SProdCategory).

Program Definition SProdFun_mixin := SProdCategory.Mixin (Fun S T)
  (fun I F => {|
    fobj x := ∏ i, F i x;
    fmap x y f := (∏) i, fmap (F i) f;
  |})
  (fun I F G η => {|
    transform x := ∏' i, η i x;
  |})
  (fun I F i => {|
    transform x := @π T I (fun i => F i x) i;
  |})
  _.
Next Obligation.
  setoid_rewrite fmap_id.
  apply spmap_id.
Qed.
Next Obligation.
  setoid_rewrite fmap_comp.
  apply spmap_comp.
Qed.
Next Obligation.
  rewrite spmap_sfork, <- sfork_comp.
  f_equiv.
  intros i.
  apply naturality.
Qed.
Next Obligation.
  apply (pi_spmap (fun i => fmap (F i) f)).
Qed.
Next Obligation.
  setoid_rewrite natural_eq; simpl.
  now setoid_rewrite sfork_ump.
Qed.
Canonical SProdFun := SProdCategory.Pack (Fun S T) SProdFun_mixin.

End SProduct.

Section SCoproduct.
Context (S: Category) (T: SCoprodCategory).

Program Definition SCoprodFun_mixin := SCoprodCategory.Mixin (Fun S T)
  (fun I F => {|
    fobj x := ∑ i, F i x;
    fmap x y f := (∑) i, fmap (F i) f;
  |})
  (fun I F G η => {|
    transform x := ∑' i, η i x;
  |})
  (fun I F i => {|
    transform x := @ι T I (fun i => F i x) i;
  |})
  _.
Next Obligation.
  setoid_rewrite fmap_id.
  apply scpmap_id.
Qed.
Next Obligation.
  setoid_rewrite fmap_comp.
  apply scpmap_comp.
Qed.
Next Obligation.
  rewrite smerge_scpmap, <- comp_smerge.
  f_equiv.
  intros i.
  apply naturality.
Qed.
Next Obligation.
  symmetry.
  apply (scpmap_sinto (fun i => fmap (F i) f)).
Qed.
Next Obligation.
  setoid_rewrite natural_eq; simpl.
  now setoid_rewrite smerge_ump.
Qed.
Canonical SCoprodFun := SCoprodCategory.Pack (Fun S T) SCoprodFun_mixin.

End SCoproduct.

Section Equalizer.
Context (S: Category) (T: EqCategory).

Program Definition FunEqz {F G: Functor S T} (η μ: F ~> G): Functor S T := {|
  fobj X := Eqz (η X) (μ X);
  fmap X Y f := eqz_med (η Y) (μ Y) (fmap F f ∘ eqz (η X) (μ X)) _;
|}.
Next Obligation.
  rewrite !comp_assoc, !naturality, <- !comp_assoc.
  f_equal.
  apply eqz_comm.
Qed.
Next Obligation.
  apply eqz_med_unique.
  rewrite fmap_id, comp_id_l.
  apply comp_id_r.
Qed.
Next Obligation.
  apply eqz_monic.
  rewrite comp_assoc, !eqz_med_comm, <- comp_assoc.
  rewrite eqz_med_comm, comp_assoc.
  f_equal.
  apply fmap_comp.
Qed.

Program Definition Fun_eqz {F G: Functor S T} (η μ: F ~> G): FunEqz η μ ~> F := {|
  transform x := eqz (η x) (μ x);
|}.
Next Obligation.
  apply eqz_med_comm.
Qed.

Lemma Fun_eqz_comm {F G: Functor S T} (η μ: F ~> G): η ∘ Fun_eqz η μ = μ ∘ Fun_eqz η μ.
Proof.
  natural_eq x.
  apply eqz_comm.
Qed.

Program Definition Fun_eqz_med {F G H: Functor S T} (η μ: G ~> H) (e: F ~> G) (He: η ∘ e = μ ∘ e): F ~> FunEqz η μ := {|
  transform x := eqz_med (η x) (μ x) (e x) (f_equal (fun f => transform f x) He);
|}.
Next Obligation.
  apply eqz_monic.
  rewrite !comp_assoc, !eqz_med_comm.
  rewrite <- comp_assoc, eqz_med_comm.
  apply naturality.
Qed.

Lemma Fun_eqz_med_comm {F G H: Functor S T} (η μ: G ~> H) (e: F ~> G) (He: η ∘ e = μ ∘ e): Fun_eqz η μ ∘ (Fun_eqz_med η μ e He) = e.
Proof.
  natural_eq x.
  apply eqz_med_comm.
Qed.

Lemma Fun_eqz_med_unique {F G H: Functor S T} (η μ: G ~> H) (e: F ~> G) (u: F ~> FunEqz η μ) (He: η ∘ e = μ ∘ e): Fun_eqz η μ ∘ u = e -> Fun_eqz_med η μ e He = u.
Proof.
  intros H1.
  subst e.
  natural_eq x.
  now apply eqz_med_unique.
Qed.

Definition EqFun_mixin: EqCategory.mixin_of (Fun S T) :=
  EqCategory.Mixin (Fun S T) (@FunEqz) (@Fun_eqz) (@Fun_eqz_comm) (@Fun_eqz_med) (@Fun_eqz_med_comm) (@Fun_eqz_med_unique).

Canonical EqFun: EqCategory :=
  EqCategory.Pack (Fun S T) EqFun_mixin.

End Equalizer.


From Coq Require Import ssreflect ssrbool Decimal DecimalString ZArith.
From MetaCoq.Template Require Import MCCompare bytestring ReflectEq.

Local Open Scope bs.
Notation string := String.t.

(** When defining [Show] instance for your own datatypes, you sometimes need to
    start a new line for better printing. [nl] is a shorthand for it. *)
Definition nl : string := String.String "010"%byte String.EmptyString.

Definition string_of_list_aux {A} (f : A -> string) (sep : string) (l : list A) : string :=
  let fix aux l :=
      match l return string with
      | nil => ""
      | cons a nil => f a
      | cons a l => f a ++ sep ++ aux l
      end
  in aux l.

Definition string_of_list {A} (f : A -> string) (l : list A) : string :=
  "[" ++ string_of_list_aux f "," l ++ "]".

Definition print_list {A} (f : A -> string) (sep : string) (l : list A) : string :=
  string_of_list_aux f sep l.

Definition parens (top : bool) (s : string) :=
  if top then s else "(" ++ s ++ ")".

Local Infix "::" := String.String.

Fixpoint string_of_uint n :=
  match n with
  | Nil => ""
  | D0 n => "0" :: string_of_uint n
  | D1 n => "1" :: string_of_uint n
  | D2 n => "2" :: string_of_uint n
  | D3 n => "3" :: string_of_uint n
  | D4 n => "4" :: string_of_uint n
  | D5 n => "5" :: string_of_uint n
  | D6 n => "6" :: string_of_uint n
  | D7 n => "7" :: string_of_uint n
  | D8 n => "8" :: string_of_uint n
  | D9 n => "9" :: string_of_uint n
  end.

Definition string_of_nat n : string :=
  string_of_uint (Nat.to_uint n).

#[global]
Hint Resolve String.string_dec : eq_dec.

Definition string_of_positive p :=
  string_of_uint (Pos.to_uint p).

Definition string_of_Z (z : Z) : string :=
  match z with
  | Z0 => "0"
  | Zpos p => string_of_positive p
  | Zneg p => "-" ++ string_of_positive p
  end.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Rbase.
Require Import Ranalysis_reg.
Require Import Rfunctions.
Require Import Rseries.
Require Import Fourier.
Require Import RiemannInt.
Require Import SeqProp.
Require Import Max.
Require Import Omega.
Require Import Lra.
Local Open Scope R_scope.

(** * Preliminaries lemmas *)

Lemma f_incr_implies_g_incr_interv : forall f g:R->R, forall lb ub,
       lb < ub ->
       (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) ->
       (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) ->
       (forall x , f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
       (forall x y, f lb <= x -> x < y -> y <= f ub -> g x < g y).
Proof.
  intros f g lb ub lb_lt_ub f_incr f_eq_g g_ok x y lb_le_x x_lt_y y_le_ub.
  assert (x_encad : f lb <= x <= f ub) by lra.
  assert (y_encad : f lb <= y <= f ub) by lra.
  assert (gx_encad := g_ok _ (proj1 x_encad) (proj2 x_encad)).
  assert (gy_encad := g_ok _ (proj1 y_encad) (proj2 y_encad)).
  case (Rlt_dec (g x) (g y)); [ easy |].
  intros Hfalse.
  assert (Temp := Rnot_lt_le _ _ Hfalse).
  enough (y <= x) by lra.
  replace y with (id y) by easy.
  replace x with (id x) by easy.
  rewrite <- f_eq_g by easy.
  rewrite <- f_eq_g by easy.
  assert (f_incr2 : forall x y, lb <= x -> x <= y -> y < ub -> f x <= f y). {
    intros m n lb_le_m m_le_n n_lt_ub.
    case (m_le_n).
    - intros; apply Rlt_le, f_incr, Rlt_le; assumption.
    - intros Hyp; rewrite Hyp; apply Req_le; reflexivity.
  }
  apply f_incr2; intuition.
  enough (g x <> ub) by lra.
  intro Hf.
  assert (Htemp : (comp f g) x = f ub). {
    unfold comp; rewrite Hf; reflexivity.
  }
  rewrite f_eq_g in Htemp by easy.
  unfold id in Htemp.
  fourier.
Qed.

Lemma derivable_pt_id_interv : forall (lb ub x:R),
       lb <= x <= ub ->
       derivable_pt id x.
Proof.
intros.
 reg.
Qed.

Lemma pr_nu_var2_interv : forall (f g : R -> R) (lb ub x : R) (pr1 : derivable_pt f x)
       (pr2 : derivable_pt g x),
       lb < ub ->
       lb < x < ub ->
       (forall h : R, lb < h < ub -> f h = g h) -> derive_pt f x pr1 = derive_pt g x pr2.
Proof.
intros f g lb ub x Prf Prg lb_lt_ub x_encad local_eq.
assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs g x l)).
 intros a l a_encad.
 unfold derivable_pt_abs, derivable_pt_lim.
 split.
 intros Hyp eps eps_pos.
 elim (Hyp eps eps_pos) ; intros delta Hyp2.
 assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0).
  clear-a lb ub a_encad delta.
  apply Rmin_pos ; [exact (delta.(cond_pos)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition.
 exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond).
 intros h h_neq h_encad.
 replace (g (a + h) - g a) with (f (a + h) - f a).
 apply Hyp2 ; intuition.
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))).
 assumption. apply Rmin_l.
 assert (local_eq2 : forall h : R, lb < h < ub -> - f h = - g h).
  intros ; apply Ropp_eq_compat ; intuition.
 rewrite local_eq ; unfold Rminus. rewrite local_eq2. reflexivity.
 assumption.
 assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y).
  intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n).
   apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs.
   apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption.
 split.
 assert (Sublemma : forall x y z, -z < y - x -> x < y + z).
  intros ; fourier.
 apply Sublemma.
 apply Sublemma2. rewrite Rabs_Ropp.
 apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 assert (Sublemma : forall x y z, y < z - x -> x + y < z).
  intros ; fourier.
 apply Sublemma.
 apply Sublemma2.
 apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 intros Hyp eps eps_pos.
 elim (Hyp eps eps_pos) ; intros delta Hyp2.
 assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0).
  clear-a lb ub a_encad delta.
  apply Rmin_pos ; [exact (delta.(cond_pos)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition.
 exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond).
 intros h h_neq h_encad.
 replace (f (a + h) - f a) with (g (a + h) - g a).
 apply Hyp2 ; intuition.
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))).
 assumption. apply Rmin_l.
 assert (local_eq2 : forall h : R, lb < h < ub -> - f h = - g h).
  intros ; apply Ropp_eq_compat ; intuition.
 rewrite local_eq ; unfold Rminus. rewrite local_eq2. reflexivity.
 assumption.
 assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y).
  intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n).
   apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs.
   apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption.
 split.
 assert (Sublemma : forall x y z, -z < y - x -> x < y + z).
  intros ; fourier.
 apply Sublemma.
 apply Sublemma2. rewrite Rabs_Ropp.
 apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 assert (Sublemma : forall x y z, y < z - x -> x + y < z).
  intros ; fourier.
 apply Sublemma.
 apply Sublemma2.
 apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
 unfold derivable_pt in Prf.
  unfold derivable_pt in Prg.
  elim Prf; intros x0 p.
  elim Prg; intros x1 p0.
  assert (Temp := p); rewrite H in Temp.
  unfold derivable_pt_abs in p.
  unfold derivable_pt_abs in p0.
  simpl in |- *.
  apply (uniqueness_limite g x x0 x1 Temp p0).
  assumption.
Qed.

(* begin hide *)
Lemma leftinv_is_rightinv : forall (f g:R->R),
       (forall x y, x < y -> f x < f y) ->
       (forall x, (comp f g) x = id x) ->
       (forall x, (comp g f) x = id x).
Proof.
intros f g f_incr Hyp x.
 assert (forall x, f (g (f x)) = f x).
  intros ; apply Hyp.
 assert(f_inj : forall x y, f x = f y -> x = y).
  intros a b fa_eq_fb.
  case(total_order_T a b).
  intro s ; case s ; clear s.
  intro Hf.
  assert (Hfalse := f_incr a b Hf).
  apply False_ind. apply (Rlt_not_eq (f a) (f b)) ; assumption.
  intuition.
  intro Hf. assert (Hfalse := f_incr b a Hf).
  apply False_ind. apply (Rlt_not_eq (f b) (f a)) ; [|symmetry] ; assumption.
 apply f_inj. unfold comp.
 unfold comp in Hyp.
 rewrite Hyp.
 unfold id.
 reflexivity.
Qed.
(* end hide *)

Lemma leftinv_is_rightinv_interv : forall (f g:R->R) (lb ub:R),
       (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) ->
       (forall y, f lb <= y -> y <= f ub -> (comp f g) y = id y) ->
       (forall x, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
       forall x,
       lb <= x <= ub ->
       (comp g f) x = id x.
Proof.
intros f g lb ub f_incr_interv Hyp g_wf x x_encad.
 assert(f_inj : forall x y, lb <= x <= ub -> lb <= y <= ub -> f x = f y -> x = y).
  intros a b a_encad b_encad fa_eq_fb.
  case(total_order_T a b).
  intro s ; case s ; clear s.
  intro Hf.
  assert (Hfalse := f_incr_interv a b (proj1 a_encad) Hf (proj2 b_encad)).
  apply False_ind. apply (Rlt_not_eq (f a) (f b)) ; assumption.
  intuition.
  intro Hf. assert (Hfalse := f_incr_interv b a (proj1 b_encad) Hf (proj2 a_encad)).
  apply False_ind. apply (Rlt_not_eq (f b) (f a)) ; [|symmetry] ; assumption.
 assert (f_incr_interv2 : forall x y, lb <= x -> x <= y -> y <= ub -> f x <= f y).
  intros m n cond1 cond2 cond3.
   case cond2.
   intro cond. apply Rlt_le ; apply f_incr_interv ; assumption.
   intro cond ; right ; rewrite cond ; reflexivity.
 assert (Hyp2:forall x, lb <= x <= ub -> f (g (f x)) = f x).
  intros ; apply Hyp.  apply f_incr_interv2 ; intuition.
 apply f_incr_interv2 ; intuition.
 unfold comp ; unfold comp in Hyp.
 apply f_inj.
 apply g_wf ; apply f_incr_interv2 ; intuition.
 unfold id ; assumption.
 apply Hyp2 ; unfold id ; assumption.
Qed.

(** Intermediate Value Theorem on an Interval (Proof mainly taken from Reals.Rsqrt_def) and its corollary *)

Lemma IVT_interv_prelim0 : forall (x y:R) (P:R->bool) (N:nat),
       x < y ->
       x <= Dichotomy_ub x y P N <= y /\ x <= Dichotomy_lb x y P N <= y.
Proof.
assert (Sublemma : forall x y lb ub, lb <= x <= ub /\ lb <= y <= ub -> lb <= (x+y) / 2 <= ub).
  intros x y lb ub Hyp.
  lra.
intros x y P N x_lt_y.
induction N.
 simpl ; intuition.
 simpl.
 case (P ((Dichotomy_lb x y P N + Dichotomy_ub x y P N) / 2)).
 split. apply Sublemma ; intuition.
 intuition.
 split. intuition.
 apply Sublemma ; intuition.
Qed.

Lemma IVT_interv_prelim1 : forall (x y x0:R) (D : R -> bool),
       x < y ->
       Un_cv (dicho_up x y D) x0 ->
       x <= x0 <= y.
Proof.
intros x y x0 D x_lt_y bnd.
 assert (Main : forall n, x <= dicho_up x y D n <= y).
  intro n. unfold dicho_up.
  apply (proj1 (IVT_interv_prelim0 x y D n x_lt_y)).
 split.
  apply Rle_cv_lim with (Vn:=dicho_up x y D) (Un:=fun n => x).
  intro n ; exact (proj1 (Main n)).
  unfold Un_cv ; intros ; exists 0%nat ; intros ; unfold R_dist ; replace (x -x) with 0 by field ; rewrite Rabs_R0 ; assumption.
  assumption.
  apply Rle_cv_lim with (Un:=dicho_up x y D) (Vn:=fun n => y).
  intro n ; exact (proj2 (Main n)).
  assumption.
  unfold Un_cv ; intros ; exists 0%nat ; intros ; unfold R_dist ; replace (y -y) with 0 by field ; rewrite Rabs_R0 ; assumption.
Qed.

Lemma IVT_interv : forall (f : R -> R) (x y : R),
       (forall a, x <= a <= y -> continuity_pt f a) ->
       x < y ->
       f x < 0 ->
       0 < f y ->
       {z : R | x <= z <= y /\ f z = 0}.
Proof.
intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*)
  cut (x <= y).
  intro.
  generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3).
  generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3).
  intros X X0.
  elim X; intros x0 p.
  elim X0; intros x1 p0.
  assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p).
  rewrite H4 in p0.
  exists x0.
  split.
  split.
  apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0).
  simpl in |- *.
  right; reflexivity.
  apply growing_ineq.
  apply dicho_lb_growing; assumption.
  assumption.
  apply Rle_trans with (dicho_up x y (fun z:R => cond_positivity (f z)) 0).
  apply decreasing_ineq.
  apply dicho_up_decreasing; assumption.
  assumption.
  right; reflexivity.
  2: left; assumption.
  set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n).
  set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n).
  cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0).
  cut ((forall n:nat, 0 <= f (Wn n)) -> 0 <= f x0).
  intros.
  cut (forall n:nat, f (Vn n) <= 0).
  cut (forall n:nat, 0 <= f (Wn n)).
  intros.
  assert (H9 := H6 H8).
  assert (H10 := H5 H7).
  apply Rle_antisym; assumption.
  intro.
  unfold Wn in |- *.
  cut (forall z:R, cond_positivity z = true <-> 0 <= z).
  intro.
  assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n).
  elim (H7 (f (dicho_up x y (fun z:R => cond_positivity (f z)) n))); intros.
  apply H9.
  apply H8.
  elim (H7 (f y)); intros.
  apply H12.
  left; assumption.
  intro.
  unfold cond_positivity in |- *.
  destruct (Rle_dec 0 z) as [|Hnotle].
  split.
  intro; assumption.
  intro; reflexivity.
  split.
  intro feqt;discriminate feqt.
  intro.
  elim Hnotle; assumption.
  unfold Vn in |- *.
  cut (forall z:R, cond_positivity z = false <-> z < 0).
  intros.
  assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n).
  left.
  elim (H7 (f (dicho_lb x y (fun z:R => cond_positivity (f z)) n))); intros.
  apply H9.
  apply H8.
  elim (H7 (f x)); intros.
  apply H12.
  assumption.
  intro.
  unfold cond_positivity in |- *.
  destruct (Rle_dec 0 z) as [Hle|].
  split.
  intro feqt; discriminate feqt.
  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H7)).
  split.
  intro; auto with real.
  intro; reflexivity.
  cut (Un_cv Wn x0).
  intros.
  assert (Temp : x <= x0 <= y).
   apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption.
  assert (H7 := continuity_seq f Wn x0 (H x0 Temp) H5).
  destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt].
  left; assumption.
  right; reflexivity.
  unfold Un_cv in H7; unfold R_dist in H7.
  cut (0 < - f x0).
  intro.
  elim (H7 (- f x0) H8); intros.
  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
  assert (H11 := H9 x2 H10).
  rewrite Rabs_right in H11.
  pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
  unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11.
  assert (H12 := Rplus_lt_reg_l _ _ _ H11).
  assert (H13 := H6 x2).
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
  apply Rle_ge; left; unfold Rminus in |- *; apply Rplus_le_lt_0_compat.
  apply H6.
  exact H8.
  apply Ropp_0_gt_lt_contravar; assumption.
  unfold Wn in |- *; assumption.
  cut (Un_cv Vn x0).
  intros.
  assert (Temp : x <= x0 <= y).
   apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption.
  assert (H7 := continuity_seq f Vn x0 (H x0 Temp) H5).
  destruct (total_order_T 0 (f x0)) as [[Hlt|Heq]|].
  unfold Un_cv in H7; unfold R_dist in H7.
  elim (H7 (f x0) Hlt); intros.
  cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ].
  assert (H10 := H8 x2 H9).
  rewrite Rabs_left in H10.
  pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
  rewrite Ropp_minus_distr' in H10.
  unfold Rminus in H10.
  assert (H11 := Rplus_lt_reg_l _ _ _ H10).
  assert (H12 := H6 x2).
  cut (0 < f (Vn x2)).
  intro.
  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)).
  rewrite <- (Ropp_involutive (f (Vn x2))).
  apply Ropp_0_gt_lt_contravar; assumption.
  apply Rplus_lt_reg_l with (f x0 - f (Vn x2)).
  rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
    [ unfold Rminus in |- *; apply Rplus_lt_le_0_compat | ring ].
  assumption.
  apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
  right; rewrite <- Heq; reflexivity.
  left; assumption.
  unfold Vn in |- *; assumption.
Qed.

(* begin hide *)
Ltac case_le H :=
   let t := type of H in
   let h' := fresh in
      match t with ?x <= ?y => case (total_order_T x y);
         [intros h'; case h'; clear h' |
          intros h'; clear -H h'; elimtype False; fourier ] end.
(* end hide *)

Lemma f_interv_is_interv : forall (f:R->R) (lb ub y:R),
       lb < ub ->
       f lb <= y <= f ub ->
       (forall x, lb <=  x <= ub -> continuity_pt f x) ->
       {x | lb <= x <= ub /\ f x = y}.
Proof.
intros f lb ub y lb_lt_ub y_encad f_cont_interv.
 case y_encad ; intro y_encad1.
   case_le y_encad1 ; intros y_encad2 y_encad3 ; case_le y_encad3.
    intro y_encad4.
     clear y_encad y_encad1 y_encad3.
     assert (Cont : forall a : R, lb <= a <= ub -> continuity_pt (fun x => f x - y) a).
      intros a a_encad. unfold continuity_pt, continue_in, limit1_in, limit_in ; simpl ; unfold R_dist.
      intros eps eps_pos. elim (f_cont_interv a a_encad eps eps_pos).
      intros alpha alpha_pos. destruct alpha_pos as (alpha_pos,Temp).
      exists alpha. split.
      assumption. intros x  x_cond.
      replace (f x - y - (f a - y)) with (f x - f a) by field.
      exact (Temp x x_cond).
     assert (H1 : (fun x : R => f x - y) lb < 0).
       apply Rlt_minus. assumption.
      assert (H2 : 0 < (fun x : R => f x - y) ub).
       apply Rgt_minus ; assumption.
     destruct (IVT_interv (fun x => f x - y) lb ub Cont lb_lt_ub H1 H2) as (x,Hx).
     exists x.
     destruct Hx as (Hyp,Result).
     intuition.
     intro H ; exists ub ; intuition.
     intro H ; exists lb ; intuition.
     intro H ; exists ub ; intuition.
Qed.

(** ** The derivative of a reciprocal function       *)

(** * Continuity of the reciprocal function *)

Lemma continuity_pt_recip_prelim : forall (f g:R->R) (lb ub : R) (Pr1:lb < ub),
       (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) ->
       (forall x, lb <= x <= ub -> (comp g f) x = id x) ->
       (forall a, lb <= a <= ub -> continuity_pt f a) ->
       forall b,
       f lb < b < f ub ->
       continuity_pt g b.
Proof.
assert (Sublemma : forall x y z, Rmax x y < z <-> x < z /\ y < z).
 intros x y z. split.
  unfold Rmax. case (Rle_dec x y) ; intros Hyp Hyp2.
  split. apply Rle_lt_trans with (r2:=y) ; assumption. assumption.
  split. assumption. apply Rlt_trans with (r2:=x).
  assert (Temp : forall x y, ~ x <= y -> x > y).
   intros m n Hypmn. intuition.
  apply Temp ; clear Temp ; assumption.
  assumption.
  intros Hyp.
  unfold Rmax. case (Rle_dec x y).
  intro ; exact (proj2 Hyp).
  intro ; exact (proj1 Hyp).
assert (Sublemma2 : forall x y z, Rmin x y > z <-> x > z /\ y > z).
 intros x y z. split.
  unfold Rmin. case (Rle_dec x y) ; intros Hyp Hyp2.
  split. assumption.
  apply Rlt_le_trans with (r2:=x) ; intuition.
  split.
  apply Rlt_trans with (r2:=y). intuition.
  assert (Temp : forall x y, ~ x <= y -> x > y).
   intros m n Hypmn. intuition.
  apply Temp ; clear Temp ; assumption.
  assumption.
  intros Hyp.
  unfold Rmin. case (Rle_dec x y).
  intro ; exact (proj1 Hyp).
  intro ; exact (proj2 Hyp).
assert (Sublemma3 : forall x y, x <= y /\ x <> y -> x < y).
 intros m n Hyp. unfold Rle in Hyp.
  destruct Hyp as (Hyp1,Hyp2).
  case Hyp1.
  intuition.
  intro Hfalse ; apply False_ind ; apply Hyp2 ; exact Hfalse.
intros f g lb ub lb_lt_ub f_incr_interv f_eq_g f_cont_interv b b_encad.
 assert (f_incr_interv2 : forall x y, lb <= x -> x <= y -> y <= ub -> f x <= f y).
  intros m n cond1 cond2 cond3.
   case cond2.
   intro cond. apply Rlt_le ; apply f_incr_interv ; assumption.
   intro cond ; right ; rewrite cond ; reflexivity.
 unfold continuity_pt, continue_in, limit1_in, limit_in ; intros eps eps_pos.
 unfold dist ; simpl ; unfold R_dist.
 assert (b_encad_e : f lb <= b <= f ub) by intuition.
 elim (f_interv_is_interv f lb ub b lb_lt_ub b_encad_e f_cont_interv) ; intros x Temp.
 destruct Temp as (x_encad,f_x_b).
 assert (lb_lt_x : lb < x).
 assert (Temp : x <> lb).
  intro Hfalse.
  assert (Temp' : b = f lb).
   rewrite <- f_x_b ; rewrite Hfalse ; reflexivity.
  assert (Temp'' : b <> f lb).
   apply Rgt_not_eq ; exact (proj1 b_encad).
  apply Temp'' ; exact Temp'.
 apply Sublemma3.
 split. exact (proj1 x_encad).
 assert (Temp2 : forall x y:R, x <> y <-> y <> x).
  intros m n. split ; intuition.
 rewrite Temp2 ; assumption.
 assert (x_lt_ub : x < ub).
 assert (Temp : x <> ub).
  intro Hfalse.
  assert (Temp' : b = f ub).
   rewrite <- f_x_b ; rewrite Hfalse ; reflexivity.
  assert (Temp'' : b <> f ub).
   apply Rlt_not_eq ; exact (proj2 b_encad).
  apply Temp'' ; exact Temp'.
 apply Sublemma3.
 split ; [exact (proj2 x_encad) | assumption].
 pose (x1 := Rmax (x - eps) lb).
 pose (x2 := Rmin (x + eps) ub).
 assert (Hx1 : x1 = Rmax (x - eps) lb) by intuition.
 assert (Hx2 : x2 = Rmin (x + eps) ub) by intuition.
 assert (x1_encad : lb <= x1 <= ub).
  split. apply RmaxLess2.
  apply Rlt_le. rewrite Hx1. rewrite Sublemma.
  split. apply Rlt_trans with (r2:=x) ; fourier.
  assumption.
 assert (x2_encad : lb <= x2 <= ub).
  split. apply Rlt_le ; rewrite Hx2 ; apply Rgt_lt ; rewrite Sublemma2.
  split. apply Rgt_trans with (r2:=x) ; fourier.
  assumption.
  apply Rmin_r.
 assert (x_lt_x2 : x < x2).
  rewrite Hx2.
  apply Rgt_lt. rewrite Sublemma2.
  split ; fourier.
 assert (x1_lt_x : x1 < x).
  rewrite Hx1.
  rewrite Sublemma.
  split ; fourier.
 exists (Rmin (f x - f x1) (f x2 - f x)).
 split. apply Rmin_pos ; apply Rgt_minus. apply f_incr_interv ; [apply RmaxLess2 | | ] ; fourier.
 apply f_incr_interv ; intuition.
 intros y Temp.
 destruct Temp as (_,y_cond).
  rewrite <- f_x_b in y_cond.
  assert (Temp : forall x y d1 d2, d1 > 0 -> d2 > 0 -> Rabs (y - x) < Rmin d1 d2 -> x - d1 <= y <= x + d2).
   intros.
    split. assert (H10 : forall x y z, x - y <= z -> x - z <= y). intuition. fourier.
    apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)).
    replace (Rabs (y0 - x0)) with (Rabs (x0 - y0)). apply RRle_abs.
    rewrite <- Rabs_Ropp. unfold Rminus ; rewrite Ropp_plus_distr. rewrite Ropp_involutive.
    intuition.
    apply Rle_trans with (r2:= Rmin d1 d2). apply Rlt_le ; assumption.
    apply Rmin_l.
    assert (H10 : forall x y z, x - y <= z -> x <= y + z). intuition. fourier.
    apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)). apply RRle_abs.
    apply Rle_trans with (r2:= Rmin d1 d2). apply Rlt_le ; assumption.
    apply Rmin_r.
  assert (Temp' := Temp (f x) y (f x - f x1) (f x2 - f x)).
  replace (f x - (f x - f x1)) with (f x1) in Temp' by field.
  replace (f x + (f x2 - f x)) with (f x2) in Temp' by field.
  assert (T : f x - f x1 > 0).
   apply Rgt_minus. apply f_incr_interv ; intuition.
  assert (T' : f x2 - f x > 0).
   apply Rgt_minus. apply f_incr_interv ; intuition.
  assert (Main := Temp' T T' y_cond).
  clear Temp Temp' T T'.
  assert (x1_lt_x2 : x1 < x2).
   apply Rlt_trans with (r2:=x) ; assumption.
   assert (f_cont_myinterv : forall a : R, x1 <= a <= x2 -> continuity_pt f a).
    intros ; apply f_cont_interv ; split.
    apply Rle_trans with (r2 := x1) ; intuition.
    apply Rle_trans with (r2 := x2) ; intuition.
   elim (f_interv_is_interv f x1 x2 y x1_lt_x2 Main f_cont_myinterv) ; intros x' Temp.
   destruct Temp as (x'_encad,f_x'_y).
   rewrite <- f_x_b ; rewrite <- f_x'_y.
   unfold comp in f_eq_g. rewrite f_eq_g. rewrite f_eq_g.
   unfold id.
   assert (x'_encad2 : x - eps <= x' <= x + eps).
    split.
    apply Rle_trans with (r2:=x1) ; [ apply RmaxLess1|] ; intuition.
    apply Rle_trans with (r2:=x2) ; [ | apply Rmin_l] ; intuition.
    assert (x1_lt_x' : x1 < x').
     apply Sublemma3.
     assert (x1_neq_x' : x1 <> x').
      intro Hfalse. rewrite Hfalse, f_x'_y in y_cond.
      assert (Hf : Rabs (y - f x) < f x - y).
       apply Rlt_le_trans with (r2:=Rmin (f x - y) (f x2 - f x)). fourier.
       apply Rmin_l.
      assert(Hfin : f x - y < f x - y).
       apply Rle_lt_trans with (r2:=Rabs (y - f x)).
       replace (Rabs (y - f x)) with (Rabs (f x - y)). apply RRle_abs.
       rewrite <- Rabs_Ropp. replace (- (f x - y)) with (y - f x) by field ; reflexivity. fourier.
      apply (Rlt_irrefl (f x - y)) ; assumption.
      split ; intuition.
     assert (x'_lb : x - eps < x').
      apply Sublemma3.
      split. intuition. apply Rlt_not_eq.
      apply Rle_lt_trans with (r2:=x1) ; [ apply RmaxLess1|] ; intuition.
     assert (x'_lt_x2 : x' < x2).
     apply Sublemma3.
     assert (x1_neq_x' : x' <> x2).
      intro Hfalse. rewrite <- Hfalse, f_x'_y in y_cond.
      assert (Hf : Rabs (y - f x) < y - f x).
       apply Rlt_le_trans with (r2:=Rmin (f x - f x1) (y - f x)). fourier.
       apply Rmin_r.
      assert(Hfin : y - f x < y - f x).
       apply Rle_lt_trans with (r2:=Rabs (y - f x)). apply RRle_abs. fourier.
      apply (Rlt_irrefl (y - f x)) ; assumption.
      split ; intuition.
     assert (x'_ub : x' < x + eps).
      apply Sublemma3.
      split. intuition. apply Rlt_not_eq.
      apply Rlt_le_trans with (r2:=x2) ; [ |rewrite Hx2 ; apply Rmin_l] ; intuition.
    apply Rabs_def1 ; fourier.
    assumption.
    split. apply Rle_trans with (r2:=x1) ; intuition.
    apply Rle_trans with (r2:=x2) ; intuition.
Qed.

Lemma continuity_pt_recip_interv : forall (f g:R->R) (lb ub : R) (Pr1:lb < ub),
       (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) ->
       (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) ->
       (forall x, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
       (forall a, lb <= a <= ub -> continuity_pt f a) ->
       forall b,
       f lb < b < f ub ->
       continuity_pt g b.
Proof.
intros f g lb ub lb_lt_ub f_incr_interv f_eq_g g_wf.
assert (g_eq_f_prelim := leftinv_is_rightinv_interv f g lb ub f_incr_interv f_eq_g).
assert (g_eq_f : forall x, lb <= x <= ub -> (comp g f) x = id x).
intro x ; apply g_eq_f_prelim ; assumption.
apply (continuity_pt_recip_prelim f g lb ub lb_lt_ub f_incr_interv g_eq_f).
Qed.

(** *   Derivability of the reciprocal function        *)

Lemma derivable_pt_lim_recip_interv : forall (f g:R->R) (lb ub x:R)
       (Prf:forall a : R, g lb <= a <= g ub -> derivable_pt f a) (Prg : continuity_pt g x),
       lb < ub ->
       lb < x < ub ->
       forall (Prg_incr:g lb <= g x <= g ub),
       (forall x, lb <= x <= ub -> (comp f g) x = id x) ->
       derive_pt f (g x) (Prf (g x) Prg_incr) <> 0 ->
       derivable_pt_lim g x (1 / derive_pt f (g x) (Prf (g x) Prg_incr)).
Proof.
intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq.
 assert (x_encad2 : lb <= x <= ub).
  split ; apply Rlt_le ; intuition.
 elim (Prf (g x)); simpl; intros l Hl.
 unfold derivable_pt_lim.
 intros eps eps_pos.
  pose (y := g x).
   assert (Hlinv := limit_inv).
    assert (Hf_deriv : forall eps:R,
    0 < eps ->
    exists delta : posreal,
    (forall h:R,
    h <> 0 -> Rabs h < delta -> Rabs ((f (g x + h) - f (g x)) / h - l) < eps)).
     intros eps0 eps0_pos.
      red in Hl ; red in Hl. elim (Hl eps0 eps0_pos).
      intros deltatemp Htemp.
       exists deltatemp ; exact Htemp.
    elim (Hf_deriv eps eps_pos).
    intros deltatemp Htemp.
     red in Hlinv ; red in Hlinv ; unfold dist in Hlinv ; unfold R_dist in Hlinv.
     assert (Hlinv' := Hlinv (fun h => (f (y+h) - f y)/h) (fun h => h <>0) l 0).
     unfold limit1_in, limit_in, dist in Hlinv' ; simpl in Hlinv'. unfold R_dist in Hlinv'.
     assert (Premisse : (forall eps : R,
     eps > 0 ->
     exists alp : R,
     alp > 0 /\
     (forall x : R,
     (fun h => h <>0) x /\ Rabs (x - 0) < alp ->
     Rabs ((f (y + x) - f y) / x - l) < eps))).
      intros eps0 eps0_pos.
       elim (Hf_deriv eps0 eps0_pos).
       intros deltatemp' Htemp'.
        exists deltatemp'.
        split.
         exact deltatemp'.(cond_pos).
         intros htemp cond.
          apply (Htemp' htemp).
          exact (proj1 cond).
         replace (htemp) with (htemp - 0).
         exact (proj2 cond).
         intuition.
     assert (Premisse2 : l <> 0).
      intro l_null.
       rewrite l_null in Hl.
       apply df_neq.
       rewrite derive_pt_eq.
       exact Hl.
     elim (Hlinv' Premisse Premisse2 eps eps_pos).
     intros alpha cond.
      assert (alpha_pos := proj1 cond) ; assert (inv_cont := proj2 cond) ; clear cond.
      unfold derivable, derivable_pt, derivable_pt_abs, derivable_pt_lim in Prf.
      elim (Hl eps eps_pos).
      intros delta f_deriv.
       assert (g_cont := g_cont_pur).
       unfold continuity_pt, continue_in, limit1_in, limit_in in g_cont.
       pose (mydelta := Rmin delta alpha).
       assert (mydelta_pos : mydelta > 0).
        unfold mydelta, Rmin.
        case (Rle_dec delta alpha).
        intro ; exact (delta.(cond_pos)).
        intro ; exact alpha_pos.
       elim (g_cont mydelta mydelta_pos).
       intros delta' new_g_cont.
        assert(delta'_pos := proj1 (new_g_cont)).
        clear g_cont ; assert (g_cont := proj2 (new_g_cont)) ; clear new_g_cont.
        pose (mydelta'' := Rmin delta' (Rmin (x - lb) (ub - x))).
        assert(mydelta''_pos : mydelta'' > 0).
         unfold mydelta''.
         apply Rmin_pos ; [intuition | apply Rmin_pos] ; apply Rgt_minus ; intuition.
        pose (delta'' := mkposreal mydelta'' mydelta''_pos: posreal).
        exists delta''.
        intros h h_neq h_le_delta'.
  assert (lb <= x +h <= ub).
 assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y).
  intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n).
   apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs.
   apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption.
 assert (lb <= x + h <= ub).
 split.
 assert (Sublemma : forall x y z, -z <= y - x -> x <= y + z).
  intros ; fourier.
 apply Sublemma.
 apply Rlt_le ; apply Sublemma2. rewrite Rabs_Ropp.
 apply Rlt_le_trans with (r2:=x-lb) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))).
 apply Rlt_le_trans with (r2:=delta''). assumption. intuition. apply Rmin_r.
 apply Rgt_minus. intuition.
 assert (Sublemma : forall x y z, y <= z - x -> x + y <= z).
  intros ; fourier.
 apply Sublemma.
 apply Rlt_le ; apply Sublemma2.
 apply Rlt_le_trans with (r2:=ub-x) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_r] ;
 apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))) ; [| apply Rmin_r] ; assumption.
 apply Rlt_le_trans with (r2:=delta''). assumption.
  apply Rle_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))). intuition.
  apply Rle_trans with (r2:=Rmin (x - lb) (ub - x)). apply Rmin_r. apply Rmin_r.
         replace ((g (x + h) - g x) / h) with (1/ (h / (g (x + h) - g x))).
         assert (Hrewr : h = (comp f g ) (x+h) - (comp f g) x).
          rewrite f_eq_g. rewrite f_eq_g ; unfold id. rewrite Rplus_comm ;
          unfold Rminus ; rewrite Rplus_assoc ; rewrite Rplus_opp_r. intuition. intuition.
 assumption.
         split ; [|intuition].
         assert (Sublemma : forall x y z, - z <= y - x -> x <= y + z).
          intros ; fourier.
         apply Sublemma ; apply Rlt_le ; apply Sublemma2. rewrite Rabs_Ropp.
 apply Rlt_le_trans with (r2:=x-lb) ; [| apply RRle_abs] ;
 apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_l] ;
 apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))) ; [| apply Rmin_r] ; assumption.
 apply Rgt_minus. intuition.
 field.
 split. assumption.
 intro Hfalse. assert (Hf : g (x+h) = g x) by intuition.
 assert ((comp f g) (x+h) = (comp f g) x).
  unfold comp ; rewrite Hf ; intuition.
 assert (Main : x+h = x).
 replace (x +h) with (id (x+h)) by intuition.
 assert (Temp : x = id x) by intuition ; rewrite Temp at 2 ; clear Temp.
 rewrite <- f_eq_g. rewrite <- f_eq_g. assumption.
 intuition. assumption.
 assert (h = 0).
 apply Rplus_0_r_uniq with (r:=x) ; assumption.
 apply h_neq ; assumption.
         replace ((g (x + h) - g x) / h) with (1/ (h / (g (x + h) - g x))).
         assert (Hrewr : h = (comp f g ) (x+h) - (comp f g) x).
          rewrite f_eq_g. rewrite f_eq_g. unfold id ; rewrite Rplus_comm ;
          unfold Rminus ; rewrite Rplus_assoc ; rewrite Rplus_opp_r ; intuition.
          assumption. assumption.
         rewrite Hrewr at 1.
         unfold comp.
         replace (g(x+h)) with (g x + (g (x+h) - g(x))) by field.
         pose (h':=g (x+h) - g x).
         replace (g (x+h) - g x) with h' by intuition.
         replace (g x + h' - g x) with h' by field.
         assert (h'_neq : h' <> 0).
          unfold h'.
          intro Hfalse.
          unfold Rminus in Hfalse ; apply Rminus_diag_uniq in Hfalse.
          assert (Hfalse' : (comp f g) (x+h) = (comp f g) x).
           intros ; unfold comp ; rewrite Hfalse ; trivial.
          rewrite f_eq_g in Hfalse' ; rewrite f_eq_g in Hfalse'.
          unfold id in Hfalse'.
          apply Rplus_0_r_uniq in Hfalse'.
          apply h_neq ; exact Hfalse'. assumption. assumption. assumption.
         unfold Rdiv at 1 3; rewrite Rmult_1_l ; rewrite Rmult_1_l.
         apply inv_cont.
         split.
          exact h'_neq.
          rewrite Rminus_0_r.
          unfold continuity_pt, continue_in, limit1_in, limit_in in g_cont_pur.
          elim (g_cont_pur mydelta mydelta_pos).
          intros delta3 cond3.
          unfold dist in cond3 ; simpl in cond3 ; unfold R_dist in cond3.
          unfold h'.
          assert (mydelta_le_alpha : mydelta <= alpha).
           unfold mydelta, Rmin ; case (Rle_dec delta alpha).
           trivial.
           intro ; intuition.
          apply Rlt_le_trans with (r2:=mydelta).
          unfold dist in g_cont ; simpl in g_cont ; unfold R_dist in g_cont ; apply g_cont.
          split.
           unfold D_x ; simpl.
           split.
            unfold no_cond ; trivial.
            intro Hfalse ; apply h_neq.
             apply (Rplus_0_r_uniq x).
             symmetry ; assumption.
            replace (x + h - x) with h by field.
            apply Rlt_le_trans with (r2:=delta'').
            assumption ; unfold delta''. intuition.
            apply Rle_trans with (r2:=mydelta''). apply Req_le. unfold delta''. intuition.
            apply Rmin_l. assumption.
            field ; split.
             assumption.
             intro Hfalse ; apply h_neq.
             apply (Rplus_0_r_uniq x).
             assert (Hfin : (comp f g) (x+h) = (comp f g) x).
              apply Rminus_diag_uniq in Hfalse.
              unfold comp.
              rewrite Hfalse ; reflexivity.
              rewrite f_eq_g in Hfin. rewrite f_eq_g in Hfin. unfold id in Hfin. exact Hfin.
              assumption. assumption.
Qed.

Lemma derivable_pt_recip_interv_prelim0 : forall (f g : R -> R) (lb ub x : R)
       (Prf : forall a : R, g lb <= a <= g ub -> derivable_pt f a),
       continuity_pt g x ->
       lb < ub ->
       lb < x < ub ->
       forall Prg_incr : g lb <= g x <= g ub,
       (forall x0 : R, lb <= x0 <= ub -> comp f g x0 = id x0) ->
       derive_pt f (g x) (Prf (g x) Prg_incr) <> 0 ->
       derivable_pt g x.
Proof.
intros f g lb ub x Prf g_cont_pt lb_lt_ub x_encad Prg_incr f_eq_g Df_neq.
unfold derivable_pt, derivable_pt_abs.
exists (1 / derive_pt f (g x) (Prf (g x) Prg_incr)).
apply derivable_pt_lim_recip_interv ; assumption.
Qed.

Lemma derivable_pt_recip_interv_prelim1 :forall (f g:R->R) (lb ub x : R),
         lb < ub ->
         f lb < x < f ub ->
         (forall x : R, f lb <= x -> x <= f ub -> comp f g x = id x) ->
         (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
         (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) ->
         (forall a : R, lb <= a <= ub -> derivable_pt f a) ->
         derivable_pt f (g x).
Proof.
intros f g lb ub x lb_lt_ub x_encad f_eq_g g_ok f_incr f_derivable.
 apply f_derivable.
 assert (Left_inv := leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_ok).
 replace lb with ((comp g f) lb).
 replace ub with ((comp g f) ub).
 unfold comp.
 assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_ok).
 split ; apply Rlt_le ; apply Temp ; intuition.
 apply Left_inv ; intuition.
 apply Left_inv ; intuition.
Qed.

Lemma derivable_pt_recip_interv : forall (f g:R->R) (lb ub x : R)
         (lb_lt_ub:lb < ub) (x_encad:f lb < x < f ub)
         (f_eq_g:forall x : R, f lb <= x -> x <= f ub -> comp f g x = id x)
         (g_wf:forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub)
         (f_incr:forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y)
         (f_derivable:forall a : R, lb <= a <= ub -> derivable_pt f a),
         derive_pt f (g x)
              (derivable_pt_recip_interv_prelim1 f g lb ub x lb_lt_ub
              x_encad f_eq_g g_wf f_incr f_derivable)
         <> 0 ->
         derivable_pt g x.
Proof.
intros f g lb ub x lb_lt_ub x_encad f_eq_g g_wf f_incr f_derivable Df_neq.
 assert(g_incr : g (f lb) < g x < g (f ub)).
  assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_wf).
  split ; apply Temp ; intuition.
  exact (proj1 x_encad). apply Rlt_le ; exact (proj2 x_encad).
  apply Rlt_le ; exact (proj1 x_encad). exact (proj2 x_encad).
 assert(g_incr2 :  g (f lb) <= g x <= g (f ub)).
  split ; apply Rlt_le ; intuition.
 assert (g_eq_f :=  leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_wf).
 unfold comp, id in g_eq_f.
 assert (f_derivable2 : forall a : R, g (f lb) <= a <= g (f ub) -> derivable_pt f a).
  intros a a_encad ; apply f_derivable.
   rewrite g_eq_f in a_encad ; rewrite g_eq_f in a_encad ; intuition.
 apply derivable_pt_recip_interv_prelim0 with (f:=f) (lb:=f lb) (ub:=f ub)
     (Prf:=f_derivable2) (Prg_incr:=g_incr2).
 apply continuity_pt_recip_interv with (f:=f) (lb:=lb) (ub:=ub) ; intuition.
 apply derivable_continuous_pt ; apply f_derivable ; intuition.
 exact (proj1 x_encad). exact (proj2 x_encad).  apply f_incr ; intuition.
 assumption.
 intros x0 x0_encad ; apply f_eq_g ; intuition.
 rewrite pr_nu_var2_interv with (g:=f) (lb:=lb) (ub:=ub) (pr2:=derivable_pt_recip_interv_prelim1 f g lb ub x lb_lt_ub x_encad
      f_eq_g g_wf f_incr f_derivable) ; [| |rewrite g_eq_f in g_incr ; rewrite g_eq_f in g_incr| ] ; intuition.
Qed.

(****************************************************)
(** *   Value of the derivative of the reciprocal function        *)
(****************************************************)

Lemma derive_pt_recip_interv_prelim0 : forall (f g:R->R) (lb ub x:R)
       (Prf:derivable_pt f (g x)) (Prg:derivable_pt g x),
       lb < ub ->
       lb < x < ub ->
       (forall x, lb < x < ub -> (comp f g) x = id x) ->
       derive_pt f (g x) Prf <> 0 ->
       derive_pt g x Prg = 1 / (derive_pt f (g x) Prf).
Proof.
intros f g lb ub x Prf Prg lb_lt_ub x_encad local_recip Df_neq.
 replace (derive_pt g x Prg) with
  ((derive_pt g x Prg) * (derive_pt f (g x) Prf) * / (derive_pt f (g x) Prf)).
 unfold Rdiv.
 rewrite (Rmult_comm _ (/ derive_pt f (g x) Prf)).
 rewrite (Rmult_comm _ (/ derive_pt f (g x) Prf)).
 apply Rmult_eq_compat_l.
 rewrite Rmult_comm.
 rewrite <- derive_pt_comp.
 assert (x_encad2 : lb <= x <= ub) by intuition.
 rewrite pr_nu_var2_interv with (g:=id) (pr2:= derivable_pt_id_interv lb ub x x_encad2) (lb:=lb) (ub:=ub) ; [reg| | |] ; assumption.
 rewrite Rmult_assoc, Rinv_r.
 intuition.
 assumption.
Qed.

Lemma derive_pt_recip_interv_prelim1_0 : forall (f g:R->R) (lb ub x:R),
       lb < ub ->
       f lb < x < f ub ->
       (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) ->
       (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
       (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) ->
       lb < g x < ub.
Proof.
intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g.
 assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_wf).
 assert (Left_inv := leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_wf).
 unfold comp, id in Left_inv.
 split ; [rewrite <- Left_inv with (x:=lb) | rewrite <- Left_inv ].
 apply Temp ; intuition.
 intuition.
 apply Temp ; intuition.
 intuition.
Qed.

Lemma derive_pt_recip_interv_prelim1_1 : forall (f g:R->R) (lb ub x:R),
       lb < ub ->
       f lb < x < f ub ->
       (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) ->
       (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
       (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) ->
       lb <= g x <= ub.
Proof.
intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g.
 assert (Temp := derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g).
 split ; apply Rlt_le ; intuition.
Qed.

Lemma derive_pt_recip_interv : forall (f g:R->R) (lb ub x:R)
       (lb_lt_ub:lb < ub) (x_encad:f lb < x < f ub)
       (f_incr:forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y)
       (g_wf:forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub)
       (Prf:forall a : R, lb <= a <= ub -> derivable_pt f a)
       (f_eq_g:forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x)
       (Df_neq:derive_pt f (g x) (derivable_pt_recip_interv_prelim1 f g lb ub x
                 lb_lt_ub x_encad f_eq_g g_wf f_incr Prf) <> 0),
       derive_pt g x (derivable_pt_recip_interv f g lb ub x lb_lt_ub x_encad f_eq_g
                 g_wf f_incr Prf Df_neq)
       =
       1 / (derive_pt f (g x) (Prf (g x) (derive_pt_recip_interv_prelim1_1 f g lb ub x
       lb_lt_ub x_encad f_incr g_wf f_eq_g))).
Proof.
intros.
 assert(g_incr := (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub
        x_encad f_incr g_wf f_eq_g)).
 apply derive_pt_recip_interv_prelim0 with (lb:=f lb) (ub:=f ub) ;
 [intuition |assumption | intuition |].
 intro Hfalse ; apply Df_neq.  rewrite pr_nu_var2_interv with (g:=f) (lb:=lb) (ub:=ub)
        (pr2:= (Prf (g x) (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub x_encad
                 f_incr g_wf f_eq_g))) ;
 [intuition | intuition | | intuition].
 exact (derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g).
Qed.

(****************************************************)
(** * Existence of the derivative of a function which is the limit of a sequence of functions *)
(****************************************************)

(* begin hide *)
Lemma ub_lt_2_pos : forall x ub lb, lb < x -> x < ub -> 0 < (ub-lb)/2.
Proof.
intros x ub lb lb_lt_x x_lt_ub.
lra.
Qed.

Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb<x) (x_lt_ub:x<ub) : posreal.
 apply (mkposreal ((ub-lb)/2) (ub_lt_2_pos x ub lb lb_lt_x x_lt_ub)).
Defined.
(* end hide *)

Lemma derivable_pt_lim_CVU : forall (fn fn':nat -> R -> R) (f g:R->R)
      (x:R) c r, Boule c r x ->
      (forall y n, Boule c r y -> derivable_pt_lim (fn n) y (fn' n y)) ->
      (forall y, Boule c r y -> Un_cv (fun n => fn n y) (f y)) ->
      (CVU fn' g c r) ->
      (forall y, Boule c r y -> continuity_pt g y) ->
      derivable_pt_lim f x (g x).
Proof.
intros fn fn' f g x c' r xinb Dfn_eq_fn' fn_CV_f fn'_CVU_g g_cont eps eps_pos.
assert (eps_8_pos : 0 < eps / 8) by fourier.
elim (g_cont x xinb _ eps_8_pos) ; clear g_cont ;
intros delta1 (delta1_pos, g_cont).
destruct (Ball_in_inter _ _ _ _ _ xinb
   (Boule_center x (mkposreal _ delta1_pos)))
   as [delta Pdelta].
exists delta; intros h hpos hinbdelta.
assert (eps'_pos : 0 < (Rabs h) * eps / 4).
 unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat.
 apply Rabs_pos_lt ; assumption.
fourier.
destruct (fn_CV_f x xinb ((Rabs h) * eps / 4) eps'_pos) as [N2 fnx_CV_fx].
assert (xhinbxdelta : Boule x delta (x + h)).
 clear -hinbdelta; apply Rabs_def2 in hinbdelta; unfold Boule; simpl.
 destruct hinbdelta; apply Rabs_def1; fourier.
assert (t : Boule c' r (x + h)).
 apply Pdelta in xhinbxdelta; tauto.
destruct (fn_CV_f (x+h) t ((Rabs h) * eps / 4) eps'_pos) as [N1 fnxh_CV_fxh].
clear fn_CV_f t.
destruct (fn'_CVU_g (eps/8) eps_8_pos) as [N3 fn'c_CVU_gc].
pose (N := ((N1 + N2) + N3)%nat).
assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn N x - h * (g x))) < (Rabs h)*eps).
 apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h) - (f x - fn N x)) +  Rabs ((fn N (x + h) - fn N x - h * g x))).
  solve[apply Rabs_triang].
 apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h)) + Rabs (- (f x - fn N x)) + Rabs (fn N (x + h) - fn N x - h * g x)).
  solve[apply Rplus_le_compat_r ; apply Rabs_triang].
 rewrite Rabs_Ropp.
 case (Rlt_le_dec h 0) ; intro sgn_h.
  assert (pr1 : forall c : R, x + h < c < x -> derivable_pt (fn N) c).
   intros c c_encad ; unfold derivable_pt.
   exists (fn' N c) ; apply Dfn_eq_fn'.
   assert (t : Boule x delta c).
    apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta; destruct c_encad.
    apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
   apply Pdelta in t; tauto.
  assert (pr2 : forall c : R, x + h < c < x -> derivable_pt id c).
   solve[intros; apply derivable_id].
  assert (xh_x : x+h < x) by fourier.
  assert (pr3 : forall c : R, x + h <= c <= x -> continuity_pt (fn N) c).
   intros c c_encad ; apply derivable_continuous_pt.
   exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
   assert (t : Boule x delta c).
    apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
    apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
   apply Pdelta in t; tauto.
  assert (pr4 : forall c : R, x + h <= c <= x -> continuity_pt id c).
   solve[intros; apply derivable_continuous ; apply derivable_id].
  destruct (MVT (fn N) id (x+h) x pr1 pr2 xh_x pr3 pr4) as [c [P Hc]].
  assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = (fn N (x+h) - fn N x)).
   apply Rmult_eq_reg_l with (-1).
    replace (-1 * (h * derive_pt (fn N) c (pr1 c P))) with (-h * derive_pt (fn N) c (pr1 c P)) by field.
    replace (-1 * (fn N (x + h) - fn N x)) with (- (fn N (x + h) - fn N x)) by field.
    replace (-h) with (id x - id (x + h)) by (unfold id; field).
    rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
    replace (- (fn N (x + h) - fn N x)) with (fn N x - fn N (x + h)) by field.
    assumption.
  now apply Rlt_not_eq, IZR_lt.
  rewrite <- Hc'; clear Hc Hc'.
  replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
  replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
   rewrite Rabs_mult.
   apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
    apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
 rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
   unfold N; omega.
   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
    apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
    unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
    unfold N ; omega.
   replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
   apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
    rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
    apply Rplus_le_compat_l ; apply Rplus_le_compat_l ;
    rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l.
     solve[apply Rabs_pos].
    solve[apply Rabs_triang].
   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * (eps / 8) + Rabs h * Rabs (g c - g x)).
    apply Rplus_lt_compat_r; apply Rplus_lt_compat_l; apply Rmult_lt_compat_l.
     apply Rabs_pos_lt ; assumption.
    rewrite Rabs_minus_sym ; apply fn'c_CVU_gc.
     unfold N ; omega.
    assert (t : Boule x delta c).
     destruct P.
     apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
     apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
    apply Pdelta in t; tauto.
   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
         Rabs h * (eps / 8)).
    rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
    apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ;
    rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l.
     apply Rabs_pos_lt ; assumption.
     apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
      solve[unfold no_cond ; intuition].
     apply Rgt_not_eq ; exact (proj2 P).
    apply Rlt_trans with (Rabs h).
     apply Rabs_def1.
      apply Rlt_trans with 0.
       destruct P; fourier.
      apply Rabs_pos_lt ; assumption.
     rewrite <- Rabs_Ropp, Rabs_pos_eq, Ropp_involutive;[ | fourier].
     destruct P; fourier.
    clear -Pdelta xhinbxdelta.
    apply Pdelta in xhinbxdelta; destruct xhinbxdelta as [_ P'].
    apply Rabs_def2 in P'; simpl in P'; destruct P';
    apply Rabs_def1; fourier.
   rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
   replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
   apply Rmult_lt_compat_l.
    apply Rabs_pos_lt ; assumption.
   fourier.
  assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
  assert (Temp : l = fn' N c).
   assert (bc'rc : Boule c' r c).
    assert (t : Boule x delta c).
     clear - xhinbxdelta P.
     destruct P; apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
     apply Rabs_def1; fourier.
    apply Pdelta in t; tauto.
   assert (Hl' := Dfn_eq_fn' c N bc'rc).
   unfold derivable_pt_abs in Hl; clear -Hl Hl'.
   apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
  rewrite <- Temp.
  assert (Hl' : derivable_pt (fn N) c).
  exists l ; apply Hl.
  rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
   elim Hl' ; clear Hl' ; intros l' Hl'.
   assert (Main : l = l').
    apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
   rewrite Main ; reflexivity.
  reflexivity.
 assert (h_pos : h > 0).
  case sgn_h ; intro Hyp.
  assumption.
  apply False_ind ; apply hpos ; symmetry ; assumption.
 clear sgn_h.
 assert (pr1 : forall c : R, x < c < x + h -> derivable_pt (fn N) c).
  intros c c_encad ; unfold derivable_pt.
  exists (fn' N c) ; apply Dfn_eq_fn'.
  assert (t : Boule x delta c).
   apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta; destruct c_encad.
   apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
  apply Pdelta in t; tauto.
  assert (pr2 : forall c : R, x < c < x + h -> derivable_pt id c).
   solve[intros; apply derivable_id].
  assert (xh_x : x < x + h) by fourier.
  assert (pr3 : forall c : R, x <= c <= x + h -> continuity_pt (fn N) c).
   intros c c_encad ; apply derivable_continuous_pt.
   exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
   assert (t : Boule x delta c).
    apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
    apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
   apply Pdelta in t; tauto.
  assert (pr4 : forall c : R, x <= c <= x + h -> continuity_pt id c).
   solve[intros; apply derivable_continuous ; apply derivable_id].
  destruct (MVT (fn N) id x (x+h) pr1 pr2 xh_x pr3 pr4) as [c [P Hc]].
  assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = fn N (x+h) - fn N x).
    pattern h at 1; replace h with (id (x + h) - id x) by (unfold id; field).
    rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
    assumption.
  rewrite <- Hc'; clear Hc Hc'.
  replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
  replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
   rewrite Rabs_mult.
   apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
    apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
 rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
   unfold N; omega.
   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
    apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
    unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
    unfold N ; omega.
   replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
   apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
    rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
    apply Rplus_le_compat_l ; apply Rplus_le_compat_l ;
    rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l.
     solve[apply Rabs_pos].
    solve[apply Rabs_triang].
   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * (eps / 8) + Rabs h * Rabs (g c - g x)).
    apply Rplus_lt_compat_r; apply Rplus_lt_compat_l; apply Rmult_lt_compat_l.
     apply Rabs_pos_lt ; assumption.
    rewrite Rabs_minus_sym ; apply fn'c_CVU_gc.
     unfold N ; omega.
    assert (t : Boule x delta c).
     destruct P.
    apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
    apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
   apply Pdelta in t; tauto.
  apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
         Rabs h * (eps / 8)).
   rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
    apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ;
   rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l.
    apply Rabs_pos_lt ; assumption.
   apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
     solve[unfold no_cond ; intuition].
    apply Rlt_not_eq ; exact (proj1 P).
   apply Rlt_trans with (Rabs h).
    apply Rabs_def1.
     destruct P; rewrite Rabs_pos_eq;fourier.
    apply Rle_lt_trans with 0.
     assert (t := Rabs_pos h); clear -t; fourier.
    clear -P; destruct P; fourier.
   clear -Pdelta xhinbxdelta.
   apply Pdelta in xhinbxdelta; destruct xhinbxdelta as [_ P'].
   apply Rabs_def2 in P'; simpl in P'; destruct P';
    apply Rabs_def1; fourier.
  rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
  replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
  apply Rmult_lt_compat_l.
   apply Rabs_pos_lt ; assumption.
  fourier.
 assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
 assert (Temp : l = fn' N c).
  assert (bc'rc : Boule c' r c).
   assert (t : Boule x delta c).
    clear - xhinbxdelta P.
    destruct P; apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
    apply Rabs_def1; fourier.
   apply Pdelta in t; tauto.
  assert (Hl' := Dfn_eq_fn' c N bc'rc).
  unfold derivable_pt_abs in Hl; clear -Hl Hl'.
  apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
 rewrite <- Temp.
 assert (Hl' : derivable_pt (fn N) c).
 exists l ; apply Hl.
 rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
  elim Hl' ; clear Hl' ; intros l' Hl'.
  assert (Main : l = l').
   apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
  rewrite Main ; reflexivity.
 reflexivity.
 replace ((f (x + h) - f x) / h - g x) with ((/h) * ((f (x + h) - f x) - h * g x)).
 rewrite Rabs_mult ; rewrite Rabs_Rinv.
 replace eps with (/ Rabs h * (Rabs h * eps)).
 apply Rmult_lt_compat_l.
 apply Rinv_0_lt_compat ; apply Rabs_pos_lt ; assumption.
 replace (f (x + h) - f x - h * g x) with (f (x + h) - fn N (x + h) - (f x - fn N x) +
          (fn N (x + h) - fn N x - h * g x)) by field.
 assumption.
 field ; apply Rgt_not_eq ; apply Rabs_pos_lt ; assumption.
 assumption.
 field. assumption.
Qed.