(** * Univalent Foundations. Vladimir Voevodsky. Feb. 2010 - Sep. 2011.
  Port to coq trunk (8.4-8.5) in March 2014. The third part of the original
  uu0 file, created on Dec. 3, 2014.

Only one universe is used and never as a type.

*)

(** ** Contents
- Sections of "double fibration" [(P : T -> UU) (PP : ∏ t : T, P t -> UU)] and
  pairs of sections
 - General case
 - Functions on dependent sum (to a [total2])
 - Functions to direct product
- Homotopy fibers of the map [∏ x : X, P x -> ∏ x : X, Q x]
 - General case
 - The weak equivalence between sections spaces (dependent products) defined
   by a family of weak equivalences [(P x) ≃ (Q x)]
 - Composition of functions with a weak equaivalence on the right
- The map between section spaces (dependent products) defined by the map
  between the bases [ f : Y -> X ]
 - General case
 - Composition of functions with a weak equivalence on the left
- Sections of families over an empty type and over coproducts
 - General case
 - Functions from the empty type
 - Functions from a coproduct
- Sections of families over contractible types and over [ total2 ]
  (over dependent sums)
 - General case
 - Functions from [unit] and from contractible types
 - Functions from [total2]
 - Functiosn from direct product
- Theorem saying that if each member of a family is of h-level n then the
  space of sections of the family is of h-level n.
 - General case
 - Functions to a contractible type
 - Functions to a proposition
 - Functions to an empty type (generalization of [isapropneg])
- Theorems saying that  [ iscontr T ], [ isweq f ] etc. are of h-level 1
- Theorems saying that various [ pr1 ] maps are inclusions
- Various weak equivalences between spaces of weak equivalences
 - Composition with a weak equivalence is a weak equivalence on weak
   equivalences
 - Invertion on weak equivalences as a weak equivalence
- h-levels of spaces of weak equivalences
 - Weak equivalences to and from types of h-level (S n)
 - Weak equivalences to and from contractible types
 - Weak equivalences to and from propositions
 - Weak equivalences to and from sets
 - Weak equivalences to an empty type
 - Weak equivalences from an empty type
 - Weak equivalences to and from [unit]
- Weak auto-equivalences of a type with an isolated point
*)

(** ** Preamble *)

(** Imports *)

Require Export UniMath.Foundations.PartC.

(** ** Sections of "double fibration" [(P : T -> UU) (PP : ∏ t : T, P t -> UU)] and pairs of sections *)

(** *** General case *)

Definition totaltoforall {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) :
  (∑ (s0 : ∏ x, P x), ∏ x, PP x (s0 x))
  ->
  ∏ x, ∑ p, PP x p.
Proof.
  intros X0 x.
  exists (pr1 X0 x).
  apply (pr2 X0 x).
Defined.

Definition foralltototal {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) :
  (∏ x, ∑ p, PP x p)
  ->
  (∑ (s0 : ∏ x, P x), ∏ x, PP x (s0 x)).
Proof.
  intros X0.
  exists (λ x, pr1 (X0 x)).
  apply (λ x, pr2 (X0 x)).
Defined.

Theorem isweqforalltototal {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) :
  isweq (foralltototal P PP).
Proof.
  intros.
  simple refine (isweq_iso (foralltototal P PP) (totaltoforall P PP) _ _).
  - apply idpath.
  - apply idpath.
Defined.

Theorem isweqtotaltoforall {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU) :
  isweq (totaltoforall P PP).
Proof.
  intros.
  simple refine (isweq_iso (totaltoforall P PP) (foralltototal P PP) _ _).
  - apply idpath.
  - apply idpath.
Defined.

Definition weqforalltototal {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU)
  :  (∏ x, ∑ y, PP x y)
      ≃
     (∑ s : (∏ x, P x), (∏ x, PP x (s x)))
  := make_weq _ (isweqforalltototal P PP).

Definition weqtotaltoforall {X : UU} (P : X -> UU) (PP : ∏ x, P x -> UU)
  : (∑ s : (∏ x, P x), (∏ x, PP x (s x)))
     ≃
    (∏ x, ∑ y, PP x y)
  := invweq (weqforalltototal P PP).

(** *** Functions to a dependent sum (to a [ total2 ]) *)

Definition weqfuntototaltototal (X : UU) {Y : UU} (Q : Y -> UU)
  : (X → ∑ y, Q y)
    ≃
    (∑ f : X → Y, ∏ x, Q (f x))
  := weqforalltototal (λ x, Y) (λ x, Q).

(** *** Functions to direct product *)

(** Note: we give direct proofs for this special case. *)

Definition funtoprodtoprod {X Y Z : UU} (f : X -> Y × Z)
  : (X -> Y) × (X -> Z)
  := make_dirprod (λ x, pr1 (f x)) (λ x, (pr2 (f x))).

Definition prodtofuntoprod {X Y Z : UU} (fg : (X -> Y) × (X -> Z))
  : X -> Y × Z
  := λ x, (pr1 fg x ,, pr2 fg x).

Theorem weqfuntoprodtoprod (X Y Z : UU) :
  (X -> Y × Z) ≃ (X -> Y) × (X -> Z).
Proof.
  intros.
  simple refine (make_weq _ (isweq_iso (@funtoprodtoprod X Y Z)
                                   (@prodtofuntoprod X Y Z) _ _)).
  - intro a. apply funextfun. intro x. apply idpath.
  - intro a. induction a as [ fy fz ]. apply idpath.
Defined.

(** ** Homotopy fibers of the map [∏ x, P x -> ∏ x, Q x] *)

(** *** General case *)

Definition maponsec {X : UU}  (P Q : X -> UU) (f : ∏ x, P x -> Q x) :
  (∏ x, P x) -> (∏ x, Q x)
  := λ (s : ∏ x, P x) (x : X), (f x) (s x).

Definition maponsec1 {X Y : UU} (P : Y -> UU) (f : X -> Y) :
  (∏ y : Y, P y) -> (∏ x, P (f x))
  := λ (sy : ∏ y : Y, P y) (x : X), sy (f x).

Definition hfibertoforall {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x)
           (s : ∏ x, Q x) :
  hfiber  (maponsec _ _ f) s -> ∏ x, hfiber  (f x) (s x).
Proof.
  unfold hfiber.
  set (map1 := totalfun (λ (pointover : ∏ x, P x), (λ x, f x (pointover x)) = s)
                        (λ (pointover : ∏ x, P x), ∏ x, (f x) (pointover x) = s x)
                        (λ (pointover : ∏ x, P x), toforallpaths _ (λ x, f x (pointover x)) s)).
  set (map2 := totaltoforall P (λ x pointover, f x pointover = s x)).
  exact (map2 ∘ map1).
Defined.

Definition foralltohfiber {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x)
           (s : ∏ x, Q x) :
  (∏ x, hfiber (f x) (s x)) -> hfiber (maponsec _ _ f) s.
Proof.
  unfold hfiber.
  set (map2inv := foralltototal P (λ x pointover, f x pointover = s x)).
  set (map1inv := totalfun (λ pointover, ∏ x, f x (pointover x) = s x)
                           (λ pointover, (λ x, f x (pointover x)) = s)
                           (λ pointover, funextsec _ (λ x, f x (pointover x)) s)).
  exact (λ a, map1inv (map2inv a)).
Defined.

Theorem isweqhfibertoforall {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x)
        (s : ∏ x, Q x) : isweq (hfibertoforall P Q f s).
Proof.
  use twooutof3c.
  - exact (isweqfibtototal _ _ (λ pointover, weqtoforallpaths _ _ _)).
  - apply isweqtotaltoforall.
Defined.

Definition weqhfibertoforall {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x)
           (s : ∏ x, Q x)
  : hfiber (maponsec P Q f) s  ≃  ∏ x, hfiber (f x) (s x)
  := make_weq _ (isweqhfibertoforall P Q f s).

Theorem isweqforalltohfiber {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x)
        (s : ∏ x, Q x) : isweq (foralltohfiber  _ _ f s).
Proof.
  use (twooutof3c (Y := @total2 (forall x, P x)
     (λ (s0 : forall x, P x),
      forall x,
      (λ x0 (pointover : P x0), f x0 pointover = s x0) x (s0 x)))).
  - exact (isweqforalltototal P (λ x, (λ pointover, f x pointover = s x))).
  - exact (isweqfibtototal _ _ (λ pointover, weqfunextsec _ _ _)).
Defined.

Definition weqforalltohfiber {X : UU} (P Q : X -> UU) (f : ∏ x, P x -> Q x)
           (s : ∏ x, Q x)
  : (∏ x, hfiber (f x) (s x)) ≃ hfiber (maponsec P Q f) s
  := make_weq _ (isweqforalltohfiber P Q f s).

(** *** The weak equivalence  between section spaces (dependent products) defined by a family of weak equivalences  [ (P x) ≃ (Q x) ] *)

Corollary isweqmaponsec {X : UU} (P Q : X -> UU) (f : ∏ x, (P x) ≃ (Q x)) :
  isweq (maponsec _ _ f).
Proof.
  intros. unfold isweq. intro y.
  assert (is1 : iscontr (∏ x, hfiber (f x) (y x))).
  {
    assert (is2 : ∏ x, iscontr (hfiber (f x) (y x)))
      by (intro x; apply ((pr2 (f x)) (y x))).
    apply funcontr. assumption.
  }
  apply (iscontrweqb (weqhfibertoforall P Q f y) is1).
Defined.

Definition weqonsecfibers {X : UU} (P Q : X -> UU) (f : ∏ x, (P x) ≃ (Q x))
  : (∏ x, P x) ≃ (∏ x, Q x)
  := make_weq _ (isweqmaponsec P Q f).

(** *** Composition of functions with a weak equivalence on the right *)

Definition weqffun (X : UU) {Y Z : UU} (w : Y ≃ Z)
  : (X -> Y) ≃ (X -> Z)
  := weqonsecfibers _ _ (λ x, w).

(** ** The map between section spaces (dependent products) defined by the map between the bases [ f : Y -> X ] *)

(** *** General case *)

Definition maponsec1l0 {X : UU} (P : X -> UU) (f : X -> X)
           (h : ∏ x, f x = x) : (∏ x, P x) -> (∏ x, P x)
  := λ s x, transportf P (h x) (s (f x)).

Lemma maponsec1l1 {X : UU} (P : X -> UU) (x : X) (s : ∏ x, P x) :
  maponsec1l0 P (λ x, x) idpath s x = s x.
Proof.
  intros. unfold maponsec1l0. apply idpath.
Defined.

Lemma maponsec1l2 {X : UU} (P : X -> UU) (f : X -> X) (h : ∏ x, f x = x)
      (s : ∏ x, P x) x : maponsec1l0 P f h s x = s x.
Proof.
  intros.
  set (map := λ (ff : (∑ (f0 : X -> X), ∏ x, (f0 x) = x)),
                maponsec1l0 P (pr1 ff) (pr2 ff) s x).
  assert (is1 : iscontr (∑ (f0 : X -> X), ∏ x, (f0 x) = x))
    by apply funextcontr.
  assert (e: (f,,h) = tpair (λ g, ∏ x, g x = x) (λ x, x) idpath)
    by (apply proofirrelevancecontr; assumption).
  apply (maponpaths map e).
Defined.

Theorem isweqmaponsec1 {X Y : UU} (P : Y -> UU) (f : X ≃ Y) :
  isweq (maponsec1 P f).
Proof.
  intros.
  set (map := maponsec1  P f).
  set (invf := invmap f).
  set (e1 := homotweqinvweq f). set (e2 := homotinvweqweq f).
  set (im1 := λ (sx : ∏ x, P (f x)) y, sx (invf y)).
  set (im2 := λ (sy': ∏ y : Y, P (f (invf y))) y, transportf _ (homotweqinvweq f y) (sy' y)).
  set (invmapp := λ (sx : ∏ x, P (f x)), im2 (im1 sx)).
  assert (efg0 : ∏ (sx : (∏ x, P (f x))) x, (map (invmapp sx)) x = sx x).
  {
    intro. intro. unfold map. unfold invmapp. unfold im1. unfold im2.
    unfold maponsec1. simpl. fold invf. set (ee := e2 x). fold invf in ee.
    set (e3x := λ x0 : X, invmaponpathsweq f (invf (f x0)) x0
                                            (homotweqinvweq f (f x0))).
    set (e3 := e3x x).
    assert (e4 : homotweqinvweq f (f x) = maponpaths f  e3)
      by apply (pathsinv0 (pathsweq4 f (invf (f x)) x _)).
    assert  (e5 : transportf P (homotweqinvweq f (f x)) (sx (invf (f x))) =
                  transportf P (maponpaths f e3) (sx (invf (f x))))
      by apply (maponpaths (λ e40, (transportf P e40 (sx (invf (f x)))))
                           e4).
    assert (e6 : transportf P (maponpaths f e3) (sx (invf (f x))) =
                 transportf (λ x, P (f x)) e3 (sx (invf (f x))))
      by apply (pathsinv0 (functtransportf f P e3 (sx (invf (f x))))).
    set (ff := λ x, invf (f x)).
    assert (e7 : transportf (λ x, P (f x)) e3 (sx (invf (f x))) = sx x)
      by apply (maponsec1l2 (λ x, P (f x)) ff e3x sx x).
    apply (pathscomp0 (pathscomp0 e5 e6) e7).
  }
  assert (efg : ∏ sx : (∏ x, P (f x)), map (invmapp sx) = sx)
    by (intro; apply (funextsec _ _ _ (efg0 sx))).

  assert (egf0 : ∏ sy : (∏ y : Y, P y), ∏ y : Y, (invmapp (map sy)) y = sy y).
  {
    intros. unfold invmapp. unfold map. unfold im1. unfold im2.
    unfold maponsec1.
    set (ff := λ y : Y, f (invf y)). fold invf.
    apply (maponsec1l2 P ff (homotweqinvweq f) sy y).
  }
  assert (egf : ∏ sy : (∏ y : Y, P y), invmapp (map sy) = sy)
    by (intro; apply (funextsec _ _ _ (egf0 sy))).

  apply (isweq_iso map invmapp egf efg).
Defined.

Definition weqonsecbase {X Y : UU} (P : Y -> UU) (f : X ≃ Y)
  : (∏ y : Y, P y) ≃ (∏ x, P (f x))
  := make_weq _ (isweqmaponsec1 P f).

(** *** Composition of functions with a weak equivalence on the left *)

Definition weqbfun {X Y : UU} (Z : UU) (w : X ≃ Y) : (Y -> Z) ≃ (X -> Z)
  := weqonsecbase _ w.

(** ** Sections of families over an empty type and over coproducts *)

(** *** General case *)

Definition iscontrsecoverempty (P : empty -> UU) : iscontr (∏ x : empty, P x).
Proof.
  split with (λ x : empty, fromempty x).
  intro t. apply funextsec.
  intro t0. induction t0.
Defined.

Definition iscontrsecoverempty2 {X : UU} (P : X -> UU) (is : neg X) :
  iscontr (∏ x, P x).
Proof.
  intros. set (w := weqtoempty is). set (w' := weqonsecbase P (invweq w)).
  apply (iscontrweqb w' (iscontrsecoverempty _)).
Defined.

Definition secovercoprodtoprod {X Y : UU} (P : X ⨿ Y -> UU)
           (a : ∏ xy : X ⨿ Y, P xy) :
  (∏ x, P (ii1 x)) × (∏ y : Y, P (ii2 y))
  := make_dirprod (λ x, a (ii1 x)) (λ y : Y, a (ii2 y)).

Definition prodtosecovercoprod {X Y : UU} (P : X ⨿ Y -> UU)
           (a : (∏ x, P (ii1 x)) × (∏ y : Y, P (ii2 y))) :
  ∏ xy : X ⨿ Y, P xy.
Proof.
  intros. induction xy as [ x | y ].
  - exact (pr1 a x).
  - exact (pr2 a y).
Defined.

Definition weqsecovercoprodtoprod {X Y : UU} (P : X ⨿ Y -> UU) :
  (∏ xy : X ⨿ Y, P xy)
  ≃
  (∏ x, P (ii1 x)) × (∏ y : Y, P (ii2 y)).
Proof.
  intros.
  use (weq_iso (secovercoprodtoprod P) (prodtosecovercoprod P)).
  - intro. apply funextsec. intro t. induction t; reflexivity.
  - intro a. apply pathsdirprod.
    + apply funextsec. apply homotrefl.
    + apply funextsec. apply homotrefl.
Defined.

(** *** Functions from the empty type *)

Theorem iscontrfunfromempty (X : UU) : iscontr (empty -> X).
Proof.
  split with fromempty.
  intro t. apply funextfun.
  intro x. induction x.
Defined.

Theorem iscontrfunfromempty2 (X : UU) {Y : UU} (is : neg Y) : iscontr (Y -> X).
Proof.
  intros. set (w := weqtoempty is). set (w' := weqbfun X (invweq w)).
  apply (iscontrweqb w' (iscontrfunfromempty X)).
Defined.

(** *** Functions from a coproduct *)

Definition funfromcoprodtoprod {X Y Z : UU} (f : X ⨿ Y -> Z) :
  (X -> Z) × (Y -> Z)
  := make_dirprod (λ x, f (ii1 x)) (λ y : Y, f (ii2 y)).

Definition prodtofunfromcoprod {X Y Z : UU} (fg : (X -> Z) × (Y -> Z)) :
  X ⨿ Y -> Z := sumofmaps (pr1 fg) (pr2 fg).

Theorem weqfunfromcoprodtoprod (X Y Z : UU) :
  (X ⨿ Y -> Z) ≃ ((X -> Z) × (Y -> Z)).
Proof.
  intros.
  simple refine (
           make_weq _ (isweq_iso (@funfromcoprodtoprod X Y Z)
                             (@prodtofunfromcoprod X Y Z) _ _)).
  - intro a. apply funextfun; intro xy. induction xy as [ x | y ]; apply idpath.
  - intro a. induction a as [fx fy]. apply idpath.
Defined.

(** ** Sections of families over contractible types and over [ total2 ] (over dependent sums) *)

(** *** General case *)

Definition tosecoverunit (P : unit -> UU) (p : P tt) : ∏ t : unit, P t.
Proof.
  intros. induction t. apply p.
Defined.

Definition weqsecoverunit (P : unit -> UU) : (∏ t : unit, P t) ≃ (P tt).
Proof.
  set (f := λ a : ∏ t : unit, P t, a tt).
  set (g := tosecoverunit P).
  split with f.
  assert (egf : ∏ a, g (f a) = a).
  {
    intro. apply funextsec.
    intro t. induction t. apply idpath.
  }
  assert (efg : ∏ a, f (g a) = a) by (intros; apply idpath).
  apply (isweq_iso _ _ egf efg).
Defined.

Definition weqsecovercontr {X : UU} (P : X -> UU) (is : iscontr X) :
  (∏ x, P x) ≃ (P (pr1 is)).
Proof.
  intros. set (w1 := weqonsecbase P (wequnittocontr is)).
  apply (weqcomp w1 (weqsecoverunit _)).
Defined.

Definition tosecovertotal2 {X : UU} (P : X -> UU) (Q : (∑ x, P x) -> UU)
           (a : ∏ x, ∏ p : P x, Q (x ,, p)) :
  ∏ xp : (∑ x, P x), Q xp.
Proof.
  intros. induction xp as [ x p ]. apply (a x p).
Defined.

(** General equivalence between curried and uncurried function types *)
Definition weqsecovertotal2 {X : UU} (P : X -> UU) (Q : (∑ x, P x) -> UU) :
  (∏ xp : (∑ x, P x), Q xp) ≃ (∏ x, ∏ p : P x, Q (x,, p)).
Proof.
  intros.
  set (f := λ a : ∏ xp : (∑ x, P x), Q xp, λ x, λ p : P x, a (x,, p)).
  set (g := tosecovertotal2 P Q). split with f.
  assert (egf : ∏ a, g (f a) = a).
  {
    intro. apply funextsec.
    intro xp. induction xp as [ x p ]. apply idpath.
  }
  assert (efg : ∏ a, f (g a) = a).
  {
    intro. apply funextsec.
    intro x. apply funextsec.
    intro p. apply idpath.
  }
  apply (isweq_iso _ _ egf efg).
Defined.

(** *** Functions from [ unit ] and from contractible types *)

Definition weqfunfromunit (X : UU) : (unit -> X) ≃ X := weqsecoverunit _.

Definition weqfunfromcontr {X : UU} (Y : UU) (is : iscontr X) : (X -> Y) ≃ Y
  := weqsecovercontr _ is.

(** *** Functions from [ total2 ] *)

Definition weqfunfromtotal2 {X : UU} (P : X -> UU) (Y : UU) :
  ((∑ x, P x) -> Y) ≃ (∏ x, P x -> Y) := weqsecovertotal2 P _.

(** *** Functions from direct product *)

Definition weqfunfromdirprod (X X' Y : UU) :
  (X × X' -> Y) ≃ (∏ x, X' -> Y) := weqsecovertotal2 _ _.

(** ** Theorem saying that if each member of a family is of h-level n then the space of sections of the family is of h-level n. *)

(** *** General case *)

Theorem impred (n : nat) {T : UU} (P : T -> UU) :
  (∏ t : T, isofhlevel n (P t)) -> (isofhlevel n (∏ t : T, P t)).
Proof.
  revert T P. induction n as [ | n IHn ].
  - intros T P X. apply (funcontr P X).
  - intros T P X. unfold isofhlevel in X. unfold isofhlevel. intros x x'.
    assert (is : ∏ t : T, isofhlevel n (x t = x' t))
      by (intro; apply (X t (x t) (x' t))).
    assert (is2 : isofhlevel n (∏ t : T, x t = x' t))
      by apply (IHn _ (λ t0 : T, x t0 = x' t0) is).
    set (u := toforallpaths P x x').
    assert (is3: isweq u) by apply isweqtoforallpaths.
    set (v:= invmap (make_weq u is3)).
    assert (is4: isweq v) by apply isweqinvmap.
    apply (isofhlevelweqf n (make_weq v is4)).
    assumption.
Defined.

Corollary impred_iscontr {T : UU} (P : T -> UU) :
  (∏ t : T, iscontr (P t)) -> (iscontr (∏ t : T, P t)).
Proof.
  intros. apply (impred 0). assumption.
Defined.

Corollary impred_isaprop {T : UU} (P : T -> UU) :
  (∏ t : T, isaprop (P t)) -> (isaprop (∏ t : T, P t)).
Proof.
  apply impred.
Defined.

Corollary impred_isaset {T : UU} (P : T -> UU) :
  (∏ t : T, isaset (P t)) -> (isaset (∏ t : T, P t)).
Proof.
  intros. apply (impred 2). assumption.
Defined.

Corollary impredtwice  (n : nat) {T T' : UU} (P : T -> T' -> UU) :
  (∏ (t : T) (t': T'), isofhlevel n (P t t'))
  -> (isofhlevel n (∏ (t : T) (t': T'), P t t')).
Proof.
  intros X.
  assert (is1 : ∏ t : T, isofhlevel n (∏ t': T', P t t'))
    by (intro; apply (impred n _ (X t))).
  apply (impred n _ is1).
Defined.

Corollary impredfun (n : nat) (X Y : UU) (is : isofhlevel n Y) :
  isofhlevel n (X -> Y).
Proof.
  intros. apply (impred n (λ x , Y) (λ x, is)).
Defined.

Theorem impredtech1 (n : nat) (X Y : UU) :
  (X -> isofhlevel n Y) -> isofhlevel n (X -> Y).
Proof.
  revert X Y. induction n as [ | n IHn ]. intros X Y X0. simpl.
  split with (λ x, pr1 (X0 x)).
  - intro t.
    assert (s1 : ∏ x, t x = pr1 (X0 x))
           by (intro; apply proofirrelevancecontr; apply (X0 x)).
    apply funextsec. assumption.
  - intros X Y X0. simpl.
    assert (X1 : X -> isofhlevel (S n) (X -> Y))
      by (intro X1; apply impred; assumption).
    intros x x'.
    assert (s1 : isofhlevel n (∏ xx, x xx = x' xx))
           by (apply impred; intro t; apply (X0 t)).
    assert (w : (∏ xx, x xx = x' xx) ≃ (x = x'))
      by apply (weqfunextsec  _ x x').
    apply (isofhlevelweqf n w s1).
Defined.

(** ***  Functions to a contractible type *)

Theorem iscontrfuntounit (X : UU) : iscontr (X -> unit).
Proof.
  split with (λ x, tt).
  intro f. apply funextfun.
  intro x. induction (f x). apply idpath.
Defined.

Theorem iscontrfuntocontr (X : UU) {Y : UU} (is : iscontr Y) : iscontr (X -> Y).
Proof.
  set (w := weqcontrtounit is). set (w' := weqffun X w).
  apply (iscontrweqb w' (iscontrfuntounit X)).
Defined.

(** *** Functions to a proposition *)

Lemma isapropimpl (X Y : UU) (isy : isaprop Y) : isaprop (X -> Y).
Proof.
  apply impred. intro. assumption.
Defined.

(** *** Functions to an empty type (generalization of [ isapropneg ]) *)

Theorem isapropneg2 (X : UU) {Y : UU} (is : neg Y) : isaprop (X -> Y).
Proof.
  intros. apply impred. intro. apply (isapropifnegtrue is).
Defined.

(** ** Theorems saying that  [ iscontr T ], [ isweq f ] etc. are of h-level 1 *)

Theorem iscontriscontr {X : UU} (is : iscontr X) : iscontr (iscontr X).
Proof.
  assert (is0 : ∏ (x x' : X), x = x')
         by (apply proofirrelevancecontr; assumption).
  assert (is1 : ∏ cntr : X, iscontr (∏ x, x = cntr)).
  {
    intro.
    assert (is2 : ∏ x, iscontr (x = cntr)).
    {
      assert (is2 : isaprop X)
             by (apply isapropifcontr; assumption).
      unfold isaprop in is2. unfold isofhlevel in is2.
      intro x. apply (is2 x cntr).
    }
    apply funcontr. assumption.
  }
  set (f := @pr1 X (λ cntr : X, ∏ x, x = cntr)).
  assert (X1 : isweq f)
    by (apply isweqpr1; assumption).
  change (∑ (cntr : X), ∏ x, x = cntr) with (iscontr X) in X1.
  apply (iscontrweqb (make_weq f X1)). assumption.
Defined.

Theorem isapropiscontr (T : UU) : isaprop (iscontr T).
Proof.
  intros. unfold isaprop. unfold isofhlevel.
  intros x x'. assert (is : iscontr(iscontr T)).
  apply iscontriscontr. apply x.
  assert (is2 : isaprop (iscontr T)) by apply (isapropifcontr is).
  apply (is2 x x').
Defined.

Theorem isapropisweq {X Y : UU} (f : X -> Y) : isaprop (isweq f).
Proof.
  intros. unfold isweq.
  apply (impred (S O) (λ y : Y, iscontr (hfiber f y))
                (λ y : Y, isapropiscontr (hfiber f y))).
Defined.

Theorem isapropisisolated (X : UU) (x : X) : isaprop (isisolated X x).
(* uses funextemptyAxiom *)
Proof.
  intros. apply isofhlevelsn. intro is. apply impred. intro x'.
  apply (isapropdec _ (isaproppathsfromisolated X x is x')).
Defined.

Theorem isapropisdeceq (X : UU) : isaprop (isdeceq X).
(* uses funextemptyAxiom *)
Proof.
  apply (isofhlevelsn 0). intro is. unfold isdeceq. apply impred.
  intro x. apply (isapropisisolated X x).
Defined.

Theorem isapropisofhlevel (n : nat) (X : UU) : isaprop (isofhlevel n X).
Proof.
  revert X. induction n as [ | n IHn ].
  - apply isapropiscontr.
  - intro X.
    apply impred. intros t.
    apply impred. intros t0.
    apply IHn.
Defined.

Corollary isapropisaprop (X : UU) : isaprop (isaprop X).
Proof.
  intro. apply (isapropisofhlevel (S O)).
Defined.

Definition isapropisdecprop (X : UU) : isaprop (isdecprop X).
Proof.
  intros.
  unfold isdecprop.
  apply (isofhlevelweqf 1 (weqdirprodcomm _ _)).
  apply isofhleveltotal2.
  - apply isapropisaprop.
  - intro i. apply isapropdec. assumption.
Defined.

Corollary isapropisaset (X : UU) : isaprop (isaset X).
Proof.
  intro. apply (isapropisofhlevel (S (S O))).
Defined.

Theorem isapropisofhlevelf (n : nat) {X Y : UU} (f : X -> Y) :
  isaprop (isofhlevelf n f).
Proof.
  intros. unfold isofhlevelf. apply impred. intro y. apply isapropisofhlevel.
Defined.

Definition isapropisincl {X Y : UU} (f : X -> Y) : isaprop (isofhlevelf 1 f)
  := isapropisofhlevelf 1 f.

Lemma isaprop_isInjective {X Y : UU} (f : X -> Y) : isaprop (isInjective f).
Proof.
  intros.
  unfold isInjective.
  apply impred; intro.
  apply impred; intro.
  apply isapropisweq.
Defined.

Lemma incl_injectivity {X Y : UU} (f : X -> Y) : isincl f ≃ isInjective f.
Proof.
  intros.
  apply weqimplimpl.
  - apply isweqonpathsincl.
  - apply isinclweqonpaths.
  - apply isapropisincl.
  - apply isaprop_isInjective.
Defined.

(** ** Theorems saying that various [ pr1 ] maps are inclusions *)

Theorem isinclpr1weq (X Y : UU) : isincl (pr1weq : X ≃ Y -> X -> Y).
Proof.
  intros. refine (isinclpr1 _ _). intro f.   apply isapropisweq.
Defined.

Corollary isinjpr1weq (X Y : UU) : isInjective (pr1weq : X ≃ Y -> X -> Y).
Proof.
  intros. apply isweqonpathsincl. apply isinclpr1weq.
Defined.

Theorem isinclpr1isolated (T : UU) : isincl (pr1isolated T).
Proof.
  intro. apply (isinclpr1 _ (λ t : T, isapropisisolated T t)).
Defined.

(** associativity of weqcomp **)

Definition weqcomp_assoc {W X Y Z : UU} (f : W ≃ X) (g: X ≃ Y) (h : Y ≃ Z) :
  (h ∘ (g ∘ f) = (h ∘ g) ∘ f)%weq.
Proof.
  intros. apply subtypePath.
  - intros p. apply isapropisweq.
  - simpl. apply idpath.
Defined.

Lemma eqweqmap_pathscomp0 {A B C : UU} (p : A = B) (q : B = C)
  : weqcomp (eqweqmap p) (eqweqmap q)
  = eqweqmap (pathscomp0 p q).
Proof.
  induction p. induction q. apply pair_path_in2. apply isapropisweq.
Defined.

Lemma inv_idweq_is_idweq {A : UU} :
  idweq A = invweq (idweq A).
Proof.
  apply pair_path_in2. apply isapropisweq.
Defined.

Lemma eqweqmap_pathsinv0 {A B : UU} (p : A = B)
  : eqweqmap (!p) = invweq (eqweqmap p).
Proof.
  induction p. exact inv_idweq_is_idweq.
Defined.

(** ** Various weak equivalences between spaces of weak equivalences *)

(** *** Composition with a weak quivalence is a weak equivalence on weak equivalences *)

Theorem weqfweq (X : UU) {Y Z : UU} (w : Y ≃ Z) : (X ≃ Y) ≃ (X ≃ Z).
Proof.
  intros.
  set (f := λ a : X ≃ Y, weqcomp a w).
  set (g := λ b : X ≃ Z, weqcomp b (invweq w)).
  split with f.
  assert (egf : ∏ a, g (f a) = a).
  {
    intro a. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun.
    intro x. apply (homotinvweqweq w (a x)).
  }
  assert (efg : ∏ b, f (g b) = b).
  {
    intro b. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun.
    intro x. apply (homotweqinvweq w (b x)).
  }
  apply (isweq_iso _ _ egf efg).
Defined.

Theorem weqbweq {X Y : UU} (Z : UU) (w : X ≃ Y) : (Y ≃ Z) ≃ (X ≃ Z).
Proof.
  intros.
  set (f := λ a : Y ≃ Z, weqcomp w a).
  set (g := λ b : X ≃ Z, weqcomp (invweq w) b).
  split with f.
  assert (egf : ∏ a, g (f a) = a).
  {
    intro a. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun.
    intro y. apply (maponpaths a (homotweqinvweq w y)).
  }
  assert (efg : ∏ b, f (g b) = b).
  {
    intro b. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun.
    intro x. apply (maponpaths b (homotinvweqweq w x)).
  }
  apply (isweq_iso _ _ egf efg).
Defined.

Theorem weqweq {X Y : UU} (w: X ≃ Y) : (X ≃ X) ≃ (Y ≃ Y).
Proof.
  intros. intermediate_weq (X ≃ Y).
  - apply weqfweq. assumption.
  - apply invweq. apply weqbweq. assumption.
Defined.

(** *** Invertion on weak equivalences as a weak equivalence *)

(** Comment : note that full form of [ funextfun ] is only used in the proof of
  this theorem in the form of [ isapropisweq ]. The rest of the proof can be
  completed using eta-conversion. *)

Theorem weqinvweq (X Y : UU) : (X ≃ Y) ≃ (Y ≃ X).
Proof.
  intros.
  apply (weq_iso invweq invweq).
  - intro. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun. apply homotrefl.
  - intro. apply (invmaponpathsincl _ (isinclpr1weq _ _)). apply funextfun. apply homotrefl.
Defined.

(** ** h-levels of spaces of weak equivalences *)

(** *** Weak equivalences to and from types of h-level (S n) *)

Theorem isofhlevelsnweqtohlevelsn (n : nat) (X Y : UU)
        (is : isofhlevel (S n) Y) : isofhlevel (S n) (X ≃ Y).
Proof.
  intros.
  apply (isofhlevelsninclb n _ (isinclpr1weq _ _)).
  apply impred. intro. exact is.
Defined.

Theorem isofhlevelsnweqfromhlevelsn (n : nat) (X Y : UU)
        (is : isofhlevel (S n) Y) : isofhlevel (S n) (Y ≃ X).
Proof.
  intros.
  apply (isofhlevelweqf (S n) (weqinvweq X Y)).
  apply isofhlevelsnweqtohlevelsn.
  exact is.
Defined.

(** *** Weak equivalences to and from contractible types *)

Theorem isapropweqtocontr (X : UU) {Y : UU} (is : iscontr Y) : isaprop (X ≃ Y).
Proof.
  intros. apply (isofhlevelsnweqtohlevelsn 0 _ _ (isapropifcontr is)).
Defined.

Theorem isapropweqfromcontr (X : UU) {Y : UU} (is : iscontr Y) : isaprop (Y ≃ X).
Proof.
  intros. apply (isofhlevelsnweqfromhlevelsn 0 X _ (isapropifcontr is)).
Defined.

(** *** Weak equivalences to and from propositions *)

Theorem isapropweqtoprop (X  Y : UU) (is : isaprop Y) : isaprop (X ≃ Y).
Proof.
  intros. apply (isofhlevelsnweqtohlevelsn 0 _ _ is).
Defined.

Theorem isapropweqfromprop (X Y : UU) (is : isaprop Y) : isaprop (Y ≃ X).
Proof.
  intros. apply (isofhlevelsnweqfromhlevelsn 0 X _ is).
Defined.

(** *** Weak equivalences to and from sets *)

Theorem isasetweqtoset (X  Y : UU) (is : isaset Y) : isaset (X ≃ Y).
Proof.
  intros. apply (isofhlevelsnweqtohlevelsn 1 _ _ is).
Defined.

Theorem isasetweqfromset (X Y : UU) (is : isaset Y) : isaset (Y ≃ X).
Proof.
  intros. apply (isofhlevelsnweqfromhlevelsn 1 X _ is).
Defined.

(** *** Weak equivalences to an empty type *)

Theorem isapropweqtoempty (X : UU) : isaprop (X ≃ empty).
Proof.
  intro. apply (isofhlevelsnweqtohlevelsn 0 _ _ (isapropempty)).
Defined.

Theorem isapropweqtoempty2 (X : UU) {Y : UU} (is : neg Y) : isaprop (X ≃ Y).
Proof.
  intros. apply (isofhlevelsnweqtohlevelsn 0 _ _ (isapropifnegtrue is)).
Defined.

(** *** Weak equivalences from an empty type *)

Theorem isapropweqfromempty (X : UU) : isaprop (empty ≃ X).
Proof.
  intro. apply (isofhlevelsnweqfromhlevelsn 0 X _ (isapropempty)).
Defined.

Theorem isapropweqfromempty2 (X : UU) {Y : UU} (is : neg Y) : isaprop (Y ≃ X).
Proof.
  intros. apply (isofhlevelsnweqfromhlevelsn 0 X _ (isapropifnegtrue is)).
Defined.

(** *** Weak equivalences to and from [ unit ] *)

Theorem isapropweqtounit (X : UU) : isaprop (X ≃ unit).
Proof.
  intro. apply (isofhlevelsnweqtohlevelsn 0 _ _ (isapropunit)).
Defined.

Theorem isapropweqfromunit (X : UU) : isaprop (unit ≃ X).
Proof.
  intros. apply (isofhlevelsnweqfromhlevelsn 0 X _ (isapropunit)).
Defined.

(** ** Weak auto-equivalences of a type with an isolated point *)

Definition cutonweq {T : UU} t (is : isisolated T t) (w : T ≃ T) :
  isolated T × (compl T t ≃ compl T t).
Proof.
  intros. split.
  - exists (w t). apply isisolatedweqf. assumption.
  - intermediate_weq (compl T (w t)).
    + apply weqoncompl.
    + apply weqtranspos0.
      * apply isisolatedweqf. assumption.
      * assumption.
Defined.

Definition invcutonweq {T : UU} (t : T)
           (is : isisolated T t)
           (t'w : isolated T × (compl T t ≃ compl T t)) : T ≃ T
  := weqcomp (weqrecomplf t t is is (pr2 t'w))
             (weqtranspos t (pr1 (pr1 t'w)) is (pr2 (pr1 t'w))).

Lemma pathsinvcuntonweqoft {T : UU} (t : T)
      (is : isisolated T t)
      (t'w : isolated T × (compl T t ≃ compl T t)) :
  invcutonweq t is t'w t = pr1 (pr1 t'w).
Proof.
  intros. unfold invcutonweq. simpl. unfold recompl. unfold coprodf.
  unfold invmap. simpl. unfold invrecompl.
  induction (is t) as [ ett | nett ].
  - apply pathsfuntransposoft1.
  - induction (nett (idpath _)).
Defined.

Definition weqcutonweq (T : UU) (t : T) (is : isisolated T t) :
  (T ≃ T) ≃ isolated T × (compl T t ≃ compl T t).
Proof.
  intros.
  set (f := cutonweq t is). set (g := invcutonweq t is).
  apply (weq_iso f g).
  - intro w. Set Printing Coercions. idtac.
    apply (invmaponpathsincl _ (isinclpr1weq _ _)).
    apply funextfun; intro t'. simpl.
    unfold invmap; simpl. unfold coprodf, invrecompl.
    induction (is t') as [ ett' | nett' ].
    + simpl. rewrite (pathsinv0 ett'). apply pathsfuntransposoft1.
    + unfold funtranspos0; simpl.
      induction (is (w t)) as [ etwt | netwt ].
      * induction (is (w t')) as [ etwt' | netwt' ].
        -- induction (negf (invmaponpathsincl w (isofhlevelfweq 1 w) t t') nett'
                           (pathscomp0 (pathsinv0 etwt) etwt')).
        -- simpl. assert (newtt'' := netwt'). rewrite etwt in netwt'.
           apply (pathsfuntransposofnet1t2 t (w t) is _ (w t') newtt'' netwt').
      * simpl. induction (is (w t')) as [ etwt' | netwt' ].
        -- simpl. rewrite (pathsinv0 etwt').
           apply (pathsfuntransposoft2 t (w t) is _).
        -- simpl.
           assert (ne : neg (w t = w t'))
             by apply (negf (invmaponpathsweq w _ _) nett').
           apply (pathsfuntransposofnet1t2 t (w t) is _ (w t') netwt' ne).
  - intro xw. induction xw as [ x w ]. induction x as [ t' is' ].
    simpl in w. apply pathsdirprod.
    + apply (invmaponpathsincl _ (isinclpr1isolated _)).
      simpl. unfold recompl, coprodf, invmap; simpl. unfold invrecompl.
      induction (is t) as [ ett | nett ].
      * apply pathsfuntransposoft1.
      * induction (nett (idpath _)).
    + simpl.
      apply (invmaponpathsincl _ (isinclpr1weq _ _) _ _). apply funextfun.
      intro x. induction x as [ x netx ].
      unfold g, invcutonweq; simpl.
      set (int := funtranspos
                    (t,, is) (t',, is')
                    (recompl T t (coprodf w (λ x0 :unit, x0)
                                          (invmap (weqrecompl T t is) t)))).
      assert (eee : int = t').
      {
        unfold int. unfold recompl, coprodf, invmap; simpl. unfold invrecompl.
        induction (is t) as [ ett | nett ].
        - apply pathsfuntransposoft1.
        - induction (nett (idpath _)).
      }
      assert (isint : isisolated _ int).
      {
        rewrite eee. apply is'.
      }
      apply (ishomotinclrecomplf _ _ isint (funtranspos0 _ _ _) _ _).
      simpl.
      change (recomplf int t isint (funtranspos0 int t is))
      with (funtranspos (int,, isint) (t,, is)).
      assert (ee : (int,, isint) = (t',, is')).
      {
        apply (invmaponpathsincl _ (isinclpr1isolated _) _ _).
        simpl. apply eee.
      }
      rewrite ee.
      set (e := homottranspost2t1t1t2
                  t t' is is'
                  (recompl T t (coprodf w (λ x0 : unit, x0)
                                        (invmap (weqrecompl T t is) x)))).
      simpl in e.
      rewrite e. unfold recompl, coprodf, invmap; simpl. unfold invrecompl.
      induction (is x) as [ etx | netx' ].
      * induction (netx etx).
      * apply (maponpaths (@pr1 _ _)). apply (maponpaths w).
        apply (invmaponpathsincl _ (isinclpr1compl _ _) _ _).
        simpl. apply idpath.
        Unset Printing Coercions.
Defined.

(* Coprojections i.e. functions which are weakly equivalent to functions of the
  form ii1 : X -> X ⨿ Y

Definition locsplit (X : UU) (Y : UU) (f : X -> Y)
:= ∏ y : Y, (hfiber  f y) ⨿ (hfiber  f y -> empty).

Definition dnegimage (X : UU) (Y : UU) (f : X -> Y)
:= total2 Y (λ y : Y, dneg(hfiber  f y)).
Definition dnegimageincl (X Y : UU) (f : X -> Y)
:= pr1 Y (λ y : Y, dneg(hfiber  f y)).

Definition xtodnegimage (X : UU) (Y : UU) (f : X -> Y) : X -> dnegimage f
:= λ x, tpair (f x) ((todneg _) (make_hfiber  f (f x) x (idpath (f x)))).

Definition locsplitsec (X : UU) (Y : UU) (f : X -> Y) (ls : locsplit  f) :
dnegimage f -> X
:= λ u,
match u with
tpair y psi =>
match (ls y) with
ii1 z => pr1  z|
ii2 phi => fromempty (psi phi)
end
end.

Definition locsplitsecissec (X Y : UU) (f : X -> Y) (ls : locsplit f)
(u:dnegimage  f) : paths (xtodnegimage f (locsplitsec  f ls u)) u.
Proof.
  intros. set (p := xtodnegimage f). set (s := locsplitsec f ls).
assert (paths (pr1 (p (s u))) (pr1  u)). unfold p. unfold xtodnegimage.
unfold s. unfold locsplitsec. simpl. induction u. set (lst := ls t).
induction lst.  simpl. apply (pr2  x0). induction (x y).
assert (is : isofhlevelf (S O) (dnegimageincl f)).
apply (isofhlevelfpr1 (S O) (λ y : Y, isapropdneg (hfiber f y))).
assert (isw: isweq (maponpaths (dnegimageincl f) (p (s u)) u)).
apply (isofhlevelfonpaths O  _ is).
apply (invmap  _ isw X0).
Defined.

Definition negimage (X : UU) (Y : UU) (f : X -> Y)
:= total2 Y (λ y : Y, neg(hfiber f y)).
Definition negimageincl (X Y : UU) (f : X -> Y)
:= pr1 Y (λ y : Y, neg(hfiber f y)).

Definition imsum (X : UU) (Y : UU) (f : X -> Y) :
(dnegimage  f) ⨿ (negimage  f) -> Y
:= λ u,
match u with
ii1 z => pr1  z|
ii2 z => pr1  z
end.

 *)

(** some lemmas about weak equivalences *)

Definition weqcompidl {X Y} (f:X ≃ Y) : weqcomp (idweq X) f = f.
Proof.
  intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)).
  apply funextsec; intro x; simpl. apply idpath.
Defined.

Definition weqcompidr {X Y} (f:X ≃ Y) : weqcomp f (idweq Y) = f.
Proof.
  intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)).
  apply funextsec; intro x; simpl. apply idpath.
Defined.

Definition weqcompinvl {X Y} (f:X ≃ Y) : weqcomp (invweq f) f = idweq Y.
Proof.
  intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)).
  apply funextsec; intro y; simpl. apply homotweqinvweq.
Defined.

Definition weqcompinvr {X Y} (f:X ≃ Y) : weqcomp f (invweq f) = idweq X.
Proof.
  intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)).
  apply funextsec; intro x; simpl. apply homotinvweqweq.
Defined.

Definition weqcompassoc {X Y Z W} (f:X ≃ Y) (g:Y ≃ Z) (h:Z ≃ W) :
  weqcomp (weqcomp f g) h = weqcomp f (weqcomp g h).
Proof.
  intros. apply (invmaponpathsincl _ (isinclpr1weq _ _)).
  apply funextsec; intro x; simpl. apply idpath.
Defined.

Definition weqcompweql {X Y Z} (f:X ≃ Y) :
  isweq (λ g:Y ≃ Z, weqcomp f g).
Proof.
  intros. simple refine (isweq_iso _ _ _ _).
  { intro h. exact (weqcomp (invweq f) h). }
  { intro g. simpl. rewrite <- weqcompassoc. rewrite weqcompinvl. apply weqcompidl. }
  { intro h. simpl. rewrite <- weqcompassoc. rewrite weqcompinvr. apply weqcompidl. }
Defined.

Definition weqcompweqr {X Y Z} (g:Y ≃ Z) :
  isweq (λ f:X ≃ Y, weqcomp f g).
Proof.
  intros. simple refine (isweq_iso _ _ _ _).
  { intro h. exact (weqcomp h (invweq g)). }
  { intro f. simpl. rewrite weqcompassoc. rewrite weqcompinvr. apply weqcompidr. }
  { intro h. simpl. rewrite weqcompassoc. rewrite weqcompinvl. apply weqcompidr. }
Defined.

Definition weqcompinjr {X Y Z} {f f':X ≃ Y} (g:Y ≃ Z) :
  weqcomp f g = weqcomp f' g -> f = f'.
Proof.
  apply (invmaponpathsincl _ (isinclweq _ _ _ (weqcompweqr g))).
Defined.

Definition weqcompinjl {X Y Z} (f:X ≃ Y) {g g':Y ≃ Z} :
  weqcomp f g = weqcomp f g' -> g = g'.
Proof.
  apply (invmaponpathsincl _ (isinclweq _ _ _ (weqcompweql f))).
Defined.

Definition invweqcomp {X Y Z} (f:X ≃ Y) (g:Y ≃ Z) :
  invweq (weqcomp f g) = weqcomp (invweq g) (invweq f).
Proof.
  intros. apply (weqcompinjr (weqcomp f g)). rewrite weqcompinvl.
  rewrite weqcompassoc. rewrite <- (weqcompassoc (invweq f)).
  rewrite weqcompinvl. rewrite weqcompidl. rewrite weqcompinvl. apply idpath.
Defined.

Definition invmapweqcomp {X Y Z} (f:X ≃ Y) (g:Y ≃ Z) :
  invmap (weqcomp f g) = weqcomp (invweq g) (invweq f).
Proof.
  reflexivity.
Defined.

(* End of the file uu0d.v *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

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

Require Export Ensembles.

Section Ensembles_facts.
  Variable U : Type.

  Lemma Extension : forall B C:Ensemble U, B = C -> Same_set U B C.
  Proof.
    intros B C H'; rewrite H'; auto with sets.
  Qed.

  Lemma Noone_in_empty : forall x:U, ~ In U (Empty_set U) x.
  Proof.
    red in |- *; destruct 1.
  Qed.

  Lemma Included_Empty : forall A:Ensemble U, Included U (Empty_set U) A.
  Proof.
    intro; red in |- *.
    intros x H; elim (Noone_in_empty x); auto with sets.
  Qed.

  Lemma Add_intro1 :
    forall (A:Ensemble U) (x y:U), In U A y -> In U (Add U A x) y.
  Proof.
    unfold Add at 1 in |- *; auto with sets.
  Qed.

  Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x.
  Proof.
    unfold Add at 1 in |- *; auto with sets.
  Qed.

  Lemma Inhabited_add : forall (A:Ensemble U) (x:U), Inhabited U (Add U A x).
  Proof.
    intros A x.
    apply Inhabited_intro with (x := x); auto using Add_intro2 with sets.
  Qed.

  Lemma Inhabited_not_empty :
    forall X:Ensemble U, Inhabited U X -> X <> Empty_set U.
  Proof.
    intros X H'; elim H'.
    intros x H'0; red in |- *; intro H'1.
    absurd (In U X x); auto with sets.
    rewrite H'1; auto using Noone_in_empty with sets.
  Qed.

  Lemma Add_not_Empty : forall (A:Ensemble U) (x:U), Add U A x <> Empty_set U.
  Proof.
    intros A x; apply Inhabited_not_empty; apply Inhabited_add.
  Qed.

  Lemma not_Empty_Add : forall (A:Ensemble U) (x:U), Empty_set U <> Add U A x.
  Proof.
    intros; red in |- *; intro H; generalize (Add_not_Empty A x); auto with sets.
  Qed.

  Lemma Singleton_inv : forall x y:U, In U (Singleton U x) y -> x = y.
  Proof.
    intros x y H'; elim H'; trivial with sets.
  Qed.

  Lemma Singleton_intro : forall x y:U, x = y -> In U (Singleton U x) y.
  Proof.
    intros x y H'; rewrite H'; trivial with sets.
  Qed.

  Lemma Union_inv :
    forall (B C:Ensemble U) (x:U), In U (Union U B C) x -> In U B x \/ In U C x.
  Proof.
    intros B C x H'; elim H'; auto with sets.
  Qed.

  Lemma Add_inv :
    forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y.
  Proof.
    intros A x y H'; induction H'.
      left; assumption.
      right; apply Singleton_inv; assumption.
  Qed.

  Lemma Intersection_inv :
    forall (B C:Ensemble U) (x:U),
      In U (Intersection U B C) x -> In U B x /\ In U C x.
  Proof.
    intros B C x H'; elim H'; auto with sets.
  Qed.

  Lemma Couple_inv : forall x y z:U, In U (Couple U x y) z -> z = x \/ z = y.
  Proof.
    intros x y z H'; elim H'; auto with sets.
  Qed.

  Lemma Setminus_intro :
    forall (A B:Ensemble U) (x:U),
      In U A x -> ~ In U B x -> In U (Setminus U A B) x.
  Proof.
    unfold Setminus at 1 in |- *; red in |- *; auto with sets.
  Qed.

  Lemma Strict_Included_intro :
    forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y.
  Proof.
    auto with sets.
  Qed.

  Lemma Strict_Included_strict : forall X:Ensemble U, ~ Strict_Included U X X.
  Proof.
    intro X; red in |- *; intro H'; elim H'.
    intros H'0 H'1; elim H'1; auto with sets.
  Qed.

End Ensembles_facts.

Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2
  Intersection_inv Couple_inv Setminus_intro Strict_Included_intro
  Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty
  not_Empty_Add Inhabited_add Included_Empty: sets v62.


(*
Copyright © 2007-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QposMinMax.
Require Export CoRN.model.structures.StepQsec.
Require Export CoRN.metric2.UniformContinuity.
Require Import CoRN.metric2.Prelength.
Require Import CoRN.model.structures.OpenUnit.
Require Import Coq.QArith.QArith.
Require Import CoRN.model.totalorder.QMinMax.
Require Import Coq.QArith.Qabs.
Require Import CoRN.model.ordfields.Qordfield.
Require Import CoRN.model.metric2.Qmetric.
Require Import CoRN.algebra.COrdFields2.
Require Import CoRN.tactics.CornTac.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Set Implicit Arguments.

Local Open Scope Q_scope.
Local Open Scope sfstscope.
Local Open Scope StepQ_scope.

Opaque Qred.

(**
** L1 metric for Step Functions
The L1 metric is measured by the integral of the absolute value of the
difference between step functions.

*** Integeral for Step Functions.
*)
Definition IntegralQ:(StepQ)->Q:=(StepFfold (fun x => x) (fun b (x y:QS) => (Qred (affineCombo b x y:QS))))%Q.
Definition L1Norm(f:StepF QS):Q:=(IntegralQ (StepQabs f)).
Definition L1Distance(f g:StepF QS):Q:=(L1Norm (f - g)).
Definition L1Ball (e:Q)(f g:StepF QS):Prop:=((L1Distance f g)<= e)%Q.

(*
Definition test1:=(constStepF (1:QS)).
Definition test2:=(glue (ou 1/2) (constStepF (0:QS)) (constStepF (1:QS))).
Eval lazy beta zeta delta iota in (L1Distance test1 test2):Q.
Why is compute so slow?
Eval compute in (L1Distance test1 test2):Q.
Eval lazy beta zeta delta iota in (L1Distance test2 test1):Q.
Eval lazy beta zeta delta iota in (L1Ball (1#1)%Qpos test2 test1).
Eval compute in (Mesh test2).
*)

Lemma L1ball_dec : forall e a b, {L1Ball e a b}+{~L1Ball e a b}.
Proof.
 intros e a b.
 unfold L1Ball.
 set (d:=L1Distance a b).
 destruct (Qlt_le_dec_fast e d) as [Hdc|Hdc].
  right. abstract auto with *.
  left. exact Hdc.
Defined.

(** The integral of the glue of two step functions. *)
Lemma Integral_glue : forall o s t, (IntegralQ (glue o s t) == o*(IntegralQ s) + (1-o)*(IntegralQ t))%Q.
Proof.
 intros o s t.
 unfold IntegralQ.
 simpl.
 rewrite -> Qred_correct.
 reflexivity.
Qed.

(** The integral of the split of a step function. *)
Lemma IntegralSplit : forall (o:OpenUnit) x,
 (IntegralQ x ==
 affineCombo o (IntegralQ (SplitL x o)) (IntegralQ (SplitR x o)))%Q.
Proof.
 intros o x.
 revert o.
 induction x.
  unfold IntegralQ. simpl. intros. unfold affineCombo; simpl in x; ring.
  intros p.
 rewrite -> Integral_glue.
 apply SplitLR_glue_ind; intros H.
   rewrite -> Integral_glue.
   unfold affineCombo in *.
   rewrite -> (IHx1 (OpenUnitDiv p o H)).
   unfold IntegralQ; simpl; fold IntegralQ. unfold affineCombo; field; auto with *. (*why does this not work*)
   rewrite -> Integral_glue.
  simpl. unfold IntegralQ; simpl; fold IntegralQ.
  repeat rewrite Qred_correct.
  unfold affineCombo in *.
  rewrite -> (IHx2 (OpenUnitDualDiv p o H)).
  unfold IntegralQ; simpl; fold IntegralQ. unfold affineCombo; field; auto with *.
  unfold affineCombo in *.
 rewrite -> H.
 reflexivity.
Qed.
(* begin hide *)
#[global]
Hint Resolve IntegralSplit : StepQArith.

Add Morphism IntegralQ
  with signature  (@StepF_eq _) ==>  Qeq
 as IntegralQ_wd.
Proof.
 induction x.
  intros x2 H. simpl. induction x2.
  auto with *.
  rewrite -> Integral_glue.
  simpl.
  destruct H as [H0 H1] using (eq_glue_ind x2_1).
  rewrite <- IHx2_1; auto with *.
  rewrite <- IHx2_2; auto with *.
  simpl in x; unfold affineCombo; ring.
 intros y H.
 destruct H as [H0 H1] using (glue_eq_ind x1).
 rewrite -> Integral_glue.
 rewrite -> (IHx1 _ H0).
 rewrite -> (IHx2 _ H1).
 symmetry.
 apply IntegralSplit.
Qed.

Add Morphism L1Norm
  with signature (@StepF_eq _) ==>  Qeq
 as L1Norm_wd.
Proof.
 unfold L1Norm.
 intros x y Hxy.
 rewrite -> Hxy.
 reflexivity.
Qed.

Add Morphism L1Distance
  with signature (@StepF_eq _) ==> (@StepF_eq _) ==>  Qeq
 as L1Distance_wd.
Proof.
 unfold L1Distance.
 intros x1 x2 Hx y1 y2 Hy.
 rewrite -> Hx.
 rewrite -> Hy.
 reflexivity.
Qed.

#[global]
Hint Rewrite Integral_glue: StepF_rew.
(* end hide *)
(** How the intergral intreacts with arithemetic functions on step
functions. *)
Lemma Integral_plus:forall s t,
  ((IntegralQ s)+(IntegralQ t)==(IntegralQ (s + t)))%Q.
Proof.
 apply StepF_ind2; try reflexivity.
  intros s s0 t t0 Hs Ht.
  rewrite -> Hs, Ht; auto.
 intros o s s0 t t0 H0 H1.
 unfold StepQplus.
 rewriteStepF.
 replace LHS with (o*(IntegralQ s + IntegralQ t) + (1-o)*(IntegralQ s0 + IntegralQ t0))%Q by simpl; ring.
 rewrite -> H0, H1.
 reflexivity.
Qed.

Lemma Integral_opp:forall s,
  (-(IntegralQ s)==(IntegralQ (- s)))%Q.
Proof.
 induction s.
  reflexivity.
 unfold StepQopp in *.
 rewriteStepF.
 rewrite <- IHs1.
 rewrite <- IHs2.
 ring.
Qed.

Lemma Integral_minus:forall s t,
  ((IntegralQ s)-(IntegralQ t)==(IntegralQ (s - t)))%Q.
Proof.
 intros s t.
 unfold Qminus.
 rewrite -> Integral_opp, Integral_plus.
 apply IntegralQ_wd.
 ring.
Qed.

Lemma Integral_scale :forall q x,
 (q*(IntegralQ x) == (IntegralQ (QscaleS q^@>x)))%Q.
Proof.
 intros q x.
 induction x.
  reflexivity.
 rewriteStepF.
 rewrite <- IHx1.
 rewrite <- IHx2.
 ring.
Qed.

Lemma Abs_Integral : forall x,
 (Qabs (IntegralQ x) <= IntegralQ (QabsS ^@> x))%Q.
Proof.
 intros x.
 induction x.
  apply Qle_refl.
 rewriteStepF.
 eapply Qle_trans.
  apply Qabs_triangle.
 do 2 rewrite -> Qabs_Qmult.
 rewrite -> (Qabs_pos o); auto with *.
 rewrite -> (Qabs_pos (1-o)); auto with *.
 apply: plus_resp_leEq_both;simpl; apply: mult_resp_leEq_lft; simpl; auto with *.
Qed.

Lemma Abs_Integral_Norm : forall x,
 (Qabs (IntegralQ x) <= L1Norm x)%Q.
Proof.
 exact Abs_Integral.
Qed.

(** The integral of a nonnegative function is nonnegative. *)
Lemma Integral_resp_nonneg :forall x,
 (constStepF (0:QS)) <= x -> (0 <= (IntegralQ x))%Q.
Proof.
 intros x.
 unfold StepQ_le.
 rewriteStepF.
 induction x.
  auto.
 rewriteStepF.
 intros [Hxl Hxr].
 apply: plus_resp_nonneg; apply: mult_resp_nonneg; simpl; auto with *.
Qed.

Lemma Integral_resp_le :forall x y,
 x <= y -> (IntegralQ x <= IntegralQ y)%Q.
Proof.
 intros x y H.
 rewrite -> Qle_minus_iff.
 rewrite -> Integral_opp, Integral_plus.
 apply Integral_resp_nonneg.
 revert H.
 apply StepF_imp_imp.
 unfold StepF_imp.
 rewriteStepF.
 set (g:= QleS 0).
 pose (f:=(ap (compose (@ap _ _ _) (compose (compose imp) QleS))
   (compose (compose g) (compose (flip QplusS) QoppS)))).
 cut (StepFfoldProp (f ^@> x <@> y)).
  unfold f.
  evalStepF.
  tauto.
 apply StepFfoldPropForall_Map2.
 intros a b.
 change (a <= b -> 0 <= b + (- a))%Q.
 rewrite -> Qle_minus_iff.
 tauto.
Qed.

(** Properties of the L1 norm. *)
Lemma L1Norm_glue : forall o s t, (L1Norm (glue o s t) == o*L1Norm s + (1-o)*L1Norm t)%Q.
Proof.
 intros o s t.
 unfold L1Norm.
 rewrite <- Integral_glue.
 reflexivity.
Qed.

Lemma L1Norm_nonneg : forall x, (0 <= (L1Norm x))%Q.
Proof.
 intros x.
 apply Integral_resp_nonneg.
 unfold StepQ_le.
 rewriteStepF.
 set (g:=QleS 0).
 cut (StepFfoldProp ((compose g QabsS) ^@> x)).
  evalStepF.
  tauto.
 apply StepFfoldPropForall_Map.
 intros a.
 apply: Qabs_nonneg.
Qed.

Lemma L1Norm_Zero : forall s,
 (L1Norm s <= 0)%Q -> s == (constStepF (0:QS)).
Proof.
 intros s.
 intros Hs.
 induction s.
  apply: Qle_antisym.
   eapply Qle_trans;[apply Qle_Qabs|assumption].
  rewrite <- (Qopp_involutive x).
  change 0 with (- (- 0))%Q.
  apply Qopp_le_compat.
  eapply Qle_trans;[apply Qle_Qabs|].
  rewrite -> Qabs_opp.
  assumption.
 unfold L1Norm, StepQabs in *.
 rewrite MapGlue in Hs.
 rewrite -> Integral_glue in Hs.
 apply glue_StepF_eq.
  apply IHs1.
  unfold L1Norm.
  setoid_replace 0 with (0/o); [| simpl; field; auto with *].
  apply Qle_shift_div_l; auto with *.
  rewrite -> Qmult_comm.
  apply Qle_trans with (-((1 - o) * IntegralQ (QabsS ^@> s2)))%Q.
   rewrite -> Qle_minus_iff.
   rewrite -> Qle_minus_iff in Hs.
   replace RHS with (0 +
     - (o * IntegralQ (QabsS ^@> s1) + (1 - o) * IntegralQ (QabsS ^@> s2)))%Q by simpl; ring.
   assumption.
  change 0 with (-0)%Q.
  apply Qopp_le_compat.
  apply: mult_resp_nonneg; simpl; auto with *.
  apply: L1Norm_nonneg.
 apply IHs2.
 unfold L1Norm.
 setoid_replace 0 with (0/(1-o)); [| simpl; field; auto with *].
 apply Qle_shift_div_l; auto with *.
 rewrite -> Qmult_comm.
 apply Qle_trans with (-(o * IntegralQ (QabsS ^@> s1)))%Q.
  rewrite -> Qle_minus_iff.
  rewrite -> Qle_minus_iff in Hs.
  replace RHS with (0 +
    - (o * IntegralQ (QabsS ^@> s1) + (1 - o) * IntegralQ (QabsS ^@> s2)))%Q by simpl; ring.
  assumption.
 change 0 with (-0)%Q.
 apply Qopp_le_compat.
 apply: mult_resp_nonneg; simpl; auto with *.
 apply L1Norm_nonneg.
Qed.

Lemma L1Norm_scale : forall q s,
 (L1Norm (QscaleS q ^@> s) == Qabs q * L1Norm s)%Q.
Proof.
 intros q s.
 unfold L1Norm.
 rewrite -> Integral_scale.
 apply IntegralQ_wd.
 unfold StepF_eq.
 set (g:= st_eqS).
 set (q0 := (QscaleS q)).
 set (q1 := (QscaleS (Qabs q))).
 set (f:= ap (compose g (compose QabsS q0)) (compose q1 QabsS)).
 cut (StepFfoldProp (f ^@> s)).
  unfold f.
  evalStepF.
  tauto.
 apply StepFfoldPropForall_Map.
 intros a.
 apply: Qabs_Qmult.
Qed.

(** L1 ball has all the required properties. *)
Lemma L1ball_refl : forall e x, Qle 0 e -> (L1Ball e x x).
Proof.
 intros e x epos.
 unfold L1Ball, L1Distance.
 setoid_replace (x-x) with (constStepF (0:QS)); [| ring].
 change (0 <= e)%Q.
 auto with *.
Qed.

Lemma L1ball_sym : forall e x y, (L1Ball e x y) -> (L1Ball e y x).
Proof.
 intros e x y.
 unfold L1Ball, L1Distance.
 unfold L1Norm.
 setoid_replace (x-y) with (-(y-x)); [| ring].
 rewrite -> StepQabsOpp.
 auto.
Qed.

Lemma L1ball_triangle : forall e d x y z, (L1Ball e x y) -> (L1Ball d y z) -> (L1Ball (e+d) x z).
Proof.
 intros e d x y z.
 unfold L1Ball, L1Distance.
 unfold L1Norm.
 setoid_replace (x-z) with ((x-y)+(y-z)); [| ring].
 intros He Hd.
 autorewrite with QposElim.
 apply Qle_trans with (IntegralQ (StepQabs (x-y) + StepQabs (y-z)))%Q.
  apply Integral_resp_le.
  apply StepQabs_triangle.
 rewrite <- Integral_plus.
 apply: plus_resp_leEq_both; assumption.
Qed.

Lemma L1ball_closed : forall e x y, (forall d, Qlt 0 d -> (L1Ball (e+d) x y)) -> (L1Ball e x y).
Proof.
 unfold L1Ball. intros e a b H.
 assert (forall x, (forall d : Qpos, x <= e+ proj1_sig d) -> x <= e)%Q.
 { intros. apply: shift_zero_leEq_minus'.
  apply inv_cancel_leEq. apply approach_zero_weak.
  intros. replace LHS with (x[-]e).
  apply: shift_minus_leEq;simpl.
  replace RHS with (e+ e0)%Q by simpl; ring.
  exact (H0 (exist _ _ X)).
  unfold cg_minus; simpl; ring. }
 apply H0. intros [d dpos]. apply H, dpos.
Qed.

Lemma L1ball_eq : forall x y, (forall e : Q, Qlt 0 e -> L1Ball e x y) -> StepF_eq x y.
Proof.
 intros x y H.
 unfold L1Ball in H.
 setoid_replace y with (constStepF (0:QS)+y); [| ring].
 set (z:=constStepF (0:QS)).
 setoid_replace x with (x - y + y); [| ring].
 apply StepQplus_wd; try reflexivity.
 unfold z; clear z.
 apply L1Norm_Zero.
 apply Qnot_lt_le.
 intro H0.
 assert (H1:0<(1#2)*( L1Norm (QminusS ^@> x <@> y))).
  apply: mult_resp_pos; simpl; auto with *.
 apply: (Qle_not_lt _ _ (H _ H1)).
 simpl.
 rewrite -> Qlt_minus_iff.
 unfold L1Distance.
 unfold StepQminus.
 simpl.
 ring_simplify.
 assumption.
Qed.

Definition L1S : RSetoid := Build_RSetoid (StepF_Sth QS).
(* begin hide *)
Canonical Structure L1S.
(* end hide *)
(**
*** Example of a Metric Space <StepQ, L1Ball>
*)
Lemma L1_is_MetricSpace :
 (is_MetricSpace L1Ball).
Proof.
 split.
 - intros e H x. apply L1ball_refl, H.
 - apply: L1ball_sym.
 - apply: L1ball_triangle.
 - apply: L1ball_closed.
 - intros. unfold L1Ball, L1Distance in H.
   apply (Qle_trans _ (L1Norm (a-b))).
   apply L1Norm_nonneg. exact H.
 - intros. unfold L1Ball, L1Distance.
   unfold L1Ball, L1Distance in H.
   apply Qnot_lt_le. intro abs.
   contradict H; intro H.
   exact (Qle_not_lt _ _ H abs).
Qed.
(* begin hide *)
Lemma L1Ball_e_wd : forall (e1 e2:Q) x y,
    Qeq e1 e2 -> (L1Ball e1 x y <-> L1Ball e2 x y).
Proof.
 intros x1 x2 y1 y2 Hx.
 unfold L1Ball.
 rewrite -> Hx.
 reflexivity.
Qed.
(* end hide *)
Definition L1StepQ : MetricSpace :=
@Build_MetricSpace L1S _ L1Ball_e_wd L1_is_MetricSpace.
(* begin hide *)
Canonical Structure L1StepQ.
(* end hide *)
(** The L1 metric is a prelength space. *)
Lemma L1StepQPrelengthSpace : PrelengthSpace L1StepQ.
Proof.
 intros x y e d1 d2 He Hxy.
 set (d:=(d1+d2)%Qpos) in *.
 simpl in *.
 unfold L1Ball in *.
 unfold L1Distance in *.
 pose (d1':=constStepF (proj1_sig d1)).
 pose (d2':=constStepF (proj1_sig d2)).
 pose (d':=constStepF ((/proj1_sig d))).
 set (f:=(d'*(x*d2' + y*d1'))%SQ).
 assert (X:(((d1' + d2')*d')==constStepF (1:QS))%SQ).
 { change (constStepF (proj1_sig (d1 + d2)%Qpos/proj1_sig (d1 + d2)%Qpos:QS)==constStepF (X:=QS) 1).
  apply constStepF_wd.
  simpl.
  field.
  intro. destruct d1, d2, e. simpl in H.
  simpl in He. rewrite H in He.
  exact (Qlt_irrefl 0 (Qlt_trans _ _ _ q1 He)). }
 exists (f).
  setoid_replace (x - f)%SQ with (d1' * d' * (x - y))%SQ.
  change ((d1' * d')%SQ * (x - y)%SQ)
    with (QscaleS (proj1_sig d1/ proj1_sig d)%Qpos ^@> (x-y)%SQ).
   rewrite -> L1Norm_scale.
   rewrite -> Qabs_pos; auto with *.
   unfold Qdiv.
   rewrite <- Qmult_assoc, <- (Qmult_comm (L1Norm (x-y))), Qmult_assoc.
   apply Qle_shift_div_r; auto with *.
   apply: mult_resp_leEq_lft; simpl; auto with *.
   apply Qle_trans with (proj1_sig e); auto with *.
   destruct d1,d. simpl. apply Qle_shift_div_l.
   exact q0. rewrite Qmult_0_l. apply Qlt_le_weak, q.
  setoid_replace (x - f) with (constStepF (1:QS)*x - f); [| simpl; ring].
  rewrite <- X.
  unfold f.
  simpl; ring.
 setoid_replace (f -y) with (d2' * d' * (x - y))%SQ.
 change ((d2' * d')%SQ * (x - y)%SQ)
   with (QscaleS (proj1_sig d2/proj1_sig d)%Qpos ^@> (x-y)%SQ).
  rewrite -> L1Norm_scale.
  rewrite -> Qabs_pos; auto with *.
  unfold Qdiv.
  rewrite <- Qmult_assoc, <- (Qmult_comm (L1Norm (x-y))), Qmult_assoc.
  apply Qle_shift_div_r; auto with *.
  apply: mult_resp_leEq_lft; simpl;auto with *.
  apply Qle_trans with (proj1_sig e); auto with *.
   destruct d2,d. simpl. apply Qle_shift_div_l.
   exact q0. rewrite Qmult_0_l. apply Qlt_le_weak, q.
 setoid_replace (f- y) with (f - constStepF (1:QS)*y); [| simpl; ring].
 rewrite <- X.
 unfold f.
 simpl. ring.
Qed.

(** Integration is uniformly continuous. *)
Lemma integral_uc_prf : @is_UniformlyContinuousFunction
                          L1StepQ Q_as_MetricSpace IntegralQ Qpos2QposInf.
Proof.
 intros e x y.
 simpl in *.
 rewrite -> Qball_Qabs.
 rewrite -> Integral_minus.
 unfold L1Ball, L1Distance.
 generalize (x - y).
 clear x y.
 intros x.
 intros Hx.
 eapply Qle_trans.
  apply Abs_Integral_Norm.
 assumption.
Qed.

Local Open Scope uc_scope.

Definition IntegralQ_uc : L1StepQ --> Q_as_MetricSpace
:= Build_UniformlyContinuousFunction integral_uc_prf.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.ftc.Rolle.
From Coq Require Import Lia.

Opaque Min.

Section Taylor_Defs.

(**
* Taylor's Theorem

We now prove Taylor's theorem for the remainder of the Taylor
series.  This proof is done in two steps: first, we prove the lemma
for a proper compact interval; next we generalize the result to two
arbitrary (eventually equal) points in a proper interval.

** First case

We assume two different points [a] and [b] in the domain of [F] and
define the nth order derivative of [F] in the interval
[[Min(a,b),Max(a,b)]].
*)

Variables a b : IR.
Hypothesis Hap : a [#] b.

(* begin hide *)
Let Hab' := ap_imp_Min_less_Max _ _ Hap.
Let Hab := less_leEq _ _ _ Hab'.
Let I := Compact Hab.
(* end hide *)

Variable F : PartIR.
Hypothesis Ha : Dom F a.
Hypothesis Hb : Dom F b.

(* begin show *)
Let fi n (Hf : Diffble_I_n Hab' n F) i Hi := ProjT1 (Diffble_I_n_imp_deriv_n _ _ _
 i F (le_imp_Diffble_I _ _ _ _ _ (lt_n_Sm_le i n Hi) _ Hf)).
(* end show *)

(**
This last local definition is simply:
$f_i=f^{(i)}$#fi=f(i)#.
*)

(* begin hide *)
Lemma Taylor_lemma1 : forall n Hf i Hi,
 Derivative_I_n Hab' i F (PartInt (fi n Hf i Hi)).
Proof.
 intros.
 unfold fi in |- *.
 apply projT2.
Qed.
(* end hide *)

(**
Now we can define the Taylor sequence around [a].  The auxiliary
definition gives, for any [i], the function expressed by the rule
%\[g(x)=\frac{f^{(i)}
(a)}{i!}*(x-a)^i.\]%#g(x)=f(i)(a)/i!*(x-a)i.#
We denote by [A] and [B] the elements of [[Min(a,b),Max(a,b)]]
corresponding to [a] and [b].
*)

(* begin hide *)
Let TL_compact_a := compact_Min_lft _ _ Hab.
Let TL_compact_b := compact_Min_rht _ _ Hab.

Notation A := (Build_subcsetoid_crr IR _ _ TL_compact_a).
Notation B := (Build_subcsetoid_crr IR _ _ TL_compact_b).
(* end hide *)

(* begin show *)
Let funct_i n Hf i Hi := [-C-] (fi n Hf i Hi A [/] _[//] nring_fac_ap_zero _ i) {*} (FId{-} [-C-]a) {^}i.
(* end show *)

(* begin hide *)
Let funct_i' n Hf i Hi := PartInt (fi n Hf i Hi) {*}
 [-C-] ([1][/] _[//]nring_fac_ap_zero IR i) {*} ( [-C-]b{-}FId) {^}i.

Lemma TL_a_i : forall n Hf i Hi, Dom (funct_i n Hf i Hi) a.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_b_i : forall n Hf i Hi, Dom (funct_i n Hf i Hi) b.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_x_i : forall x, I x -> forall n Hf i Hi, Dom (funct_i n Hf i Hi) x.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_a_i' : forall n Hf i Hi, Dom (funct_i' n Hf i Hi) a.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_b_i' : forall n Hf i Hi, Dom (funct_i' n Hf i Hi) b.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_x_i' : forall x, I x -> forall n Hf i Hi, Dom (funct_i' n Hf i Hi) x.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma Taylor_lemma2 : forall n Hf, ext_fun_seq (funct_i n Hf).
Proof.
 red in |- *; intros n Hf i j H H0 H' x y H1 Hx Hy.
 simpl in |- *.
 apply mult_wd.
  apply div_wd.
   2: rewrite H; algebra.
  generalize H' Hx Hy; clear Hy Hx H'.
  rewrite <- H; intros.
  cut (forall Ha1 Ha2, PartInt (fi n Hf i H0) a Ha1 [=] PartInt (fi n Hf i H') a Ha2); intros.
   simpl in H2.
   apply H2.
  apply Feq_imp_eq with (Compact Hab).
   unfold Hab in |- *; apply Derivative_I_n_unique with i F; apply Taylor_lemma1.
  apply TL_compact_a.
 rewrite H.
 astepl ((x[+][--]a) [^]j); Step_final ((y[+][--]a) [^]j).
Qed.

Lemma Taylor_lemma2' : forall n Hf, ext_fun_seq' (funct_i n Hf).
Proof.
 repeat intro.
 repeat split.
Qed.

Lemma Taylor_lemma3 : forall n Hf, ext_fun_seq (funct_i' n Hf).
Proof.
 red in |- *; intros n Hf i j H H0 H' x y H1 Hx Hy.
 simpl in |- *.
 apply mult_wd.
  apply mult_wd.
   2: rewrite H; algebra.
  generalize H' Hx Hy; clear Hy Hx H'.
  rewrite <- H; intros.
  cut (forall Hx' Hy', PartInt (fi n Hf i H0) x Hx' [=] PartInt (fi n Hf i H') y Hy'); intros.
   simpl in H2.
   apply H2.
  cut (Dom (PartInt (fi n Hf i H')) x); [ intro H2 | apply dom_wd with y; algebra ].
  apply eq_transitive_unfolded with (Part _ _ H2).
   apply Feq_imp_eq with (Compact Hab).
    unfold Hab in |- *; apply Derivative_I_n_unique with i F; apply Taylor_lemma1.
   simpl in Hx.
   elim Hx; intros.
   inversion_clear a0; auto.
  algebra.
 rewrite H.
 astepl ((b[+][--]x) [^]j); Step_final ((b[+][--]y) [^]j).
Qed.

Lemma Taylor_lemma3' : forall n Hf, ext_fun_seq' (funct_i' n Hf).
Proof.
 intros n Hf i j H H0 H' x y H1 H2.
 elim H2; intros.
 simpl in a0, b0.
 clear b0; inversion_clear a0 as (X,X0).
 inversion_clear X; repeat split.
  astepr x; auto.
 astepl x; auto.
Qed.
(* end hide *)

(**
Adding the previous expressions up to a given bound [n] gives us the
Taylor sum of order [n].
*)

Definition Taylor_seq' n Hf := FSumx _ (funct_i n Hf).

(* begin hide *)
Let Taylor_seq'_aux n Hf := FSumx _ (funct_i' n Hf).

Lemma TL_lemma_a : forall n Hf, Dom (Taylor_seq' n Hf) a.
Proof.
 intros.
 repeat split.
 apply FSumx_pred'.
  repeat split.
 repeat split.
Qed.
(* end hide *)

(**
It is easy to show that [b] is in the domain of this series, which allows us to write down the Taylor remainder around [b].
*)

Lemma TL_lemma_b : forall n Hf, Dom (Taylor_seq' n Hf) b.
Proof.
 intros.
 repeat split.
 apply FSumx_pred'.
  repeat split.
 repeat split.
Qed.

(* begin hide *)
Lemma TL_lemma_a' : forall n Hf, Dom (Taylor_seq'_aux n Hf) a.
Proof.
 intros.
 split.
  apply FSumx_pred'.
   red in |- *; intros.
   simpl in X.
   inversion_clear X.
   inversion_clear X0.
   simpl in |- *.
   split; split; auto.
   apply compact_wd with x; auto.
  intros.
  apply TL_a_i'.
 apply TL_a_i'.
Qed.

Lemma TL_lemma_b' : forall n Hf, Dom (Taylor_seq'_aux n Hf) b.
Proof.
 intros.
 split.
  apply FSumx_pred'.
   red in |- *; intros.
   simpl in X.
   inversion_clear X.
   inversion_clear X0.
   simpl in |- *.
   split; split; auto.
   apply compact_wd with x; auto.
  intros.
  apply TL_b_i'.
 apply TL_b_i'.
Qed.
(* end hide *)

Definition Taylor_rem n Hf := F b Hb[-]Taylor_seq' n Hf b (TL_lemma_b n Hf).

(* begin hide *)
Let g n Hf Hab := [-C-] (F b Hb) {-}Taylor_seq'_aux n Hf{-}
 [-C-] (Taylor_rem n Hf) {*} (( [-C-]b{-}FId) {*} [-C-] ([1][/] (b[-]a) [//]Hab)).

Lemma Taylor_lemma4 : forall n Hf Hab Ha', g n Hf Hab a Ha' [=] [0].
Proof.
 unfold g in |- *; clear g; intros.
 cut (Dom ( [-C-] (F b Hb) {-}Taylor_seq'_aux n Hf{-} [-C-] (Taylor_rem n Hf)) a). intro H.
  apply eq_transitive_unfolded with (Part _ _ H).
   Opaque Taylor_seq'_aux Taylor_rem.
   simpl in |- *; rational.
  Transparent Taylor_rem.
  unfold Taylor_rem in |- *.
  apply eq_transitive_unfolded with (Part _ _ (TL_lemma_b n Hf) [-]Part _ _ (TL_lemma_a' n Hf)).
   Opaque Taylor_seq'.
   simpl in |- *; rational.
  Transparent Taylor_seq' Taylor_seq'_aux.
  unfold Taylor_seq', Taylor_seq'_aux in |- *.
  cut (Dom (FSum 0 n (FSumx_to_FSum _ (funct_i n Hf))) b). intro H0.
   cut (Dom (FSum 0 n (FSumx_to_FSum _ (funct_i' n Hf))) a). intro H1.
    apply eq_transitive_unfolded with (Part _ _ H0[-]Part _ _ H1).
     apply eq_symmetric_unfolded; apply cg_minus_wd; apply FSum_FSumx_to_FSum.
        apply Taylor_lemma2.
       apply Taylor_lemma2'.
      apply Taylor_lemma3.
     apply Taylor_lemma3'.
    eapply eq_transitive_unfolded.
     simpl in |- *.
     apply eq_symmetric_unfolded; apply Sum_minus_Sum.
    apply Sum_zero.
     auto with arith.
    intros.
    cut (forall Hb' Ha', FSumx_to_FSum (S n) (funct_i n Hf) i b Hb'[-]
      FSumx_to_FSum (S n) (funct_i' n Hf) i a Ha' [=] [0]); auto.
    unfold FSumx_to_FSum in |- *.
    elim le_lt_dec; intro; simpl in |- *.
     algebra.
    intros.
    set (w := fi n Hf i b0 (Build_subcsetoid_crr _ _ _ TL_compact_a) [*]
      ([1][/] _[//]nring_fac_ap_zero IR i) [*] (b[+][--]a) [^]i) in *.
    astepr (w[-]w); unfold w in |- *; simpl in |- *.
    repeat first [ apply cg_minus_wd | simple apply mult_wd ]; try apply csf_wd_unfolded; algebra.
     rational.
    simpl in |- *; algebra.
   simpl in |- *; intro i.
   Opaque funct_i'.
   unfold FSumx_to_FSum in |- *.
   elim le_lt_dec; intro; simpl in |- *.
    auto.
   apply TL_a_i'.
  Opaque funct_i.
  simpl in |- *; intro i.
  unfold FSumx_to_FSum in |- *.
  elim le_lt_dec; intro; simpl in |- *.
   auto.
  apply TL_b_i.
 split; split; split.
  apply FSumx_pred'.
   red in |- *; intros.
   inversion_clear X.
   inversion_clear X0.
   simpl in X.
   split; split; auto.
   simpl in |- *; apply compact_wd with x; auto.
  intros; apply TL_a_i'.
 apply TL_a_i'.
Qed.

Transparent funct_i funct_i'.

Lemma Taylor_lemma5 : forall n Hf Hab Hb', g n Hf Hab b Hb' [=] [0].
Proof.
 unfold g in |- *; intros.
 cut (Dom ( [-C-] (F b Hb) {-}Taylor_seq'_aux n Hf) b). intro H.
  apply eq_transitive_unfolded with (Part _ _ H).
   Opaque Taylor_seq'_aux.
   simpl in |- *; rational.
  Transparent Taylor_seq'_aux.
  unfold Taylor_seq'_aux in |- *.
  cut (Dom (FSum 0 n (FSumx_to_FSum _ (funct_i' n Hf))) b). intro H0.
   apply eq_transitive_unfolded with (F b Hb[-]Part _ _ H0).
    Opaque FSumx.
    apply eq_transitive_unfolded with (F b Hb[-]FSumx (S n) (funct_i' n Hf) b (ProjIR2 H)).
     simpl in |- *; rational.
    apply cg_minus_wd.
     algebra.
    apply eq_symmetric_unfolded; apply FSum_FSumx_to_FSum.
     apply Taylor_lemma3.
    apply Taylor_lemma3'.
   simpl in |- *.
   astepr (Part _ _ Hb[-]Part _ _ Hb); apply cg_minus_wd.
    algebra.
   eapply eq_transitive_unfolded.
    apply Sum_first.
   astepr (Part _ _ Hb[+][0]); apply bin_op_wd_unfolded.
    cut (forall H', FSumx_to_FSum (S n) (funct_i' n Hf) 0 b H' [=] Part _ _ Hb); auto.
    unfold FSumx_to_FSum in |- *.
    elim le_lt_dec; intro; simpl in |- *.
     exfalso; inversion a0.
    intros; simpl in |- *.
    rstepr (Part _ _ Hb[*][1][*][1]).
    apply mult_wdl.
    apply mult_wd.
     2: rational.
    apply eq_symmetric_unfolded.
    apply eq_transitive_unfolded with (PartInt (fi n Hf 0 b0) b TL_compact_b).
     2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
    apply Feq_imp_eq with (Compact Hab).
     apply (ProjT2 (Diffble_I_n_imp_deriv_n _ _ _ _ _
       (le_imp_Diffble_I _ _ _ _ _ (lt_n_Sm_le 0 n b0) _ Hf))).
    apply TL_compact_b.
   apply Sum_zero.
    auto with arith.
   intros.
   cut (forall H', FSumx_to_FSum (S n) (funct_i' n Hf) i b H' [=] [0]); auto.
   unfold FSumx_to_FSum in |- *.
   elim le_lt_dec; intro; simpl in |- *.
    algebra.
   intro.
   astepr (fi n Hf i b0 (Build_subcsetoid_crr IR _ b (ProjIR1 (ProjIR1 H'))) [*]
     ([1][/] _[//]nring_fac_ap_zero _ i) [*][0]).
   apply mult_wdr.
   astepl ((b[-]b) [^]i).
   Step_final (ZeroR[^]i).
  intro i.
  Opaque funct_i'.
  unfold FSumx_to_FSum in |- *.
  elim le_lt_dec; intro; simpl in |- *.
   auto.
  apply TL_b_i'.
 split.
  simpl in |- *; auto.
 simpl in |- *.
 apply TL_lemma_b'.
Qed.

Transparent funct_i' FSumx.

Let funct_aux n Hf i Hi := PartInt (fi (S n) Hf (S i) (lt_n_S _ _ Hi)) {*}
  [-C-] ([1][/] _[//]nring_fac_ap_zero IR i) {*} ( [-C-]b{-}FId) {^}i.

Lemma Taylor_lemma6 :  forall n Hf Hf' i Hi, Derivative_I Hab'
 (PartInt (fi n Hf i Hi)) (PartInt (fi (S n) Hf' (S i) (lt_n_S _ _ Hi))).
Proof.
 intros.
 cut (Derivative_I_n Hab' 1 (PartInt (fi n Hf i Hi))
   (PartInt (fi (S n) Hf' (S i) (lt_n_S i (S n) Hi)))).
  intro H.
  simpl in H.
  elim H; intros f' H1 H2.
  apply Derivative_I_wdr with (PartInt f'); assumption.
 cut (S i = 1 + i); [ intro | lia ].
 cut (1 + i < S (S n)); [ intro | lia ].
 apply Derivative_I_n_wdr with (PartInt (fi (S n) Hf' _ H0)).
  apply Derivative_I_n_unique with (S i) F.
   generalize H0; clear H0.
   rewrite <- H; intro.
   apply Taylor_lemma1.
  apply Taylor_lemma1.
 apply Derivative_I_n_wdl with (n_deriv_I _ _ _ _ _
   (le_imp_Diffble_I _ _ _ _ _ (lt_n_Sm_le i n Hi) _ Hf)).
  2: apply Derivative_I_n_wdr with (n_deriv_I _ _ _ _ _
    (le_imp_Diffble_I _ _ _ _ _ (lt_n_Sm_le _ _ H0) _ Hf')).
   3: apply n_deriv_plus.
  apply Derivative_I_n_unique with i F.
   apply n_deriv_lemma.
  apply Taylor_lemma1.
 apply Derivative_I_n_unique with (1 + i) F.
  apply n_deriv_lemma.
 apply Taylor_lemma1.
Qed.

Ltac Lazy_Included :=
  repeat first
   [ simple apply included_IR
   | simple apply included_FPlus
   | simple apply included_FInv
   | simple apply included_FMinus
   | simple apply included_FMult
   | simple apply included_FNth
   | simple apply included_refl ].

Ltac Lazy_Eq :=
  repeat first
   [ simple apply bin_op_wd_unfolded
   | simple apply un_op_wd_unfolded
   | simple apply cg_minus_wd
   | simple apply div_wd
   | simple apply csf_wd_unfolded ]; algebra.

Lemma Taylor_lemma7 : forall n Hf Hf' i (Hi : 0 < i) Hi', Derivative_I Hab'
 (funct_i' n Hf i Hi') (funct_aux n Hf' i Hi'{-}funct_aux n Hf' (pred i) (lt_5 i (S n) Hi')).
Proof.
 do 5 intro.
 rewrite (S_pred _ _ Hi).
 set (p := pred i) in *; clearbody p; clear Hi i.
 intros.
 cut (Derivative_I Hab' (PartInt (fi n Hf _ Hi'))
   (PartInt (fi (S n) Hf' (S (S p)) (lt_n_S _ _ Hi')))); [ intro | apply Taylor_lemma6 ].
 unfold funct_aux, funct_i' in |- *.
 New_Deriv.
  apply Feq_reflexive.
  Lazy_Included.
 apply eq_imp_Feq.
   Lazy_Included.
  Lazy_Included.
 intros x X0 Hx Hx'.
 simpl in Hx, Hx'; simpl in |- *.
 set (fiSp1 := fi n Hf (S p) Hi') in *.
 set (fiSp2 := fi (S n) Hf' (S p) (lt_n_S p (S n) (lt_5 (S p) (S n) Hi'))) in *.
 cut (forall x y : subset I, scs_elem _ _ x [=] scs_elem _ _ y -> fiSp1 x [=] fiSp2 y); intros.
  set (x1 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR1 Hx)))) in *.
  simpl in (value of x1); fold x1 in |- *.
  set (x2 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR2 Hx')))) in *.
  simpl in (value of x2); fold x2 in |- *.
  set (x3 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR1 (ProjIR2 Hx))))) in *.
  simpl in (value of x3); fold x3 in |- *.
  set (x4 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR1 Hx')))) in *.
  simpl in (value of x4); fold x4 in |- *.
  set (x5 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR2 (ProjIR1 (ProjIR2 Hx))))) in *.
  simpl in (value of x5); fold x5 in |- *.
  set (fiSSp := fi (S n) Hf' (S (S p)) (lt_n_S (S p) (S n) Hi')) in *.
  set (pp := [1][/] nring (fact p + p * fact p) [//]nring_fac_ap_zero IR (S p)) in *.
  set (bxp := nexp _ p (b[-]x)) in *.
  set (a1 := fiSp1 x1) in *; set (a5 := fiSSp x5) in *;
    simpl in (value of a1), (value of a5); fold a1 a5 in |- *.
  rstepl (a5[*]pp[*] (bxp[*] (b[-]x)) [-]a1[*] ((nring p[+][1]) [*]pp) [*]bxp).
  unfold a1, a5 in |- *; clear a1 a5.
  Lazy_Eq.
   unfold x4, x5 in |- *; algebra.
   simpl in |- *; algebra.
  unfold pp in |- *.
  rstepr (nring (S p) [*] ([1][/] _[//] mult_resp_ap_zero _ _ _ (nring_fac_ap_zero _ p)
    (pos_ap_zero _ _ (pos_nring_S IR p)))); simpl in |- *.
  apply mult_wdr; apply div_wd.
   algebra.
  clear X H bxp pp x5 x4 x3 x2 x1 fiSSp fiSp1 fiSp2 Hx.
  cut (fact p + p * fact p = fact p * S p).
   intro; rewrite H.
   eapply eq_transitive_unfolded.
    apply nring_comm_mult.
   algebra.
  transitivity (S p * fact p); auto with arith.
 unfold fiSp1, fiSp2 in |- *.
 apply eq_transitive_unfolded with (PartInt (fi n Hf (S p) Hi') (scs_elem _ _ x0) (scs_prf _ _ x0)).
  2: apply eq_transitive_unfolded with (PartInt (fi (S n) Hf' (S p) (lt_n_S _ _ (lt_5 _ _ Hi')))
    (scs_elem _ _ x0) (scs_prf _ _ x0)).
   simpl in |- *; apply csf_wd_unfolded.
   case x0; simpl in |- *; algebra.
  apply Feq_imp_eq with (Compact Hab).
   unfold Hab in |- *; apply Derivative_I_n_unique with (S p) F; apply Taylor_lemma1.
  apply scs_prf.
 simpl in |- *; apply csf_wd_unfolded.
 generalize H; case x0; case y; auto.
Qed.

Lemma Taylor_lemma8 : forall n Hf Hf' Hi,
  Derivative_I Hab' (funct_i' n Hf 0 Hi) (funct_aux n Hf' 0 Hi).
Proof.
 intros.
 cut (Derivative_I Hab' (PartInt (fi n Hf _ Hi)) (PartInt (fi (S n) Hf' 1 (lt_n_S _ _ Hi))));
   [ intro | apply Taylor_lemma6 ].
 unfold funct_aux, funct_i' in |- *; New_Deriv.
  apply Feq_reflexive; Lazy_Included.
 apply eq_imp_Feq.
   Lazy_Included.
  Lazy_Included.
 intros; simpl in |- *.
 apply eq_transitive_unfolded with (fi (S n) Hf' 1 (lt_n_S _ _ Hi)
   (Build_subcsetoid_crr _ _ _ (ProjIR1 (ProjIR2 (ProjIR1 (ProjIR2 Hx))))) [*]
     ([1][/] _[//]nring_fac_ap_zero IR 0) [*][1]).
  simpl in |- *; rational.
 Lazy_Eq; simpl in |- *; algebra.
Qed.

Lemma Taylor_lemma9 : forall n Hf Hf',
  Derivative_I Hab' (Taylor_seq'_aux n Hf) (funct_aux n Hf' n (lt_n_Sn n)).
Proof.
 intro; induction  n as [| n Hrecn].
  intros.
  unfold Taylor_seq'_aux in |- *; simpl in |- *.
  apply Derivative_I_wdl with (funct_i' 0 Hf 0 (lt_n_Sn 0)).
   apply eq_imp_Feq.
     split; split; simpl in |- *; auto.
    split; split; split; simpl in |- *; auto.
   intros; simpl in |- *.
   apply eq_transitive_unfolded with ([0][+] fi 0 Hf 0 (lt_n_Sn 0)
     (Build_subcsetoid_crr _ _ _ (ProjIR1 (ProjIR1 Hx))) [*]
       ([1][/] [0][+][1][//]nring_fac_ap_zero IR 0) [*][1]).
    simpl in |- *; rational.
   Lazy_Eq; simpl in |- *; algebra.
  apply Taylor_lemma8; assumption.
 cut {p : nat | S n = p}; [ intro H | exists (S n); auto ].
 elim H; intros p H0.
 rewrite H0.
 intros.
 unfold Taylor_seq'_aux in |- *; simpl in |- *.
 generalize Hf Hf'; clear Hf Hf'.
 rewrite <- H0; intros.
 cut (Diffble_I_n Hab' n F); [ intro H1 | apply le_imp_Diffble_I with (S n); [ lia | assumption ] ].
 apply Derivative_I_wdl with (Taylor_seq'_aux n H1{+}funct_i' _ Hf _ (lt_n_Sn (S n))).
  unfold Taylor_seq'_aux in |- *.
  apply eq_imp_Feq.
    repeat (split; auto). try rename X into H2.
    apply FSumx_pred'.
     red in |- *; intros. try rename X into H6.
     exact (Taylor_lemma3' _ _ _ _ H3 _ _ _ _ H4 H6).
    intros; simpl in |- *; repeat (split; auto).
   repeat (split; auto). try rename X into H2.
   apply FSumx_pred'.
    red in |- *; intros. try rename X into H6.
    exact (Taylor_lemma3' _ _ _ _ H3 _ _ _ _ H4 H6).
   intros; simpl in |- *; repeat (split; auto).
  intros x H2 Hx Hx'; simpl in |- *.
  repeat first [ simple apply mult_wd | simple apply bin_op_wd_unfolded | simple apply csf_wd_unfolded
    | simple apply eq_reflexive_unfolded ]; simpl in |- *.
    3: algebra.
   apply Feq_imp_eq with (Compact Hab).
    2: assumption.
   apply FSumx_wd'.
   intros; apply eq_imp_Feq.
     repeat (split; auto).
    repeat (split; auto).
   intros x0 H4; intros; simpl in |- *.
   repeat apply mult_wdl.
   apply eq_transitive_unfolded with (PartInt (fi n H1 i (lt_S _ _ H3)) x0 H4).
    simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
   apply eq_transitive_unfolded with (PartInt (fi (S n) Hf i (lt_S _ _ (lt_S _ _ H'))) x0 H4).
    2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
   apply Feq_imp_eq with (Compact Hab).
    unfold Hab in |- *; apply Derivative_I_n_unique with i F; apply Taylor_lemma1.
   auto.
  apply eq_transitive_unfolded with (PartInt (fi n H1 n (lt_n_Sn _)) x H2).
   2: apply eq_transitive_unfolded with (PartInt (fi (S n) Hf n (lt_S _ _ (lt_n_Sn _))) x H2).
    simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
   2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
  apply Feq_imp_eq with (Compact Hab).
   unfold Hab in |- *; apply Derivative_I_n_unique with n F; apply Taylor_lemma1.
  auto.
 apply Derivative_I_wdr with (funct_aux (S n) Hf' (pred (S n)) (lt_5 _ _ (lt_n_Sn (S n))) {+}
   (funct_aux _ Hf' _ (lt_n_Sn (S n)) {-}
     funct_aux (S n) Hf' (pred (S n)) (lt_5 _ _ (lt_n_Sn (S n))))).
  Opaque funct_aux.
  FEQ.
   Transparent funct_aux.
   repeat (split; auto).
  repeat (split; auto).
 apply Derivative_I_plus.
  apply Derivative_I_wdr with (funct_aux n Hf n (lt_n_Sn n)).
   apply eq_imp_Feq.
     repeat (split; auto).
    repeat (split; auto).
   intros x H2 Hx Hx'; simpl in |- *.
   repeat apply mult_wdl.
   apply eq_transitive_unfolded with (PartInt (fi (S n) Hf (S n) (lt_n_S _ _ (lt_n_Sn _))) x H2).
    2: apply eq_transitive_unfolded with (PartInt
      (fi (S (S n)) Hf' (S n) (lt_n_S _ _ (lt_5 _ _ (lt_n_Sn (S n))))) x H2).
     simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
    2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
   apply Feq_imp_eq with (Compact Hab).
    unfold Hab in |- *; apply Derivative_I_n_unique with (S n) F; apply Taylor_lemma1.
   auto.
  apply Hrecn.
 apply Taylor_lemma7.
 lia.
Qed.

Let g' n Hf Hf' Hab :=
 [-C-] (Taylor_rem n Hf[/] (b[-]a) [//]Hab) {-}funct_aux n Hf' n (lt_n_Sn n).

Lemma Taylor_lemma10 : forall n Hf Hf' Hab (H : a [#] b),
 Derivative_I Hab' (g n Hf Hab) (g' n Hf Hf' Hab).
Proof.
 unfold g, g' in |- *.
 intros.
 cut (Derivative_I Hab' (Taylor_seq'_aux n Hf) (funct_aux n Hf' n (lt_n_Sn n)));
   [ intro | apply Taylor_lemma9; assumption ].
 Opaque Taylor_rem funct_aux.
 New_Deriv.
  apply Feq_reflexive; Lazy_Included.
  Included.
 apply eq_imp_Feq.
   Lazy_Included.
   Included.
  Lazy_Included.
  Included.
 intros; simpl in |- *; rational.
Qed.

Transparent Taylor_rem funct_aux.
(* end hide *)

(**
Now Taylor's theorem.

%\begin{convention}% Let [e] be a positive real number.
%\end{convention}%
*)

Variable e : IR.
Hypothesis He : [0] [<] e.

(* begin hide *)
Lemma Taylor_lemma11 : forall n Hf Hf' H, {c : IR | I c |
  forall Hc, AbsIR (g' n Hf Hf' H c Hc) [<=] e[*]AbsIR ([1][/] (b[-]a) [//]H)}.
Proof.
 intros.
 cut (Dom (g n Hf H) (Min a b)). intro H0.
  cut (Dom (g n Hf H) (Max a b)). intro H1.
   cut (Dom (g n Hf H) a). intro H2.
    cut (Dom (g n Hf H) b). intro H3.
     unfold I, Hab in |- *; apply Rolle with (g n Hf H) H0 H1.
       apply Taylor_lemma10; auto.
      elim (ap_imp_less _ _ _ Hap); intro.
       apply eq_transitive_unfolded with ZeroR.
        eapply eq_transitive_unfolded.
         2: apply Taylor_lemma4 with (Ha' := H2).
        apply pfwdef; apply leEq_imp_Min_is_lft; apply less_leEq; auto.
       apply eq_symmetric_unfolded.
       eapply eq_transitive_unfolded.
        2: apply Taylor_lemma5 with (Hb' := H3).
       apply pfwdef; apply leEq_imp_Max_is_rht; apply less_leEq; auto.
      apply eq_transitive_unfolded with ZeroR.
       eapply eq_transitive_unfolded.
        2: apply Taylor_lemma5 with (Hb' := H3).
       apply pfwdef; eapply eq_transitive_unfolded.
        apply Min_comm.
       apply leEq_imp_Min_is_lft; apply less_leEq; auto.
      apply eq_symmetric_unfolded.
      eapply eq_transitive_unfolded.
       2: apply Taylor_lemma4 with (Ha' := H2).
      apply pfwdef; eapply eq_transitive_unfolded.
       apply Max_comm.
      apply leEq_imp_Max_is_rht; apply less_leEq; auto.
     astepl ([0][*]AbsIR ([1][/] _[//]H)).
     apply mult_resp_less.
      assumption.
     apply AbsIR_pos.
     apply div_resp_ap_zero_rev.
     apply one_ap_zero.
    split; split; split; simpl in |- *; auto.
      3: split; split.
     2: split; split; auto; apply TL_compact_b.
    apply FSumx_pred'; intros.
     2: apply TL_b_i'.
    red in |- *; intros. try rename X into H6.
    exact (Taylor_lemma3' _ _ _ _ H3 _ _ _ _ H4 H6).
   split; split; split; simpl in |- *; auto.
     3: split; split.
    2: split; split; auto; apply TL_compact_a.
   apply FSumx_pred'; intros.
    2: apply TL_a_i'.
   red in |- *; intros. try rename X into H5.
   exact (Taylor_lemma3' _ _ _ _ H2 _ _ _ _ H3 H5).
  split; split; split; simpl in |- *; auto.
    3: split; split.
   2: split; split; auto; apply compact_inc_rht.
  apply FSumx_pred'; intros.
   2: apply TL_x_i'.
   red in |- *; intros. try rename X into H4.
   exact (Taylor_lemma3' _ _ _ _ H1 _ _ _ _ H2 H4).
  unfold I in |- *; apply compact_inc_rht.
 split; split; split; simpl in |- *; auto.
   3: split; split.
  2: split; split; auto; apply compact_inc_lft.
 apply FSumx_pred'; intros.
  2: apply TL_x_i'.
  red in |- *; intros. try rename X into H3.
  exact (Taylor_lemma3' _ _ _ _ H0 _ _ _ _ H1 H3).
 unfold I in |- *; apply compact_inc_lft.
Qed.
(* end hide *)

(* begin show *)
Let deriv_Sn' n Hf' :=
 n_deriv_I _ _ Hab' (S n) F Hf'{*} [-C-] ([1][/] _[//]nring_fac_ap_zero _ n) {*} ( [-C-]b{-}FId) {^}n.
(* end show *)

(* begin hide *)
Lemma TLH : b[-]a [#] [0].
Proof.
 rstepl ( [--] (a[-]b)).
 apply inv_resp_ap_zero.
 apply minus_ap_zero; auto.
Qed.
(* end hide *)

Lemma Taylor_lemma : forall n Hf Hf', {c : IR | I c |
 forall Hc, AbsIR (Taylor_rem n Hf[-]deriv_Sn' n Hf' c Hc[*] (b[-]a)) [<=] e}.
Proof.
 intros.
 assert (H := TLH).
 cut {c : IR | I c | forall Hc, AbsIR (g' n Hf Hf' H c Hc) [<=] e[*]AbsIR ([1][/] _[//]H)};
   [ intro H0 | apply Taylor_lemma11; assumption ].
 elim H0; intros c Hc' Hc; clear H0; exists c.
  auto.
 intro.
 cut (Dom (funct_aux n Hf' n (lt_n_Sn n)) c). intro H0.
  apply leEq_wdl with (AbsIR (((Taylor_rem n Hf[/] _[//]H) [-]Part _ _ H0) [*] (b[-]a))).
   eapply leEq_wdl.
    2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
   apply shift_mult_leEq with (AbsIR_resp_ap_zero _ H).
    apply AbsIR_pos; apply H.
   rstepr (e[*] ([1][/] _[//]AbsIR_resp_ap_zero _ H)).
   apply leEq_wdr with (e[*]AbsIR ([1][/] _[//]H)).
    Opaque funct_aux.
    cut (Dom (g' n Hf Hf' H) c). intro H1.
     eapply leEq_wdl.
      apply (Hc H1).
     apply AbsIR_wd; unfold g' in |- *.
     Opaque Taylor_rem.
     simpl in |- *; rational.
    repeat (split; auto).
   apply mult_wdr.
   apply AbsIR_recip.
  apply eq_symmetric_unfolded.
  apply eq_transitive_unfolded
    with (AbsIR ((Taylor_rem n Hf[/] _[//]H) [-]Part _ _ H0) [*]AbsIR (b[-]a)).
   eapply eq_transitive_unfolded.
    2: apply AbsIR_resp_mult.
   apply AbsIR_wd.
   rstepr (Taylor_rem n Hf[-]Part _ _ H0[*] (b[-]a)).
   apply cg_minus_wd.
    algebra.
   apply mult_wdl.
   Transparent Taylor_rem funct_aux.
   unfold deriv_Sn', funct_aux in |- *.
   cut (Dom (n_deriv_I _ _ Hab' (S n) F Hf') c). intro H1.
    simpl in |- *; apply eq_transitive_unfolded with (n_deriv_I _ _ Hab' (S n) F Hf' c H1[*]
      ([1][/] _[//]nring_fac_ap_zero _ n) [*] (b[-]c) [^]n).
     repeat apply mult_wdl; apply pfwdef; algebra.
    repeat apply mult_wdl.
    apply eq_transitive_unfolded with (PartInt (fi (S n) Hf' (S n) (lt_n_S _ _ (lt_n_Sn _))) c Hc').
     2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
    apply Feq_imp_eq with (Compact Hab).
     unfold Hab in |- *; apply Derivative_I_n_unique with (S n) F.
      apply n_deriv_lemma.
     apply Taylor_lemma1.
    auto.
   apply n_deriv_inc; auto.
  apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
 repeat (split; auto).
Qed.

End Taylor_Defs.