Require Import StLib.Main StLib.Kernels.
Require Import Psatz.
Require Import Utils.

Parameters N P : Z.
Axiom Ngt0 : N > 0.
Axiom Pgt0 : P > 0.

Module AmPutOpt <: (PROBLEM Z2).
  Local Open Scope aexpr.

  Definition space := 〚0, N-1〛×〚0, N*P-1〛.
  Definition target := 〚0, N-1〛×〚0, N*P-1〛.
  Definition dep c :=
    match c with
      | (t,s) =>
        [(t+1,s); (t+1,s-1); (t+1,s+1)]
    end.
End AmPutOpt.

Module P := Kern Z2 AmPutOpt.
Import P.

Definition my_comp0 :=
  (For "t" From 0 To N-1 Do
     For "x" From N*2*"id"+"t" To N*2*"id" + N*2-"t"-1 Do
       Fire (N - 1 - "t", "x" : aexpr))%code.

Definition my_send :=
  (If "to" =? "id" - 1 Then
    For "t" From 0 To N-1 Do
      Fire (N - 1 - "t", N*2*"id" + "t");;
    For "t" From 1 To N-1 Do
      Fire (N - "t", N*2*"id" + "t")
   Else
     If "to" =? "id" + 1 Then
       For "t" From 0 To N-1 Do
         Fire (N - 1 - "t", N*2*"id" + N*2-"t"-1);;
       For "t" From 1 To N-1 Do
         Fire (N - "t", N*2*"id" + N*2-"t"-1)
     Else
       Nop)%code.

Definition my_comp1_0 :=
  (For "t" From 0 To N-1 Do
     For "x" From N*2*"id" - "t" To N*2*"id" + "t" - 1 Do
       Fire (N - 1 - "t":aexpr, "x":aexpr))%code.

Definition my_comp1_1 :=
  (For "t" From 0 To N-1 Do
     For "x" From N*2*"id" + N*2-"t" To N*2*"id" + N*2+"t"-1 Do
       Fire (N - 1 - "t":aexpr, "x":aexpr))%code.

(** Merge all computation steps together. *)
Definition my_comp :=
  (If "T" =? 0 Then
     my_comp0
   Else
     If "T" =? 1 Then
       my_comp1_0;; my_comp1_1
     Else
       Nop)%code.

(** And here is the kernel! *)
Definition my_code :=
  makeKernel my_comp my_send.

(** Let's now prove the correctness of this kernel. *)
Theorem my_code_correct :
  kcorrect my_code (P-1) 1.
Proof.
  to_ctx Ngt0; to_ctx Pgt0.

  synthesize trace; intros.

  (** First goal is the verification conditions for the computation steps,
   * which encapsulate the dependencies. *)
  - decide T=0.

    + simplify sets with ceval; forward.

      (** COMP0, first dependency (south). *)
      decide i=0; [right; unfold space; forward; unfold fst, snd in *; omega|].

      left; lhs. rhs; forward.
      exists (i-1); forward. omega.
      exists i0; forward; omega.

      (** COMP0, second dependency (south-west). *)
      decide i=0; [right; unfold space; forward; unfold fst, snd in *; omega|].

      left; lhs. rhs; forward.
      exists (i-1); forward. omega.
      exists (i0-1); forward; omega.

      (** COMP0, last dependency (south-east). *)
      decide i=0; [right; unfold space; forward; unfold fst, snd in *; omega|].

      left; lhs. rhs; forward.
      exists (i-1); forward. omega.
      exists (i0+1); forward; omega.

    + decide T=1.
      simplify sets with ceval; forward.

      (** COMP1, TL, first dependency (south). *)
      assert (HT : N*2*id - i = i0 \/ i0 = N*2*id + i - 1
                   \/ N*2*id - i < i0 < N*2*id + i - 1)
        by omega; destruct HT as [?|[?|?]].

      (* Left edge of TL[id]. *)
      decide id=0; [right; unfold space; forward; unfold fst, snd in *; omega|].

      left; lhs; lhs; rhs; forward.
      exists 0; forward.
      exists (id-1); forward; try omega.
      unfold sends_synth; simpl; forward.

      destr_case (id =? id - 1 - 1).
      destr_case (id =? id - 1 + 1).
      forward.
      simplify sets with ceval.
      exists (i-1); forward; try omega.
      lhs; forward; try omega; nia.

      (* Right edge of TL[id]. *)
      left. lhs; lhs; lhs; forward.
      exists 0; forward.
      unfold computes_synth; simpl; simplify sets with ceval; forward.
      exists (i-1); forward; try omega.
      exists i0; forward; omega.

      (* Interior of TL[id]. *)
      left; lhs; rhs; forward.
      exists (i-1); forward; try omega.
      exists i0; forward; omega.

      (** COMP1, TL, second dependency (south-west). *)
      destruct Z_le_gt_dec with i0 (N*2*id - i + 1).

      (* The two left edges of TL[id]. *)
      decide id=0; [right; unfold space; forward; unfold fst, snd in *; omega|].

      left; lhs; lhs; rhs; forward.
      exists 0; forward.
      exists (id - 1); forward; try omega.
      unfold sends_synth; simpl; forward.

      destr_case (id=?id-1-1); destr_case (id=?id-1+1).
      simplify sets with ceval; forward.
      exists (i - 1); forward; try omega.
      clear H11.
      decide i0=(N*2*id - i).
      rhs; forward.
      exists i; forward; try omega. nia.
      decide i0=(N*2*id - i + 1).
      lhs; forward.
      nia.
      nia.
      exfalso; omega.

      (* The rest of TL[id]. *)
      left. lhs; rhs; forward.
      exists (i-1); forward; try omega.
      exists (i0-1); forward; try omega.

      (** COMP1, TL, last dependency (south-east). *)
      destruct Z_le_gt_dec with (N*2*id + i - 2) i0.

      (* The two right edges of TL[id]. *)
      left; lhs; lhs; lhs; forward.
      exists 0; forward.
      unfold computes_synth; simpl; simplify sets with ceval; forward.
      exists (i-1); forward; try omega.
      exists (i0+1); forward; omega.

      (* Interior of TL[id]. *)
      left; lhs; rhs; forward.
      exists (i-1); forward; try omega.
      exists (i0+1); forward; omega.

      (** COMP1, TR, first dependency (south). *)
      assert (HT : N*2*id + N*2 - i = i0 \/ i0 = N*2*id + N*2 + i - 1
                   \/ N*2*id + N*2 - i < i0 < N*2*id + N*2 + i - 1)
        by omega; destruct HT as [?|[?|?]].

      (* Left edge of TR[id]. *)
      left; lhs; lhs; lhs; lhs; forward.
      exists 0; forward.
      unfold computes_synth; simpl; simplify sets with ceval; forward.
      exists (i-1); forward; try omega.
      exists i0; forward; omega.

      (* Right edge of TR[id]. *)
      decide id=(P-1); [right; unfold space; forward; unfold fst, snd in *; nia|].

      left; lhs; lhs; lhs; rhs; forward.
      exists 0; forward.
      exists (id+1); forward; try omega.
      unfold sends_synth; simpl; forward.

      destr_case (id =? id + 1 - 1).
      forward.
      exists (i-1); forward; try omega.
      simplify sets with ceval.
      lhs; forward. nia.
      nia.

      (* Interior of TR[id]. *)
      left; lhs; rhs; forward.
      exists (i-1); forward; try omega.
      exists i0; forward; omega.

      (** COMP1, TR, second dependency (south-west). *)
      destruct Z_le_gt_dec with i0 (N*2*id + N*2 - i + 1).

      (* Left edge of TR[id]. *)
      left; lhs; lhs; lhs; lhs; forward.
      exists 0; forward.
      unfold computes_synth; simpl; simplify sets with ceval; forward.
      exists (i-1); forward; try omega.
      exists (i0-1); forward; try omega.

      (* Interior of TR[id]. *)
      left; lhs; rhs; forward.
      exists (i-1); forward; try omega.
      exists (i0-1); forward; try omega.

      (** COMP1, TR, last dependency (south-east). *)
      destruct Z_le_gt_dec with (N*2*id + N*2 + i - 2) i0.

      (* Right edge of TR[id]. *)
      decide id=(P-1); [right; unfold space; forward; unfold fst, snd in *; nia|].

      left; lhs; lhs; lhs; rhs; forward.
      exists 0; forward.
      exists (id+1); forward; try omega.
      unfold sends_synth; simpl; simplify sets with ceval.
      destr_case (id =? id + 1 - 1); forward.
      exists (i-1); forward; try omega.
      clear H10; decide i0=(N*2*id + N*2 + i - 1).

      rhs; forward.
      exists i; forward; try omega. nia.
      lhs; forward; nia.

      (* Interior of TR[id]. *)
      left; lhs; rhs; forward.
      exists (i-1); forward; try omega.
      exists (i0+1); forward; try omega.

      omega.

  (** Second goal is the verification conditions for the communication steps,
   * which are trivial. *)
  - destruct (to =? id - 1); forward.
    destruct (to =? id + 1); forward.

  (** Third goal is "conservation of knowledge": we are not allowed to send
   * a value that we don't know. *)
  - unfold af_synth, computes_synth, sends_synth in *; simpl in *.
    simplify sets with ceval.
    repeat intro; lhs.

    destruct (to =? id - 1); forward.
    (* Left border *)
    exists 0; simpl; forward. (* Time step 0 *)
    exists x0; forward.
    exists (snd x); rewrite H10; simpl; forward'; omega.
    exists 0; simpl; forward. (* Time step 0 *)
    exists (x1 - 1); forward; try omega.
    exists (snd x); rewrite H11; simpl; forward'; try omega.
    repeat rhs; forward; omega.

    destruct (to =? id + 1); simpl; forward.

    (* Right border *)
    exists 0; simpl; forward. (* Time step 0 *)
    exists x0; forward.
    exists (snd x); rewrite H10; simpl; forward'; try omega.
    exists 0; simpl; forward. (* Time step 0 *)
    exists (x1 - 1); forward; try omega.
    exists (snd x); rewrite H11; simpl; forward'; try omega.
    repeat rhs; forward; omega.

  (** Last goal is completeness: we computed all the cells we were supposed
   * to compute. *)
  - unfold target, bf_synth, computes_synth, sends_synth; simpl.
    repeat intro.
    destruct x; forward; unfold fst, snd in *.

    (** We have to prove that [x] belongs to some T[I], TL[I] or TR[I], for
     * some "I". This "I" is obtained by take the quotient of x's abscissa
     * by 2N. *)
    pose (I := z0 / (N*2)).
    assert (HNT : N*2 > 0) by omega.
    to_ctx (Z_div_mod_spec z0 (N*2) HNT).
    exists I; forward.
    unfold I; nia.
    unfold I; nia.

    destruct seg_dec with (N*2*I + (N - 1 - z)) (N*2*I + N*2-(N - 1 - z)-1) z0 as [?|[?|?]];
      lhs; forward.

    (* Case T[I]. *)
    exists 0; simpl; simplify sets with ceval;
    forward; try omega. (* First computation step. *)
    exists (N - 1 - z); forward; try omega.
    exists z0; forward; try omega.

    (* Case TL[I]. *)
    exists 1; simpl; simplify sets with ceval;
    forward; try omega. (* Second computation step. *)
    lhs; forward. (* First sub-step *)
    exists (N - 1 - z); forward; try omega.
    exists z0; forward; try omega.
    unfold I; omega.

    (* Case TR[I] *)
    exists 1; simpl; simplify sets with ceval;
    forward; try omega. (* Second computation step. *)
    rhs; forward. (* Second sub-step *)
    exists (N - 1 - z); forward; try omega.
    exists z0; forward; try omega.
    unfold I; omega.
Qed.


(* Copyright 2021 Joshua M. Cohen

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

Require Import VST.floyd.functional_base.

From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

(*Facts about Z, bytes, and bounds that are needed in various places. Some of the proofs use ssreflect because
  they were originally in the ByteField code*)

(** Facts about Z*)

Lemma Z_lxor_nonneg': forall a b,
  0 <= a ->
  0 <= b ->
  0 <= Z.lxor a b.
Proof.
  move => a b Ha Hb. by rewrite Z.lxor_nonneg.
Qed.

Lemma Z_shiftl_nonneg': forall a n,
  0 <= a ->
  0 <= Z.shiftl a n.
Proof.
  move => a n Ha. by rewrite Z.shiftl_nonneg.
Qed.

Lemma Int_repr_zero: forall z,
  0 <= z <= Int.max_unsigned ->
  Int.repr z = Int.zero <-> z = 0.
Proof.
  move => z Hz. split => [| Hzero].
  - rewrite /Int.zero => Hzero. apply repr_inj_unsigned in Hzero; rep_lia.
  - by subst.
Qed.

(** Facts about byte*)

Lemma byte_unsigned_inj: forall (b1 b2: byte),
  Byte.unsigned b1 = Byte.unsigned b2 ->
  b1 = b2.
Proof.
  move => b1 b2 Hb12. apply Vubyte_injective. by rewrite /Vubyte Hb12.
Qed.

Lemma byte_log2_range: forall (b: byte),
  0 <= Z.log2 (Byte.unsigned b) <= 7%Z.
Proof.
  move => [z Hz /=]. move: Hz; have ->: Byte.modulus = 256%Z by []; move => [Hlo Hhi]. split.
  apply Z.log2_nonneg. have {}Hhi: z <= 255 by lia.
  apply Z.log2_le_mono in Hhi. by move: Hhi; have->: Z.log2 255 = 7 by [].
Qed.

Lemma Byte_unsigned_nonneg: forall b,
  0 <= Byte.unsigned b.
Proof.
  move => b. pose proof (Byte.unsigned_range_2 b); lia.
Qed.

(*Fold tactics don't work great*)
Lemma byte_testbit_fold: forall b i,
  Z.testbit (Byte.unsigned b) i = Byte.testbit b i.
Proof.
  by [].
Qed.

Lemma byte_unsigned_zero: forall b,
  Byte.unsigned b = 0%Z -> b = Byte.zero.
Proof.
  move => b. have->:0%Z = Byte.unsigned (Byte.zero) by [] => Hzero.
  by apply byte_unsigned_inj in Hzero.
Qed.

Lemma zbits_small: forall i,
  0 <= i < Byte.modulus ->
  Zbits.Zzero_ext 8 i = i.
Proof.
  move => i Hi. rewrite Zbits.Zzero_ext_mod; try rep_lia. have->: two_p 8 = 256 by [].
  rewrite Zmod_small; rep_lia.
Qed.

Lemma byte_shiftl1: forall b: byte,
  Int.signed (Int.shl (Int.repr (Byte.unsigned b)) (Int.repr 1)) =
  Z.shiftl (Byte.unsigned b) 1.
Proof.
  move => b. rewrite /Int.shl; rewrite !Int.unsigned_repr; try rep_lia.
  apply Int.signed_repr. rewrite Z.shiftl_mul_pow2; rep_lia.
Qed.

Lemma byte_shiftl1': forall b: byte,
  Int.unsigned (Int.shl (Int.repr (Byte.unsigned b)) (Int.repr 1)) =
  Z.shiftl (Byte.unsigned b) 1.
Proof.
  move => b. rewrite /Int.shl (Int.unsigned_repr 1); try rep_lia.
  rewrite (Int.unsigned_repr (Byte.unsigned b)); try rep_lia.
  apply Int.unsigned_repr. rewrite Z.shiftl_mul_pow2; rep_lia.
Qed.

(** Constants *)
Definition fec_n : Z := proj1_sig (opaque_constant 256).
Definition fec_n_eq : fec_n = 256%Z := proj2_sig (opaque_constant _).

Definition modulus : Z := proj1_sig (opaque_constant 285).
Definition modulus_eq : modulus = 285%Z := proj2_sig (opaque_constant _).

Definition fec_max_h : Z := proj1_sig (opaque_constant 128).
Definition fec_max_h_eq : fec_max_h = 128%Z := proj2_sig (opaque_constant _).

Definition fec_max_cols : Z := proj1_sig (opaque_constant 16000).
Definition fec_max_cols_eq: fec_max_cols = 16000%Z := proj2_sig(opaque_constant _).

#[export] Hint Rewrite fec_n_eq : rep_lia.
#[export] Hint Rewrite fec_max_h_eq : rep_lia.
#[export] Hint Rewrite modulus_eq : rep_lia.
#[export] Hint Rewrite fec_max_cols_eq : rep_lia.

(*The next 3 lemmas are trying to prove that, if we take 2 integers whose logs are equal and we add them,
  the log of the resulting integer is smaller. We need this for the field table correctness and VST proofs*)

(*If z2 has its last true testbit at after z2, then its log is larger*)
Lemma testbit_lt: forall m z1 z2,
  0 <= m ->
  2 <= z2 ->
  (forall n, m <= n -> Z.testbit z1 n = false) ->
  Z.testbit z2 m = true ->
  Z.log2 z1 < Z.log2 z2.
Proof.
  move => m z1 z2 Hm Hz2 Hafter Htestm.
  have [Hz1 | Hz1]: (z1 <= 0 \/ 0 < z1) by lia.
  - rewrite Z.log2_nonpos //. apply Z.log2_le_mono in Hz2. move: Hz2; rewrite /=; lia.
  - have Hmlog: m <= Z.log2 z2. have [Hmlog // | Hmlog]: (m <= Z.log2 z2 \/ Z.log2 z2 < m) by lia.
      apply Z.bits_above_log2 in Hmlog; try lia. by rewrite Hmlog in Htestm.
    have [Hz12 // | Hz12]: (Z.log2 z1 < Z.log2 z2 \/ Z.log2 z2 <= Z.log2 z1) by lia.
    have: Z.testbit z1 (Z.log2 z1) = false. apply Hafter; lia. by rewrite Z.bit_log2.
Qed.

(*This is actually not too bad to prove*)
Lemma Z_lxor_smaller: forall z1 z2,
  2 <= z1 ->
  Z.log2 z1 = Z.log2 z2 ->
  Z.log2 (Z.lxor z1 z2) < Z.log2 z1.
Proof.
  move => z1 z2 Hz1 Hlog. have Hz2: 2 <= z2. { have Hz2: 1 <= Z.log2 z2.
    rewrite -Hlog. by apply Z.log2_le_mono in Hz1. have [Hz21 | Hz21]: (z2 <= 1 \/ 2 <= z2) by lia.
    move: Hz21. rewrite -Z.log2_null. lia. by []. }
  apply (@testbit_lt (Z.log2 z1)) => [|//||].
  - apply Z.log2_nonneg.
  - move => n Hn. rewrite Z.lxor_spec. have [Hzn | Hzn]: (Z.log2 z1 = n \/ Z.log2 z1 < n) by lia.
    + subst. by rewrite {2}Hlog !Z.bit_log2; try lia.
    + by rewrite !Z.bits_above_log2; try lia.
  - apply Z.bit_log2; lia.
Qed.

(*Now, we can prove the result we want*)
Lemma xor_modulus_bound: forall (b: byte),
  2 * Byte.unsigned b >= Byte.modulus ->
  0 <= Z.lxor (2 * Byte.unsigned b) modulus < Byte.modulus.
Proof.
  move => b Hlarge. split.
  - rewrite Z.lxor_nonneg. rep_lia.
  - pose proof (byte_log2_range b) as [Hpos Hb].
    have H2b: (Z.log2 (2 * (Byte.unsigned b)) = 1 + Z.log2 (Byte.unsigned b))%Z
      by rewrite Z.log2_double; rep_lia.
    have: (Z.log2 256 <= Z.log2 (2 * Byte.unsigned b))%Z. apply Z.log2_le_mono. rep_lia.
    have->: Z.log2 256 = 8 by [] => H2b'.
    have Hlog: Z.log2 (2 * Byte.unsigned b) = 8 by lia.
    have Hmod: Z.log2 285 = 8 by [].
    have Hxor: (Z.log2 (Z.lxor (2 * Byte.unsigned b) modulus) < 8)%Z. rewrite -Hlog. apply Z_lxor_smaller; rep_lia.
    by apply Z.log2_lt_cancel.
Qed.

(*We also need some more about xor*)

Lemma byte_xor_size: forall b1 b2,
  0 <= Z.lxor (Byte.unsigned b1) (Byte.unsigned b2) <= Byte.max_unsigned.
Proof.
  intros b1 b2. split.
  - apply Z.lxor_nonneg; rep_lia.
  - pose proof (@Byte_unsigned_nonneg b1) as Hb1.
    pose proof (@Byte_unsigned_nonneg b2) as Hb2.
    pose proof (Z.log2_lxor (Byte.unsigned b1) (Byte.unsigned b2) Hb1 Hb2) as Hlog.
    assert (Hxorlog: Z.log2 (Z.lxor (Byte.unsigned b1) (Byte.unsigned b2)) <= 7). {
      apply (Z.le_trans _ _ _ Hlog). apply Z.max_lub; apply byte_log2_range. }
    assert (Hxorlt: Z.log2 (Z.lxor (Byte.unsigned b1) (Byte.unsigned b2)) < 8) by lia.
    replace 8 with (Z.log2 Byte.modulus) in Hxorlt by reflexivity.
    apply Z.log2_lt_cancel in Hxorlt. rep_lia.
Qed.

Lemma byte_xor_fold: forall b1 b2,
  (Z.lxor (Byte.unsigned b1) (Byte.unsigned b2)) = Byte.unsigned (Byte.xor b1 b2).
Proof.
  intros b1 b2. unfold Byte.xor. rewrite Byte.unsigned_repr; [ reflexivity | apply byte_xor_size].
Qed.


From iris.algebra Require Export big_op.
From Perennial.Helpers Require Import ipm.

Set Default Proof Using "Type".

Lemma wlog_assume_pure {PROP:bi} (φ: Prop) (P Q: PROP) :
  (P -∗ ⌜φ⌝) →
  (Q -∗ ⌜φ⌝) →
  (φ → P ⊣⊢ Q) →
  P ⊣⊢ Q.
Proof.
  intros HP HQ HPQ.
  iSplit.
  - iIntros "H".
    iDestruct (HP with "H") as %H.
    rewrite HPQ //.
  - iIntros "H".
    iDestruct (HQ with "H") as %H.
    rewrite HPQ //.
Qed.

Section list.
  Context {PROP : bi}.
  Implicit Types (P Q : PROP).
  Implicit Types (A : Type).

  Lemma big_sepL_drop {A} `{!BiAffine PROP} (Φ: nat → A → PROP) (m: list A) (n: nat):
    ([∗ list] k ↦ x ∈ m, Φ k x) ⊢ ([∗ list] k ↦ x ∈ drop n m, Φ (n + k) x).
  Proof.
    rewrite -{1}(take_drop n m) big_sepL_app take_length.
    iIntros "(_&H)".
    destruct (decide (length m ≤ n)).
    - rewrite drop_ge //=.
    - rewrite Nat.min_l //=; lia.
  Qed.

  Lemma big_sepL_mono_with_inv' {A} P Φ Ψ (m: list A) n :
    (∀ k x, m !! k = Some x → P ∗ Φ (k + n) x ⊢ P ∗ Ψ (k + n) x) →
    P ∗ ([∗ list] k ↦ x ∈ m, Φ (k + n) x) ⊢ P ∗ [∗ list] k ↦ x ∈ m, Ψ (k + n) x.
  Proof.
    revert n.
    induction m as [|a m] => n Hwand //=.
    - iIntros "(HP&HΦ&Hl)".
      iDestruct (Hwand 0 a with "[HP HΦ]") as "(HP&HΨ)"; eauto.
      { rewrite Nat.add_0_l. iFrame. }
      rewrite ?Nat.add_0_l.
      iFrame "HΨ".
      setoid_rewrite <-Nat.add_succ_r.
      iApply (IHm with "[$ ]"); eauto.
      intros; eauto.
      specialize (Hwand (S k)).
      rewrite Nat.add_succ_r -Nat.add_succ_l. iApply Hwand; eauto.
  Qed.

  Lemma big_sepL_mono_with_inv {A} P Φ Ψ (m: list A) :
    (∀ k x, m !! k = Some x → P ∗ Φ k x ⊢ P ∗ Ψ k x) →
    P -∗ ([∗ list] k ↦ x ∈ m, Φ k x) -∗ P ∗ [∗ list] k ↦ x ∈ m, Ψ k x.
  Proof.
    iIntros (?) "HP H".
    iPoseProof (big_sepL_mono_with_inv' P Φ Ψ _ O with "[HP H]") as "H";
    setoid_rewrite Nat.add_0_r; eauto; iFrame.
  Qed.

Section list2.
  Context {A B : Type}.
  Implicit Types Φ Ψ : nat → A → B → PROP.

  Lemma big_sepL2_const_sepL_l (Φ : nat → A → PROP) (l1 : list A) (l2 : list B) :
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1) ⊣⊢ ⌜length l1 = length l2⌝ ∧ ([∗ list] k↦y1 ∈ l1, Φ k y1).
  Proof.
    rewrite big_sepL2_alt.
    trans (⌜length l1 = length l2⌝ ∧ [∗ list] k↦y1 ∈ (zip l1 l2).*1, Φ k y1)%I.
    - rewrite big_sepL_fmap //.
    - apply (anti_symm (⊢)); apply bi.pure_elim_l=> Hl; rewrite fst_zip;
      try (rewrite Hl //);
      (apply bi.and_intro; [by apply bi.pure_intro|done]).
  Qed.

  Lemma big_sepL2_const_sepL_r (Φ : nat → B → PROP) (l1 : list A) (l2 : list B) :
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y2) ⊣⊢ ⌜length l1 = length l2⌝ ∧ ([∗ list] k↦y2 ∈ l2, Φ k y2).
  Proof.
    rewrite big_sepL2_alt.
    trans (⌜length l1 = length l2⌝ ∧ [∗ list] k↦y2 ∈ (zip l1 l2).*2, Φ k y2)%I.
    - rewrite big_sepL_fmap //.
    - apply (anti_symm (⊢)); apply bi.pure_elim_l=> Hl; rewrite snd_zip;
      try (rewrite Hl //);
      (apply bi.and_intro; [by apply bi.pure_intro|done]).
  Qed.

  Lemma big_sepL2_sep_sepL_l (Φ : nat → A → PROP) Ψ l1 l2 :
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 ∗ Ψ k y1 y2)
    ⊣⊢ ([∗ list] k↦y1 ∈ l1, Φ k y1) ∗ ([∗ list] k↦y1;y2 ∈ l1;l2, Ψ k y1 y2).
  Proof.
    rewrite big_sepL2_sep big_sepL2_const_sepL_l. apply (anti_symm _).
    - rewrite bi.and_elim_r. done.
    - rewrite !big_sepL2_alt [(_ ∗ _)%I]comm -!bi.persistent_and_sep_assoc.
      apply bi.pure_elim_l=>Hl. apply bi.and_intro.
      { apply bi.pure_intro. done. }
      rewrite [(_ ∗ _)%I]comm. apply bi.sep_mono; first done.
      apply bi.and_intro; last done.
      apply bi.pure_intro. done.
  Qed.

  Lemma big_sepL2_sep_sepL_r Φ (Ψ : nat → B → PROP) l1 l2 :
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2 ∗ Ψ k y2)
    ⊣⊢ ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) ∗ ([∗ list] k↦y2 ∈ l2, Ψ k y2).
  Proof.
    rewrite big_sepL2_sep big_sepL2_const_sepL_r. apply (anti_symm _).
    - rewrite bi.and_elim_r. done.
    - rewrite !big_sepL2_alt -!bi.persistent_and_sep_assoc.
      apply bi.pure_elim_l=>Hl. apply bi.and_intro.
      { apply bi.pure_intro. done. }
      apply bi.sep_mono; first done.
      apply bi.and_intro; last done.
      apply bi.pure_intro. done.
  Qed.

  Lemma big_sepL2_elim_big_sepL_aux `{!BiAffine PROP} {C} (P: nat → C → PROP) Φ (l1: list A) (l2: list B) (l: list C) n:
    length l = length l1 →
    □ (∀ k x y z, ⌜ l1 !! k = Some x ⌝ -∗
                  ⌜ l2 !! k = Some y ⌝ -∗
                  ⌜ l !! k = Some z ⌝ -∗ Φ (k + n) x y -∗ P (k + n) z) -∗
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ (k + n) y1 y2) -∗
    ([∗ list] k↦z ∈ l, P (k + n) z).
  Proof.
    intros Hlen1.  rewrite big_sepL2_alt.
    iIntros "#Halways (H&Hzip)". iDestruct "H" as %Hlen2.
    iInduction l as [|c l] "IH" forall (l1 l2 Hlen1 Hlen2 n);
    rewrite //=; destruct l1; destruct l2; simpl in Hlen1, Hlen2; try congruence; eauto.

    simpl. iDestruct "Hzip" as "(H&Hrest)".
    iDestruct ("Halways" $! 0 with "[] [] [] [H]") as "HP".
    { iPureIntro. simpl; eauto. }
    { iPureIntro. simpl; eauto. }
    { iPureIntro. simpl; eauto. }
    { rewrite Nat.add_0_l. iFrame. }
    rewrite Nat.add_0_l. iFrame.
    setoid_rewrite <-Nat.add_succ_r.
    unshelve (iSpecialize ("IH" $! l1 l2 _ _ (S n))); eauto.
    iApply "IH"; eauto.
    iModIntro. iIntros (???? ???) "HΦ".
    setoid_rewrite Nat.add_succ_r.
    setoid_rewrite <-Nat.add_succ_l.
    iApply ("Halways" with "[] [] [] [$]"); eauto.
  Qed.

  Lemma big_sepL2_elim_big_sepL `{!BiAffine PROP} {C} (P: nat → C → PROP) Φ (l1: list A) (l2: list B) (l: list C):
    length l = length l1 →
    □ (∀ k x y z, ⌜ l1 !! k = Some x ⌝ -∗
                  ⌜ l2 !! k = Some y ⌝ -∗
                  ⌜ l !! k = Some z ⌝ -∗ Φ k x y -∗ P k z) -∗
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) -∗
    ([∗ list] k↦z ∈ l, P k z).
  Proof.
    iIntros (?) "H1 H2". iPoseProof (big_sepL2_elim_big_sepL_aux P Φ l1 l2 l O) as "H"; auto.
    setoid_rewrite Nat.add_0_r; eauto.
    iApply ("H" with "H1 H2"); eauto.
  Qed.

  Local Lemma big_sepL2_to_sepL_aux Φ n l1 l2 :
    length l1 = length l2 →
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ (n+k) y1 y2) ⊣⊢
    ([∗ list] k↦y1 ∈ l1, ∃ y2, ⌜l2 !! k = Some y2⌝ ∧ Φ (n+k) y1 y2).
  Proof.
    intros Hlen.
    (iInduction l1 as [|y1 l1] "IH" forall (n l2 Hlen)).
    - assert (l2 = []); subst; simpl.
      { apply length_zero_iff_nil; auto. }
      auto.
    - destruct l2 as [|y2 l2].
      { simpl in Hlen; congruence. }
      inversion Hlen; subst; clear Hlen.
      iSpecialize ("IH" $! (S n) l2 with "[% //]").
      rewrite big_sepL2_cons big_sepL_cons /=.
      assert (forall k, n + S k = S (n + k)) as Harith by lia.
      setoid_rewrite Harith.
      iSplit.
      + iIntros "[HΦ Hl]".
        iSplitL "HΦ"; first by eauto with iFrame.
        iApply ("IH" with "Hl").
      + iIntros "[HΦ Hl]".
        iDestruct "HΦ" as (y) "[%Heq HΦ]".
        inversion Heq; subst; iFrame.
        iApply ("IH" with "Hl").
  Qed.

  Lemma big_sepL2_to_sepL_1 Φ l1 l2 :
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) -∗
    ([∗ list] k↦y1 ∈ l1, ∃ y2, ⌜l2 !! k = Some y2⌝ ∧ Φ k y1 y2).
  Proof.
    iIntros "H".
    iDestruct (big_sepL2_length with "H") as %Hlen.
    iApply (big_sepL2_to_sepL_aux Φ 0 with "H"); auto.
  Qed.

  Lemma big_sepL2_to_sepL_2 (Φ: nat → B → A → PROP) l1 l2 :
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) -∗
    ([∗ list] k↦y2 ∈ l2, ∃ y1, ⌜l1 !! k = Some y1⌝ ∧ Φ k y1 y2).
  Proof. rewrite big_sepL2_flip big_sepL2_to_sepL_1 //. Qed.

  (* expressed as an equivalence, but needs a separate length assumption (to
  strengthen the right-hand side) *)
  Lemma big_sepL2_to_sepL_1' Φ l1 l2 :
    length l1 = length l2 →
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) ⊣⊢
    ([∗ list] k↦y1 ∈ l1, ∃ y2, ⌜l2 !! k = Some y2⌝ ∧ Φ k y1 y2).
  Proof.
    apply (big_sepL2_to_sepL_aux Φ 0).
  Qed.

  Lemma big_sepL2_to_sepL_2' (Φ: nat → B → A → PROP) l1 l2 :
    length l1 = length l2 →
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) ⊣⊢
    ([∗ list] k↦y2 ∈ l2, ∃ y1, ⌜l1 !! k = Some y1⌝ ∧ Φ k y1 y2).
  Proof. intros. rewrite big_sepL2_flip big_sepL2_to_sepL_1' //. Qed.

  Lemma big_sepL2_lookup_1_some
      Φ (l1 : list A) (l2 : list B) (i : nat) (x1 : A) :
    l1 !! i = Some x1 ->
      ⊢ ( [∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2 ) -∗
          ⌜∃ x2, l2 !! i = Some x2⌝.
  Proof.
    intros.
    iIntros "H".
    apply lookup_lt_Some in H as Hlen.
    iDestruct (big_sepL2_length with "H") as %Hslen.
    rewrite Hslen in Hlen.
    apply lookup_lt_is_Some_2 in Hlen.
    destruct Hlen.
    eauto.
  Qed.

  Lemma big_sepL2_lookup_2_some
      Φ (l1 : list A) (l2 : list B) (i : nat) (x2 : B) :
    l2 !! i = Some x2 ->
      ⊢ ( [∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2 ) -∗
          ⌜∃ x1, l1 !! i = Some x1⌝.
  Proof.
    intros.
    iIntros "H".
    apply lookup_lt_Some in H as Hlen.
    iDestruct (big_sepL2_length with "H") as %Hslen.
    rewrite -Hslen in Hlen.
    apply lookup_lt_is_Some_2 in Hlen.
    destruct Hlen.
    eauto.
  Qed.

  Lemma big_sepL2_lookup_1_none
      Φ (l1 : list A) (l2 : list B) (i : nat) :
    l1 !! i = None ->
      ⊢ ( [∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2 ) -∗
          ⌜l2 !! i = None⌝.
  Proof.
    intros.
    iIntros "H".
    apply lookup_ge_None in H as Hlen.
    iDestruct (big_sepL2_length with "H") as %Hslen.
    rewrite Hslen in Hlen.
    apply lookup_ge_None in Hlen.
    eauto.
  Qed.

  Lemma big_sepL2_lookup_2_none
      Φ (l1 : list A) (l2 : list B) (i : nat) :
    l2 !! i = None ->
    ([∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2) -∗
    ⌜l1 !! i = None⌝.
  Proof.
    iIntros (?) "H".
    apply lookup_ge_None in H as Hlen.
    iDestruct (big_sepL2_length with "H") as %Hslen.
    rewrite -Hslen in Hlen.
    apply lookup_ge_None in Hlen.
    eauto.
  Qed.

  Local Lemma big_sepL_exists_list_aux n Φ l :
    ([∗ list] i↦a ∈ l, ∃ x, Φ (n+i) a x) -∗
    ∃ xs, ⌜length xs = length l⌝ ∧
                    ([∗ list] i ↦ a ∈ l, ∃ x, ⌜xs !! i = Some x⌝ ∧ Φ (n+i) a x).
  Proof.
    iInduction l as [|a l] "IH" forall (n).
    - simpl.
      iIntros "H".
      iExists [].
      eauto.
    - simpl.
      iIntros "[HΦ Hl]".
      iDestruct "HΦ" as (x) "HΦ".
      assert (∀ k, n + S k = S n + k) as Harith by lia.
      setoid_rewrite Harith.
      iDestruct ("IH" with "Hl") as (xs) "Hl".
      iDestruct "Hl" as "[%Hlen Hl]".
      iExists (x::xs); simpl; eauto 10 with iFrame.
  Qed.

  Lemma big_sepL_exists_list Φ l :
    ([∗ list] i↦a ∈ l, ∃ x, Φ i a x) -∗
    ∃ xs, ⌜length xs = length l⌝ ∧
                    ([∗ list] i ↦ a ∈ l, ∃ x, ⌜xs !! i = Some x⌝ ∧ Φ i a x).
  Proof.
    apply (big_sepL_exists_list_aux 0 Φ).
  Qed.

  Lemma big_sepL_exists_to_sepL2 Φ l :
    ([∗ list] i↦a ∈ l, ∃ x, Φ i a x) -∗
    ∃ xs, [∗ list] i ↦ a;x ∈ l;xs, Φ i a x.
  Proof.
    iIntros "H".
    iDestruct (big_sepL_exists_list with "H") as (xs Hlen) "H".
    iExists xs. iApply big_sepL2_to_sepL_1'; done.
  Qed.

  Lemma big_sepL2_app_equiv Φ l1 l2 l1' l2' :
    length l1 = length l1' →
    ([∗ list] k↦y1;y2 ∈ l1; l1', Φ k y1 y2) ∗
    ([∗ list] k↦y1;y2 ∈ l2; l2', Φ (length l1 + k) y1 y2) ⊣⊢
    ([∗ list] k↦y1;y2 ∈ l1 ++ l2; l1' ++ l2', Φ k y1 y2).
  Proof.
    intros.
    iSplit.
    - iIntros "[H1 H2]".
      iApply (big_sepL2_app with "H1 H2").
    - iIntros "H".
      iDestruct (big_sepL2_app_inv with "H") as "[$ $]"; auto.
  Qed.

  (* this is a general theorem but we use Φ and Φc to suggest that Φc is the
  weaker crash condition for each element in the big_sepL2 *)
  Theorem big_sepL2_lookup_acc_and Φ Φc l1 l2 i x1 x2 :
    (* this is a pure assumption (instead of a persistent implication) because
    that's how big_sepL2_mono is written *)
    (∀ k y1 y2, l1 !! k = Some y1 → l2 !! k = Some y2 → Φ k y1 y2 -∗ Φc k y1 y2) →
    l1 !! i = Some x1 →
    l2 !! i = Some x2 →
    big_sepL2 Φ l1 l2 -∗
    Φ i x1 x2 ∗ ((Φ i x1 x2 -∗ big_sepL2 Φ l1 l2) ∧ (Φc i x1 x2 -∗ big_sepL2 Φc l1 l2)).
  Proof.
    iIntros (Himpl Hx1 Hx2) "H".
    rewrite big_sepL2_delete; eauto.
    iDestruct "H" as "[HΦ Hl]"; iFrame.
    iSplit.
    - iIntros "$"; iFrame.
    - iIntros "HΦ".
      iApply (big_sepL2_delete Φc); eauto.
      iFrame.
      iApply (big_sepL2_mono with "Hl").
      intros; simpl.
      destruct (decide (k = i)); eauto.
  Qed.

  Theorem big_sepL2_fupd `{!BiFUpd PROP} {E} Φ l1 l2 :
    ([∗ list] k↦y1;y2 ∈ l1; l2, |={E}=> Φ k y1 y2) -∗
    |={E}=> [∗ list] k↦y1;y2 ∈ l1;l2, Φ k y1 y2.
  Proof.
    iIntros "H".
    iDestruct (big_sepL2_length with "H") as %Hlen.
    rewrite !big_sepL2_to_sepL_1'; auto.
    iApply big_sepL_fupd.
    iApply (big_sepL_mono with "H").
    iIntros (???) "H".
    iDestruct "H" as (y2) "[% H]".
    iMod "H".
    eauto with iFrame.
  Qed.

  Theorem big_sepL2_prefix `{!BiAffine PROP} (Φ : A → B → PROP) l1 l2 l1' l2' :
    l1' `prefix_of` l1 →
    l2' `prefix_of` l2 →
    length l1' = length l2' →
    ([∗ list] y1;y2 ∈ l1; l2, Φ y1 y2) -∗
    ([∗ list] y1;y2 ∈ l1'; l2', Φ y1 y2).
  Proof.
    iIntros (Hpre1 Hpre2 Hlen) "H".
    destruct Hpre1 as (l1_rest & ->).
    destruct Hpre2 as (l2_rest & ->).
    iDestruct (big_sepL2_app_equiv with "H") as "($&_)"; eauto.
  Qed.

End list2.

End list.

Section list.
  Context {PROP : bi}.
  Implicit Types (P Q : PROP).
  Implicit Types (A : Type).

  Lemma big_sepL_mono_with_fupd_inv' {A} `{!BiFUpd PROP} E P Φ Ψ (m: list A) n :
    (∀ k x, m !! k = Some x → P ∗ Φ (k + n) x ={E}=∗ P ∗ Ψ (k + n) x) →
    P ∗ ([∗ list] k ↦ x ∈ m, Φ (k + n) x) ={E}=∗ P ∗ [∗ list] k ↦ x ∈ m, Ψ (k + n) x.
  Proof.
    revert n.
    induction m as [|a m] => n Hwand //=.
    - by iIntros "($&_)".
    - iIntros "(HP&HΦ&Hl)".
      iMod (Hwand 0 a with "[HP HΦ]") as "(HP&HΨ)"; eauto.
      { rewrite Nat.add_0_l. iFrame. }
      rewrite ?Nat.add_0_l.
      iFrame "HΨ".
      setoid_rewrite <-Nat.add_succ_r.
      iApply (IHm with "[$ ]"); eauto.
      intros; eauto.
      specialize (Hwand (S k)).
      rewrite Nat.add_succ_r -Nat.add_succ_l. iApply Hwand; eauto.
  Qed.

  Lemma big_sepL_mono_with_fupd_inv {A} `{!BiFUpd PROP} E P Φ Ψ (m: list A) :
    (∀ k x, m !! k = Some x → P ∗ Φ k x ={E}=∗ P ∗ Ψ k x) →
    P -∗ ([∗ list] k ↦ x ∈ m, Φ k x) ={E}=∗ P ∗ [∗ list] k ↦ x ∈ m, Ψ k x.
  Proof.
    iIntros (?) "HP H".
    iPoseProof (big_sepL_mono_with_fupd_inv' E P Φ Ψ _ O with "[HP H]") as "H";
    setoid_rewrite Nat.add_0_r; eauto; iFrame.
  Qed.
End list.

Section list2.
  Context {A B : Type}.
  Context {PROP : bi}.
  Implicit Types Φ Ψ : nat → A → B → PROP.

  Lemma big_sepL2_mono_with_fupd_inv E (P: PROP) `{!BiAffine PROP, !BiFUpd PROP} (Φ Ψ: nat → A → B → PROP) l1 l2:
    (∀ k x y, l1 !! k = Some x → l2 !! k = Some y → P ∗ Φ k x y ={E}=∗ P ∗ Ψ k x y) →
    P -∗ ([∗ list] k ↦ x;y ∈ l1;l2, Φ k x y) ={E}=∗ P ∗ [∗ list] k ↦ x;y ∈ l1;l2, Ψ k x y.
  Proof.
    iIntros (Himpl) "HP".
    rewrite ?big_sepL2_alt.
    iIntros "(%&Hwand)".
    iPoseProof (big_sepL_mono_with_fupd_inv E P (λ k ab, Φ k (fst ab) (snd ab))
                                      (λ k ab, Ψ k (fst ab) (snd ab)) with "HP Hwand") as "H".
    { intros k x Hlookup. eapply Himpl; eauto.
      - rewrite -(fst_zip l1 l2); last lia.
        rewrite list_lookup_fmap Hlookup //=.
      - rewrite -(snd_zip l1 l2); last lia.
        rewrite list_lookup_fmap Hlookup //=.
    }
    iMod "H" as "($&$)". eauto.
  Qed.

  Lemma big_sepL2_mono_with_inv (P: PROP) `{!BiAffine PROP} (Φ Ψ: nat → A → B → PROP) l1 l2:
    (∀ k x y, l1 !! k = Some x → l2 !! k = Some y → P ∗ Φ k x y ⊢ P ∗ Ψ k x y) →
    P -∗ ([∗ list] k ↦ x;y ∈ l1;l2, Φ k x y) -∗ P ∗ [∗ list] k ↦ x;y ∈ l1;l2, Ψ k x y.
  Proof.
    iIntros (Himpl) "HP".
    rewrite ?big_sepL2_alt.
    iIntros "(%&Hwand)".
    iPoseProof (big_sepL_mono_with_inv P (λ k ab, Φ k (fst ab) (snd ab))
                                      (λ k ab, Ψ k (fst ab) (snd ab)) with "HP Hwand") as "H".
    { intros k x Hlookup. eapply Himpl; eauto.
      - rewrite -(fst_zip l1 l2); last lia.
        rewrite list_lookup_fmap Hlookup //=.
      - rewrite -(snd_zip l1 l2); last lia.
        rewrite list_lookup_fmap Hlookup //=.
    }
    iDestruct "H" as "($&$)". eauto.
  Qed.
End list2.


(*
Copyright © 2020 Vincent Semeria

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software 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 Software.

THE SOFTWARE 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 SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*)

(*
  The uniformly continuous functions R -> R.
 *)

Require Import List Permutation Orders Sorted Mergesort.
Require Import QArith Qpower.
Require Import ConstructiveReals.
Require Import ConstructiveAbs.
Require Import ConstructiveMinMax.
Require Import ConstructiveSum.
Require Import ConstructivePower.
Require Import ConstructiveLimits.
Require Import ConstructiveDiagonal.

Local Open Scope ConstructiveReals.

Definition UniformCont {R : ConstructiveReals}
           (f : CRcarrier R -> CRcarrier R)
           (cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R) : Set
  := prod (forall (x:CRcarrier R) (xPos : 0 < x), 0 < cont_mod x xPos) (* otherwise any function is trivially continuous *)
      (forall (eps x y : CRcarrier R) (epsPos : 0 < eps),
           CRabs _ (x - y) < cont_mod eps epsPos
           -> CRabs _ (f x - f y) < eps).

Definition Lipschitz {R : ConstructiveReals}
           (f : CRcarrier R -> CRcarrier R) (k : CRcarrier R) : Set
  := forall (x y : CRcarrier R),
    CRabs _ (f x - f y) <= k * CRabs _ (x - y).

Lemma UniformContProper :
  forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
    (cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    UniformCont f cont_mod
    -> (forall x y : CRcarrier R, x == y -> f x == f y).
Proof.
  intros. destruct H. split.
  - intro abs.
    assert (0 < f y - f x) as epsPos.
    { rewrite <- (CRplus_opp_r (f x)).
      apply CRplus_lt_compat_r. exact abs. }
    specialize (c0 (f y - f x) x y epsPos).
    apply (CRle_abs (f y - f x)).
    rewrite CRabs_minus_sym. apply c0.
    apply (CRle_lt_trans _ (CRabs _ 0)).
    rewrite H0. unfold CRminus. rewrite CRplus_opp_r.
    apply CRle_refl. rewrite CRabs_right. apply c.
    apply CRle_refl.
  - intro abs.
    assert (0 < f x - f y) as epsPos.
    { rewrite <- (CRplus_opp_r (f y)).
      apply CRplus_lt_compat_r. exact abs. }
    specialize (c0 (f x - f y) x y epsPos).
    apply (CRle_abs (f x - f y)).
    apply c0. apply (CRle_lt_trans _ (CRabs _ 0)).
    rewrite H0. unfold CRminus. rewrite CRplus_opp_r.
    apply CRle_refl. rewrite CRabs_right. apply c.
    apply CRle_refl.
Qed.

Lemma LipschitzUC
  : forall {R : ConstructiveReals}
      (f : CRcarrier R -> CRcarrier R)
      (k : CRcarrier R) (kPos : 0 < k),
    Lipschitz f k
    -> UniformCont f (fun eps epsPos => eps * CRinv R k (inr kPos)).
Proof.
  split.
  - intros eps epsPos.
    apply (CRle_lt_trans _ (eps * 0)). rewrite CRmult_0_r.
    apply CRle_refl. apply CRmult_lt_compat_l. exact epsPos.
    apply CRinv_0_lt_compat, kPos.
  - intros. apply (CRle_lt_trans _ _ _ (H x y)).
    apply (CRmult_lt_compat_r k) in H0.
    rewrite CRmult_assoc, CRinv_l, CRmult_1_r in H0.
    rewrite CRmult_comm. exact H0. exact kPos.
Qed.

(* Compact support and uniformly continuous.
   On R we simplify this by segment support and uniformly continuous. *)
Definition CSUC {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
           (a b : CRcarrier R) (cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R) : Set
  := prod (UniformCont f cont_mod)
     (forall x : CRcarrier R, (sum (x < a) (b < x)) -> f x == 0).

Lemma CSUC_connect_support
  : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
      (a b : CRcarrier R) (cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    CSUC f a b cont_mod
    -> (forall x : CRcarrier R, (sum (x <= a) (b <= x)) -> f x == 0).
Proof.
  intros. destruct H, u. split.
  - intro abs. destruct H0.
    + apply CRopp_gt_lt_contravar in abs. rewrite CRopp_0 in abs.
      specialize (c1 (-f x) (x - (cont_mod (-f x) abs) * CR_of_Q R (1#2)) x abs).
      apply (CRle_abs (-f x)).
      apply (CRle_lt_trans
               _ (CRabs _ (f (x - cont_mod (- f x) abs * CR_of_Q R (1 # 2)) - f x))).
      rewrite (c (x - cont_mod (-f x) abs * CR_of_Q R (1#2))).
      unfold CRminus. rewrite CRplus_0_l. apply CRle_refl.
      left. apply (CRlt_le_trans _ (x + 0)).
      apply CRplus_lt_compat_l. rewrite <- CRopp_0. apply CRopp_gt_lt_contravar.
      apply CRmult_lt_0_compat. apply c0.
      apply CR_of_Q_pos; reflexivity.
      rewrite CRplus_0_r. exact c2. apply c1.
      setoid_replace (x + - (cont_mod (-f x) abs * CR_of_Q R (1#2)) + - x)
        with (- (cont_mod (-f x) abs * CR_of_Q R (1#2))).
      rewrite CRabs_opp. rewrite CRabs_right.
      rewrite <- (CRmult_1_r (cont_mod (- f x) abs)).
      rewrite CRmult_assoc. apply CRmult_lt_compat_l. apply c0.
      rewrite CRmult_1_l. apply CR_of_Q_lt; reflexivity.
      apply CRlt_asym.
      apply CRmult_lt_0_compat. apply c0.
      apply CR_of_Q_pos; reflexivity.
      rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l.
      reflexivity.
    + apply CRopp_gt_lt_contravar in abs. rewrite CRopp_0 in abs.
      specialize (c1 (-f x) (x + (cont_mod (-f x) abs) * CR_of_Q R (1#2)) x abs).
      apply (CRle_abs (-f x)).
      apply (CRle_lt_trans
               _ (CRabs _ (f (x + cont_mod (- f x) abs * CR_of_Q R (1 # 2)) - f x))).
      rewrite (c (x + cont_mod (-f x) abs * CR_of_Q R (1#2))).
      unfold CRminus. rewrite CRplus_0_l. apply CRle_refl.
      right. apply (CRle_lt_trans _ (x + 0)).
      rewrite CRplus_0_r. exact c2. apply CRplus_lt_compat_l.
      apply CRmult_lt_0_compat. apply c0.
      apply CR_of_Q_pos; reflexivity.
      apply c1.
      setoid_replace (x + (cont_mod (-f x) abs * CR_of_Q R (1#2)) + - x)
        with (cont_mod (-f x) abs * CR_of_Q R (1#2)).
      rewrite CRabs_right. rewrite <- (CRmult_1_r (cont_mod (- f x) abs)).
      rewrite CRmult_assoc. apply CRmult_lt_compat_l. apply c0.
      rewrite CRmult_1_l.
      apply CR_of_Q_lt; reflexivity.
      apply CRlt_asym.
      apply CRmult_lt_0_compat. apply c0.
      apply CR_of_Q_pos; reflexivity.
      rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l.
      reflexivity.
  - intro abs. destruct H0.
    + specialize (c1 (f x) (x - (cont_mod (f x) abs) * CR_of_Q R (1#2)) x abs).
      apply (CRle_abs (f x)).
      apply (CRle_lt_trans
               _ (CRabs _ (f (x - cont_mod (f x) abs * CR_of_Q R (1 # 2)) - f x))).
      rewrite (c (x - cont_mod (f x) abs * CR_of_Q R (1#2))).
      unfold CRminus. rewrite CRplus_0_l, CRabs_opp.
      apply CRle_refl. left. apply (CRlt_le_trans _ (x + 0)).
      apply CRplus_lt_compat_l. rewrite <- CRopp_0. apply CRopp_gt_lt_contravar.
      apply CRmult_lt_0_compat. apply c0.
      apply CR_of_Q_pos; reflexivity.
      rewrite CRplus_0_r. exact c2. apply c1.
      setoid_replace (x + - (cont_mod (f x) abs * CR_of_Q R (1#2)) + - x)
        with (- (cont_mod (f x) abs * CR_of_Q R (1#2))).
      rewrite CRabs_opp. rewrite CRabs_right.
      rewrite <- (CRmult_1_r (cont_mod (f x) abs)).
      rewrite CRmult_assoc. apply CRmult_lt_compat_l. apply c0.
      rewrite CRmult_1_l. apply CR_of_Q_lt; reflexivity.
      apply CRlt_asym.
      apply CRmult_lt_0_compat. apply c0.
      apply CR_of_Q_pos; reflexivity.
      rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l.
      reflexivity.
    + specialize (c1 (f x) (x + (cont_mod (f x) abs) * CR_of_Q R (1#2)) x abs).
      apply (CRle_abs (f x)).
      apply (CRle_lt_trans
               _ (CRabs _ (f (x + cont_mod (f x) abs * CR_of_Q R (1 # 2)) - f x))).
      rewrite (c (x + cont_mod (f x) abs * CR_of_Q R (1#2))).
      unfold CRminus. rewrite CRplus_0_l, CRabs_opp.
      apply CRle_refl. right. apply (CRle_lt_trans _ (x + 0)).
      rewrite CRplus_0_r. exact c2. apply CRplus_lt_compat_l.
      apply CRmult_lt_0_compat. apply c0.
      apply CR_of_Q_pos; reflexivity.
      apply c1.
      setoid_replace (x + (cont_mod (f x) abs * CR_of_Q R (1#2)) + - x)
        with (cont_mod (f x) abs * CR_of_Q R (1#2)).
      rewrite CRabs_right. rewrite <- (CRmult_1_r (cont_mod (f x) abs)).
      rewrite CRmult_assoc. apply CRmult_lt_compat_l. apply c0.
      rewrite CRmult_1_l. apply CR_of_Q_lt; reflexivity.
      apply CRlt_asym.
      apply CRmult_lt_0_compat. apply c0.
      apply CR_of_Q_pos; reflexivity.
      rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l.
      reflexivity.
Qed.

Lemma UC_constant : forall {R : ConstructiveReals} (c : CRcarrier R),
    UniformCont (fun _:CRcarrier R => c) (fun _ _ => 1).
Proof.
  split. intros. apply CRzero_lt_one.
  intros. unfold CRminus.
  rewrite CRplus_opp_r, CRabs_right.
  exact epsPos. apply CRle_refl.
Qed.

Lemma eps2_Rgt_R0 : forall {R : ConstructiveReals} (eps : CRcarrier R),
    0 < eps -> 0 < eps * CR_of_Q R (1#2).
Proof.
  intros.
  apply CRmult_lt_0_compat. apply H.
  apply CR_of_Q_pos; reflexivity.
Qed.

Lemma UC_plus : forall {R : ConstructiveReals} (f g : CRcarrier R -> CRcarrier R)
                  (modF modG : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    UniformCont f modF
    -> UniformCont g modG
    -> UniformCont (fun x:CRcarrier R => f x + g x)
                  (fun eps epsPos => CRmin (modF (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos))
                                       (modG (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos))).
Proof.
  split.
  - intros. apply CRmin_lt. destruct H. apply c.
    destruct H0. apply c.
  - intros.
    setoid_replace (f x + g x - (f y + g y))
      with (f x - f y + (g x - g y)).
    apply (CRle_lt_trans _ _ _ (CRabs_triang _ _)).
    setoid_replace eps with (eps* CR_of_Q R (1#2) + eps* CR_of_Q R (1#2)).
    apply CRplus_le_lt_compat. apply CRlt_asym.
    destruct H.
    apply (c0 _ _ _ (eps2_Rgt_R0 eps epsPos)).
    apply (CRlt_le_trans
             _ (CRmin (modF (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos))
                      (modG (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos)))).
    apply H1. apply CRmin_l.
    destruct H0. apply (c0 _ _ _ (eps2_Rgt_R0 eps epsPos)).
    apply (CRlt_le_trans
             _ (CRmin (modF (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos))
                      (modG (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos)))).
    apply H1. apply CRmin_r.
    rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus.
    setoid_replace ((1 # 2) + (1#2))%Q with 1%Q.
    rewrite CRmult_1_r.
    reflexivity. reflexivity.
    unfold CRminus. do 2 rewrite CRplus_assoc. apply CRplus_morph.
    reflexivity. rewrite CRplus_comm, CRopp_plus_distr.
    rewrite CRplus_assoc. apply CRplus_morph. reflexivity.
    rewrite CRplus_comm. reflexivity.
Qed.

Fixpoint UC_sum {R : ConstructiveReals} (fn : nat -> CRcarrier R -> CRcarrier R)
         (fnMod : nat -> forall x:CRcarrier R, 0 < x -> CRcarrier R)
         (fnCont : forall n:nat, UniformCont (fn n) (fnMod n))
         (n : nat)
  : { sMod : forall x:CRcarrier R, 0 < x -> CRcarrier R
    & UniformCont (fun x:CRcarrier R => CRsum (fun i => fn i x) n) sMod }.
Proof.
  destruct n.
  - exists (fnMod O). apply fnCont.
  - destruct (UC_sum R fn fnMod fnCont n) as [sMod sCont].
    exists (fun eps epsPos => CRmin (sMod (eps* CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos))
                            (fnMod (S n) (eps* CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos))).
    simpl. apply UC_plus. apply sCont. apply fnCont.
Qed.

Lemma UC_translate : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
                       (a : CRcarrier R)
                       (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    UniformCont f modF
    -> UniformCont (fun x:CRcarrier R => f x + a) modF.
Proof.
  split. apply H. intros.
  setoid_replace (f x + a - (f y + a)) with (f x - f y).
  destruct H. apply (c0 _ _ _ epsPos). apply H0.
  unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph.
  reflexivity.
  rewrite CRplus_comm, CRopp_plus_distr.
  rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity.
Qed.

Lemma UC_translate_horizontal
  : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
      (a : CRcarrier R)
      (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    UniformCont f modF
    -> UniformCont (fun x:CRcarrier R => f (x + a)) modF.
Proof.
  split. apply H. intros.
  destruct H. apply (c0 _ _ _ epsPos).
  setoid_replace (x + a - (y + a)) with (x-y).
  apply H0.
  unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph.
  reflexivity.
  rewrite CRplus_comm, CRopp_plus_distr.
  rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity.
Qed.

Lemma UC_modExt : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
                    (modF modG : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    UniformCont f modF
    -> (forall x xPos, modF x xPos == modG x xPos)
    -> UniformCont f modG.
Proof.
  split.
  - intros. rewrite <- H0. destruct H. apply c.
  - intros. rewrite <- H0 in H1. destruct H.
    apply (c0 _ _ _ epsPos). apply H1.
Qed.

Lemma UC_ext : forall {R : ConstructiveReals} (f g : CRcarrier R -> CRcarrier R)
                 (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    UniformCont f modF
    -> (forall x:CRcarrier R, f x == g x)
    -> UniformCont g modF.
Proof.
  intros. destruct H. split.
  - apply c.
  - intros. do 2 rewrite <- H0. exact (c0 eps x y epsPos H).
Qed.

Lemma posScale : forall {R : ConstructiveReals} (a : CRcarrier R),
    0 < CRmax 1 (CRabs _ a).
Proof.
  intros. apply (CRlt_le_trans 0 1).
  apply CRzero_lt_one. apply CRmax_l.
Qed.

Lemma UC_scale : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
                   (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R)
                   (a : CRcarrier R),
    UniformCont f modF
    -> UniformCont
        (fun x:CRcarrier R => a * f x)
        (fun (eps:CRcarrier R) epsPos => modF (eps * (CRinv R (CRmax 1 (CRabs _ a)) (inr (posScale a))))
                                     (CRmult_lt_0_compat _
                                        eps _ epsPos (CRinv_0_lt_compat _
                                                        _ (inr (posScale a)) (posScale a)))).
Proof.
  split.
  - intros x xPos. destruct H. apply c.
  - intros. unfold CRminus.
    rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l.
    rewrite CRabs_mult.
    apply (CRle_lt_trans
             _ (CRmax 1 (CRabs _ a) * CRabs _ (f x - f y))).
    apply CRmult_le_compat_r. apply CRabs_pos. apply CRmax_r.
    destruct H. specialize (c0 _ _ _ _ H0).
    apply (CRmult_lt_compat_r (CRmax 1 (CRabs _ a))) in c0.
    rewrite CRmult_assoc, CRinv_l, CRmult_1_r in c0.
    rewrite CRmult_comm. exact c0. apply posScale.
Qed.

Lemma TelescopicSum : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (n : nat),
    CRsum (fun k => un (S k) - un k) n == un (S n) - (un O).
Proof.
  induction n.
  - reflexivity.
  - simpl. rewrite IHn. rewrite CRplus_comm.
    unfold CRminus. rewrite CRplus_assoc.
    apply CRplus_morph. reflexivity.
    rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity.
Qed.

Lemma Rsum_minus : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (n : nat),
    CRsum (fun k => un k - vn k) n
    == CRsum un n - CRsum vn n.
Proof.
  induction n.
  - reflexivity.
  - simpl. rewrite IHn.
    unfold CRminus. do 2 rewrite CRplus_assoc.
    apply CRplus_morph. reflexivity. rewrite CRplus_comm.
    rewrite CRplus_assoc. apply CRplus_morph. reflexivity.
    rewrite CRplus_comm, CRopp_plus_distr. reflexivity.
Qed.

Lemma Rsmaller_interval : forall {R : ConstructiveReals} (a b c d : CRcarrier R),
    a <= c -> c <= b
    -> a <= d -> d <= b
    -> CRabs _ (d - c) <= b-a.
Proof.
  intros. apply CRabs_le. split.
  - apply (CRplus_le_reg_l (c+b)).
    unfold CRminus. rewrite CRopp_plus_distr.
    rewrite CRplus_assoc, <- (CRplus_assoc b).
    rewrite CRplus_opp_r, (CRplus_comm c b), CRplus_assoc.
    apply CRplus_le_compat. exact H0.
    rewrite CRopp_involutive, CRplus_0_l, CRplus_comm.
    rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. exact H1.
  - apply (CRplus_le_reg_r (a+c)).
    unfold CRminus. rewrite (CRplus_assoc b), <- (CRplus_assoc (-a)).
    rewrite CRplus_opp_l, CRplus_0_l, CRplus_assoc.
    apply CRplus_le_compat. exact H2. rewrite CRplus_comm.
    rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. exact H.
Qed.

Lemma sum_by_packets
  : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) (Pn : nat -> nat) (n : nat),
    (forall k, le k n -> lt (Pn k) (Pn (S k)))
    -> Pn O = O
    -> CRsum (fun i => CRsum (fun k => xn (k + Pn i))%nat
                               (pred (Pn (S i) - Pn i))) n
      == CRsum xn (pred (Pn (S n))).
Proof.
  induction n.
  - intros. simpl. rewrite H0.
    replace (pred (Pn 1 - 0))%nat with (pred (Pn 1%nat)).
    apply CRsum_eq. intros. rewrite Nat.add_comm. reflexivity.
    rewrite Nat.sub_0_r. reflexivity.
  - intros.
    assert (forall k : nat, k <= n -> Pn k < Pn (S k))%nat.
    { intros. apply H. apply (le_trans _ n _ H1). apply le_S, le_refl. }
    specialize (IHn H1 H0). clear H1. simpl.
    rewrite IHn.
    destruct (Pn (S (S n)) - Pn (S n))%nat eqn:des.
    exfalso. apply Nat.sub_0_le in des.
    apply (le_not_lt _ _ des). apply H, le_refl. simpl.
    pose proof (H n). destruct (Pn (S n)).
    exfalso. apply (le_not_lt 0 (Pn n) (le_0_n _)). apply H1, le_S, le_refl.
    clear H1. simpl.
    rewrite (CRsum_eq (fun k : nat => xn (k + S n1)%nat)
                      (fun k : nat => xn (S n1 + k)%nat)).
    2: intros; rewrite Nat.add_comm; reflexivity.
    rewrite <- (sum_assoc xn n1).
    replace (S n1 + n0)%nat with (Init.Nat.pred (Pn (S (S n)))).
    reflexivity.
    pose proof (H (S n) (le_refl _)). destruct (Pn (S (S n))). exfalso.
    inversion H1.
    simpl. simpl in des.
    replace (S (n1 + n0)) with (n1 + S n0)%nat.
    2: apply Nat.add_succ_r.
    rewrite <- des. rewrite Nat.add_comm. rewrite Nat.sub_add.
    reflexivity. destruct (le_lt_dec n2 n1).
    apply Nat.sub_0_le in l. rewrite l in des. discriminate.
    apply (le_trans _ (S n1)). apply le_S, le_refl. exact l.
Qed.

(* TODO replace SubSeqCv *)
Lemma ShouldReplaceSubSeq : forall (sub : SubSeq) (n : nat),
    le n (proj1_sig sub n).
Proof.
  induction n.
  - apply le_0_n.
  - destruct sub; simpl. simpl in IHn. specialize (l n (S n) (le_refl _)).
    apply (le_trans _ (S (x n))). apply le_n_S, IHn. exact l.
Qed.

Lemma SubSeqCvMerge : forall {R : ConstructiveReals} (un : nat -> CRcarrier R)
                        (sub : nat -> nat) (l : CRcarrier R),
    (forall n:nat, le n (sub n))
    -> CR_cv R un l -> CR_cv R (fun n => un (sub n)) l.
Proof.
  intros. intros n. specialize (H0 n) as [p pmaj].
  exists p. intros. apply pmaj.
  apply (le_trans _ i _ H0), H.
Qed.

Lemma Qpower_positive : forall (q : Q) (n : nat),
    Qlt 0 q -> Qlt 0 (q^Z.of_nat n).
Proof.
  induction n.
  - intros. reflexivity.
  - intros. rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite Qpower_plus.
    rewrite <- (Qmult_0_l q). apply Qmult_lt_r. exact H. exact (IHn H).
    intro abs. rewrite abs in H. inversion H.
Qed.

Lemma pow_inject_Q : forall {R : ConstructiveReals} (q : Q) (n : nat),
    ~(q == 0)%Q
     -> (CR_of_Q R (q ^ Z.of_nat n) == CRpow (CR_of_Q R q) n).
Proof.
  induction n.
  - intros. reflexivity.
  - intros. rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite Qpower_plus.
    rewrite CR_of_Q_mult, IHn. simpl. apply CRmult_comm. exact H. exact H.
Qed.

Definition UCUnitHeaviside {R : ConstructiveReals}
           (a b : CRcarrier R) (ltab : a < b)
  : CRcarrier R -> CRcarrier R
  := fun x => (CRmax 0 (CRmin 1 ((x - a) * (CRinv R (b-a) (inr (CRlt_minus _ _ ltab)))))).

Lemma LipschitzMin
  : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
      (k m : CRcarrier R),
    Lipschitz f k
    -> Lipschitz (fun x => CRmin m (f x)) k.
Proof.
  intros R f k m fl x y.
  rewrite CRmin_sym, (CRmin_sym m).
  apply (CRle_trans _ _ _ (CRmin_contract _ _ _)).
  apply fl.
Qed.

Lemma UCmin : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
                (m : CRcarrier R)
                (fMod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R),
    0 <= m
    -> UniformCont f fMod -> UniformCont (fun x => CRmin m (f x)) fMod.
Proof.
  intros R f m fMod mPos H. destruct H. split. exact c.
  intros. apply (CRle_lt_trans _ (CRabs _ (f x - f y))).
  2: apply (c0 eps _ _ epsPos H).
  rewrite CRmin_sym, (CRmin_sym m). apply CRmin_contract.
Qed.

Lemma UCmax : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
                (m : CRcarrier R)
                (fMod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R),
    0 <= m
    -> UniformCont f fMod -> UniformCont (fun x => CRmax m (f x)) fMod.
Proof.
  intros R f m fMod mPos H. destruct H. split. exact c.
  intros. apply (CRle_lt_trans _ (CRabs _ (f x - f y))).
  2: apply (c0 eps _ _ epsPos H).
  rewrite CRmax_sym, (CRmax_sym m). apply CRmax_contract.
Qed.

Lemma UCHeaviside_cont
  : forall {R : ConstructiveReals} (a b : CRcarrier R) (ltab : a < b),
    UniformCont (UCUnitHeaviside a b ltab)
                (fun eps epsPos => eps * (b-a)).
Proof.
  intros.
  apply UCmax. apply CRle_refl. apply UCmin. apply CRlt_asym, CRzero_lt_one.
  assert (0 < (b - a)). apply CRlt_minus. apply ltab.
  split.
  - intros. apply CRmult_lt_0_compat; assumption.
  - intros.
    rewrite (CRabs_morph
               _ ((x - y) * (CRinv R (b - a) (inr (CRlt_minus a b ltab))))).
    rewrite CRabs_mult.
    rewrite (CRabs_right (CRinv R (b - a) (inr (CRlt_minus a b ltab)))).
    apply (CRlt_le_trans
             _ (eps * (b-a) * (CRinv R (b - a) (inr (CRlt_minus a b ltab))))).
    apply CRmult_lt_compat_r. 2: exact H0.
    apply CRinv_0_lt_compat, H.
    rewrite CRmult_assoc, CRinv_r, CRmult_1_r. apply CRle_refl.
    apply CRlt_asym, CRinv_0_lt_compat, H.
    unfold CRminus. rewrite CRopp_mult_distr_l.
    rewrite <- CRmult_plus_distr_r.
    setoid_replace (x + - a + - (y + - a)) with (x+-y). reflexivity.
    rewrite CRplus_assoc. apply CRplus_morph. reflexivity.
    rewrite CRplus_comm, CRopp_plus_distr.
    rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity.
Qed.

Lemma UCHeavisideBounded : forall {R : ConstructiveReals} (a b x : CRcarrier R)
                             (ltab : a < b),
    (0 <= UCUnitHeaviside a b ltab x <= 1).
Proof.
  intros. unfold UCUnitHeaviside. split.
  - apply CRmax_l.
  - apply CRmax_lub. apply CRlt_asym, CRzero_lt_one. apply CRmin_l.
Qed.

Lemma Rplus_pos_higher : forall {R : ConstructiveReals} (a eps:CRcarrier R),
    0 < eps -> a < (a+eps).
Proof.
  intros.
  rewrite <- (CRplus_0_r a). rewrite CRplus_assoc.
  apply CRplus_lt_compat_l. rewrite CRplus_0_l.
  exact H.
Qed.

Lemma Rminus_pos_lower : forall {R : ConstructiveReals} (a eps:CRcarrier R),
    0 < eps -> (a-eps) < a.
Proof.
  intros. apply (CRplus_lt_reg_r eps).
  unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r.
  apply Rplus_pos_higher. apply H.
Qed.

Definition CSUCUnitTrapeze {R : ConstructiveReals}
           (a b eta : CRcarrier R) (etaPos : 0 < eta)
           (x : CRcarrier R) : CRcarrier R
  := UCUnitHeaviside (a-eta) a (Rminus_pos_lower a eta etaPos) x
     - UCUnitHeaviside b (b+eta) (Rplus_pos_higher b eta etaPos) x.

Lemma CSUCUnitTrapeze_cont
  : forall {R : ConstructiveReals} (a b eta : CRcarrier R) (etaPos : 0 < eta),
    a <= b -> UniformCont (CSUCUnitTrapeze a b eta etaPos)
                        (* The modulus could be improved to eps*eta *)
                        (fun eps epsPos => eps * CR_of_Q R (1#2) * eta).
Proof.
  intros.
  apply (UC_modExt _ (fun eps epsPos =>
                        CRmin (eps * CR_of_Q R (1#2) * (a - (a - eta)))
                              (eps * CR_of_Q R (1#2) * (b + eta - b)))).
  - apply (UC_plus _ _
                   (fun eps epsPos => eps * (a-(a-eta)))
                   (fun eps epsPos => eps * (b+eta-b))).
    apply UCHeaviside_cont. split.
    intros. rewrite CRplus_comm. unfold CRminus.
    rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r.
    rewrite <- (CRmult_0_r x). apply CRmult_lt_compat_l.
    exact xPos. exact etaPos.
    intros. unfold CRminus.
    rewrite <- CRopp_plus_distr. rewrite CRabs_opp.
    apply UCHeaviside_cont. apply epsPos. apply H0.
  - intros. rewrite CRmin_left.
    unfold CRminus.
    rewrite CRopp_plus_distr, <- CRplus_assoc, CRplus_opp_r, CRplus_0_l.
    rewrite CRopp_involutive. reflexivity.
    setoid_replace (a - (a - eta)) with eta.
    setoid_replace (b + eta - b) with eta. apply CRle_refl.
    unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc.
    rewrite CRplus_opp_l, CRplus_0_l. reflexivity.
    unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc.
    rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity.
Qed.

Lemma UCHeavisideIn : forall {R : ConstructiveReals} (a b x : CRcarrier R) (altb : a < b),
    b <= x -> UCUnitHeaviside a b altb x == 1.
Proof.
  intros. unfold UCUnitHeaviside.
  rewrite CRmin_left, CRmax_right. reflexivity.
  apply CRlt_asym, CRzero_lt_one.
  apply (CRmult_le_reg_r (b-a)).
  unfold CRminus. rewrite <- (CRplus_opp_r a).
  apply CRplus_lt_compat_r. exact altb.
  rewrite CRmult_assoc, CRinv_l, CRmult_1_l, CRmult_1_r.
  unfold CRminus. rewrite CRplus_comm, (CRplus_comm x).
  apply CRplus_le_compat_l. apply H.
Qed.

Lemma CSUCTrapezePlateau
  : forall {R : ConstructiveReals} (a b eta x : CRcarrier R) (etaPos : 0 < eta),
    (a <= x <= b) -> CSUCUnitTrapeze a b eta etaPos x == 1.
Proof.
  intros. unfold CSUCUnitTrapeze. rewrite UCHeavisideIn. 2: apply H.
  unfold UCUnitHeaviside. rewrite CRmax_left.
  unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity.
  apply (CRle_trans _ _ _ (CRmin_r _ _)).
  apply (CRmult_le_reg_r (b+eta-b)).
  unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc.
  rewrite CRplus_opp_l, CRplus_0_l. apply etaPos.
  rewrite CRmult_assoc, CRinv_l, CRmult_0_l, CRmult_1_r.
  unfold CRminus. rewrite CRplus_comm.
  rewrite <- (CRplus_opp_l b). apply CRplus_le_compat_l. apply H.
Qed.

Lemma CSUCTrapezeInPlateau
  : forall {R : ConstructiveReals} (a b eta x : CRcarrier R) (etaPos : 0 < eta),
    0 < CSUCUnitTrapeze a b eta etaPos x
    -> (a-eta < x < b+eta).
Proof.
  intros. unfold CSUCUnitTrapeze in H.
  apply (CRplus_lt_compat_r
           (UCUnitHeaviside b (b + eta) (Rplus_pos_higher b eta etaPos) x)) in H.
  unfold CRminus in H.
  rewrite CRplus_0_l, CRplus_assoc, CRplus_opp_l, CRplus_0_r in H.
  split.
  - assert (0 < UCUnitHeaviside (a - eta) a (Rminus_pos_lower a eta etaPos) x).
    { apply (CRle_lt_trans
               _ (UCUnitHeaviside b (b + eta) (Rplus_pos_higher b eta etaPos) x)).
      2: exact H. apply UCHeavisideBounded. }
    unfold UCUnitHeaviside in H0.
    rewrite CRmax_right in H0. apply CRlt_min in H0. destruct H0.
    apply (CRmult_lt_compat_r (a-(a-eta))) in c0.
    rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r in c0.
    rewrite <- (CRplus_opp_r (a-eta)) in c0. apply CRplus_lt_reg_r in c0.
    exact c0. unfold CRminus.
    rewrite CRopp_plus_distr, <- CRplus_assoc, CRplus_opp_r, CRplus_0_l.
    rewrite CRopp_involutive. exact etaPos.
    intro abs. rewrite CRmax_left in H0. exact (CRlt_asym 0 0 H0 H0).
    apply CRlt_asym, abs.
  - assert (UCUnitHeaviside b (b+eta) (Rplus_pos_higher b eta etaPos) x < 1).
    { apply (CRlt_le_trans _ _ _ H). apply UCHeavisideBounded. }
    unfold UCUnitHeaviside in H0. apply CRlt_max in H0. destruct H0 as [_ H0].
    rewrite CRmin_right in H0.
    apply (CRmult_lt_compat_r (b+eta-b)) in H0.
    rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r in H0.
    apply CRplus_lt_reg_r in H0. exact H0. unfold CRminus.
    rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l.
    exact etaPos.
    intro abs. rewrite CRmin_left in H0. exact (CRlt_asym 1 1 H0 H0).
    apply CRlt_asym, abs.
Qed.

Lemma CSUCTrapezePositive
  : forall {R : ConstructiveReals} (a b eta x : CRcarrier R)
      (etaPos : 0 < eta) (leab : a <= b),
    prod (a-eta < x) (x < b+eta)
    -> 0 < (CSUCUnitTrapeze a b eta etaPos x).
Proof.
  intros. unfold CSUCUnitTrapeze, UCUnitHeaviside.
  rewrite CRmax_right.
  rewrite (CRmin_right
             1 ((x - b) *
        CRinv R (b + eta - b) (inr (CRlt_minus b (b + eta) (Rplus_pos_higher b eta etaPos))))).
  - apply (CRle_lt_trans
             _ (CRmax 0
    ((x - b) *
     CRinv R (b + eta - b) (inr (CRlt_minus b (b + eta) (Rplus_pos_higher b eta etaPos))))
                            - CRmax 0
    ((x - b) *
     CRinv R (b + eta - b) (inr (CRlt_minus b (b + eta) (Rplus_pos_higher b eta etaPos)))))).
    unfold CRminus. rewrite CRplus_opp_r. apply CRle_refl.
    apply CRplus_lt_compat_r.
    apply CRmin_lt. apply CRmax_lub_lt. apply CRzero_lt_one.
    2: apply CRmax_lub_lt.
    + apply (CRmult_lt_reg_r (b+eta-b)).
      unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc.
      rewrite CRplus_opp_l, CRplus_0_l. exact etaPos.
      rewrite CRmult_assoc, CRinv_l, CRmult_1_l, CRmult_1_r.
      unfold CRminus. apply CRplus_lt_compat_r. apply H.
    + apply (CRmult_lt_reg_r (a-(a-eta))).
      unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc.
      rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. exact etaPos.
      rewrite CRmult_assoc, CRinv_l, CRmult_0_l, CRmult_1_r.
      rewrite <- (CRplus_opp_r (a-eta)).
      apply CRplus_lt_compat_r. apply H.
    + apply (CRmult_lt_reg_r (b+eta-b)).
      unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc.
      rewrite CRplus_opp_l, CRplus_0_l. exact etaPos.
      rewrite CRmult_assoc, CRinv_l, CRmult_1_r.
      setoid_replace (b + eta - b) with eta.
      rewrite <- (CRmult_comm eta).
      apply (CRmult_lt_reg_r (a-(a-eta))).
      unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc.
      rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. exact etaPos.
      rewrite CRmult_assoc, CRmult_assoc, CRinv_l, CRmult_1_r.
      setoid_replace (a - (a - eta)) with eta.
      rewrite CRmult_comm. apply CRmult_lt_compat_l. exact etaPos.
      apply CRplus_lt_compat_l. apply CRopp_gt_lt_contravar.
      apply (CRlt_le_trans _ a). apply (CRplus_lt_reg_r eta).
      unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l.
      apply CRplus_lt_compat_l, etaPos. exact leab.
      unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc.
      rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity.
      unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc.
      rewrite CRplus_opp_l, CRplus_0_l. reflexivity.
  - apply (CRmult_le_reg_r (b+eta-b)).
    unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc.
    rewrite CRplus_opp_l, CRplus_0_l. exact etaPos.
    rewrite CRmult_assoc, CRinv_l, CRmult_1_l, CRmult_1_r.
    unfold CRminus. rewrite CRplus_comm.
    rewrite <- (CRplus_comm (-b)). apply CRplus_le_compat_l.
    apply CRlt_asym, H.
  - apply CRmin_glb. apply CRlt_asym, CRzero_lt_one.
    apply (CRmult_le_reg_r (a-(a-eta))).
    unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc.
    rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. exact etaPos.
    rewrite CRmult_assoc, CRinv_l, CRmult_0_l, CRmult_1_r.
    unfold CRminus.
    rewrite <- (CRplus_opp_l (a-eta)), (CRplus_comm x).
    apply CRplus_le_compat_l. apply CRlt_asym, H.
Qed.

Lemma CSUCTrapezeBounded
  : forall {R : ConstructiveReals} (a b eta x : CRcarrier R) (etaPos : 0 < eta),
    a <= b
    -> (0 <= CSUCUnitTrapeze a b eta etaPos x <= 1).
Proof.
  intros. unfold CSUCUnitTrapeze, UCUnitHeaviside.
  rewrite (CRinv_morph (a - (a-eta)) eta _ (inr etaPos)).
  rewrite (CRinv_morph (b + eta - b) eta _ (inr etaPos)).
  destruct (CRltLinear R). destruct (s a x (b+eta)).
  - apply (CRle_lt_trans _ (b+0)). rewrite CRplus_0_r. exact H.
    apply CRplus_lt_compat_l. exact etaPos.
  - (* a < x *)
    rewrite CRmax_right, CRmin_left.
    split.
    + apply (CRle_trans _ (1-1)).
      unfold CRminus. rewrite CRplus_opp_r. apply CRle_refl.
      apply CRplus_le_compat_l. apply CRopp_ge_le_contravar.
      apply CRmax_lub. apply CRlt_asym, CRzero_lt_one. apply CRmin_l.
    + apply (CRle_trans _ (1-0)). apply CRplus_le_compat_l.
      apply CRopp_ge_le_contravar. apply CRmax_l.
      unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply CRle_refl.
    + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive.
      rewrite <- CRplus_assoc, CRmult_plus_distr_r, CRinv_r.
      apply (CRle_trans _ (0+1)). rewrite CRplus_0_l. apply CRle_refl.
      apply CRplus_le_compat_r. apply (CRle_trans _ ((x-a)*0)).
      rewrite CRmult_0_r. apply CRle_refl. apply CRlt_asym.
      apply CRmult_lt_compat_l.
      rewrite <- (CRplus_opp_r a). apply CRplus_lt_compat_r, c.
      apply CRinv_0_lt_compat. exact etaPos.
    + apply CRmin_glb.
      apply CRlt_asym, CRzero_lt_one.
      apply (CRle_trans _ ((x-(a-eta))*0)).
      rewrite CRmult_0_r. apply CRle_refl. apply CRlt_asym.
      apply CRmult_lt_compat_l.
      apply (CRplus_lt_reg_r (a-eta)). unfold CRminus.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_0_l.
      apply (CRlt_trans _ a). 2: apply c.
      apply (CRplus_lt_reg_r eta). rewrite CRplus_assoc, CRplus_opp_l.
      apply CRplus_lt_compat_l. exact etaPos.
      apply CRinv_0_lt_compat. exact etaPos.
  - rewrite (CRmin_right 1 ((x - b) * CRinv R eta (inr etaPos))). split.
    + unfold CRminus. rewrite CRplus_comm.
      apply (CRle_trans _ (-(CRmax 0 ((x - b) * CRinv R eta (inr etaPos)))
                           + CRmax 0 ((x - b)* CRinv R eta (inr etaPos)))).
      rewrite CRplus_opp_l. apply CRle_refl.
      apply CRplus_le_compat_l.
      apply CRmax_lub. apply CRmax_l.
      apply (CRle_trans
               _ (CRmin 1 ((x + - (a + - eta)) * CRinv R eta (inr etaPos)))).
      2: apply CRmax_r. apply CRmin_glb.
      apply (CRmult_le_reg_r eta _ 1). exact etaPos.
      rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l.
      apply (CRplus_le_reg_r b). unfold CRminus.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r.
      rewrite CRplus_comm. apply CRlt_asym, c.
      apply CRmult_le_compat_r.
      apply CRlt_asym, CRinv_0_lt_compat. exact etaPos.
      apply CRplus_le_compat_l. apply CRopp_ge_le_contravar.
      apply (CRplus_le_reg_r eta).
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r.
      apply (CRle_trans _ (b+0)). rewrite CRplus_0_r. exact H.
      apply CRplus_le_compat_l. apply CRlt_asym, etaPos.
    + apply (CRplus_le_reg_r (CRmax 0 ((x - b) * CRinv R eta (inr etaPos)))).
      unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r.
      apply CRmax_lub. apply (CRle_trans _ (1+0)).
      rewrite CRplus_0_r. apply CRlt_asym, CRzero_lt_one.
      apply CRplus_le_compat_l. apply CRmax_l.
      apply (CRle_trans _ (1+0)).
      rewrite CRplus_0_r. apply CRmin_l.
      apply CRplus_le_compat_l. apply CRmax_l.
    + apply (CRmult_le_reg_r eta _ 1). exact etaPos.
      rewrite CRmult_assoc, CRinv_l, CRmult_1_l, CRmult_1_r.
      apply (CRplus_le_reg_r b).
      unfold CRminus. rewrite CRplus_assoc.
      rewrite CRplus_opp_l, CRplus_0_r.
      rewrite CRplus_comm. apply CRlt_asym, c.
  - unfold CRminus. rewrite CRplus_comm.
    rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity.
  - unfold CRminus. rewrite CRopp_plus_distr.
    rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l.
    rewrite CRopp_involutive. reflexivity.
Qed.

Lemma TrapezeIncluded
  : forall {R : ConstructiveReals} (a b c d eta mu x : CRcarrier R)
           (etaPos : 0 < eta) (muPos : 0 < mu),
    a - eta == c - mu
    -> b + eta == d + mu
    -> eta <= mu
    -> CSUCUnitTrapeze c d mu muPos x
       <= CSUCUnitTrapeze a b eta etaPos x.
Proof.
  intros.
  assert (CRinv R mu (inr muPos) <= CRinv R eta (inr etaPos)) as invLe.
  { apply (CRmult_le_reg_l mu _ _ muPos). rewrite CRinv_r.
    apply (CRmult_le_reg_r eta _ _ etaPos).
    rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r. exact H1. }
  apply CRplus_le_compat.
  - unfold UCUnitHeaviside.
    rewrite (CRinv_morph (a - (a-eta)) eta _ (inr etaPos)).
    rewrite (CRinv_morph (c - (c-mu)) mu _ (inr muPos)).
    apply CRmax_lub. apply CRmax_l. rewrite <- H.
    destruct (CRltLinear R). destruct (s (a-eta) x a).
    + apply (CRplus_lt_reg_r eta). unfold CRminus.
      rewrite CRplus_assoc. apply CRplus_lt_compat_l.
      rewrite CRplus_opp_l. exact etaPos.
    + apply (CRle_trans _ (CRmin 1 ((x - (a - eta)) * CRinv R eta (inr etaPos)))).
      2: apply CRmax_r. apply CRmin_glb. apply CRmin_l.
      apply (CRle_trans _ ((x - (a - eta)) * CRinv R mu (inr muPos))).
      apply CRmin_r. apply CRmult_le_compat_l.
      rewrite <- (CRplus_opp_r (a-eta)). apply CRplus_le_compat_r, CRlt_asym, c0.
      exact invLe.
    + rewrite CRmin_right. rewrite CRmin_right.
      apply (CRmult_le_reg_r mu _ _ muPos).
      rewrite CRmult_assoc, CRinv_l, CRmult_1_r.
      apply (CRle_trans
               _ (eta * CRmax 0 ((x - (a - eta)) * CRinv R eta (inr etaPos)))).
      rewrite <- CRmax_mult. rewrite CRmult_0_r, CRmult_comm.
      rewrite CRmult_assoc, CRinv_l, CRmult_1_r. apply CRmax_r.
      apply CRlt_asym, etaPos. rewrite CRmult_comm.
      apply CRmult_le_compat_l. apply CRmax_l. exact H1.
      apply (CRmult_le_reg_r eta _ _ etaPos).
      rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r.
      apply (CRplus_le_reg_l a). unfold CRminus.
      rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_assoc, <- CRplus_assoc.
      apply CRplus_le_compat_r.
      rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l.
      apply CRlt_asym, c0.
      apply (CRmult_le_reg_r mu _ _ muPos).
      rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r.
      apply (CRle_trans _ eta).
      apply (CRplus_le_reg_l a). unfold CRminus.
      rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_assoc, <- CRplus_assoc.
      apply CRplus_le_compat_r.
      rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l.
      apply CRlt_asym, c0. exact H1.
    + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_assoc.
      rewrite CRplus_opp_r, CRplus_0_l. reflexivity.
    + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_assoc.
      rewrite CRplus_opp_r, CRplus_0_l. reflexivity.
  - apply CRopp_ge_le_contravar. unfold UCUnitHeaviside.
    rewrite (CRinv_morph (b + eta - b) eta _ (inr etaPos)).
    rewrite (CRinv_morph (d + mu - d) mu _ (inr muPos)).
    apply CRmax_lub. apply CRmax_l.
    destruct (CRltLinear R). destruct (s b x (b+eta)).
    + apply (CRplus_lt_reg_r 0).
      rewrite CRplus_assoc. apply CRplus_lt_compat_l.
      rewrite CRplus_0_r. exact etaPos.
    + apply (CRle_trans _ (CRmin 1 ((x - d) * CRinv R mu (inr muPos)))).
      2: apply CRmax_r. apply CRmin_glb. apply CRmin_l.
      apply (CRmult_le_reg_r mu _ _ muPos).
      rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_comm.
      rewrite <- (CRplus_0_r 1).
      setoid_replace ((x - b) * CRinv R eta (inr etaPos))
        with (1 + (x - (b+eta)) * CRinv R eta (inr etaPos)).
      rewrite <- CRmin_plus, CRmult_plus_distr_l, CRmult_1_r.
      apply (CRplus_le_reg_l (-mu)).
      rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l.
      apply (CRle_trans _ (x - (b + eta))).
      assert (0 == CRinv R eta (inr etaPos) * 0).
      symmetry. apply CRmult_0_r. rewrite (CRmult_comm (x - (b + eta))).
      rewrite (CRmin_morph R 0 (CRinv R eta (inr etaPos) * 0) H2 _ _ (CReq_refl _)).
      rewrite CRmin_mult. apply (CRle_trans _ (CRmin 0 (x - (b + eta)))).
      2: apply CRmin_r.
      rewrite <- CRopp_involutive, <- (CRopp_involutive (CRmin 0 (x - (b + eta)))).
      apply CRopp_ge_le_contravar.
      rewrite CRopp_involutive, CRopp_mult_distr_r, CRopp_mult_distr_r.
      rewrite <- (CRmult_1_l (- CRmin 0 (x - (b + eta)))), <- CRmult_assoc.
      rewrite <- CRmult_assoc. apply CRmult_le_compat_r.
      rewrite <- CRopp_0. apply CRopp_ge_le_contravar.
      apply (CRle_trans _ (-0)). apply CRmin_l. rewrite CRopp_0. apply CRle_refl.
      rewrite CRmult_1_r. apply (CRmult_le_reg_r eta _ _ etaPos).
      rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l. exact H1.
      apply CRlt_asym, CRinv_0_lt_compat, etaPos.
      unfold CRminus. rewrite H0, CRopp_plus_distr, (CRplus_comm (-mu)).
      rewrite CRplus_assoc. apply CRle_refl.
      unfold CRminus. rewrite (CRplus_comm 1), CRmult_plus_distr_r.
      rewrite CRmult_plus_distr_r, CRopp_plus_distr, CRmult_plus_distr_r.
      rewrite CRplus_assoc. apply CRplus_morph. reflexivity.
      rewrite <- (CRopp_mult_distr_l eta), CRinv_r.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity.
    + rewrite CRmin_right. rewrite CRmin_right.
      apply (CRle_trans _ ((x - d) * CRinv R mu (inr muPos))). 2: apply CRmax_r.
      apply (CRplus_le_reg_r (-(1))).
      apply (CRle_trans _ ((x - (b+eta)) * CRinv R eta (inr etaPos))).
      unfold CRminus. do 2 rewrite CRmult_plus_distr_r.
      rewrite CRopp_plus_distr, CRmult_plus_distr_r, <- (CRopp_mult_distr_l eta).
      rewrite CRinv_r, <- CRplus_assoc. apply CRle_refl.
      apply (CRle_trans _ ((x - (d+mu)) * CRinv R mu (inr muPos))).
      rewrite <- H0. rewrite <- CRopp_involutive.
      rewrite <- (CRopp_involutive ((x - (b + eta)) * CRinv R mu (inr muPos))).
      apply CRopp_ge_le_contravar. do 2 rewrite CRopp_mult_distr_l.
      apply CRmult_le_compat_l. unfold CRminus.
      rewrite CRopp_plus_distr, CRopp_involutive, <- (CRplus_opp_l x).
      apply CRplus_le_compat_l. apply CRlt_asym, c0. exact invLe.
      unfold CRminus. do 2 rewrite CRmult_plus_distr_r.
      rewrite CRopp_plus_distr, CRmult_plus_distr_r, <- (CRopp_mult_distr_l mu).
      rewrite CRinv_r, <- CRplus_assoc. apply CRle_refl.
      apply (CRmult_le_reg_r mu _ _ muPos).
      rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l.
      apply (CRplus_le_reg_r d). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l.
      rewrite CRplus_0_r, CRplus_comm, <- H0. apply CRlt_asym, c0.
      apply (CRmult_le_reg_r eta _ _ etaPos).
      rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l.
      apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l.
      rewrite CRplus_0_r, CRplus_comm. apply CRlt_asym, c0.
    + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc.
      rewrite CRplus_opp_l, CRplus_0_l. reflexivity.
    + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc.
      rewrite CRplus_opp_l, CRplus_0_l. reflexivity.
Qed.

Lemma Rminus_plus_one_lower : forall {R : ConstructiveReals} (a b : CRcarrier R),
    a <= b -> (a-1) <= (b+1).
Proof.
  intros. apply (CRle_trans _ a).
  apply CRlt_asym, Rminus_pos_lower. apply CRzero_lt_one.
  apply (CRle_trans _ b _ H).
  apply CRlt_asym, Rplus_pos_higher. apply CRzero_lt_one.
Qed.

Lemma UC_x : forall {R : ConstructiveReals},
    UniformCont (fun x:CRcarrier R => x) (fun eps _ => eps).
Proof.
  split. intros. exact xPos. intros. exact H.
Qed.

Lemma S_INR : forall {R : ConstructiveReals} (n:nat),
    INR (S n) == @INR R n + 1.
Proof.
  intros R n. unfold INR. rewrite <- CR_of_Q_plus.
  apply CR_of_Q_morph. rewrite Qinv_plus_distr.
  unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r.
  fold (1 + n)%nat.
  rewrite (Nat2Z.inj_add 1 n). rewrite Z.add_comm. reflexivity.
Qed.

Lemma sum_INR :
  forall {R : ConstructiveReals} (n:nat),
    CRsum INR n
    == INR n * (INR (S n)) * CR_of_Q R (1#2).
Proof.
  induction n.
  - unfold CRsum, INR, Z.of_nat. rewrite CRmult_0_l, CRmult_0_l.
    reflexivity.
  - transitivity (CRsum INR n + @INR R (S n)).
    reflexivity. rewrite IHn. clear IHn.
    transitivity (INR (S n) * (INR n * CR_of_Q R (1#2) + 1)).
    rewrite CRmult_plus_distr_l. apply CRplus_morph.
    rewrite <- CRmult_assoc. apply CRmult_morph. 2: reflexivity.
    apply CRmult_comm. rewrite CRmult_1_r. reflexivity.
    rewrite CRmult_assoc. apply CRmult_morph.
    reflexivity.
    apply (CRmult_eq_reg_r (CR_of_Q R 2)).
    left. apply CR_of_Q_pos; reflexivity.
    rewrite CRmult_plus_distr_r, CRmult_1_l.
    rewrite CRmult_assoc, <- CR_of_Q_mult.
    rewrite CRmult_assoc, <- (CR_of_Q_mult _ (1#2)).
    setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity.
    do 2 rewrite CRmult_1_r. rewrite (CR_of_Q_plus R 1 1).
    do 2 rewrite S_INR. rewrite CRplus_assoc.
    reflexivity.
Qed.

Lemma CSUCTrapeze_CSUC
  : forall {R : ConstructiveReals} (a b eta : CRcarrier R) (etaPos : 0 < eta),
    a <= b -> CSUC (CSUCUnitTrapeze a b eta etaPos)
                 (a-eta) (b+eta) (fun eps epsPos => eps * CR_of_Q R (1#2) * eta).
Proof.
  intros. split.
  - apply CSUCUnitTrapeze_cont. apply H.
  - intros. unfold CSUCUnitTrapeze, UCUnitHeaviside.
    rewrite (CRinv_morph (a - (a-eta)) eta _ (inr etaPos)).
    rewrite (CRinv_morph (b + eta - b) eta _ (inr etaPos)).
    destruct H0 as [H0|H0].
    + assert (x < a).
      { apply (CRlt_trans x (a-eta)). apply H0.
        apply Rminus_pos_lower. exact etaPos. }
      assert (x < b).
      { exact (CRlt_le_trans x a _ H1 H). }
      rewrite CRmax_left, CRmax_left.
      unfold CRminus. rewrite CRplus_opp_r. reflexivity.
      apply (CRle_trans _ _ _ (CRmin_r _ _)).
      apply (CRmult_le_reg_r eta). exact etaPos.
      rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r.
      apply (CRplus_le_reg_r b). unfold CRminus.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_0_r.
      apply CRlt_asym, H2.
      apply (CRle_trans _ _ _ (CRmin_r _ _)).
      apply (CRmult_le_reg_r eta). exact etaPos.
      rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r.
      apply (CRplus_le_reg_r (a-eta)). unfold CRminus.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_0_r.
      apply CRlt_asym, H0.
    + assert (b < x).
      { apply (CRlt_trans b (b+eta)). apply Rplus_pos_higher.
        exact etaPos. apply H0. }
      assert (a < x).
      { exact (CRle_lt_trans a b _ H H1). }
      rewrite CRmax_right, CRmax_right.
      rewrite CRmin_left, CRmin_left.
      unfold CRminus. apply CRplus_opp_r.
      apply (CRmult_le_reg_r eta _ _ etaPos).
      rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r.
      apply (CRplus_le_reg_r b). unfold CRminus.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm.
      apply CRlt_asym, H0.
      apply (CRmult_le_reg_r eta _ _ etaPos).
      rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r.
      apply (CRplus_le_reg_r (a-eta)). unfold CRminus.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r.
      apply CRlt_asym, H2.
      apply CRmin_glb. apply CRlt_asym, CRzero_lt_one.
      apply (CRmult_le_reg_r eta _ _ etaPos).
      rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r.
      apply (CRplus_le_reg_r b). unfold CRminus.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_0_l.
      apply CRlt_asym, H1.
      apply CRmin_glb. apply CRlt_asym, CRzero_lt_one.
      apply (CRmult_le_reg_r eta _ _ etaPos).
      rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r.
      apply (CRplus_le_reg_r (a-eta)). unfold CRminus.
      rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_0_l.
      apply (CRle_trans _ a). 2: apply CRlt_asym, H2.
      apply (CRplus_le_reg_r eta).
      rewrite CRplus_assoc, CRplus_opp_l.
      apply CRplus_le_compat_l. apply CRlt_asym, etaPos.
    + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc.
      rewrite CRplus_opp_l, CRplus_0_l. reflexivity.
    + unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc.
      rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity.
Qed.

Definition UC_bounded {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
           (a b : CRcarrier R) (fMod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R)
           (fUC : UniformCont f fMod)
  : a <= b -> { B : CRcarrier R & forall x:CRcarrier R, a <= x -> x <= b -> CRabs _ (f x) < B }.
Proof.
  (* Evaluate the modulus of uniform continuity for 1,
     then divide the segment [a,b] by this length and
     take the highest value of f at those points, plus 1. *)
  pose proof ((snd fUC) 1). intros.
  (* Divide the modulus by 2, because constructively there is no exact
     comparison of real numbers. *)
  pose (nat_rec (fun n => CRcarrier R) (CRabs _ (f a))
                (fun n x => CRmax x (CRabs _ (f (a + INR (S n) * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2))))))
    as maxou.
  assert (forall i k : nat, le i k
                     -> CRabs _ (f (a + INR i * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1# 2)))
                       <= (maxou k))
    as maxouSpec.
  { induction k.
    - intros. inversion H1. unfold INR, Z.of_nat.
      rewrite (UniformContProper f fMod fUC _ a).
      apply CRle_refl.
      rewrite CRmult_0_l. rewrite CRmult_0_l, CRplus_0_r. reflexivity.
    - intros. apply Nat.le_succ_r in H1. destruct H1.
      apply (CRle_trans _ (maxou k) _ (IHk H1)). apply CRmax_l.
      subst i. apply CRmax_r. }
  (* Get maximal index k of subdivision *)
  destruct (CRup_nat ((b - a) * CR_of_Q R 2
                     * (CRinv R (fMod 1 (CRzero_lt_one R)) (inr ((fst fUC) 1 (CRzero_lt_one R))))))
    as [k kmaj].
  exists (maxou k + 1). intros.
  assert (0 < fMod 1 (CRzero_lt_one R)) as stepPos.
  { apply (fst fUC). }
  (* Find 2 columns around x *)
  destruct (CRfloor ((x-a) * CR_of_Q R 2 * (CRinv R (fMod 1 (CRzero_lt_one R))
                                                  (inr ((fst fUC) 1 (CRzero_lt_one R))))))
    as [i [H4 H5]].
  apply (CRmult_lt_compat_r (fMod 1 (CRzero_lt_one R))) in H4.
  rewrite CRmult_assoc in H4. rewrite CRinv_l in H4.
  rewrite CRmult_1_r in H4.
  apply (CRmult_lt_compat_r (fMod 1 (CRzero_lt_one R))) in H5.
  rewrite CRmult_assoc in H5. rewrite CRinv_l in H5.
  rewrite CRmult_1_r in H5.
  2: apply (fst fUC).
  2: apply (fst fUC). apply CRltEpsilon.
  destruct (Z.le_gt_cases i 0).
  - (* i <= 0 *)
    clear H4. apply CRltForget.
    apply (CRlt_le_trans _ (CRabs _ (f a) + 1)).
    apply (CRplus_lt_reg_r (-CRabs _ (f a))).
    rewrite (CRplus_comm (CRabs _ (f a))), CRplus_assoc.
    rewrite CRplus_opp_r, CRplus_0_r.
    apply (CRle_lt_trans _ _ _ (CRabs_triang_inv _ _)).
    apply (H _ _ (CRzero_lt_one R)).
    rewrite CRabs_right. apply (CRmult_lt_reg_r (CR_of_Q R 2)).
    apply CR_of_Q_pos; reflexivity.
    apply (CRlt_le_trans _ _ _ H5). rewrite CRmult_comm.
    apply CRmult_le_compat_l. apply CRlt_asym, (fst fUC).
    rewrite <- (CRplus_0_l (CR_of_Q R 2)), <- CRplus_assoc.
    apply CRplus_le_compat. 2: apply CRle_refl.
    rewrite CRplus_0_r. apply CR_of_Q_le.
    unfold Qle,Qnum,Qden. simpl. rewrite Z.mul_1_r. exact H3.
    apply CRle_minus. exact H1.
    rewrite (UniformContProper
               f fMod fUC _ (a + INR 0 * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2))).
    apply CRplus_le_compat. 2: apply CRle_refl.
    apply maxouSpec, le_0_n. unfold INR, Z.of_nat.
    rewrite CRmult_0_l, CRmult_0_l, CRplus_0_r. reflexivity.
  - (* 0 < i *)
    apply CRltForget.
    apply (CRlt_le_trans
             _ (CRabs _ (f (a + CR_of_Q R (i#1) * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2))) + 1)).
    + apply (CRplus_lt_reg_l _
               (-CRabs _ (f (a + CR_of_Q R (i#1)
                                   * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2))))).
      rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_comm.
      apply (CRle_lt_trans _ _ _ (CRabs_triang_inv _ _)).
      apply (H _ _ (CRzero_lt_one R)).
      rewrite CRabs_right.
      apply (CRplus_lt_reg_r
               (a + CR_of_Q R (i#1) * (fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2)))).
      unfold CRminus.
      rewrite CRplus_assoc, <- CRmult_assoc, CRplus_opp_l, CRplus_0_r.
      rewrite CRplus_comm. apply (CRplus_lt_reg_l _ (-a)).
      do 2 rewrite <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l.
      rewrite CRplus_comm. apply (CRmult_lt_reg_r (CR_of_Q R 2)).
      apply CR_of_Q_pos; reflexivity.
      apply (CRlt_le_trans _ _ _ H5).
      do 2 rewrite CRmult_plus_distr_r. apply CRplus_le_compat.
      2: rewrite CRmult_comm; apply CRle_refl.
      do 2 rewrite CRmult_assoc. rewrite <- CR_of_Q_mult.
      setoid_replace ((1 # 2) * 2)%Q with 1%Q.
      rewrite CRmult_1_r, CRmult_comm. apply CRle_refl. reflexivity.
      unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc.
      apply (CRle_minus (CR_of_Q R (i # 1) * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1 # 2))
                        (x - a)).
      apply CRlt_asym, (CRmult_lt_reg_r (CR_of_Q R 2)).
      apply CR_of_Q_pos; reflexivity.
      do 2 rewrite CRmult_assoc. rewrite <- CR_of_Q_mult.
      setoid_replace ((1 # 2) * 2)%Q with 1%Q.
      rewrite CRmult_1_r. exact H4. reflexivity.
    + clear H5. apply CRplus_le_compat. 2: apply CRle_refl.
      unfold INR in maxouSpec.
      destruct i. exfalso; inversion H3. 2: exfalso; inversion H3.
      specialize (maxouSpec (Pos.to_nat p) k).
      rewrite positive_nat_Z in maxouSpec. apply maxouSpec.
      apply (CRmult_lt_compat_r (fMod 1 (CRzero_lt_one R))) in kmaj.
      rewrite CRmult_assoc, CRinv_l, CRmult_1_r in kmaj.
      2: apply (fst fUC).
      assert ((x-a)*CR_of_Q R 2 <= (b-a)*CR_of_Q R 2).
      { apply CRmult_le_compat_r.
        apply CR_of_Q_le; discriminate.
        apply CRplus_le_compat. exact H2. apply CRle_refl. }
      apply (CRlt_le_trans _ _ _ H4) in H5. clear H4.
      apply (CRlt_trans _ _ _ H5) in kmaj. clear H5.
      apply CRmult_lt_reg_r in kmaj. 2: apply (fst fUC).
      destruct (Q_dec (Z.pos p # 1) (Z.of_nat k # 1)). destruct s.
      unfold Qlt, Qnum, Qden in q.
      apply le_S_n. apply (le_trans _ k).
      apply Nat2Z.inj_lt. rewrite positive_nat_Z.
      do 2 rewrite Z.mul_1_r in q. exact q.
      apply le_S, le_refl. exfalso. apply (CR_of_Q_lt R) in q.
      exact (CRlt_asym _ _ q kmaj). exfalso.
      rewrite q in kmaj. exact (CRlt_asym _ _ kmaj kmaj).
Qed.

Definition CSUC_bounded {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R)
           (a b : CRcarrier R) (fMod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R)
           (fCSUC : CSUC f a b fMod)
  : a <= b -> { B : CRcarrier R & forall x:CRcarrier R, CRabs _ (f x) < B }.
Proof.
  intros. destruct fCSUC as [H0 H1].
  destruct (UC_bounded f (a-1) (b+1) fMod H0) as [B Bmaj].
  apply Rminus_plus_one_lower. apply H. exists B.
  assert (0 < B) as Bpos.
  { specialize (Bmaj a). apply (CRle_lt_trans _ (CRabs _ (f a))).
    apply CRabs_pos. apply Bmaj.
    apply CRlt_asym, Rminus_pos_lower. apply CRzero_lt_one.
    apply (CRle_trans _ b _ H).
    apply CRlt_asym, Rplus_pos_higher. apply CRzero_lt_one. }
  intros. destruct (CRltLinear R).
  destruct (s (a-1) x a (Rminus_pos_lower a 1 (CRzero_lt_one R))).
  - destruct (s b x (b+1) (Rplus_pos_higher b 1 (CRzero_lt_one R))).
    rewrite H1. rewrite CRabs_right. apply Bpos.
    apply CRle_refl.
    right. exact c0. apply Bmaj. apply CRlt_asym, c.
    apply CRlt_asym, c0.
  - rewrite H1. rewrite CRabs_right. apply Bpos.
    apply CRle_refl. left. exact c.
Qed.

(* Used to zoom in subdomains in the proof of Icontinuous below *)
Lemma CSUC_func_mult_stable
  : forall {R : ConstructiveReals} (f g : CRcarrier R -> CRcarrier R) (a b : CRcarrier R)
      (modF modG : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    CSUC f a b modF
    -> a <= b
    -> UniformCont g modG
    -> { modFG : forall x:CRcarrier R, 0 < x -> CRcarrier R
      & CSUC (fun x => f x * g x) a b modFG }.
Proof.
  intros.
  destruct (CSUC_bounded f a b modF H H0)
    as [Bf majf].
  destruct H. assert (0 < Bf) as Bfpos.
  { specialize (majf a). apply (CRle_lt_trans _ (CRabs _ (f a))).
    apply CRabs_pos. apply majf. }
  destruct (UC_bounded g (a-1) (b+1) modG H1 (Rminus_plus_one_lower a b H0))
    as [Bg majg].
  assert (0 < Bg) as Bgpos.
  { specialize (majg a). apply (CRle_lt_trans _ (CRabs _ (g a))).
    apply CRabs_pos. apply majg.
    apply CRlt_asym, Rminus_pos_lower. apply CRzero_lt_one.
    apply (CRle_trans _ b _ H0).
    apply CRlt_asym, Rplus_pos_higher. apply CRzero_lt_one. }
  assert (forall eps:CRcarrier R, 0 < eps -> 0 < eps * CR_of_Q R (1#2) * (CRinv R Bg (inr Bgpos))).
  { intros. apply CRmult_lt_0_compat.
    apply CRmult_lt_0_compat. exact H.
    apply CR_of_Q_pos; reflexivity.
    apply CRinv_0_lt_compat, Bgpos. }
  assert (forall eps:CRcarrier R, 0 < eps -> 0 < eps * CR_of_Q R (1#2) * (CRinv R Bf (inr Bfpos))).
  { intros. apply CRmult_lt_0_compat.
    apply CRmult_lt_0_compat. exact H2.
    apply CR_of_Q_pos; reflexivity.
    apply CRinv_0_lt_compat, Bfpos. }
  exists (fun eps epsPos => CRmin (modF (eps * CR_of_Q R (1#2) * CRinv R Bg (inr Bgpos))
                                    (H eps epsPos))
                              (modG (eps * CR_of_Q R (1#2) * CRinv R Bf (inr Bfpos))
                                    (H2 eps epsPos))).
  split. split.
  - intros. apply CRmin_lt. apply (fst u). apply (fst H1).
  - intros. destruct (CRltLinear R).
    destruct (s (a-1) x a (Rminus_pos_lower a 1 (CRzero_lt_one R))).
    + destruct (s b x (b+1) (Rplus_pos_higher b 1 (CRzero_lt_one R))).
      (* x is out to the right. *)
      destruct (s (a-1) y a (Rminus_pos_lower a 1 (CRzero_lt_one R))).
      destruct (s b y (b+1) (Rplus_pos_higher b 1 (CRzero_lt_one R))).
      rewrite c,c. do 2 rewrite CRmult_0_l.
      unfold CRminus. rewrite CRplus_0_l. rewrite CRopp_0.
      rewrite CRabs_right. apply epsPos.
      apply CRle_refl. right. exact c3. right. exact c1.
      (* y is inside *)
      specialize (c x (inr c1)).
      setoid_replace (f x * g x - f y * g y) with ((f x - f y) * g y).
      2: rewrite c.
      rewrite CRabs_mult. rewrite CRmult_comm.
      apply (CRle_lt_trans _ (Bg * CRabs _ (f x - f y))).
      apply CRmult_le_compat_r. apply CRabs_pos.
      apply CRlt_asym, majg.
      apply CRlt_asym, c2. apply CRlt_asym, c3.
      apply (CRlt_le_trans _ (Bg * (eps * CR_of_Q R (1#2) * CRinv R Bg (inr Bgpos)))).
      apply CRmult_lt_compat_l. apply Bgpos. destruct u.
      apply (c5 _ _ _ (H _ epsPos)).
      apply (CRlt_le_trans _ _ _ H3). apply CRmin_l.
      rewrite CRmult_comm, CRmult_assoc, CRinv_l, CRmult_1_r.
      rewrite <- (CRmult_1_r eps), CRmult_assoc.
      apply CRmult_le_compat_l. apply CRlt_asym, epsPos.
      rewrite CRmult_1_l. apply CR_of_Q_le; discriminate.

      unfold CRminus. rewrite CRmult_0_l, CRplus_0_l, CRplus_0_l.
      apply CRopp_mult_distr_l.
      (* y < a *)
      rewrite c, c.
      do 2 rewrite CRmult_0_l.
      unfold CRminus. rewrite CRplus_0_l. rewrite CRopp_0.
      rewrite CRabs_right. apply epsPos.
      apply CRle_refl. left. exact c2. right. exact c1.

      (* x is inside *)
      setoid_replace (f x * g x - f y * g y)
        with (g x * (f x - f y) + f y *(g x - g y)).
      apply (CRle_lt_trans _ _ _ (CRabs_triang _ _)).
      setoid_replace eps
        with (eps*CR_of_Q R (1#2) + eps*CR_of_Q R (1#2)).
      apply CRplus_le_lt_compat. apply CRlt_asym.
      * (* delta f *) rewrite CRabs_mult.
        apply (CRle_lt_trans _ (Bg * CRabs _ (f x - f y))).
        apply CRmult_le_compat_r. apply CRabs_pos.
        apply CRlt_asym, majg.
        apply CRlt_asym, c0. apply CRlt_asym, c1.
        apply (CRlt_le_trans
                 _ (Bg * (eps * CR_of_Q R (1#2) * CRinv R Bg (inr Bgpos)))).
        apply CRmult_lt_compat_l. apply Bgpos. destruct u.
        apply (c3 _ _ _ (H _ epsPos)).
        apply (CRlt_le_trans _ _ _ H3). apply CRmin_l.
        rewrite CRmult_comm, CRmult_assoc, CRinv_l.
        rewrite CRmult_1_r. apply CRle_refl.
      * (* delta g *) rewrite CRabs_mult.
        apply (CRle_lt_trans _ (Bf * CRabs _ (g x - g y))).
        apply CRmult_le_compat_r. apply CRabs_pos.
        apply CRlt_asym, majf.
        apply (CRlt_le_trans
                 _ (Bf * (eps *CR_of_Q R (1#2) * CRinv R Bf (inr Bfpos)))).
        apply CRmult_lt_compat_l. apply Bfpos. destruct H1.
        apply (c3 _ _ _ (H2 _ epsPos)).
        apply (CRlt_le_trans _ _ _ H3). apply CRmin_r.
        rewrite CRmult_comm, CRmult_assoc, CRinv_l.
        rewrite CRmult_1_r. apply CRle_refl.
      * rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus.
        setoid_replace ((1#2) + (1#2))%Q with 1%Q.
        rewrite CRmult_1_r. reflexivity. reflexivity.
      * unfold CRminus. do 2 rewrite CRmult_plus_distr_l.
        rewrite CRplus_assoc. apply CRplus_morph.
        apply CRmult_comm. rewrite <- CRplus_assoc, (CRmult_comm (g x)).
        rewrite <- CRmult_plus_distr_r, CRplus_opp_l, CRmult_0_l.
        rewrite CRplus_0_l, CRopp_mult_distr_r. reflexivity.
    + (* x is out to the left. *)
      destruct (s (a-1) y a (Rminus_pos_lower a 1 (CRzero_lt_one R))).
      destruct (s b y (b+1) (Rplus_pos_higher b 1 (CRzero_lt_one R))).
      * rewrite c,c. do 2 rewrite CRmult_0_l.
        unfold CRminus. rewrite CRplus_0_l. rewrite CRopp_0.
        rewrite CRabs_right. apply epsPos.
        apply CRle_refl. right. exact c2. left. exact c0.
      * (* y is inside *)
        specialize (c x (inl c0)).
        setoid_replace (f x * g x - f y * g y)
          with ((f x - f y) * g y).
        2: rewrite c.
        rewrite CRabs_mult. rewrite CRmult_comm.
        apply (CRle_lt_trans _ (Bg * CRabs _ (f x - f y))).
        apply CRmult_le_compat_r. apply CRabs_pos.
        apply CRlt_asym, majg.
        apply CRlt_asym, c1. apply CRlt_asym, c2.
        apply (CRlt_le_trans
                 _ (Bg * (eps * CR_of_Q R (1#2) * CRinv R Bg (inr Bgpos)))).
        apply CRmult_lt_compat_l. apply Bgpos. destruct u.
        apply (c4 _ _ _ (H _ epsPos)).
        apply (CRlt_le_trans _ _ _ H3). apply CRmin_l.
        rewrite CRmult_comm, CRmult_assoc, CRinv_l.
        rewrite CRmult_1_r.
        rewrite <- (CRmult_1_r eps), CRmult_assoc.
        apply CRmult_le_compat_l. apply CRlt_asym, epsPos.
        rewrite CRmult_1_l. apply CR_of_Q_le; discriminate.
        rewrite CRmult_0_l. unfold CRminus. do 2 rewrite CRplus_0_l.
        rewrite CRopp_mult_distr_l. reflexivity.
      * rewrite c,c. do 2 rewrite CRmult_0_l.
        unfold CRminus. rewrite CRplus_0_l. rewrite CRopp_0.
        rewrite CRabs_right. apply epsPos.
        apply CRle_refl. left. exact c1. left. exact c0.
  - intros. destruct H3. rewrite c, CRmult_0_l. reflexivity.
    left. exact c0. rewrite c, CRmult_0_l. reflexivity.
    right. exact c0.
Qed.

Lemma Rplus_lt_epsilon : forall {R : ConstructiveReals} (a b c d : CRcarrier R),
    (a + b) < (c + d)  ->  sum (a < c) (b < d).
Proof.
  intros. destruct (CRltLinear R). destruct (s (a+b) (a+d) (c+d) H).
  - right. apply CRplus_lt_reg_l in c0. exact c0.
  - left. apply CRplus_lt_reg_r in c0. exact c0.
Qed.

Lemma EnlargePointMajorationZero
  : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (x : CRcarrier R)
      (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    UniformCont f modF
    -> 0 < f x
    -> { eta : CRcarrier R & prod (0 < eta) (forall y:CRcarrier R, CRabs _ (x-y) < eta -> 0 < (f y)) }.
Proof.
  intros. destruct H as [H H1]. exists (modF (f x) H0).
  split.
  - apply H.
  - intros. specialize (H1 (f x) x y H0 H2).
    apply (CRle_lt_trans _ _ _ (CRle_abs _)) in H1.
    apply (CRplus_lt_reg_l _ (f x - f y)).
    rewrite CRplus_0_r. unfold CRminus.
    rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r.
    exact H1.
Qed.

Lemma EnlargePointMajoration
  : forall {R : ConstructiveReals} (f g : CRcarrier R -> CRcarrier R) (x : CRcarrier R)
      (modF modG : forall x:CRcarrier R, 0 < x -> CRcarrier R),
    UniformCont f modF
    -> UniformCont g modG
    -> f x < g x
    -> { eta : CRcarrier R & prod (0 < eta) (forall y:CRcarrier R, CRabs _ (x-y) < eta -> f y < g y) }.
Proof.
  intros.
  pose proof (UC_scale f modF (-(1)) H).
  pose proof (UC_plus (fun x => -(1)*f x) g _ modG H2 H0).
  destruct (EnlargePointMajorationZero (fun t => -(1)*f t + g t) x _ H3).
  rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r. rewrite CRmult_1_l.
  apply (CRplus_lt_reg_l _ (f x)).
  rewrite <- CRplus_assoc, CRplus_opp_r.
  rewrite CRplus_0_l, CRplus_0_r. exact H1.
  exists x0. destruct p. split. exact c. intros.
  specialize (c0 y H4). apply (CRplus_lt_compat_l _ (f y)) in c0.
  rewrite CRplus_0_r in c0.
  setoid_replace (g y) with (f y + (- (1) * f y + g y)).
  exact c0. rewrite <- CRopp_mult_distr_l, CRmult_1_l.
  rewrite <- CRplus_assoc, CRplus_opp_r. rewrite CRplus_0_l. reflexivity.
Qed.