(* -*- mode: coq; mode: visual-line -*-  *)

Require Import HoTT.Basics Types.Prod Types.Forall Types.Paths.
Require Export Tactics.BinderApply.

(** * Extra tactics for homotopy type theory. *)

(** ** Tactics for dealing with [Funext] *)
(** *** Tactics about [transport]ing with [path_forall] *)

(** Given using the variable names from [transport : forall {A : Type} (P : A -> Type) {x y : A}, x = y -> P x -> P y] and [path_forall : {Funext} -> forall {A B} (f g : forall x : A, B x), (forall x : A, f x = g x) -> f = g]:

The high-level idea is that we don't really need functional extensionality if we end up just applying the functions to arguments anyway.  That is, if we have that [forall x, f x = g x], and we only talk about [f y] and [f z], then we don't actually need to transport across [f = g], just [f y = g y] and [f z = g z].

In a bit more detail, if we are transporting across [path_forall f g H], and in the function [P], all instances of [f] are applied to some expressions, say we only see [f x], [f y], ..., [f z], then we can eliminate the [path_forall] by explicitly transporting across [H x], [H y], ..., [H z].  The lemma [path_forall_1_beta] expresses this fact in the case that we see [f] applied to only a single argument in [P], and the tactic [transport_path_forall_hammer] is some fancy Ltac to auto-infer what [P] is and what the argument to [f] is.

The way the tactic does this is by creating an evar for [P] and an evar for the argument to [f], and then using a combination of [assert], [pattern], etc to figure out what each should be.  If you want to see how it works, you can step through each step of [transport_path_forall_hammer] when trying to prove [path_forall_2_beta]. *)

(** First, we prove some helpful lemmas about [path_forall] and [transport] *)
Local Ltac path_forall_beta_t :=
  lazymatch goal with
    | [ |- context[@path_forall ?H ?A ?B ?f ?g ?e] ]
      => let X := fresh in
         pose proof (eissect (@path_forall H A B f g) e) as X;
           case X;
           generalize (@path_forall H A B f g e);
           clear X; clear e;
           intro X; destruct X;
           cbn;
           unfold apD10;
           rewrite !(path_forall_1 f)
  end;
  reflexivity.

(** The basic idea is expressed in the type of this lemma. *)
Lemma path_forall_1_beta `{Funext} A B x P f g e Px
: @transport (forall a : A, B a) (fun f => P (f x)) f g (@path_forall _ _ _ _ _ e) Px
  = @transport (B x) P (f x) (g x) (e x) Px.
Proof.
  path_forall_beta_t.
Defined.

(** The powerful recursive case *)
Lemma path_forall_recr_beta' `{Funext} A B x0 P f g e Px
: @transport (forall a : A, B a)
             (fun f => P f (f x0))
             f
             g
             (@path_forall _ _ _ _ _ e)
             Px
  = @transport ((forall a, B a) * B x0)%type
               (fun x => P (fst x) (snd x))
               (f, f x0)
               (g, g x0)
               (path_prod' (@path_forall _ _ _ _ _ e) (e x0))
               Px.
Proof.
  path_forall_beta_t.
Defined.

(** Rewrite the recursive case after clean-up *)
Lemma path_forall_recr_beta `{Funext} A B x0 P f g e Px
: @transport (forall a : A, B a)
             (fun f => P f (f x0))
             f
             g
             (@path_forall _ _ _ _ _ e)
             Px
  = @transport (forall x : A, B x)
               (fun x => P x (g x0))
               f
               g
               (@path_forall H A B f g e)
               (@transport (B x0)
                           (fun y => P f y)
                           (f x0)
                           (g x0)
                           (e x0)
                           Px).
Proof.
  etransitivity.
  - apply path_forall_recr_beta'.
  - refine (transport_path_prod' _ _ _ _).
Defined.

(** The sledge-hammer for computing with [transport]ing across a [path_forall].  Note that it uses [rewrite], and so should only be used in opaque proofs. *)

(** This helper tactic takes a [term] and a function [f], finds [f x] in [term] and patterns that, returning a pair [(x, term')] such that [term' (f x) ≡ term]. *)
Ltac pull_app term f :=
  let term' := (eval cbv beta in term) in
  match term' with
    | context[f ?x]
      => match eval pattern (f x) in term' with
           | ?term' (f x) => constr:((x, term'))
         end
  end.

Ltac infer_path_forall_recr_beta term :=
  let path_forall_recr_beta' :=
      match term with
        | @transport _ (fun x => @?P0 x) _ _ (@path_forall ?H ?A ?B ?f ?g ?e) _
          => constr:(fun x0 P Px => @path_forall_recr_beta H A B x0 P f g e Px)
      end in
  let Px := match term with @transport _ _ _ _ _ ?Px => constr:(Px) end in
  let P0 := match term with @transport _ (fun f => @?P0 f) _ _ _ _ => constr:(P0) end in
  (** pattern some [f x0] in [P0] *)
  (** Hopefully, no goal will have a variable called [WORKAROUND_FOR_BUG_3458] in the context.  At least not until bug #3458 is fixed. *)
  let P0f := constr:(fun WORKAROUND_FOR_BUG_3458 => ltac:(
                                                      let ret := pull_app (P0 WORKAROUND_FOR_BUG_3458) WORKAROUND_FOR_BUG_3458 in
                                                      exact ret)) in
  let x0 := match P0f with fun f => (?x0, @?P f) => constr:(x0) end in
  let P := match P0f with fun f => (?x0, @?P f) => constr:(P) end in
  let ret := constr:(path_forall_recr_beta' x0 P Px) in
  let retT := type of ret in
  let ret' := (eval cbv beta in ret) in
  let retT' := (eval cbv beta in retT) in
  constr:(ret' : retT').

Ltac transport_path_forall_hammer_helper :=
  let term := match goal with
                | |- context[@transport ?At (fun x => @?Bt x) ?ft ?gt (@path_forall ?H ?A ?B ?f ?g ?e) ?Px]
                  => constr:(@transport At Bt ft gt (@path_forall H A B f g e) Px)
              end in
  let lem := infer_path_forall_recr_beta term in
  pattern term;
    refine (transport _ lem^ _);
    cbv beta.

Ltac transport_path_forall_hammer :=
  transport_path_forall_hammer_helper;
  rewrite ?transport_const;
  repeat (
      transport_path_forall_hammer_helper;
      rewrite ?transport_const
    ).

(** An example showing that it works *)
Lemma path_forall_2_beta' `{Funext} A B x0 x1 P f g e Px
: @transport (forall a : A, B a) (fun f => P (f x0) (f x1)) f g (@path_forall _ _ _ _ _ e) Px
  = @transport (B x0 * B x1)%type (fun x => P (fst x) (snd x)) (f x0, f x1) (g x0, g x1) (path_prod' (e x0) (e x1)) Px.
Proof.
  transport_path_forall_hammer.
  repeat match goal with
           | [ |- context[e ?x] ] => induction (e x)
         end;
    cbn.
  reflexivity.
Qed.

Lemma path_forall_2_beta `{Funext} A B x0 x1 P f g e Px
: @transport (forall a : A, B a) (fun f => P (f x0) (f x1)) f g (@path_forall _ _ _ _ _ e) Px
  = transport (fun y : B x1 => P (g x0) y) (e x1)
     (transport (fun y : B x0 => P y (f x1)) (e x0) Px).
Proof.
  transport_path_forall_hammer.
  reflexivity.
Qed.

(** ** A more powerful variant of [path_induction] *)
(** We first define some helper tactics, and then define [path_induction_hammer], which has poor computational behavior, but is vastly more powerful than [path_induction], and removes paths which are discoverably contractible, and paths which only appear in the goal, etc. *)

(** A variant of [induction] which also tries [destruct] and [case], and may be extended to using other [destruct]-like tactics. *)
Ltac induction_hammer H :=
  destruct H || induction H || (case H; clear H).

(** Takes a term of type [_ = _], and tries to replace it by [idpath] by trying to prove that it's an hProp.  The ordering of attempts is tuned for speed. *)
Ltac clear_contr_path p :=
  let H := fresh in
  let T := type of p in
  progress (
      first [ assert (H : idpath = p) by exact (center _)
            | assert (H : idpath = p)
              by (
                  let a := match goal with |- @paths (?x = ?y) ?a ?b => constr:(a) end in
                  let b := match goal with |- @paths (?x = ?y) ?a ?b => constr:(b) end in
                  let x := match goal with |- @paths (?x = ?y) ?a ?b => constr:(x) end in
                  let y := match goal with |- @paths (?x = ?y) ?a ?b => constr:(y) end in
                  apply (@equiv_inv _ _ _ (@equiv_ap _ _ _ (@isequiv_apD10 _ _ _ x y) a b));
                  exact (center _)
                )
            | pose proof (@path_contr T _ idpath p) as H ];
      destruct H;
      (* now reduce any matches on [idpath] (and on other things too) *)
      cbv iota in *
    ).

(** Use both [induction_hammer] and [clear_contr_path] on a path, to try to get rid of it *)
Ltac clear_path_no_check p :=
  induction_hammer p || clear_contr_path p.
Ltac clear_path p :=
  let t := type of p in
  lazymatch eval hnf in t with
    | @paths _ _ _ => clear_path_no_check p || fail 1 "cannot clear path" p
    | _ => fail 0 "clear_path only works on paths;" p "is not a path"
  end.

(** Run [clear_path] on hypotheses *)
(** We don't match only on things of type [_ = _], because maybe that's the head normal form, but it's hiding behind something else; [clear_path] will make sure it's of the right type.  We include some redundant cases at the top, for speed; it is faster to try to destruct everything first, and then do the full battery of tactics, than to just run the hammer. *)
Ltac step_clear_paths :=
  idtac;
  match goal with
    | [ p : _ = _ |- _ ] => destruct p
    | [ p : _ = _ |- _ ] => clear_path_no_check p
    | [ p : _ |- _ ] => clear_path p
  end.
Ltac clear_paths := progress repeat step_clear_paths.

(** Run [clear_path] on anything inside a [match] *)
Ltac step_clear_paths_in_match :=
  idtac;
  match goal with
    | [ |- context[match ?p with idpath => _ end] ] => progress destruct p
    | [ |- context[match ?p with idpath => _ end] ] => clear_path_no_check p
  end.
Ltac clear_paths_in_match := progress repeat step_clear_paths_in_match.

(** Now some lemmas about trivial [match]es *)
Definition match_eta {T} {x y : T} (H0 : x = y)
: (H0 = match H0 in (_ = y) return (x = y) with
          | idpath => idpath
        end)
  := match H0 with idpath => idpath end.

Definition match_eta1 {T} {x : T} (E : x = x)
: (match E in (_ = y) return (x = y) with
     | idpath => idpath
   end = idpath)
  -> idpath = E
  := fun H => ((H # match_eta E) ^)%path.

Definition match_eta2 {T} {x : T} (E : x = x)
: (idpath
   = match E in (_ = y) return (x = y) with
       | idpath => idpath
     end)
  -> idpath = E
  := fun H => match_eta1 E (H ^)%path.

(** And now the actual tactic.  Note that the order of the cases in the [match goal with ... end] is somewhat finely tuned for speed. *)
Ltac step_path_induction_hammer :=
  idtac;
  match goal with
    | _ => reflexivity
    | _ => intro
    | _ => progress cbn in *
    | _ => exact (contr _)
    | [ p : _ = _ |- _ ]
      => progress destruct p (* placed up here for speed *)
    | [ H : _ |- _ ]
      => let H' := fresh in assert (H' := match_eta1 _ H); destruct H'
    | [ H : _ |- _ ]
      => let H' := fresh in assert (H' := match_eta2 _ H); destruct H'
    | _ => step_clear_paths
    | _ => expand; step_clear_paths_in_match
    | _ => progress auto with path_hints
    | _ => done
    | _ => exact (center _)
  end.

Ltac path_induction_hammer := progress repeat step_path_induction_hammer.

(** * Miscellaneous tactics *)

(** Substitute all hypotheses with bodies, i.e., of the form [H := _]. *)
Ltac subst_body :=
  repeat match goal with
           | [ H := _ |- _ ] => subst H
         end.

(** Some tactics to do things with some arbitrary hypothesis in the context.  These tactics are similar to, e.g., [assumption]. *)

Ltac do_with_hyp tac :=
  idtac;
  match goal with
    | [ H : _ |- _ ] => tac H
  end.

Ltac rewrite_hyp' := do_with_hyp ltac:(fun H => rewrite H).
Ltac rewrite_hyp := repeat rewrite_hyp'.
Ltac rewrite_rev_hyp' := do_with_hyp ltac:(fun H => rewrite <- H).
Ltac rewrite_rev_hyp := repeat rewrite_rev_hyp'.

Ltac apply_hyp' := do_with_hyp ltac:(fun H => apply H).
Ltac apply_hyp := repeat apply_hyp'.
Ltac eapply_hyp' := do_with_hyp ltac:(fun H => eapply H).
Ltac eapply_hyp := repeat eapply_hyp'.

(** Run [simpl] on a hypothesis before rewriting with it. *)
Ltac simpl_do_clear tac term :=
  let H := fresh in
  assert (H := term);
    cbn in H |- *;
    tac H;
    clear H.

(** The behavior of [simpl rewrite] with respect to implicit arguments is slightly different from that of [rewrite].  In some ways, it is a little more like [erewrite], but in fact both [rewrite] and [erewrite] use magic that we are unable to exactly duplicate with a user-defined tactic.

The point is that for a user-defined tactic, Coq has to resolve the meaning of the term passed to it in some way before the tactic begins executing.  In particular, if that term involves maximally inserted implicit arguments, then it will have to fill them in; but often there will be no way to do that.  If we declared the argument of [simpl rewrite] as a [constr], then this would cause it to fail.  Instead, we declare it as an [open_constr], which allows Coq to fill in those implicit arguments with existential variables, which can then be instantiated later during the rewriting. *)

Tactic Notation "simpl" "rewrite"      open_constr(term) := simpl_do_clear ltac:(fun H => rewrite    H) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> H) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- H) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite    H in hyp) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> H in hyp) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- H in hyp) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite    H in * ) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> H in * ) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- H in * ) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite    H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- H in hyp |- * ) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite    H in * |- ) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> H in * |- ) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- H in * |- ) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite    !H) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> !H) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- !H) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite    !H in hyp) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> !H in hyp) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- !H in hyp) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite    !H in * ) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> !H in * ) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- !H in * ) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite    !H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> !H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- !H in hyp |- * ) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite    !H in * |- ) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> !H in * |- ) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- !H in * |- ) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite    ?H) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> ?H) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- ?H) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite    ?H in hyp) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> ?H in hyp) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- ?H in hyp) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite    ?H in * ) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> ?H in * ) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- ?H in * ) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite    ?H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> ?H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- ?H in hyp |- * ) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite    ?H in * |- ) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> ?H in * |- ) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- ?H in * |- ) term.

Ltac head_hnf expr := let expr' := eval hnf in expr in head expr'.

(* given a [matcher] that succeeds on some hypotheses and fails on
   others, destruct any matching hypotheses, and then execute [tac]
   after each [destruct].

   The [tac] part exists so that you can, e.g., [simpl in *], to
   speed things up. *)
Ltac destruct_all_matches_then matcher tac :=
  repeat match goal with
           | [ H : ?T |- _ ] => matcher T; destruct H; tac
         end.

Ltac destruct_all_matches matcher := destruct_all_matches_then matcher ltac:(simpl in *).
Ltac destruct_all_matches' matcher := destruct_all_matches_then matcher idtac.

(** matches anything whose type has a [T] in it *)
Ltac destruct_type_matcher T HT :=
  match HT with
    | context[T] => idtac
  end.
Ltac destruct_type T := destruct_all_matches ltac:(destruct_type_matcher T).
Ltac destruct_type' T := destruct_all_matches' ltac:(destruct_type_matcher T).

Ltac destruct_head_matcher T HT :=
  match head HT with
    | T => idtac
  end.
Ltac destruct_head T := destruct_all_matches ltac:(destruct_head_matcher T).
Ltac destruct_head' T := destruct_all_matches' ltac:(destruct_head_matcher T).

Ltac destruct_head_hnf_matcher T HT :=
  match head_hnf HT with
    | T => idtac
  end.
Ltac destruct_head_hnf T := destruct_all_matches ltac:(destruct_head_hnf_matcher T).
Ltac destruct_head_hnf' T := destruct_all_matches' ltac:(destruct_head_hnf_matcher T).

(** Turns a context object, obtained via, e.g., [match goal with |- context G[...] => ... end], into a lambda / gallina function. *)
Ltac context_to_lambda G :=
  let ret := constr:(fun x => let k := x in
                              ltac:(
                                let ret := context G[k] in
                                exact ret)) in
  (eval cbv zeta in ret).


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