Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.reals.CRreal.
From Coq Require Import Utf8 Program.
Require Import CoRN.reals.fast.CRArith CoRN.reals.fast.CRabs
 CoRN.tactics.Qauto.
From Coq Require Import Qround.
Require Import CoRN.model.metric2.Qmetric
 (*stdlib_omissions.P
 stdlib_omissions.Z
 stdlib_omissions.Q
 stdlib_omissions.N*).

Require Qinf QnonNeg QnnInf CRball.
Import
  QnonNeg Qinf.notations QnonNeg.notations QnnInf.notations CRball.notations
  Qinf.coercions
  Qabs propholds.

Require Import CoRN.ode.metric CoRN.ode.FromMetric2 CoRN.ode.AbstractIntegration CoRN.ode.SimpleIntegration CoRN.ode.BanachFixpoint.
Require Import MathClasses.interfaces.canonical_names MathClasses.misc.decision MathClasses.misc.setoid_tactics MathClasses.misc.util.
Require Import MathClasses.implementations.stdlib_rationals MathClasses.theory.rationals.
Close Scope uc_scope. (* There is a leak in some module *)
Open Scope signature_scope. (* To interpret "==>" *)

Bind Scope mc_scope with Q.

Local Notation ball := mspc_ball.

Lemma Qinf_lt_le (x y : Qinf) : x < y → x ≤ y.
Proof.
destruct x as [x |]; destruct y as [y |]; [| easy..].
change (x < y -> x ≤ y). intros; solve_propholds.
Qed.

#[global]
Instance Q_nonneg (rx : QnonNeg) : PropHolds (@le Q _ 0 (proj1_sig rx)).
Proof. intros. apply (proj2_sig rx). Qed.

#[global]
Instance Q_nonempty : NonEmpty Q := inhabits 0.

#[global]
Program Instance sig_nonempty `{ExtMetricSpaceClass X}
  (r : QnonNeg) (x : X) : NonEmpty (sig (ball (proj1_sig r) x)) := inhabits x.
Next Obligation. apply mspc_refl; solve_propholds. Qed.

#[global]
Instance prod_nonempty `{NonEmpty X, NonEmpty Y} : NonEmpty (X * Y).
Proof.
(* In order not to refer to the name of the variable that has type NonEmpty X *)
match goal with H : NonEmpty X |- _ => destruct H as [x] end.
match goal with H : NonEmpty Y |- _ => destruct H as [y] end.
exact (inhabits (x, y)).
Qed.

(* The following instances are needed to show that Lipschitz functions are
uniformly continuous: metric.lip_uc *)
Global Instance Qmsd : MetricSpaceDistance Q := λ x y, abs (x - y).

Global Instance Qmsc
  : @MetricSpaceClass Q (msp_mspc_ball Q_as_MetricSpace)
                      (msp_mspc_ball_ext Q_as_MetricSpace) Qmsd.
Proof.
  intros x1 x2; apply gball_Qabs; reflexivity.
Qed.

(*Instance Q_nonempty : NonEmpty Q := inhabits 0%Q.*)

Section Extend.

Context `{ExtMetricSpaceClass Y} (a : Q) (r : QnonNeg).

(* Sould [r] be [Q] or [QnonNeg]? If [r : Q], then [extend] below is not
necessarily continuous. This may be OK because we could add the premise [0
≤ r] to the lemma that says that [extend] is Lipschitz. However, the
definition below is not well-typed because if [r < 0], then [ball r a (a -
r)] is false, so we can't apply [f] to [a - r]. So we assume [r : QnonNeg]. *)

Lemma mspc_ball_edge_l
  : @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a (a - `r).
Proof.
destruct r as [e ?]; simpl.
apply gball_Qabs. mc_setoid_replace (a - (a - e)) with e by ring.
change (abs e ≤ e). rewrite abs.abs_nonneg; [reflexivity | trivial].
Qed.

Lemma mspc_ball_edge_r
  : @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a (a + `r).
Proof.
destruct r as [e ?]; simpl.
apply Qmetric.gball_Qabs. mc_setoid_replace (a - (a + e)) with (-e) by ring.
change (abs (-e) ≤ e). rewrite abs.abs_negate, abs.abs_nonneg; [reflexivity | trivial].
Qed.

Context (f : sig (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a) -> Y).

(* Since the following is a Program Definition, we could write [f (a - r)]
and prove the obligation [mspc_ball r a (a - r)]. However, this obligation
would depend on x and [H1 : x ≤ a - r] even though they are not used in the
proof. So, if [H1 : x1 ≤ a - r] and [H2 : x2 ≤ a - r], then [extend x1]
would reduce to [f ((a - r) ↾ extend_obligation_1 x1 H1)] and [extend x2]
would reduce to [f ((a - r) ↾ extend_obligation_1 x2 H2)]. To apply
mspc_refl (see [extend_uc] below), we would need to prove that these
applications of f are equal, i.e., f is a morphism that does not depend on
the second component of the pair. So instead we prove mspc_ball_edge_l and
mspc_ball_edge_r, which don't depend on x. *)

Program Definition extend : Q -> Y :=
  λ x, if (decide (x < a - (proj1_sig r)))
       then f ((a - (r : Q)) ↾ mspc_ball_edge_l)
       else if (decide (a + r < x))
            then f ((a + r) ↾ mspc_ball_edge_r)
            else f (x ↾ _).
Next Obligation.
apply mspc_ball_Qle.
repeat match goal with [ H : ¬ _ < _ |- _ ] => apply orders.not_lt_le_flip in H end.
now split.
Qed.

(*
Global Instance extend_lip `{!IsLipschitz f L} : IsLipschitz extend L.
Proof with (assumption || (apply orders.le_flip; assumption) || reflexivity).
constructor; [apply (lip_nonneg f L) |].
intros x1 x2 e A.
assert (0 ≤ e) by now apply (radius_nonneg x1 x2).
assert (0 ≤ L) by apply (lip_nonneg f L).
assert (a - proj1_sig r ≤ a + proj1_sig r) by
  (destruct r; simpl; transitivity a;
    [apply rings.nonneg_minus_compat | apply semirings.plus_le_compat_r]; (easy || reflexivity)).
unfold extend.
destruct (decide (x1 ≤ a - proj1_sig r)); destruct (decide (x2 ≤ a - proj1_sig r)).
* apply mspc_refl; solve_propholds.
* destruct (decide (a + proj1_sig r ≤ x2));  apply (lip_prf f L).
  + apply (nested_balls A)...
  + apply (nested_balls A)...
* destruct (decide (a + proj1_sig r ≤ x1)); apply (lip_prf f L).
  + apply mspc_symm; apply mspc_symm in A. apply (nested_balls A)...
  + apply mspc_symm; apply mspc_symm in A. apply (nested_balls A)...
* destruct (decide (a + proj1_sig r ≤ x1)); destruct (decide (a + proj1_sig r ≤ x2));
  apply (lip_prf f L).
  + apply mspc_refl; solve_propholds.
  + apply mspc_symm; apply mspc_symm in A. apply (nested_balls A)...
  + apply (nested_balls A)...
  + apply A.
Qed.
*)

Global Instance extend_uc : ∀ mu_f : Q → Qinf,
         @IsUniformlyContinuous _
           (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f
         → @IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) Y H extend mu_f.
Proof with (solve_propholds || (apply orders.not_lt_le_flip; assumption) || reflexivity).
  intros. constructor.
  apply (@uc_pos _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f). exact H1.
intros e x1 x2 e_pos A.
assert (a - proj1_sig r ≤ a + proj1_sig r) by
  (destruct r; simpl; transitivity a;
    [apply rings.nonneg_minus_compat | apply semirings.plus_le_compat_r]; (easy || reflexivity)).
unfold extend.
destruct (decide (x1 < a - proj1_sig r)); destruct (decide (x2 < a - proj1_sig r)).
* apply mspc_refl...
* destruct (decide (a + proj1_sig r < x2));
  apply (@uc_prf _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f); trivial.
  + apply (nested_balls _ _ A)...
  + apply (nested_balls _ _ A)...
* destruct (decide (a + proj1_sig r < x1));
    apply (@uc_prf _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f); trivial.
  + apply @mspc_symm.
    exact (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig r) a)).
    apply @mspc_symm in A.
    apply (nested_balls _ _ A)...
    exact (msp_mspc_ball_ext Q_as_MetricSpace).
  + apply @mspc_symm.
    exact (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig r) a)).
    apply @mspc_symm in A.
    apply (nested_balls _ _ A)...
    exact (msp_mspc_ball_ext Q_as_MetricSpace).
* destruct (decide (a + proj1_sig r < x1)); destruct (decide (a + proj1_sig r < x2));
  apply (@uc_prf _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f); trivial.
  + apply @mspc_refl'.
    exact (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig r) a)).
    apply Qinf_lt_le.
    apply (@uc_pos _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f). assumption. assumption. 
  + apply @mspc_symm.
    exact (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig r) a)).
    apply @mspc_symm in A.
    apply (nested_balls _ _ A)...
    exact (msp_mspc_ball_ext Q_as_MetricSpace).
  + apply (nested_balls _ _ A)...
Qed.

End Extend.

Lemma extend_inside
: ∀ {Y : CProp} {H : MetricSpaceBall Y} { _ : @ExtMetricSpaceClass Y H },
  ∀ (a x : Q) (r : QnonNeg),
    @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a x
    → ∃ p : @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a x,
    ∀ f : sig (fun x : Q => @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a x) → Y,
      @extend Y a r f x = f (x ↾ p).
Proof.
  intros Y H H0 a x r A. 
  apply mspc_ball_Qle in A. destruct A as [A1 A2]. unfold extend.
destruct (decide (x < a - proj1_sig r)) as [H1 | H1].
(* [proj1_sig] is needed because otherwise [Negate QnonNeg] is unsatisfied.
Backtick [`] is not enough because the goal is not simplified. *)
* apply orders.lt_not_le_flip in H1; elim (H1 A1).
* destruct (decide (a + proj1_sig r < x)) as [H2 | H2].
  + apply orders.lt_not_le_flip in H2; elim (H2 A2).
  + eexists; intro f; reflexivity.
Qed.

Section Bounded.

Class Bounded {X : Type} (f : X -> CR) (M : Q) := bounded : forall x, abs (f x) ≤ 'M.

Global Instance comp_bounded {X Y : Type} (f : X -> Y) (g : Y -> CR)
  `{!Bounded g M} : Bounded (g ∘ f) M.
Proof. intro x; unfold Basics.compose; apply bounded. Qed.

Global Instance extend_bounded {a : Q} {r : QnonNeg}
       (f : {x | @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a x} -> CR)
  `{!Bounded f M} : Bounded (extend a r f) M.
Proof.
intro x. unfold extend.
destruct (decide (x < a - proj1_sig r));
  [| destruct (decide (a + proj1_sig r < x))]; apply bounded.
Qed.

Lemma bounded_nonneg {X : Type} (f : X -> CR) `{!Bounded f M} `{NonEmpty X} :
  (*PropHolds*) (0 ≤ M).
Proof.
match goal with H : NonEmpty X |- _ => destruct H as [x] end.
apply CRle_Qle. change (@zero CR _  ≤ 'M). transitivity (abs (f x)).
+ apply CRabs_nonneg.
+ apply bounded.
Qed.

End Bounded.

Global Instance bounded_int_uc {f : Q -> CR} {M : Q}
       `{!Bounded f M}
       `{!@IsUniformlyContinuous
          Q (msp_mspc_ball Q_as_MetricSpace) 
          CR (msp_mspc_ball CR) 
          f mu_f} (x0 : Q) :
  @IsUniformlyContinuous
    Q (msp_mspc_ball Q_as_MetricSpace) 
    CR (msp_mspc_ball CR) 
    (λ x, int f x0 x) (lip_modulus M).
Proof.
constructor.
+ intros. apply lip_modulus_pos; [apply (bounded_nonneg f) | easy].
+ intros e x1 x2 e_pos A. apply mspc_ball_CRabs.
  pose proof (CRabs_wd _ _ (int_diff f x0 x1 x2)).
  rewrite H0. clear H0.
  transitivity ('(abs (x1 - x2) * M)).
  - apply int_abs_bound; [apply _ |]. intros x _; apply bounded.
  - apply CRle_Qle. change (abs (x1 - x2) * M ≤ e).
    unfold lip_modulus in A. destruct (decide (M = 0)) as [E | E].
    rewrite E, rings.mult_0_r. now apply orders.lt_le. (* why does [solve_propholds] not work? *)
    apply mspc_ball_Qabs in A. assert (0 ≤ M) by apply (bounded_nonneg f).
    apply (orders.order_preserving (.* M)) in A.
    now mc_setoid_replace (e / M * M) with e in A by (field; solve_propholds).
Qed.

Section Picard.

Context (x0 : Q) (y0 : CR) (rx ry : QnonNeg).

Notation sx := (sig (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0)).
Notation sy := (sig (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0)).

Context (v : sx * sy -> CR) `{!Bounded v M}
        `{!@IsUniformlyContinuous
           _ (@Linf_product_metric_space_ball
                _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball r a))
                _ (@sig_mspc_ball CR (msp_mspc_ball CR) (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0)) )
           CR (msp_mspc_ball CR) 
           v mu_v} (L : Q).

Hypothesis v_lip : forall x : sx, IsLipschitz (λ y, v (x, y)) L.

Hypothesis L_rx : L * (proj1_sig rx) < 1.

Context {rx_M : PropHolds (`rx * M ≤ proj1_sig ry)}.

Instance L_nonneg : PropHolds (0 ≤ L).
Proof.
  assert (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0 x0) as B.
  { apply @mspc_refl.
    exact (msp_mspc_ball_ext Q_as_MetricSpace).
    solve_propholds. }
  apply (lip_nonneg (λ y, v ((x0 ↾ B), y)) L).
Qed.

(* Needed to apply Banach fixpoint theorem, which requires a finite
distance between any two points *)
Global Instance uc_msd
     : MetricSpaceDistance
         (@UniformlyContinuous
            sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace)
                              (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0))
            sy
            (@sig_mspc_ball CR (msp_mspc_ball CR) (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0)))
  := λ f1 f2, 2 * proj1_sig ry.

Global Instance uc_msc
  : @MetricSpaceClass
      _ _
      (@Linf_func_metric_space_class sx sy
            _ _ 
            (@sig_nonempty Q (msp_mspc_ball Q_as_MetricSpace)
               (msp_mspc_ball_ext Q_as_MetricSpace) rx x0)
            _ _)
      uc_msd.
Proof.
  intros f1 f2. unfold msd, uc_msd. intro x.
  apply (@mspc_triangle' CR (msp_mspc_ball CR)
                         (msp_mspc_ball_ext CR) (proj1_sig ry) (proj1_sig ry) y0).
+ change (proj1_sig ry + proj1_sig ry = 2 * (proj1_sig ry)). ring.
+ apply mspc_symm; apply (proj2_sig (func f1 x)).
+ apply (proj2_sig (func f2 x)).
Qed.

(*Check _ : MetricSpaceClass sx.
Check _ : IsUniformlyContinuous v _.

Context (f : sx -> sy) `{!IsUniformlyContinuous f mu_f}.

Check _ : IsUniformlyContinuous ((@Datatypes.id sx) ∘ (@Datatypes.id sx)) _.

Check _ : IsUniformlyContinuous (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) _.

Check _ : IsLocallyUniformlyContinuous (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) _*)
Definition picard' (f : sx -> sy)
           `{!@IsUniformlyContinuous
              sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
              sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))
              f mu_f} : Q -> CR :=
  λ x, y0 +
       @int (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag))
(@Integral_instance_0
   (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag))
       _
       (@uc_ulc Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR)
                (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag))
          _
          (@extend_uc CR (msp_mspc_ball CR) (msp_mspc_ball_ext CR) x0 rx
             _ _
             (@compose_uc sx 
                (sx and sx) CR
                (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                (@Linf_product_metric_space_ball sx 
                   (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                   sx
                   (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)))
                (@Linf_product_metric_space_class sx
                   (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                   (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                      (msp_mspc_ball_ext Q_as_MetricSpace) 
                      (ball (proj1_sig rx) x0)) sx
                   (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                   (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                      (msp_mspc_ball_ext Q_as_MetricSpace) 
                      (ball (proj1_sig rx) x0))) (msp_mspc_ball CR)
                (@diag sx)
                (v
                 ∘ @together sx sx sx sy
                     (@Datatypes.id sx) f) 
                (lip_modulus 1)
                (@comp_inf Q Qinf
                   (λ e : Q,
                      @minmax.min Qinf Qinf_le metric.Decision_instance_0
                        (lip_modulus 1 e) (mu_f e)) mu_v Qinf.infinite)
                (@lip_uc sx
                   (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                   (sx and sx)
                   (@Linf_product_metric_space_ball sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)))
                   (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                      (msp_mspc_ball_ext Q_as_MetricSpace) 
                      (ball (proj1_sig rx) x0)) (@sig_msd Q (ball (proj1_sig rx) x0) Qmsd)
                   (@sig_mspc_distance Q_as_MetricSpace
                      (msp_mspc_ball Q_as_MetricSpace)
                      (msp_mspc_ball_ext Q_as_MetricSpace) 
                      (ball (proj1_sig rx) x0) Qmsd Qmsc)
                   (@Linf_product_metric_space_class sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig rx) x0)) sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig rx) x0))) (@diag sx) 1
                   (@diag_lip sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig rx) x0))))
                (@compose_uc (sx and sx)
                   (sx and sy) CR
                   (@Linf_product_metric_space_ball sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)))
                   (@Linf_product_metric_space_ball sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      sy
                      (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)))
                   (@Linf_product_metric_space_class sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig rx) x0)) sy
                      (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))
                      (@sig_mspc CR (msp_mspc_ball CR)
                         (msp_mspc_ball_ext CR) 
                         (ball (proj1_sig ry) y0))) (msp_mspc_ball CR)
                   (@together sx sx
                      sx sy
                      (@Datatypes.id sx) f) v
                   (λ e : Q,
                      @minmax.min Qinf Qinf_le metric.Decision_instance_0
                        (lip_modulus 1 e) (mu_f e)) mu_v
                   (@together_uc sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig rx) x0)) sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig rx) x0)) sx
                      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                      (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                         (msp_mspc_ball_ext Q_as_MetricSpace)
                         (ball (proj1_sig rx) x0)) sy
                      (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))
                      (@sig_mspc CR (msp_mspc_ball CR)
                         (msp_mspc_ball_ext CR) 
                         (ball (proj1_sig ry) y0)) (@Datatypes.id sx) f
                      (lip_modulus 1)
                      (@lip_uc sx
                         (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace)
                            (ball (proj1_sig rx) x0)) sx
                         (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace)
                            (ball (proj1_sig rx) x0))
                         (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                            (msp_mspc_ball_ext Q_as_MetricSpace)
                            (ball (proj1_sig rx) x0)) (@sig_msd Q (ball (proj1_sig rx) x0) Qmsd)
                         (@sig_mspc_distance Q_as_MetricSpace
                            (msp_mspc_ball Q_as_MetricSpace)
                            (msp_mspc_ball_ext Q_as_MetricSpace)
                            (ball (proj1_sig rx) x0) Qmsd Qmsc)
                         (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                            (msp_mspc_ball_ext Q_as_MetricSpace)
                            (ball (proj1_sig rx) x0)) (@Datatypes.id sx) 1
                         (@id_lip sx
                            (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace)
                               (ball (proj1_sig rx) x0))
                            (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace)
                               (msp_mspc_ball_ext Q_as_MetricSpace)
                               (ball (proj1_sig rx) x0)))) mu_f _)
                   _)))))

            x0 x.

(*
Variable f : UniformlyContinuous sx sy.
Check _ : IsUniformlyContinuous f _.
Check _ : IsLocallyLipschitz (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) _.
Check _ : Integral (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)).
Check _ : Integrable (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)).
Check _ : IsLocallyLipschitz (λ x : Q, int (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) x0 x) _.
Check _ : IsLocallyLipschitz (picard' f) _. Goal True.
assert (0 ≤ proj1_sig rx). apply (proj2_sig rx).
Check _ : PropHolds (0 ≤ proj1_sig rx).
Check _ : IsLipschitz (restrict (picard' f) x0 rx) _.
*)

Definition picard'' (f : @UniformlyContinuous sx
         (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
         sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) )
: @UniformlyContinuous sx
                       (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) CR
                       (msp_mspc_ball CR).
Proof.
  apply (@Build_UniformlyContinuous
           sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
           CR (msp_mspc_ball CR) 
           (@restrict Q (msp_mspc_ball Q_as_MetricSpace) CR (picard' f) x0 (proj1_sig rx))
           ((λ _ _ e : Q,
              @minmax.min Qinf Qinf_le metric.Decision_instance_0
                          (lip_modulus 0 (e / 2)) (lip_modulus M (e / 2))) x0 (proj1_sig rx))
           (@luc_prf Q (msp_mspc_ball Q_as_MetricSpace) CR 
                     (msp_mspc_ball CR)
                     _ _
                     (@uc_ulc Q (msp_mspc_ball Q_as_MetricSpace) CR 
                              (msp_mspc_ball CR)
                              _ _

                              (@sum_uc Q (msp_mspc_ball Q_as_MetricSpace)
                                       (msp_mspc_ball_ext Q_as_MetricSpace) 
                                       (λ _ : Q, y0) _ _ _ _ _))
                     x0 (proj1_sig rx))).
Defined.

(* Needed below to be able to apply (order_preserving (.* M)) *)
Instance M_nonneg : PropHolds (0 ≤ M)
  := @bounded_nonneg (sx and sy) v M Bounded0
  (@prod_nonempty sx 
     (@sig_nonempty Q (msp_mspc_ball Q_as_MetricSpace)
        (msp_mspc_ball_ext Q_as_MetricSpace) rx x0)
     sy (@sig_nonempty CR (msp_mspc_ball CR) (msp_mspc_ball_ext CR) ry y0)).

Lemma picard_sy (f : UniformlyContinuous sx sy) (x : sx) : ball (proj1_sig ry) y0 (picard'' f x).
Proof.
destruct x as [x x_sx]. unfold picard''; simpl.
unfold restrict, Basics.compose; simpl.
unfold picard'. apply mspc_ball_CRabs.
assert (forall b, CRabs (y0 - (y0 + b)) == abs b)%CR.
{ intro b. pose proof (CRabs_negate b).
  rewrite <- H0.
  apply CRabs_wd.
  transitivity (y0 + (-y0-b)).
  apply ucFun2_wd. reflexivity.
  exact (CRopp_plus_distr y0 b).
  rewrite plus_assoc.
  rewrite rings.plus_negate_r, rings.plus_0_l. reflexivity. } 
unfold abs, abs_sig, proj1_sig, CR_abs.
unfold negate, plus.
rewrite H0. clear H0.
transitivity ('(abs (x - x0) * M)).
+ apply int_abs_bound; [apply _ |]. (* Should not be required *)
  intros t A.
  assert (@mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0 t) as A1.
  apply (mspc_ball_convex x0 x).
  apply (@mspc_refl Q). exact (msp_mspc_ball_ext Q_as_MetricSpace).
  apply (proj2_sig rx). trivial. trivial.
  apply (extend_inside (Y:=CR)) in A1.
  destruct A1 as [p A1].
  specialize (A1 (v ∘ together Datatypes.id f ∘ diag)).
  pose proof (CRabs_wd _ _ A1). 
  rewrite H0. clear H0. apply bounded.
+ apply CRle_Qle. change (abs (x - x0) * M ≤ proj1_sig ry). transitivity (`rx * M).
  - now apply (orders.order_preserving (.* M)), mspc_ball_Qabs_flip.
  - apply rx_M.
Qed.

(*Require Import Integration.*)

Definition picard (f : @UniformlyContinuous sx
        (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
        sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)))
  : @UniformlyContinuous sx
           (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
           sy
           (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)).
Proof.
set (g := picard'' f).
set (h x := exist _ (g x) (picard_sy f x)).
assert (@IsUniformlyContinuous sx
      (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
      sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) h
      (@uc_mu sx
         (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) CR
         (msp_mspc_ball CR) g)) as C.
{ constructor.
  + exact (@uc_pos sx
                _ CR (msp_mspc_ball CR) g _
                (@uc_proof sx
                   (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                   CR (msp_mspc_ball CR) g)).
  + intros e x1 x2 e_pos A.
    exact (@uc_prf sx _ CR (msp_mspc_ball CR) g _
                  (@uc_proof sx
                     (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
                     CR (msp_mspc_ball CR) g) e x1 x2 e_pos A). }
exact (Build_UniformlyContinuous _ _ C).
Defined.

Global Instance picard_contraction : IsContraction picard (L * proj1_sig rx).
Proof.
constructor; [| exact L_rx].
constructor; [solve_propholds |].
intros f1 f2 e A [x ?].
change (ball (L * proj1_sig rx * e) (picard' f1 x) (picard' f2 x)).
unfold picard'. apply mspc_ball_CRplus_l, mspc_ball_CRabs.
rewrite <- abs_int_minus. transitivity ('(abs (x - x0) * (L * e))).
+ apply int_abs_bound; [apply _ |]. (* remove [apply _] *)
  intros x' B.
  assert (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0 x') as B1.
  { apply (mspc_ball_convex x0 x). apply (@mspc_refl Q).
    exact (msp_mspc_ball_ext Q_as_MetricSpace). 
    solve_propholds. trivial. trivial. }
  unfold plus, negate, ext_plus, ext_negate.
  apply (extend_inside (Y:=CR)) in B1. destruct B1 as [p B1].
  assert (forall i j k l : CR, i = j -> k = l -> CRabs (i-k) == CRabs (j-l))%CR.
  { intros. apply CRabs_wd.
    transitivity (i-l).
    apply ucFun2_wd. reflexivity.
    rewrite H1. reflexivity. 
    rewrite H0. reflexivity. }
  unfold negate,plus.
  unfold abs, abs_sig, CR_abs, proj1_sig.
  rewrite (H0 _ _ _ _ (B1 _) (B1 _)). clear H0.
  apply CRabs_ball.
  unfold diag, together, Datatypes.id, Basics.compose; simpl.

  specialize (v_lip (x' ↾ p)).
  pose proof (lip_prf (λ y, v (_, y)) L).
  apply H0, A.
+ apply CRle_Qle.
  mc_setoid_replace (L * proj1_sig rx * e) with ((proj1_sig rx) * (L * e)) by ring.
  assert (0 ≤ e).
  { apply (@radius_nonneg
             _ _
             (@Linf_func_metric_space_class
                sx sy _ _ 
                (@sig_nonempty Q
                               (msp_mspc_ball
                                  Q_as_MetricSpace)
                               (msp_mspc_ball_ext Q_as_MetricSpace) rx x0)
                _ _ ) 
             f1 f2 e A). } 
  change ((abs (x - x0) * (L * e)) ≤ ((proj1_sig rx) * (L * e))).
  apply (orders.order_preserving (.* (L * e))).
  now apply mspc_ball_Qabs_flip.
Qed.

Program Definition f0 :
 @UniformlyContinuous sx
        (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
        sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))
  :=
  Build_UniformlyContinuous (λ x, y0) (λ e, Qinf.infinite) _.
Next Obligation.
 eapply (mspc_refl (X:=CR)).
 solve_propholds. Qed.

Next Obligation.
constructor.
+ intros; easy.
+ intros e x1 x2 e_pos B. change (ball e y0 y0). apply mspc_refl; solve_propholds.
Qed.

Lemma ode_solution
  : let f := @fp _ _ _ uc_msd uc_msc _ picard (L * proj1_sig rx) picard_contraction f0 in
    picard f = f.
Proof. apply banach_fixpoint. Qed.

End Picard.

Import theory.rings orders.rings.

Section Computation.

Definition x0 : Q := 0.
Definition y0 : CR := 1.
Definition rx : QnonNeg := (1 # 2)%Qnn.
Definition ry : QnonNeg := 1.

Notation sx := (sig (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0)). (* Why does Coq still print {x | ball rx x0 x} in full? *)
Notation sy := (sig (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0)).

Definition v (z : sx * sy) : CR := ` (snd z).
Definition M : Q := 2.
Definition mu_v (e : Q) : Qinf := e.
Definition L : Q := 1.

Instance : Bounded v M.
Proof.
intros [x [y H]]. unfold v; simpl. unfold M, ry, y0 in *.
apply mspc_ball_CRabs in H.
pose proof (CRdistance_CRle 1 1 y) as [_ H1].
specialize (H1 H). destruct H1 as [H1 H2].
change (1 - 1 ≤ y) in H1. change (y ≤ 1 + 1) in H2. change (abs y ≤ 2).
rewrite plus_negate_r in H1. apply CRabs_AbsSmall. split; [| assumption].
change (-2 ≤ y). transitivity (0%mc : CR); [| easy]. rewrite <- negate_0.
apply flip_le_negate. apply (CRle_trans H1 H2).
Qed.

Instance : forall {r a}, @IsUniformlyContinuous
             _ (@Linf_product_metric_space_ball
                  _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball r a))
                  _ (@sig_mspc_ball CR (msp_mspc_ball CR) (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0)) )
           CR (msp_mspc_ball CR) 
           v mu_v.
Proof.
constructor.
* now intros.
* unfold mu_v. intros e z1 z2 e_pos H. now destruct H.
Qed.

Instance v_lip (x : sx) : IsLipschitz (λ y : sy, v (x, y)) L.
Proof.
constructor.
* unfold L. solve_propholds.
* intros y1 y2 e H. unfold L; rewrite mult_1_l. apply H.
Qed.

Lemma L_rx : L * proj1_sig rx < 1.
Proof.
unfold L, rx; simpl. rewrite mult_1_l. change (1 # 2 < 1)%Q. auto with qarith.
Qed.

Instance rx_M : PropHolds (proj1_sig rx * M ≤ proj1_sig ry).
Proof.
  unfold rx, ry, M; simpl.
  rewrite Qmake_Qdiv. change (1 * / 2 * 2 <= 1)%Q.
rewrite <- Qmult_assoc, Qmult_inv_l; [auto with qarith | discriminate].
Qed.

(*Notation ucf := (UniformlyContinuous sx sy).

Check _ : MetricSpaceBall ucf.
Check _ : ExtMetricSpaceClass ucf. (* Why two colons? *)
Check _ : MetricSpaceDistance ucf.
Check _ : MetricSpaceClass ucf.
Check _ : Limit ucf.*)
(* [Check _ : IsContraction (picard x0 y0 rx ry v rx_M) (L * rx)] At this point this does not work *)
(* The following is bad because it creates a proof different from
picard_contraction. Therefore, ode_solution cannot be applied. *)
(*
Instance : IsContraction (picard x0 y0 rx ry v rx_M) (L * rx).
Proof.
apply picard_contraction.
apply v_lip. (* Is this needed because there is an explicit argument before IsLipschitz in picard_contraction? *)
apply L_rx.
Qed.

Check _ : IsContraction (picard x0 y0 rx ry v rx_M) (L * rx).*)

Let f
  : @UniformlyContinuous
      sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
      sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))
  := @fp _ _
         (@Linf_func_metric_space_class
            sx sy
            (@UniformlyContinuous
               sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
               sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)))
            (@uniformly_continuous_func
               sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))
               sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)))
            (@sig_nonempty Q (msp_mspc_ball Q_as_MetricSpace)
                           (msp_mspc_ball_ext Q_as_MetricSpace) rx x0)
            (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))
            (@sig_mspc CR (msp_mspc_ball CR) (msp_mspc_ball_ext CR)
                       (ball (proj1_sig ry) y0)))
         (uc_msd x0 y0 rx ry) (uc_msc x0 y0 rx ry)
         _
         (@picard x0 y0 rx ry v M Bounded_instance_0 0 0 mu_v
                  IsUniformlyContinuous_instance_0 rx_M)
         _
         (@picard_contraction x0 y0 rx ry v M Bounded_instance_0 _ _ mu_v
                              IsUniformlyContinuous_instance_0 L v_lip L_rx rx_M)
         (f0 x0 y0 rx ry).

(* L_rx should also be declared implicit using Context and omitted from the list of arguments *)

(* When [IsContraction (picard x0 y0 rx ry v rx_M) (L * rx)] did not work,
the error message was 'Error: Cannot infer the implicit parameter H of
fp. Could not find an instance for [MetricSpaceBall (UniformlyContinuous sx sy)]'.
In fact, [MetricSpaceBall (UniformlyContinuous sx sy)] worked fine. *)

(* f is indeed the fixpoint *)

Theorem f_fixpoint :
  @picard x0 y0 rx ry v M Bounded_instance_0 0 0 mu_v
         IsUniformlyContinuous_instance_0 rx_M f = f.
Proof. apply ode_solution. Qed.

Definition picard_iter (n : nat) :=
  iter_nat n _
           (@picard x0 y0 rx ry v M Bounded_instance_0 0 0 mu_v
                    IsUniformlyContinuous_instance_0 rx_M)
           (f0 x0 y0 rx ry).

(* (* This takes too long to compile. *)
Definition answer (n : positive) (r : CR) : Z :=
 let m := (iter_pos n (Pmult 10) 1%positive) in
 let (a,b) := (approximate r (1#m)%Qpos)*m in
 Zdiv a b.

Program Definition half : sx := 1 # 2.
Next Obligation.
apply mspc_ball_Qabs_flip. unfold x0. rewrite negate_0, plus_0_r.
rewrite abs.abs_nonneg; [reflexivity |].
change (0 <= 1 # 2)%Q. auto with qarith.
Qed.

(*
Time Compute answer 2 (` (picard_iter 3 half)). (* 10 minutes *)
Time Compute answer 1 (` (f half)). (* Too long *)
*)
*)
End Computation.

