From Coq Require Import Program.Subset.
From Topology Require Export Nets.
From Topology Require Import Homeomorphisms SubspaceTopology.
From ZornsLemma Require Import EnsemblesTactics.

Definition T0_sep (X:TopologicalSpace) : Prop :=
  forall x y:point_set X, x <> y ->
  (exists U:Ensemble (point_set X), open U /\ In U x /\ ~ In U y) \/
  (exists U:Ensemble (point_set X), open U /\ ~ In U x /\ In U y).

Lemma topological_property_T0_sep : topological_property T0_sep.
Proof.
  intros X Y f [g Hcont_f Hcont_g Hgf Hfg] Hsep x y neq.
  destruct (Hsep (g x) (g y)) as [[U [Hopen [Hin H']]] | [U [Hopen [H' Hin]]]];
  [ shelve | left | right ];
    exists (inverse_image g U);
    repeat split;
    try apply Hcont_g;
    assumption + (intros [?]; contradiction).
  Unshelve.
  intro contra.
  eapply f_equal in contra.
  rewrite Hfg, Hfg in contra.
  contradiction.
Qed.

Definition T1_sep (X:TopologicalSpace) : Prop :=
  forall x:point_set X, closed (Singleton x).

Lemma topological_property_T1_sep : topological_property T1_sep.
Proof.
  intros X Y f [g Hcont_f Hcont_g Hgf Hfg] Hsep x.
  replace (Singleton x) with (inverse_image g (Singleton (g x))).
  - red.
    rewrite <- inverse_image_complement.
    apply Hcont_g.
    apply Hsep.
  - apply Extensionality_Ensembles.
    split;
      red;
      intros.
    + destruct H.
      inversion H.
      eapply f_equal in H1.
      rewrite Hfg, Hfg in H1.
      subst.
      constructor.
    + inversion H.
      subst.
      constructor.
      constructor.
Qed.

Definition Hausdorff (X:TopologicalSpace) : Prop :=
  forall x y:point_set X, x <> y ->
    exists U:Ensemble (point_set X),
    exists V:Ensemble (point_set X),
  open U /\ open V /\ In U x /\ In V y /\
  Intersection U V = Empty_set.
Definition T2_sep := Hausdorff.

Definition topological_property_Hausdorff :
  topological_property Hausdorff.
Proof.
  intros X Y f [g Hcont_f Hcont_g Hgf Hfg] Hhaus x y neq.
  destruct (Hhaus (g x) (g y)) as [U [V [HopenU [HopenV [HinU [HinV eq]]]]]].
  - intro contra.
    eapply f_equal in contra.
    now rewrite Hfg, Hfg in contra.
  - exists (inverse_image g U), (inverse_image g V).
    repeat split;
      try apply Hcont_g;
      trivial.
    erewrite <- inverse_image_intersection, <- inverse_image_empty.
    now f_equal.
Qed.

Definition T3_sep (X:TopologicalSpace) : Prop :=
  T1_sep X /\
  forall (x:point_set X) (F:Ensemble (point_set X)),
  closed F -> ~ In F x -> exists U:Ensemble (point_set X),
                          exists V:Ensemble (point_set X),
        open U /\ open V /\ In U x /\ Included F V /\
        Intersection U V = Empty_set.

Lemma topological_property_T3_sep : topological_property T3_sep.
Proof.
  intros X Y f Hf [HT1 H].
  split.
  - eapply topological_property_T1_sep.
    + exact Hf.
    + assumption.
  - destruct Hf as [g Hcont_f Hcont_g Hgf Hfg].
    intros y F Hcl Hn.
    destruct (H (g y) (inverse_image f F)) as [U [V [HopenU [HopenV [HinU [Hincl eq]]]]]].
    + red.
      rewrite <- inverse_image_complement.
      now apply Hcont_f.
    + intros [contra].
      now rewrite Hfg in contra.
    + exists (inverse_image g U), (inverse_image g V).
      repeat split;
        try apply Hcont_g;
        trivial.
     * apply Hincl.
       constructor.
       now rewrite Hfg.
     * erewrite <- inverse_image_intersection, <- inverse_image_empty.
       now f_equal.
Qed.

Definition normal_sep (X:TopologicalSpace) : Prop :=
  T1_sep X /\
  forall (F G:Ensemble (point_set X)),
  closed F -> closed G -> Intersection F G = Empty_set ->
  exists U:Ensemble (point_set X), exists V:Ensemble (point_set X),
  open U /\ open V /\ Included F U /\ Included G V /\
  Intersection U V = Empty_set.
Definition T4_sep := normal_sep.

Lemma T1_sep_impl_T0_sep: forall X:TopologicalSpace,
  T1_sep X -> T0_sep X.
Proof.
intros.
red. intros.
left.
exists (Complement (Singleton y)).
repeat split.
- apply H.
- intro.
  destruct H1.
  now contradiction H0.
- intro.
  apply H1.
  constructor.
Qed.

Lemma Hausdorff_impl_T1_sep: forall X:TopologicalSpace,
  Hausdorff X -> T1_sep X.
Proof.
intros X H x.
replace (Singleton x) with (closure (Singleton x)).
{ apply closure_closed. }
extensionality_ensembles;
  [ | now apply closure_inflationary ].
replace x0 with x.
{ constructor. }
apply NNPP.
intro.
pose proof (H x x0 H1).
destruct H2 as [U [V [? [? [? [? ?]]]]]].
assert (In (interior (Complement (Singleton x))) x0).
{ exists V; trivial.
  constructor; split; trivial.
  red; intros.
  intro.
  destruct H8.
  eapply Noone_in_empty.
  erewrite <- H6.
  econstructor;
    eassumption. }
rewrite interior_complement in H7.
now contradiction H7.
Qed.

Lemma T3_sep_impl_Hausdorff: forall X:TopologicalSpace,
  T3_sep X -> Hausdorff X.
Proof.
intros.
destruct H.
red; intros.
pose proof (H0 x (Singleton y)).
match type of H2 with | ?A -> ?B -> ?C => assert C end.
- apply H2.
  + apply H.
  + intro.
    now destruct H3.
- destruct H3 as [U [V [? [? [? [? ?]]]]]].
  exists U, V.
  auto 6 with sets.
Qed.

Lemma normal_sep_impl_T3_sep: forall X:TopologicalSpace,
  normal_sep X -> T3_sep X.
Proof.
intros.
destruct H.
split; trivial.
intros.
pose proof (H0 (Singleton x) F).
match type of H3 with | ?A -> ?B -> ?C -> ?D => assert D end.
- apply H3; trivial.
  now extensionality_ensembles.
- destruct H4 as [U [V [? [? [? [? ?]]]]]].
  exists U, V.
  auto with sets.
Qed.

Section Hausdorff_and_nets.

Lemma Hausdorff_impl_net_limit_unique:
  forall {X:TopologicalSpace} {I:DirectedSet} (x:Net I X),
    Hausdorff X -> uniqueness (net_limit x).
Proof.
intros.
red; intros x1 x2 ? ?.
apply NNPP.
intro.
destruct (H x1 x2) as [U [V [? [? [? [? ?]]]]]]; trivial.
destruct (H0 U H3 H5) as [i].
destruct (H1 V H4 H6) as [j].
destruct (DS_join_cond i j) as [k [? ?]].
assert (In (Intersection U V) (x k)).
{ constructor.
  - now apply H8.
  - now apply H9. }
rewrite H7 in H12.
destruct H12.
Qed.

Lemma Hausdorff_impl_net_limit_is_unique_cluster_point:
  forall {X:TopologicalSpace} {I:DirectedSet} (x:Net I X)
    (x0:point_set X), Hausdorff X -> net_limit x x0 ->
    forall y:point_set X, net_cluster_point x y -> y = x0.
Proof.
intros.
destruct (net_cluster_point_impl_subnet_converges _ _ x y H1) as
  [J [x' [? ?]]].
- destruct (H0 Full_set).
  + apply open_full.
  + constructor.
  + now exists.
- assert (net_limit x' x0) by
    now apply subnet_limit with _ x.
  now apply Hausdorff_impl_net_limit_unique with x'.
Qed.

Lemma net_limit_is_unique_cluster_point_impl_Hausdorff:
  forall (X:TopologicalSpace),
  (forall (I:DirectedSet) (x:Net I X) (x0 y:point_set X),
  net_limit x x0 -> net_cluster_point x y ->
  y = x0) -> Hausdorff X.
Proof.
intros.
red; intros.
assert (~ net_cluster_point (neighborhood_net _ x) y).
{ intro.
  contradiction H0.
  symmetry.
  apply H with _ (neighborhood_net _ x); trivial.
  apply neighborhood_net_limit. }
apply not_all_ex_not in H1.
destruct H1 as [V].
apply imply_to_and in H1.
destruct H1.
apply imply_to_and in H2.
destruct H2.
apply not_all_ex_not in H3.
destruct H3 as [[U]].
exists U, V.
repeat split; trivial.
extensionality_ensembles.
contradiction H3.
exists (intro_neighborhood_net_DS X x U x0 o i H4).
split; trivial.
simpl.
auto with sets.
Qed.

Lemma net_limit_uniqueness_impl_Hausdorff:
  forall X:TopologicalSpace,
  (forall (I:DirectedSet) (x:Net I X), uniqueness (net_limit x)) ->
  Hausdorff X.
Proof.
intros.
apply net_limit_is_unique_cluster_point_impl_Hausdorff.
intros.
pose proof (net_cluster_point_impl_subnet_converges _ _ _ _ H1).
destruct H2 as [J [x' [? ?]]].
- destruct (H0 Full_set).
  + apply open_full.
  + constructor.
  + now exists.
- assert (net_limit x' x0) by
    now apply subnet_limit with _ x.
  now apply H with _ x'.
Qed.

End Hausdorff_and_nets.

Lemma Hausdorff_Subspace {X : TopologicalSpace} (A : Ensemble X) :
  Hausdorff X ->
  Hausdorff (SubspaceTopology A).
Proof.
  intros HX.
  intros [x Hx] [y Hy] H.
  specialize (HX x y) as [U [V [HU [HV [HUx [HVx HUV]]]]]].
  { intros ?. subst. apply H.
    apply subset_eq. reflexivity.
  }
  exists (inverse_image (subspace_inc _) U).
  exists (inverse_image (subspace_inc _) V).
  repeat split.
  1,2: apply subspace_inc_continuous.
  all: try assumption.
  extensionality_ensembles.
  assert (In Empty_set (subspace_inc A x0)).
  { rewrite <- HUV.
    split; assumption.
  }
  contradiction.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat seq.
From ipcssr Require Import forms normal_forms derivations in_gamma derivable_def.

Section Sound.
Context {A : Type}.

Definition sound (gamma : seq (form A)) (work : seq (normal_form A)) (ctx : seq (form A)) :=
  forall a, in_gamma gamma work a -> Derivable ctx a.

Lemma sound_cons_gamma gamma work ctx a :
  Derivable ctx a ->
  sound gamma work ctx -> sound (a :: gamma) work ctx.
Proof.
rewrite /sound =>D S c.
case/in_gamma_cons_gamma_rev=>[|{c}->] //.
by apply: S.
Qed.

Lemma sound_cons_gamma_tail gamma work ctx a :
  sound (a :: gamma) work ctx -> sound gamma work ctx.
Proof.
rewrite /sound =>S c D.
by apply/S/in_gamma_cons_gamma_tail.
Qed.

Lemma sound_cons_gamma_head gamma work ctx a :
  sound (a :: gamma) work ctx -> Derivable ctx a.
Proof. by apply; exact: in_gamma_cons_gamma_head. Qed.

(**********************************************************************)

(* TODO bijection? *)
Lemma sound_shift_gamma_work a gamma work ctx :
  sound (nf2form a :: gamma) work ctx -> sound gamma (a :: work) ctx.
Proof.
rewrite /sound =>S c D.
by apply/S/in_gamma_shift_work_gamma.
Qed.

Lemma sound_shift_work_gamma a gamma work ctx :
  sound gamma (a :: work) ctx -> sound (nf2form a :: gamma) work ctx.
Proof.
rewrite /sound =>S c D.
by apply/S/in_gamma_shift_gamma_work.
Qed.

(**********************************************************************)

Lemma sound_cons_gamma_cons_ctx gamma work ctx a :
  sound gamma work ctx -> sound (a :: gamma) work (a :: ctx).
Proof.
move=>S; apply: sound_cons_gamma.
- by apply/(Derivable_Intro _ _ (Var 0))/ByAssumption.
rewrite /sound =>c /S [t Dt].
by apply/(Derivable_Intro _ _ (Shift t))/ShiftIntro.
Qed.

(************************************************************)

Lemma sound_cons_gamma_weak gamma work ctx a b :
  (Derivable ctx a -> Derivable ctx b) ->
  sound (a :: gamma) work ctx -> sound (b :: gamma) work ctx.
Proof.
move=>Dab S; apply: sound_cons_gamma.
- by apply/Dab/sound_cons_gamma_head/S.
by apply/sound_cons_gamma_tail/S.
Qed.

Lemma sound_cons_gamma_weak2 gamma work ctx a b c :
  (Derivable ctx a -> Derivable2 ctx b c) ->
  sound (a :: gamma) work ctx -> sound (b :: c :: gamma) work ctx.
Proof.
move=>Dabc S; case: Dabc.
- by apply/sound_cons_gamma_head/S.
move=>Db Dc; do 2!apply: sound_cons_gamma=>//.
by apply/sound_cons_gamma_tail/S.
Qed.

End Sound.


Require Import Logic.lib.Bijection.

Definition Countable (A: Type): Type := injection A nat.

Definition injection_Countable {A B} (R: injection A B) (CB: Countable B): Countable A := injection_trans R CB.

Definition bijection_Countable {A B} (R: bijection A B) (CB: Countable B): Countable A := injection_Countable (bijection_injection R) CB.

Definition sum_Countable {A B} (CA: Countable A) (CB: Countable B): Countable (sum A B) :=
  injection_trans (sum_injection CA CB) (bijection_injection nat2_nat_bijection).

Definition prod_Countable {A B} (CA: Countable A) (CB: Countable B): Countable (prod A B) :=
  injection_trans (prod_injection CA CB) (bijection_injection natnat_nat_bijection).

Definition nCountable_Countable {A: nat -> Type} (CA: forall n, Countable (A n)): Countable (sigT A) :=
  injection_trans (sigT_injection _ _ _ CA) (bijection_injection natnat_nat_bijection).

Definition unit_Countable: Countable unit.
  apply (FBuild_injection _ _ (fun _ => 0)).
  hnf; intros.
  destruct a1, a2; auto.
Qed.

Ltac solve_Countable :=
  match goal with
  | |- Countable (sum _ _) => apply sum_Countable; solve_Countable
  | |- Countable (prod _ _) => apply prod_Countable; solve_Countable
  | |- Countable (sigT _) => try (apply nCountable_Countable; intro; solve_Countable)
  | |- Countable unit => apply unit_Countable
  | _ => try assumption
  end.


Require Import Reals Psatz Omega Fourier.
From stdpp Require Import tactics.
From discprob.measure Require Export measures borel outer_measure.
From discprob.prob Require Import countable rearrange double.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop.
Require ClassicalEpsilon ClassicalEpsilon.

Definition Interval a b : Type := { x : R | a <= x <= b }.
Coercion interval_R {a b} (x : Interval a b) : R := (sval x).

Hint Resolve Rabs_pos Rle_ge.
Hint Resolve disc_neighbourhood.

(* Lebesgue number lemma. Most pencil and paper proofs don't seem
   to use this, but I think it makes the proof that the outer measure
   of intervals is equal to their length simpler *)

Lemma lebesgue_number_lemma (I: Type) D (U: I → (R → Prop)) :
  compact D →
  (∀ x, D x → ∃ i, U i x) →
  (∀ i, open (U i)) →
  ∃ δ, 0 < δ ∧ ∀ x, D x → ∃ i, (∀ z, D z → ball x δ z → U i z).
Proof.
  intros Hcompact Hcover Hopen.
  apply Classical_Pred_Type.not_all_not_ex => Hnot.
  assert (Hneg: ∀ y, 0 < y → (∃ x, D x ∧ ∀ i, ∃ z, D z ∧ ball x y z ∧ ¬ U i z)).
  {
    intros y. specialize (Hnot y) => Hpos.
    apply Classical_Prop.not_and_or in Hnot as [?|Hnot]; first by auto.
    apply Classical_Pred_Type.not_all_ex_not in Hnot.
    destruct Hnot as (x&Hnot).
    apply Classical_Prop.imply_to_and in Hnot as (HDx&Hnot).
    exists x; split; auto. intros i.
    unshelve (eapply Classical_Pred_Type.not_ex_all_not in Hnot); first by exact i.
    apply Classical_Pred_Type.not_all_ex_not in Hnot.
    destruct Hnot as (r&Hnot).
    exists r.
    apply Classical_Prop.imply_to_and in Hnot as (?&Hnot).
    apply Classical_Prop.imply_to_and in Hnot as (?&Hnot).
    split_and!; auto.
  }
  unshelve (refine (let un : nat → R := _ in _)).
  { intros n.  specialize (Hneg (/(INR (n+1)))).
    apply ClassicalEpsilon.constructive_indefinite_description in Hneg as (x&Hspec).
    exact x.
    abstract (apply Rinv_0_lt_compat, pos_INR'; omega).
  }
  edestruct (Bolzano_Weierstrass un) as (x&Hneighbor); eauto.
  { intros.  rewrite /un. destruct ClassicalEpsilon.constructive_indefinite_description.
    intuition.
  }
  rewrite /ValAdh in Hneighbor.
  assert (D x).
  {
    apply adherence_P2; first by apply compact_P2.
    rewrite /adherence/point_adherent => V Hneighbor'.
    edestruct (Hneighbor V O) as (p&Hge&HV); eauto.
    exists (un p). rewrite /intersection_domain; split; auto.
    rewrite /un. destruct ClassicalEpsilon.constructive_indefinite_description; intuition.
  }
  edestruct (Hcover x) as (i&HU); auto.
  destruct (open_included_disc (U i) x) as (δ&Hsub); eauto.
  edestruct (archimed_cor1 (δ / 2)) as (N&HleN&?).
  { destruct δ => //=. nra. }
  destruct (Hneighbor (ball x (δ/2)) N) as (N'&Hle&Hin).
  { apply ball_neighbourhood. destruct δ => //=. nra. }
  rewrite /un in Hin.
  destruct (ClassicalEpsilon.constructive_indefinite_description) as (xbad&?&Hneg').
  specialize (Hneg' i). destruct Hneg' as (z&HD&Hball&Hneg').
  apply Hneg'. apply Hsub.
  apply disc_ball.
  apply: (ball_le _ (δ/2 + (/ (INR (N' + 1))))).
  { destruct δ as (δ&?) => //=.
     replace δ with (δ/2 + δ/2) at 2 by nra.
     apply Rplus_le_compat_l.
     transitivity (/ (INR N)); last (rewrite //= in HleN; nra).
     left; apply Rinv_lt_contravar.
     * assert (0 < INR N) by (apply pos_INR'; omega).
       assert (0 < INR (N' + 1)) by (apply pos_INR'; omega).
       nra.
     * apply lt_INR. omega.
  }
  eapply ball_triangle; eauto.
Qed.

Hint Resolve Rabs_pos Rle_ge.

Section Interval_UniformSpace.
  Variable a b : R.
  Implicit Types x y : Interval a b.

  Definition Interval_ball (x: Interval a b) eps y := ball (x : R) eps y.
  Definition Interval_ball_center x (e: posreal) : Interval_ball x e x := @ball_center _ _ _.
  Definition Interval_ball_sym x y e := @ball_sym _ (x : R) y e.
  Definition Interval_ball_triangle x y e := @ball_triangle _ (x : R) y e.
  Definition Interval_UniformSpace_mixin : UniformSpace.mixin_of (Interval a b).
  Proof.
    apply (UniformSpace.Mixin _ Interval_ball
                              Interval_ball_center
                              Interval_ball_sym
                              Interval_ball_triangle).
  Defined.

  Canonical Interval_UniformSpace := UniformSpace.Pack _ Interval_UniformSpace_mixin (Interval a b).
End Interval_UniformSpace.

(* Lebesgue measure restricted to finite intervals of the Reals *)

Section lebesgue_measure.
  Context {a b : R}.

  (* TODO: deduce these from the versions on R in borel.v *)
  Lemma borel_gen_closed_ray1 :
    le_prop (minimal_sigma (λ (U: Interval a b → Prop), ∃ x y, U = (λ z, x < z <= y)))
            (minimal_sigma (λ (U : Interval a b → Prop), ∃ x, U = (λ z, z <= x))).
  Proof.
    apply minimal_sigma_lub. intros ? (x&y&?); subst.
    assert ((λ z : Interval a b, x < z ∧ z <= y) ≡
            (λ z : Interval a b, z <= y) ∩ compl (λ z : Interval a b, z <= x)) as Heq.
    { intros z; split => //=.
      * intros (?&?). split => //=; intros Hneg. nra.
      * intros (?&Hcomp). split => //=. apply Rnot_ge_lt. intros Hge.
        apply Hcomp. nra.
    }
    rewrite Heq.
    apply sigma_closed_pair_intersect.
    * apply minimal_sigma_ub. eexists; eauto.
    * apply sigma_closed_complements,  minimal_sigma_ub. eexists; eauto.
  Qed.

  Lemma borel_gen_closed_ray2 :
    le_prop (borel (Interval_UniformSpace a b))
    (minimal_sigma (λ (U : Interval a b → Prop), ∃ x, U = (λ z, z <= x))).
  Proof.
    etransitivity; last eapply borel_gen_closed_ray1.
    apply minimal_sigma_lub => U HopenU.
    unshelve (eapply sigma_proper; last eapply sigma_closed_unions).
    {
      intros n.
      destruct (pickle_inv [countType of (nat * nat * nat)] n) as [((x&y)&N)|]; last exact ∅.
      set (V := (λ z : Interval a b, a + (INR x / INR y) - (1/(INR N)) < z ∧
                                     z <= a + (INR x / INR y))).
      destruct (ClassicalEpsilon.excluded_middle_informative
                  (V ⊆ U)).
      * exact V.
      * exact ∅.
    }
    {
      split.
      * intros HUz. specialize (HopenU _ HUz).
        destruct HopenU as ((δ&Hpos)&Hdelta).
        destruct x as (x&Hx1&Hx2) => //=.
        edestruct (archimed_cor1 δ) as (K&?&?); first by nra.
        assert (0 < / INR K).
        { apply Rinv_0_lt_compat, pos_INR'; done. }
        edestruct (archimed_rat_dense1 (/INR K) (x - a)) as (n&m&(?&?)&?); auto; try nra.
        exists (pickle (n, m, K)).
        rewrite pickleK_inv.
        destruct ClassicalEpsilon.excluded_middle_informative as [Hsub|Hnsub]; last first.
        { exfalso. destruct Hnsub.
          intros (z&?&?). rewrite //=. intros [? ?].
          apply Hdelta => //=.
          rewrite /ball//=/Interval_ball/ball//=/AbsRing_ball//=/abs//=.
          rewrite /minus/opp/plus//=.
          assert (z - a >= z - x) by nra.
          apply Rabs_case => Hcase; try nra.
        }
        rewrite //=. nra.
      * intros (n&HUn).
        destruct pickle_inv as [((n'&m')&K)|]; rewrite //= in HUn.
        destruct ClassicalEpsilon.excluded_middle_informative as [Hsub|Hnsub];
          rewrite //= in HUn.
        by apply Hsub.
    }
    intros i.
    destruct (pickle_inv [countType of nat * nat * nat] i) as [((n&m)&K)|] eqn:Heq; rewrite Heq.
    * set (V := λ z : Interval a b, a + INR n / INR m - 1 / INR K < z ∧ z <= a + INR n / INR m).
      destruct (Classical_Prop.classic (V ⊆ U)) as [Hsub|Hnsub].
      ** apply minimal_sigma_ub. do 2 eexists. rewrite /V.
         destruct ClassicalEpsilon.excluded_middle_informative as [|Hnsub]; first reflexivity.
         exfalso; apply Hnsub. eauto.
      ** eapply sigma_proper; last eapply sigma_empty_set; rewrite //=.
         destruct ClassicalEpsilon.excluded_middle_informative as [Hsub'|]; last reflexivity.
         exfalso; apply Hnsub; eauto.
    * apply sigma_empty_set.
  Qed.

  Definition leb_outer_set_cand (U : Interval a b → Prop)  (Us: nat → R * R) :=
    U ⊆ unionF (λ i, open_interval (fst (Us i)) (snd (Us i))).

  Definition leb_outer_set U Us :=
    leb_outer_set_cand U Us ∧ ex_series (λ i, Rabs (snd (Us i) - fst (Us i))).

  Lemma leb_outer_set_proj2 U Us :
    leb_outer_set U Us →
    ex_series (λ i, Rabs (snd (Us i) - fst (Us i))).
  Proof. intros [? ?]; auto. Qed.

  Hint Resolve leb_outer_set_proj2.

  Definition trivial_outer_set (i : nat) :=
    match i with
    | O => (a - 1, b + 1)
    | _ => (a, a)
    end.

  Lemma leb_outer_set_non_empty U : leb_outer_set U (trivial_outer_set).
  Proof.
    split.
    - intros (x&Hl&Hu) _. exists O. split => //=; nra.
    - apply ex_series_incr_1 => //=.
      exists 0. apply is_series_0 => ? //=.
        by rewrite Rminus_eq_0 Rabs_R0.
  Qed.

  Definition leb_outer_pre_fun U r :=
    ∃ Us, leb_outer_set U Us ∧ - Series (λ i, Rabs (snd (Us i) - fst (Us i))) = r.

  Lemma leb_outer_pre_fun_non_empty U : ∃ r, leb_outer_pre_fun U r.
  Proof.
    eexists. exists trivial_outer_set.
    split; first apply leb_outer_set_non_empty. reflexivity.
  Qed.

  Lemma leb_outer_pre_fun_bound U : bound (leb_outer_pre_fun U).
  Proof.
    exists 0. intros ? (Us&(Hcand&Hex)&<-).
    apply Ropp_le_cancel. rewrite Ropp_involutive Ropp_0.
    apply Series_pos => n. auto.
  Qed.

  Definition leb_outer_fun (U : Interval a b → Prop) : R.
    refine (- sval (completeness (leb_outer_pre_fun U) _ _)).
    - apply leb_outer_pre_fun_bound.
    - apply leb_outer_pre_fun_non_empty.
  Defined.

  Lemma leb_outer_fun_glb U r :
    (∀ Us, leb_outer_set U Us → r <= Series (λ i, Rabs (snd (Us i) - fst (Us i)))) →
    r <= leb_outer_fun U.
  Proof.
    intros HUs. rewrite /leb_outer_fun. destruct (completeness) as (r'&Hlub).
    rewrite //=. destruct Hlub as (?&Hlub).
    cut (r' <= - r).
    { nra.  }
    apply Hlub. intros x (?&(?&<-)).
    apply Ropp_le_contravar. auto.
  Qed.

  Lemma leb_outer_fun_lb U Us:
    leb_outer_set U Us → leb_outer_fun U <= Series (λ i, Rabs (snd (Us i) - fst (Us i))).
  Proof.
    intros HUs. rewrite /leb_outer_fun. destruct (completeness) as (r'&Hlub).
    rewrite //=. destruct Hlub as (Hub&Hlub).
    rewrite /is_upper_bound in Hub.
    apply Ropp_le_cancel. rewrite Ropp_involutive. etransitivity; last eapply Hub.
    { reflexivity. }
    eexists; eauto.
  Qed.

  Global Instance is_upper_bound_proper : Proper (eq_prop ==> eq ==> iff) is_upper_bound.
  Proof.
    intros U U' Heq ?? ->. firstorder.
  Qed.

  Lemma completeness_proper E E' Hpf1 Hpf1' Hpf2 Hpf2' :
    eq_prop E E' → sval (completeness E Hpf1 Hpf2) = sval (completeness E' Hpf1' Hpf2').
  Proof.
    intros Heq.
    destruct completeness as (x&Hub&Hlub).
    destruct completeness as (x'&Hub'&Hlub').
    rewrite //=.
    apply Rle_antisym.
    - apply Hlub. rewrite Heq; done.
    - apply Hlub'. rewrite -Heq; done.
  Qed.

  Global Instance leb_outer_set_anti : Proper (le_prop --> eq ==> impl) leb_outer_set.
  Proof.
    intros U U' Hle Us Us' ->. rewrite /leb_outer_set/leb_outer_set_cand.
    intros (?&?); split; auto.
    transitivity U;
    etransitivity; eauto.
  Qed.

  Global Instance leb_outer_set_proper : Proper (eq_prop ==> eq ==> iff) leb_outer_set.
  Proof.
    intros U U' Heq Us Us' ->. rewrite /leb_outer_set/leb_outer_set_cand.
    rewrite Heq. done.
  Qed.

  Global Instance leb_outer_pre_fun_proper : Proper (eq_prop ==> eq ==> iff) leb_outer_pre_fun.
  Proof.
    intros U U' Heq ?? ->. rewrite /leb_outer_pre_fun. setoid_rewrite Heq. done.
  Qed.

  Global Instance leb_outer_fun_proper : Proper (eq_prop ==> eq) leb_outer_fun.
  Proof.
    intros U U' Heq.
    rewrite /leb_outer_fun => //=. apply Ropp_eq_compat.
    apply completeness_proper. intros x. by rewrite Heq.
  Qed.

  Lemma leb_outer_fun_empty :
    leb_outer_fun ∅ = 0.
  Proof.
    apply Rle_antisym.
    etransitivity; first eapply (leb_outer_fun_lb _ (λ i, (a, a))).
    { split => //=. exists 0. apply is_series_0 => ?.
        by rewrite Rminus_eq_0 Rabs_R0. }
    right. apply Series_0 => ? //=. by rewrite Rminus_eq_0 Rabs_R0.
    apply leb_outer_fun_glb => Us ?.
    apply Series_pos => ?. auto.
  Qed.

  Instance leb_outer_fun_mono : Proper (le_prop ==> Rle) leb_outer_fun.
  Proof.
    intros U U' Hle.
    apply leb_outer_fun_glb => Us.
    intros H. apply leb_outer_fun_lb.
    setoid_rewrite <-Hle in H. done.
  Qed.

  Lemma leb_outer_eps_close U eps :
    0 < eps →
    ∃ Us, leb_outer_set U Us
          ∧ Series (λ i, Rabs (snd (Us i) - fst (Us i))) < leb_outer_fun U + eps.
  Proof.
    intros Hpos.
    apply Classical_Pred_Type.not_all_not_ex.
    intros Hneg.
    apply (Rlt_not_ge (leb_outer_fun U) (leb_outer_fun U + eps)); first nra.
    apply Rle_ge, leb_outer_fun_glb => Us Hin.
    apply Rnot_gt_le. intros Hgt. apply (Hneg Us).
    split; auto.
  Qed.

  Lemma leb_outer_eps_close' U eps :
    0 < eps →
    { Us : _ | leb_outer_set U Us
          ∧ Series (λ i, Rabs (snd (Us i) - fst (Us i))) < leb_outer_fun U + eps }.
  Proof.
    intros.
    apply (ClassicalEpsilon.constructive_indefinite_description).
    by apply leb_outer_eps_close.
  Qed.

  Lemma ex_series_double_shift aseq:
    (∀ j k, j = O ∨ k = O → aseq (j, k) = 0) →
    ex_series (λ j : nat, Series (λ k : nat, Rabs (aseq (S j, S k)))) →
    ex_series (λ j : nat, Series (λ k : nat, Rabs (aseq (j, k)))).
  Proof.
    intros Hjk Hex.
    eapply (ex_series_ext (λ j : nat, Series (λ k : nat, Rabs (aseq (j, S k))))).
    { intros j. destruct j.
      * apply Series_ext => k. rewrite ?Hjk //=; by left.
      * symmetry. rewrite Series_incr_1_aux; last first.
        { rewrite Hjk; last by right. rewrite Rabs_R0. done. }
        done.
    }
      by apply ex_series_incr_1.
  Qed.

  Definition int_len := λ xy, Rabs (snd xy - fst xy).

  Lemma Series_double_shift aseq:
    (∀ j k, j = O ∨ k = O → aseq (j, k) = 0) →
    (Series (λ j : nat, Series (λ n : nat, aseq (j, n)))) =
    (Series (λ j : nat, Series (λ n : nat, aseq (S j, S n)))).
  Proof.
    intros. rewrite Series_incr_1_aux.
    * apply Series_ext.
      intros n'. rewrite Series_incr_1_aux; eauto.
    * rewrite Series_0; eauto.
  Qed.

  Lemma leb_outer_fun_subadditivity Us :
    ex_series (λ n, leb_outer_fun (Us n)) →
    leb_outer_fun (unionF Us) <= Series (λ n, leb_outer_fun (Us n)).
  Proof.
    intros Hex.
    apply le_epsilon => eps Hpos.
    assert (Hpos_scale: ∀ n, 0 < eps/2 * (pow (1/2) n)).
    { intros n. cut (0 < (1 /2)^n); first by (intros; nra).
      apply pow_lt. nra. }
    set (Us' := λ n : nat, match pickle_inv [countType of nat * nat] n with
                           | Some (n, i) =>
                             (sval (leb_outer_eps_close' (Us n) (eps/2 * (pow (1/2) n))
                                                         (Hpos_scale n)) i)
                           | None => (a, a)
                           end).
    assert (unionF Us ⊆ unionF (λ i, open_interval (fst (Us' i)) (snd (Us' i)))).
    { intros x (n&Hin).
      destruct (leb_outer_eps_close' (Us n) _ (Hpos_scale n)) as (Vs&(Hcover&?)&?) eqn:Heq.
      generalize (Hcover x Hin). intros (i&Hin').
      exists (pickle (n, i)).
      rewrite /Us'. rewrite pickleK_inv => //=.
      rewrite Heq. auto.
    }

    set (len := λ xy, Rabs (snd xy - fst xy)).
    set (aseq0 := λ mn, match mn with
                       | (S m, S n) =>
                         (sval (leb_outer_eps_close' (Us m) (eps/2 * (pow (1/2) m))
                                                         (Hpos_scale m)) n)
                       | (_, _) => (a, a)
                    end).
    set (aseq := λ mn, len (aseq0 mn)).
    set (σ := λ n, match pickle_inv [countType of nat * nat] n with
                   | Some (m, n) => (S m, S n)
                   | _ => (O, O)
                   end).
    assert (∀ n, (aseq \o σ) n = len (Us' n)).
    { intros n.   rewrite /aseq/σ/Us'//=.
      destruct pickle_inv as [(?&?)|] => //=.
    }
    assert (His_plus: is_series (λ n : nat, leb_outer_fun (Us n) + eps/2 * (pow (1/2) n))
                                (Series (λ n, leb_outer_fun (Us n)) + eps)).
    { apply: is_series_plus.
      * apply Series_correct; auto.
      * assert (eps = (eps/2 * / ( 1 - 1/2))) as Heq by field. rewrite {2}Heq.
        apply: is_series_scal.
        apply: is_series_geom.
        rewrite Rabs_right; nra.
    }
    assert (double.double_summable aseq).
    {
      apply ex_series_rows_ds.
      intros j.
      * rewrite /aseq/aseq0.
        destruct j => //=.
        ** eexists; eapply is_series_0. by rewrite /aseq/aseq0 /len Rminus_eq_0 ?Rabs_R0.
        ** apply ex_series_incr_1 => //=.
           destruct (leb_outer_eps_close') as (?&Hex'&?); auto.
           eapply ex_series_ext; last eapply Hex'.
           intros ?. rewrite /len Rabs_Rabsolu => //=.
      * apply: ex_series_double_shift.
        { intros j k [?|?]; subst => //=; try destruct j;
                                       rewrite /aseq/aseq0 /len ?Rminus_eq_0 ?Rabs_R0 //.
        }
        apply: ex_series_le; last by (eexists; eapply His_plus).
        intros n. rewrite /aseq//=.
        destruct (leb_outer_eps_close') as (?&Hex'&Hlt); auto.
        etransitivity; last by (left; eapply Hlt).
        right. rewrite /norm//=/abs//=. rewrite Rabs_right.
        ** apply Series_ext => ? //=. by rewrite Rabs_Rabsolu.
        ** apply Rle_ge, Series_pos => ?. auto.
    }
    feed pose proof (series_double_covering' aseq σ) as His; auto.
    { intros n n'. rewrite /σ/aseq.
      specialize (pickle_invK [countType of nat * nat] n).
      specialize (pickle_invK [countType of nat * nat] n').
      destruct (pickle_inv) as [(?&?)|] => //=; destruct (pickle_inv) as [(?&?)|] => //=.
      intros <- ? ?. inversion 1. subst => //=.
      rewrite /len//= Rminus_eq_0 Rabs_R0 //=.
    }
    { rewrite /aseq/aseq0. intros ([|m]&[|n]) => //=;
      rewrite /len ?Rminus_eq_0 ?Rabs_R0 //=.
      exists (pickle (m, n)).
      rewrite /σ pickleK_inv => //=. }
    etransitivity.
    * apply (leb_outer_fun_lb _ (aseq0 \o σ)). split.
      ** intros x (n&Hin).
         destruct (leb_outer_eps_close' (Us n) _ (Hpos_scale n)) as (Vs&(Hcover&?)&?) eqn:Heq.
         generalize (Hcover x Hin). intros (i&Hin').
         exists (pickle (n, i)).
         rewrite /aseq0/σ//=. rewrite pickleK_inv => //=.
         rewrite Heq. auto.
      ** eexists; eauto.
    * rewrite (is_series_unique _ _ His).
      rewrite -(is_series_unique _ _ His_plus).
      rewrite Series_double_shift; last first.
      { intros ?? [?|?]; subst; try destruct j; rewrite /aseq/len//= ?Rminus_eq_0 ?Rabs_R0 //=. }
      apply Series_le; last by (eexists; eauto).
      intros n.
      split.
      ** apply Series_pos => n'. rewrite /aseq/len//=. apply Rle_ge, Rabs_pos.
      ** rewrite /aseq/aseq0//=. destruct (leb_outer_eps_close') as (?&?&Hdone); eauto.
         rewrite /len//=. nra.
  Qed.

  Lemma Rabs_Rminus_eq_0 x:
    Rabs (x - x) = 0.
  Proof.
    rewrite Rminus_eq_0 Rabs_R0 //.
  Qed.

  Hint Resolve Rabs_Rminus_eq_0.

  Inductive decreasing_intervals : list (R * R) → Prop :=
      | di_nil: decreasing_intervals nil
      | di_singleton a b: a <= b → decreasing_intervals ((a, b) :: nil)
      | di_cons a1 b1 a2 b2 l:
          b1 <= a2 <= b2 →
          decreasing_intervals ((a1, b1) :: l) →
          decreasing_intervals ((a2, b2) :: (a1, b1) :: l).

  Lemma open_interval_subset_len x1 y1 x2 y2:
    x1 <= y1 →
    open_interval x1 y1 ⊆ open_interval x2 y2 →
    Rabs (y1 - x1) <= Rabs (y2 - x2).
  Proof.
    intros Hle Hsubseteq. rewrite Rabs_right; last by nra.
    destruct Hle; last first.
    - assert (y1 - x1 = 0) as -> by nra. auto.
    - specialize (Rabs_pos (y2 - x2)). intros Hpos.
      apply le_epsilon => eps ?.
      destruct (Rlt_dec (eps) (y1 - x1)) as [?|?]; last by nra.
      destruct (Hsubseteq (x1 + eps/2)).
      { split; nra. }
      rewrite Rabs_right; last by nra.
      destruct (Hsubseteq (y1 - eps/2)).
      { split; nra. }
      nra.
  Qed.

  Lemma open_interval_subset_left_ordering x1 y1 x2 y2:
    x1 < y1 →
    open_interval x1 y1 ⊆ open_interval x2 y2 →
    x2 <= x1.
  Proof.
    intros Hle Hsubseteq.
    cut (∀ eps : R, 0 < eps → eps < (y1 - x1) → x2 <= x1 + eps).
    { intros Hcut. apply le_epsilon.
      intros eps Hlt.
      destruct (Rlt_dec (eps) (y1 - x1)) as [?|?].
      * eauto.
      * transitivity (x1 + (y1 - x1)/2); eauto.
        { eapply Hcut; nra.  }
        nra.
    }
    intros.
    destruct (Hsubseteq (x1 + eps/2)).
    { split; nra. }
    destruct (Hsubseteq (y1 - eps/2)).
    { split; nra. }
    nra.
  Qed.

  Lemma open_interval_subset_right_ordering x1 y1 x2 y2:
    x1 < y1 →
    open_interval x1 y1 ⊆ open_interval x2 y2 →
    y1 <= y2.
  Proof.
    intros Hle Hsubseteq.
    cut (∀ eps : R, 0 < eps → eps < (y1 - x1) → y1 <= y2 + eps).
    { intros Hcut. apply le_epsilon.
      intros eps Hlt.
      destruct (Rlt_dec (eps) (y1 - x1)) as [?|?].
      * eauto.
      * transitivity (y2 + (y1 - x1)/2); eauto.
        { eapply Hcut; nra.  }
        nra.
    }
    intros.
    destruct (Hsubseteq (x1 + eps/2)).
    { split; nra. }
    destruct (Hsubseteq (y1 - eps/2)).
    { split; nra. }
    nra.
  Qed.

  Lemma open_interval_subset_non_empty x1 y1 x2 y2:
    x1 < y1 →
    open_interval x1 y1 ⊆ open_interval x2 y2 →
    x2 <= y2.
  Proof.
    intros Hle Hopen.
    transitivity x1.
    { eapply open_interval_subset_left_ordering; eauto; nra.  }
    transitivity y1; first nra.
    { eapply open_interval_subset_right_ordering; eauto; nra.  }
  Qed.

  Hint Resolve open_interval_subset_non_empty.

  Lemma decreasing_intervals_1 l
    (Hdec : decreasing_intervals l):
    ∀ x' y', In (x', y') l → x' <= y'.
  Proof.
    induction Hdec => //=.
    - intros ??. destruct 1 as [Heq|[]]. inversion Heq; subst; done.
    - intros ??. destruct 1 as [Heq|[]].
      * inversion Heq; subst; nra.
      * eapply IHHdec. by left.
      * eapply IHHdec. by right.
  Qed.

  Lemma decreasing_intervals_2 x1 y1 l
    (Hdec : decreasing_intervals ((x1, y1) :: l)):
    ∀ x' y', In (x', y') l → y' <= x1.
  Proof.
    remember ((x1, y1) :: l) as l0 eqn:Heql. revert x1 y1 l Heql.
    induction Hdec.
    - congruence.
    - intros x1 y1 l. inversion 1; subst. intros ?? [].
    - intros x1 y1 l0. inversion 1; subst.
      intros ??. inversion 1.
      * inversion H1.  subst. intuition.
      * assert (y' <= a1); eauto.
        assert (a1 <= b1).
        { eapply decreasing_intervals_1. eauto. by left. }
        nra.
  Qed.

  Lemma decreasing_intervals_3 x1 y1 l
    (Hdec : decreasing_intervals ((x1, y1) :: l)):
    ∀ x' y', In (x', y') ((x1, y1) :: l) → y' <= y1.
  Proof.
    intros ?? [Heq1|Htl].
    - inversion Heq1; reflexivity.
    - transitivity x1.
      * eapply decreasing_intervals_2; eauto.
      * eapply decreasing_intervals_1; eauto; by left.
  Qed.

  Lemma intervals_contained_length Us (l: list (R * R)) :
    decreasing_intervals l →
    ex_series (λ i : nat, Rabs ((Us i).2 - (Us i).1)) →
    (∀ a b, In (a, b) l → ∃ i, (open_interval a b) ⊆ open_interval (Us i).1 (Us i).2) →
    fold_right Rplus 0 (map int_len l) <= Series (λ i : nat, Rabs ((Us i).2 - (Us i).1)).
  Proof.
    intros Hdec. revert Us.
    induction Hdec as [ | x y | x1 y1 x2 y2 l] => Us Hex Hcov.
    - rewrite //=. apply Series_pos => n; auto.
    - rewrite //= Rplus_0_r.
      destruct (Hcov x y) as (i&Hsub); first by left.
      rewrite -(Series_bump i (int_len (x, y))).
      apply Series_le.
      * intros n. destruct Nat.eq_dec => //=; split; rewrite /int_len; auto; try nra.
        apply open_interval_subset_len => //=. subst; done.
      * auto.
    - rewrite //=.
      destruct (Req_dec x2 y2).
      { subst.  rewrite /int_len//=. rewrite Rabs_Rminus_eq_0 Rplus_0_l.
        apply IHHdec; eauto. intros. eapply Hcov. by right. }
      edestruct (Hcov x2 y2) as (i&Hsubseteq).
      { by left. }
      assert (ex_series
                (λ i0 : nat, Rabs
       ((match Nat.eq_dec i0 i with | left _ => ((Us i).1, x2) | _ => Us i0 end).2 -
       ((match Nat.eq_dec i0 i with | left _ => ((Us i).1, x2) | _ => Us i0 end).1)))).
      {
        apply: ex_series_le; eauto.
        intros n. rewrite /norm//=/abs//= Rabs_Rabsolu.
        destruct Nat.eq_dec => //=; last reflexivity.
        subst.
        apply open_interval_subset_len.
        * apply open_interval_subset_left_ordering in Hsubseteq; nra.
        * apply open_interval_subset_right_ordering in Hsubseteq; last by nra.
          intros x [? ?]. split; nra.
      }
      feed pose proof (IHHdec (λ n, match eq_nat_dec n i with
                                    | left _ => ((Us i).1, x2)
                                    | _ => Us n
                                    end)); auto.
      {
        intros a' b' Hin. edestruct (Hcov a' b') as (n&Hin'); first by right.
        exists n. destruct Nat.eq_dec => //=; subst.
        intros x Hrange. specialize (Hin' _ Hrange) as (?&?).
        destruct Hrange as (?&?).
        split; first nra.
        eapply (Rlt_le_trans _ b'); first eassumption.
        transitivity y1; last by nra.
        eapply decreasing_intervals_3; eauto.
      }
      rewrite //= in H1.
      etransitivity.
      { eapply Rplus_le_compat_l. eassumption. }
      rewrite -(Series_bump i (int_len (x2, y2))).
      rewrite -Series_plus; auto; last by (eexists; eapply is_series_bump).
      apply: Series_le; eauto.
      intros n; split.
      * destruct Nat.eq_dec => //=; ring_simplify; auto.
        rewrite /int_len.
        replace 0 with (0 + 0) by nra. apply Rplus_le_compat; auto.
      * destruct Nat.eq_dec => //=; ring_simplify; auto; try reflexivity.
        rewrite /int_len//=.
        subst.
        rewrite ?Rabs_right.
        { ring_simplify.  cut (y2 <= snd (Us i)); first (intros; nra).
          eapply open_interval_subset_right_ordering; eauto. nra.
        }
        ** eapply open_interval_subset_non_empty in Hsubseteq; nra.
        ** eapply open_interval_subset_left_ordering in Hsubseteq; nra.
        ** eapply open_interval_subset_right_ordering in Hsubseteq; nra.
  Qed.

  Fixpoint decreasing_intervals_delta x δ n :=
    match n with
      0 => []
    | S n' => (x - δ, x) :: decreasing_intervals_delta (x - δ) δ n'
    end.

  Lemma decreasing_intervals_delta1  x δ n :
    0 < δ →
    decreasing_intervals (decreasing_intervals_delta x δ n).
  Proof.
    intros Hpos.
    revert x. induction n => x //=.
    - constructor.
    - induction n => //=.
      * constructor. nra.
      * econstructor; eauto. nra.
  Qed.

  Lemma decreasing_intervals_delta2  x δ n :
    0 < δ →
    ∀ a' b', In (a', b') (decreasing_intervals_delta x δ n) →
             ∃ x0, x - (δ * INR n) <= x0 <= x ∧ open_interval a' b' ⊆ ball x0 (δ/2) ∧
                   (∀ z, ball x0 (δ/2) z → x - (δ * INR n) <= z <= x).
  Proof.
    intros Hpos.
    revert x. induction n => x.
    - done.
    - intros a' b'. intros [Hhd|Htl].
      * exists (x - δ/2); split_and!.
        ** rewrite //=. destruct n; try nra. specialize (pos_INR (S n)) => H. nra.
        ** nra.
        ** inversion Hhd. subst => z [Hr1 Hr2].
           rewrite /ball//=/AbsRing_ball/abs//=/minus/plus/opp//=.
           apply Rabs_case => H; nra.
        ** rewrite S_INR //=. inversion Hhd. subst => z.
           rewrite /ball//=/AbsRing_ball/abs//=/minus/plus/opp//=.
           specialize (pos_INR n).
           apply Rabs_case => H1 H2; nra.
      * edestruct IHn as (x0&(Hlb&?)&?&Hrange); eauto.
        exists x0. split_and!; auto; try nra.
        ** rewrite S_INR. nra.
        ** intros. edestruct Hrange; eauto. rewrite S_INR. nra.
  Qed.

  Lemma decreasing_intervals_delta3  x δ n :
    0 < δ →
    fold_right Rplus 0 (map int_len (decreasing_intervals_delta x δ n)) = (INR n * δ).
  Proof.
    intros Hpos.
    revert x. induction n => x.
    - rewrite //=. nra.
    - rewrite S_INR //= IHn.
      rewrite /int_len Rabs_right //=; nra.
  Qed.

  Lemma decreasing_interval_covering x y δ:
    0 < δ →
    a <= x → x <= y → y <= b →
    ∃ l, decreasing_intervals l ∧
         (∀ a' b', In (a', b') l → ∃ x0, x <= x0 <= y ∧ open_interval a' b' ⊆ ball x0 (δ/2) ∧
                   (∀ z, open_interval a' b' z → x <= z <= y)) ∧
         fold_right Rplus 0 (map int_len l) = (y - x).
  Proof.
    intros Hpos Hle1 Hle2 Hle3.
    destruct Hle2 as [Hlt|Heq]; last first.
    { subst. exists []; split_and! => //=.
      * econstructor.
      * nra.
    }
    assert (∃ N, (y - x) / INR N < δ ∧ (0 < N)%nat) as (N&Hsize&HposN).
    { edestruct (archimed_cor1 (δ / (y - x))) as (N&?&Hpos').
      { apply Rdiv_lt_0_compat; nra. }
      exists N; split_and!; auto.
      apply pos_INR' in Hpos'.  rewrite /Rdiv.
      apply (Rmult_lt_reg_r (/ (y - x))).
      { apply Rinv_0_lt_compat; nra. }
      field_simplify; nra.
    }
    assert (0 < INR N) by (apply pos_INR'; auto).
    assert (0 < (/ INR N)) by (apply Rinv_0_lt_compat; auto).
    assert (0 < ((y - x)/ INR N)).
    { rewrite /Rdiv. nra. }
    exists (decreasing_intervals_delta y (( y - x) / INR N) N).
    split_and!.
    - by apply decreasing_intervals_delta1.
    - intros a' b' Hin.
      edestruct (decreasing_intervals_delta2 y ((y - x)/INR N) N) as (x0&(Hlb&Hub)&?&Hrange); eauto.
      exists x0. split_and!.
      * field_simplify in Hlb; nra.
      * auto.
      * etransitivity; eauto. intros z. apply ball_le.
        nra.
      * intros z ?. edestruct Hrange as (Hlb'&Hub'); eauto.
        split; auto. field_simplify in Hlb'; try nra.
    - rewrite decreasing_intervals_delta3 //=. field; nra.
  Qed.

  Lemma leb_outer_fun_interval_length x y :
    a <= x → x <= y → y <= b →
    leb_outer_fun (λ z, x <= z <= y) = y - x.
  Proof.
    intros Hle1 Hle2 Hle3.
    apply Rle_antisym.
    - apply le_epsilon => eps Hpos.
      set (aseq := (λ i, match i with
                         | O => (x - eps/2, y + eps/2)
                         | _ => (a, a)
                         end)).
      assert (ex_series (λ i : nat, Rabs ((aseq i).2 - (aseq i).1))).
      { apply ex_series_incr_1. exists 0. by apply is_series_0. }
      etransitivity.
      * eapply (leb_outer_fun_lb _ aseq).
        split.
        ** intros t [? ?]. exists O. rewrite /open_interval => //=. nra.
        ** apply ex_series_incr_1. exists 0. apply is_series_0.
           rewrite //= Rminus_eq_0 Rabs_R0 //.
      * rewrite Series_incr_1 //=. rewrite Series_0; auto.
        rewrite Rabs_right; nra.
    - apply leb_outer_fun_glb => Us Houter.
      edestruct (lebesgue_number_lemma nat (λ z, x <= z <= y)
                                       (λ n, open_interval (fst (Us n)) (snd (Us n))))
                as (δ&Hpos&Hdelta).
      { apply (compact_P3 x y). }
      { intros x' Hin.
        assert (Hrange: a <= x' <= b) by nra.
        destruct Houter as (Hcov&?).
        destruct (Hcov (exist _ x' Hrange)); eauto. }
      { intros. apply open_interval_open. }
      edestruct (decreasing_interval_covering x y δ) as (l&Hdec&Hin&Hlen); eauto.
      rewrite -Hlen.
      apply intervals_contained_length; eauto.
      intros.
      edestruct Hin as (x0&?&Hball&Hrange); eauto.
      edestruct (Hdelta x0) as (n&Hsub); eauto.
      exists n. intros z' Hin'. eapply Hsub; eauto.
      eapply ball_le; last eapply Hball; eauto. nra.
  Qed.

  Lemma leb_outer_fun_interval_length_arbitrary1 x y :
    leb_outer_fun (λ z, x <= z <= y) <= Rabs (y - x).
  Proof.
    destruct (Rle_dec a y) as [?|Hnle]; last first.
    { apply Rnot_le_gt in Hnle. transitivity 0; last by auto.
      right. rewrite (leb_outer_fun_proper _ ∅); first by rewrite leb_outer_fun_empty.
      intros (z&?&?) => //=; split => //=. intros. nra. }
    destruct (Rle_dec x b) as [?|Hnle]; last first.
    { apply Rnot_le_gt in Hnle. transitivity 0; last by auto.
      right. rewrite (leb_outer_fun_proper _ ∅); first by rewrite leb_outer_fun_empty.
      intros (z&?&?) => //=; split => //=. intros. nra. }
    destruct (Rle_dec a b) as [Hle|Hnle]; last first.
    { apply Rnot_le_gt in Hnle. transitivity 0; last by auto.
      right. rewrite (leb_outer_fun_proper _ ∅); first by rewrite leb_outer_fun_empty.
      intros (z&?&?) => //=; split => //=. intros. nra. }
    destruct (Rle_dec x y) as [Hle'|Hnle]; last first.
    { apply Rnot_le_gt in Hnle. transitivity 0; last by auto.
      right. rewrite (leb_outer_fun_proper _ ∅); first by rewrite leb_outer_fun_empty.
      intros (z&?&?) => //=; split => //=. intros. nra. }
    transitivity (leb_outer_fun (λ z, Rmax a x <= z <= Rmin y b)).
    {
      apply leb_outer_fun_mono. intros (z&(?&?)) => //=. intros (?&?); split.
      * apply Rmax_case_strong; intros; try nra.
      * apply Rmin_case_strong; intros; try nra.
    }
    rewrite leb_outer_fun_interval_length; auto using Rmax_r, Rmax_l, Rmin_r, Rmin_l.
    - apply Rmax_case_strong; apply Rmin_case_strong; intros; rewrite ?Rabs_right; nra.
    - apply Rmax_case_strong; apply Rmin_case_strong; intros; nra.
  Qed.

  Lemma leb_outer_fun_interval_length_arbitrary2 x y :
    leb_outer_fun (λ z, x < z <= y) <= Rabs (y - x).
  Proof.
    etransitivity; last eapply leb_outer_fun_interval_length_arbitrary1.
    apply leb_outer_fun_mono => z; nra.
  Qed.

  Lemma leb_outer_fun_interval_length_arbitrary3 x y :
    leb_outer_fun (λ z, x < z < y) <= Rabs (y - x).
  Proof.
    etransitivity; last eapply leb_outer_fun_interval_length_arbitrary1.
    apply leb_outer_fun_mono => z; nra.
  Qed.

  Definition leb_outer_measure : outer_measure (Interval a b).
  refine {| outer_measure_fun := leb_outer_fun |}.
  - apply leb_outer_fun_empty.
  - apply leb_outer_fun_subadditivity.
  Defined.

  Definition leb_measure := outer_measure_measure leb_outer_measure.

  Lemma norm_R_right (r: R):
    0 <= r → norm r = r.
  Proof. intros; rewrite /norm//=/abs//= Rabs_right; nra. Qed.

  Lemma leb_borel_measurable :
    le_prop (borel _) (outer_measure_sigma leb_outer_measure).
  Proof.
    etransitivity; first apply borel_gen_closed_ray2.
    apply minimal_sigma_lub. intros ? (x&->).
    apply outer_measurable_ge => V.
    apply Rle_ge, le_epsilon => eps Hpos.
    edestruct (leb_outer_eps_close V eps) as (Us&HUs_spec&?); auto.
    assert (Hbound: ∀ n, Rabs ((Us n).2 - (Us n).1) >=
                 leb_outer_measure (open_interval (Us n).1 (Us n).2 ∩
                                                 (λ z, z <= x)) +
                 leb_outer_measure (open_interval (Us n).1 (Us n).2 ∩
                                                 compl (λ z, z <= x))).
    { intros n.
      destruct (Rle_dec x (Us n).1).
      {
        assert (eq_prop (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ Rle^~ x) x0)
                        ∅) as Heq1.
        { intros (z&?&?) => //=. split.
          * intros ((Hr1&Hr2)&Hr3); try nra.
          * inversion 1.
        }
        assert (eq_prop
                  (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ compl (Rle^~ x)) x0)
                  (open_interval (Us n).1 (Us n).2)) as Heq2.
        { intros (z&?&?) => //=. split.
          * rewrite /compl. intros ((Hr1&Hr2)&Hr3); split; try nra.
          * rewrite /compl/open_interval; intros (Hr1&Hr2); split_and!; try nra.
        }
        rewrite Heq1 Heq2.
        rewrite /leb_outer_measure//= leb_outer_fun_empty Rplus_0_l.
        apply Rle_ge. apply leb_outer_fun_interval_length_arbitrary3.
      }
      destruct (Rlt_dec x (Us n).2).
      * assert (eq_prop (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ Rle^~ x) x0)
                      (λ x0, (Us n).1 < x0 <= x)) as Heq1.
        { intros (z&?&?) => //=. split.
          * intros ((Hr1&Hr2)&Hr3); split; nra.
          * rewrite /open_interval; intros; split_and!; try nra.
        }
        assert (eq_prop
                  (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ compl (Rle^~ x)) x0)
                  (λ x0, x < x0 < (Us n).2)) as Heq2.
        { intros (z&?&?) => //=. split.
          * rewrite /compl. intros ((Hr1&Hr2)&Hr3); split; try nra.
          * rewrite /compl/open_interval; intros; split_and!; nra.
        }
        rewrite Heq1 Heq2.
        apply Rle_ge.
        setoid_rewrite leb_outer_fun_interval_length_arbitrary2.
        setoid_rewrite leb_outer_fun_interval_length_arbitrary3.
        repeat apply Rabs_case; intros; try nra.
      * assert (eq_prop (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ Rle^~ x) x0)
                        (open_interval (Us n).1 (Us n).2)) as Heq1.
        { intros (z&?&?) => //=. split.
          * intros ((Hr1&Hr2)&Hr3); split; nra.
          * rewrite /open_interval; intros; split_and!; try nra.
        }
        assert (eq_prop
                  (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ compl (Rle^~ x)) x0)
                  ∅) as Heq2.
        { intros (z&?&?) => //=. split.
          * rewrite /compl. intros ((Hr1&Hr2)&Hr3); try nra.
          * inversion 1.
        }
        rewrite Heq1 Heq2.
        rewrite /leb_outer_measure//= leb_outer_fun_empty Rplus_0_r.
        apply Rle_ge. apply leb_outer_fun_interval_length_arbitrary3.
    }
    assert (ex_series (λ n : nat,
         leb_outer_measure (open_interval (Us n).1 (Us n).2 ∩ Rle^~ x))).
    { apply: ex_series_le; eauto => n. rewrite norm_R_right; last apply outer_measure_nonneg.
      specialize (Hbound n). apply Rge_le in Hbound.
      etransitivity; eauto. rewrite -[a in a <= _]Rplus_0_r.
      apply Rplus_le_compat_l; auto using outer_measure_nonneg.
    }
    assert (ex_series (λ n : nat,
         leb_outer_measure (open_interval (Us n).1 (Us n).2 ∩ compl (Rle^~ x)))).
    { apply: ex_series_le; last (destruct HUs_spec as (?&Hex); eapply Hex).
      eauto => n. rewrite norm_R_right; last apply outer_measure_nonneg.
      specialize (Hbound n). apply Rge_le in Hbound.
      etransitivity; eauto. rewrite -[a in a <= _]Rplus_0_l.
      apply Rplus_le_compat_r; auto using outer_measure_nonneg.
    }
    etransitivity; last (by left; eassumption).
    etransitivity; last first.
    { apply Series_le with (a := λ n,
           leb_outer_measure (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ Rle^~ x) x0) +
           leb_outer_measure
             (λ x0 : Interval a b, (open_interval (Us n).1 (Us n).2 ∩ compl (Rle^~ x)) x0));
        last eauto.
      intros n. split; eauto.
      * replace 0 with (0 + 0) by field. apply Rplus_le_compat; apply outer_measure_nonneg.
      * apply Rge_le. eapply Hbound.
    }
    rewrite Series_plus; eauto.
    apply Rplus_le_compat.
    * rewrite /leb_outer_measure//=.
      etransitivity; last eapply leb_outer_fun_subadditivity; eauto.
      apply leb_outer_fun_mono. intros z (HinV&Hrange).
      edestruct (HUs_spec) as (HUs1&HUs2). edestruct (HUs1 _ HinV) as (n&?).
      exists n. split; auto.
    * rewrite /leb_outer_measure//=.
      etransitivity; last eapply leb_outer_fun_subadditivity; eauto.
      apply leb_outer_fun_mono. intros z (HinV&Hrange).
      edestruct (HUs_spec) as (HUs1&HUs2). edestruct (HUs1 _ HinV) as (n&?).
      exists n. split; auto.
  Qed.

End lebesgue_measure.


(* infotheo: information theory and error-correcting codes in Coq               *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later              *)
From mathcomp Require Import all_ssreflect.
Require Import Reals Lra.
From mathcomp Require Import Rstruct.
Require Import ssrR Reals_ext Ranalysis_ext ssr_ext logb ln_facts bigop_ext.
Require Import Rbigop fdist divergence log_sum variation_dist.

(******************************************************************************)
(*                      Partition inequality                                  *)
(*                                                                            *)
(* Special case for distributions other sets with 2 elements, to be used in   *)
(* the proof of Pinsker's inequality.                                         *)
(******************************************************************************)

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

Local Open Scope divergence_scope.
Local Open Scope R_scope.

Local Notation "0" := (false).
Local Notation "1" := (true).

Section bipart_sect.

Variable A : finType.
Variable A_ : bool -> {set A}.
Hypothesis dis : A_ 0 :&: A_ 1 = set0.
Hypothesis cov : A_ 0 :|: A_ 1 = [set: A].
Variable P : fdist A.

Definition bipart_pmf := [ffun i => \sum_(a in A_ i) P a].

Definition bipart : fdist [finType of bool].
apply (@FDist.make _ bipart_pmf).
- by move=> a; rewrite ffunE; apply: sumR_ge0.
- rewrite big_bool /= /bipart_pmf /= !ffunE.
  transitivity (\sum_(a | (a \in A_ 0 :|: A_ 1)) P a).
    by rewrite [X in _ = X](@big_union _ _ _ _ (A_ 0) (A_ 1)) // -setI_eq0 setIC dis eqxx.
  by rewrite cov -(FDist.f1 P); apply eq_bigl => /= x; rewrite in_setT inE.
Defined.

End bipart_sect.

Local Open Scope reals_ext_scope.

Section bipart_lem.

Variable A : finType.
Variable A_ : bool -> {set A}.
Hypothesis dis : A_ 0 :&: A_ 1 = set0.
Hypothesis cov : A_ 0 :|: A_ 1 = setT.
Variable P Q : fdist A.
Hypothesis P_dom_by_Q : P `<< Q.

Let P_A := bipart dis cov P.
Let Q_A := bipart dis cov Q.

Lemma partition_inequality : D(P_A || Q_A) <= D(P || Q).
Proof.
have -> : D(P || Q) = \sum_(a in A_ 0) P a * log (P a / Q a) +
                      \sum_(a in A_ 1) P a * log (P a / Q a).
  rewrite /div -big_union //; last by rewrite -setI_eq0 setIC dis eqxx.
  apply eq_big => // a; first by rewrite cov in_set inE.
have step2 :
  (\sum_(a in A_ 0) P a) * log ((\sum_(a in A_ 0) P a) / \sum_(a in A_ 0) Q a) +
  (\sum_(a in A_ 1) P a) * log ((\sum_(a in A_ 1) P a) / \sum_(a in A_ 1) Q a) <=
  \sum_(a in A_ 0) P a * log (P a / Q a) + \sum_(a in A_ 1) P a * log (P a / Q a).
  apply leR_add; by apply log_sum.
apply: (leR_trans _ step2) => {step2}.
rewrite [X in _ <= X](_ : _ =
  P_A 0 * log ((P_A 0) / (Q_A 0)) + P_A 1 * log ((P_A 1) / (Q_A 1))); last first.
  by rewrite !ffunE.
rewrite /div big_bool.
rewrite [P_A]lock [Q_A]lock /= -!lock.
have [A0_P_neq0 | /esym A0_P_0] : {0 < P_A 0} + {0%R = P_A 0}.
  by apply Rle_lt_or_eq_dec; rewrite ffunE; exact: sumR_ge0.
- have [A1_Q_neq0 | /esym A1_Q_0] : {0 < Q_A 1} + {0%R = Q_A 1}.
    by apply Rle_lt_or_eq_dec; rewrite ffunE; exact: sumR_ge0.
  + have [A0_Q__neq0 | /esym A0_Q_0] : {0 < Q_A 0} + {0%R = Q_A 0}.
      by apply Rle_lt_or_eq_dec; rewrite ffunE; exact: sumR_ge0.
    * rewrite /Rdiv /log LogM //; last exact/invR_gt0.
      rewrite LogV //.
      have [A1_P_neq0 | /esym A1_P_0] : {0 < P_A 1} + {0%R = P_A 1}.
        by apply Rle_lt_or_eq_dec; rewrite ffunE; exact: sumR_ge0.
      - rewrite /log LogM //; last exact/invR_gt0.
        rewrite LogV //.
        apply Req_le; by field.
      - rewrite A1_P_0 !mul0R addR0; exact/Req_le.
    * rewrite ffunE in A0_Q_0; move/psumR_eq0P in A0_Q_0.
      have {}A0_Q_0 : forall i : A, i \in A_ 0 -> P i = 0%R.
        move=> i ?; rewrite (dominatesE P_dom_by_Q) // A0_Q_0 // => a ?; exact/pos_ff_ge0.
      have Habs : P_A 0 = 0%R.
        transitivity (\sum_(H|H \in A_ 0) 0%R).
          rewrite ffunE.
          apply eq_big => // i Hi; by rewrite -A0_Q_0.
        by rewrite big_const iter_addR mulR0.
      by move: A0_P_neq0; rewrite Habs; move/ltRR.
  + have H2 : P_A 1 = 0%R.
      rewrite ffunE in A1_Q_0; move/psumR_eq0P in A1_Q_0.
      rewrite /bipart /= ffunE /bipart_pmf (eq_bigr (fun=> 0%R)).
        by rewrite big_const iter_addR mulR0.
      move=> a ?; rewrite (dominatesE P_dom_by_Q) // A1_Q_0 // => b ?; exact/pos_ff_ge0.
    rewrite H2 !mul0R !addR0.
    have H3 : Q_A 0 = 1%R.
      rewrite -[X in X = _]addR0 -[X in _ + X = _]A1_Q_0 -(FDist.f1 Q).
      rewrite !ffunE -big_union //.
      apply eq_bigl => i; by rewrite cov in_set inE.
      by rewrite -setI_eq0 -dis setIC.
    rewrite H3 /Rdiv /log LogM //; last lra.
    by rewrite LogV; [apply Req_le; field | lra].
- have H1 : P_A 1 = 1%R.
    rewrite -[X in X = _]add0R -[X in X + _ = _]A0_P_0 -(FDist.f1 P).
    rewrite !ffunE -big_union //.
    apply eq_bigl => i; by rewrite cov in_set inE.
    by rewrite -setI_eq0 -dis setIC.
  have [A1_Q_neq0 | /esym A1_Q_0] : {0 < Q_A 1} + {0%R = Q_A 1}.
    by apply Rle_lt_or_eq_dec; rewrite ffunE; exact: sumR_ge0.
  + rewrite A0_P_0 !mul0R !add0R H1 !mul1R.
    rewrite /Rdiv /log LogM; last 2 first.
      lra.
      exact/invR_gt0.
    rewrite /log LogV //; apply Req_le; by field.
  + (* contradiction H1 / Bi_true_Q_0 *)
    rewrite ffunE in A1_Q_0; move/psumR_eq0P in A1_Q_0.
    have : P_A 1 = 0%R.
      rewrite !ffunE /bipart /= /bipart_pmf (eq_bigr (fun=> 0%R)).
      by rewrite big_const iter_addR mulR0.
      move=> a ?; rewrite (dominatesE P_dom_by_Q) // A1_Q_0 // => b ?; exact/pos_ff_ge0.
    by move=> abs; rewrite abs in H1; lra.
Qed.

End bipart_lem.


Require Import
  Algebra.SetsC
  Algebra.OrderC
  CMorphisms
  Prob.StdLib
  Types.UIP.

Set Universe Polymorphism.

Local Open Scope Subset.

Record PreOrder :=
  { PO_car :> Type
    (** The type of basic opens, i.e., observable property *)
  ; le : crelation PO_car
    (** a preorder on [S] which indicates when one basic open lies in another,
       i.e., one observable property implies another *)
   }.

Infix "<=" := (le _) : FT_scope.
Notation "a <=[ X ] b" := (le X a b) (at level 40, format "a  <=[ X ]  b").

Definition Open@{A P} (A : PreOrder@{A P}) := Subset@{A P} A.
Delimit Scope FT_scope with FT.

Local Open Scope FT.

Set Printing Universes.

Definition downset@{A P} {A : PreOrder@{A P}} (U : Open A) : Open A :=
  union U (fun x y => y <= x).

Notation "⇓ U" := (downset U) (at level 30).

Definition down@{A P} {A : PreOrder@{A P}} (U V : Open A) : Open A :=
  ⇓ U ∩ ⇓ V.

Infix "↓" := (down) (at level 30).

Section Down_Props.
Context {A : PreOrder}.

Lemma downset_included {PO : PreO.t (le A)} : forall (V : Open A),
   V ⊆ ⇓ V.
Proof.
intros. unfold Included, pointwise_rel, arrow; intros.
econstructor. eassumption. reflexivity.
Qed.

Lemma downset_Proper_impl : Proper (Included ==> Included)
  (@downset A).
Proof.
unfold Proper, respectful.
intros. unfold Included, In, pointwise_rel, arrow.
firstorder. unfold downset. exists a0. apply X. assumption. assumption.
Qed.

Instance downset_Proper : Proper (Same_set ==> Same_set) (@downset A).
Proof.
unfold Proper, respectful. intros.
apply Same_set_Included in X. destruct X.
apply Included_Same_set; apply downset_Proper_impl; try assumption;
  unfold respectful, arrow; intros; subst.
Qed.

Context {PO : PreO.t (le A)}.

Lemma down_intersection {U V : Subset A} :
  U ∩ V ⊆ U ↓ V.
Proof.
apply Included_impl. intros. destruct X.
unfold down. split; exists x;
  (assumption || reflexivity).
Qed.

Lemma downset_down_incl {U V : Subset A} :
  ⇓ (U ↓ V) === ⇓ (U ∩ V).
Proof.
Abort.

Lemma downset_down {U V : Subset A} :
  ⇓ (U ↓ V) === U ↓ V.
Proof.
apply Included_Same_set.
- unfold down. apply Intersection_Included.
  + apply Included_impl; intros. destruct X.
    destruct i. destruct d.
    eexists. eassumption. etransitivity; eassumption.
  + apply Included_impl; intros. destruct X.
    destruct i. destruct d0. eexists. eassumption.
    etransitivity; eassumption.
- apply downset_included.
Qed.

Lemma downset_idempotent (U : Subset A) :
 ⇓ (⇓ U) === ⇓ U.
Proof.
unfold downset. apply Same_set_iff. intros. split; intros.
- destruct X. destruct i. econstructor. eassumption.
  etransitivity; eassumption.
- exists x. assumption. reflexivity.
Qed.

Lemma down_assoc {U V W : Subset A} :
  (U ↓ V) ↓ W === U ↓ (V ↓ W).
Proof.
unfold down at 1 3.
rewrite !downset_down. unfold down.
symmetry.
apply Intersection_assoc.
Qed.

Lemma le_down {a b : A} : a <=[A] b
  -> eq a ↓ eq b === ⇓ (eq a).
Proof.
intros H. apply Included_Same_set.
- unfold down. apply Intersection_Included_l.
- apply Included_impl. intros. destruct X.
  unfold In in i. subst. split.
  eexists. reflexivity. eassumption. eexists.
  reflexivity. etransitivity; eassumption.
Qed.

Lemma down_eq {a b : A}
 : forall c : A, ((c <= a) * (c <= b))%type <--> (eq a ↓ eq b) c.
Proof.
intros. split; intros.
- destruct X. split; (eexists; [reflexivity | eassumption]).
- destruct X. destruct d, d0. unfold In in *. subst.
  split; assumption.
Qed.

Lemma down_Proper {U V U' V' : Subset A} :
  U ⊆ U' -> V ⊆ V' -> U ↓ V ⊆ U' ↓ V'.
Proof.
intros HU HV. unfold down.
apply Intersection_Included.
- etransitivity. apply Intersection_Included_l.
  apply downset_Proper_impl. assumption.
- etransitivity. apply Intersection_Included_r.
  apply downset_Proper_impl; assumption.
Qed.

Lemma down_comm {U V : Subset A}
  : U ↓ V === V ↓ U.
Proof.
unfold down. apply Intersection_comm.
Qed.

End Down_Props.

Lemma le_down1@{A P} {A : PreOrder@{A P}} {H : PreO.t@{A P} (le A)} (a b : A)
  : a <=[A] b <--> (⇓ eq b) a.
Proof.
split; intros X.
- exists b. reflexivity. assumption.
- destruct X. unfold In in i. subst. assumption.
Qed.

Lemma union_down {A B : PreOrder}
  (U : Subset A)
  (F : A -> B -> Type)
  : union U (fun a => ⇓ F a) === ⇓ union U F.
Proof.
intros b; split.
- intros H. destruct H. destruct d.
eexists. 2:eassumption.
econstructor; eassumption.
- intros H.  destruct H.  destruct i.
  eexists. eassumption. eexists; eassumption.
Qed.

Ltac le_down := rewrite <- !le_down1.
Ltac le_downH H := rewrite <- !le_down1 in H.

Lemma downset_eq_le {A : PreOrder}
  {PO : PreO.t (le A)}
(a b : A) :
  a <=[A] b ->
  ⇓ eq a ⊆ ⇓ eq b.
Proof.
intros Hle x H.
le_downH H.
le_down. etransitivity; eassumption.
Qed.

Definition BProdPO (A B : PreOrder) : PreOrder :=
  {| PO_car := A * B
  ; le := prod_op (le A) (le B) |}.

Section Sum.
Universes A P Ix.
Context {Ix : Type@{Ix}}.
Context {Ix_UIP : EqdepFacts.UIP_ Ix}.
Context {X : Ix -> PreOrder@{A P}}.

(** See
  https://www.cs.bham.ac.uk/~sjv/InfiniteTych.pdf
*)
Record SomeOpen_car@{} : Type@{A} :=
  { SOIx : Ix
  ; SOOpen : X SOIx
  }.

Inductive SomeOpen_le : SomeOpen_car -> SomeOpen_car -> Type :=
  | MkSomeOpen_le : forall ix (aix bix : X ix),
     aix <=[X ix] bix
     -> SomeOpen_le (Build_SomeOpen_car ix aix) (Build_SomeOpen_car ix bix).

Definition SomeOpen : PreOrder :=
  {| PO_car := SomeOpen_car
  ;  le := SomeOpen_le
  |}.

Definition MkSomeOpen (ix : Ix) (u : X ix) : SomeOpen
  := Build_SomeOpen_car ix u.

Context {PO : forall ix : Ix, PreO.t (le (X ix))}.

Instance Sum_PO : PreO.t SomeOpen_le.
Proof.
constructor; simpl; intros.
- destruct x. econstructor. reflexivity.
- induction X0. UIP_inv X1.
  econstructor. etransitivity; eassumption.
Qed.

End Sum.

Arguments SomeOpen {Ix} X.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import FunctionalExtensionality.
Require Import all_rs rs_reals Rstruct under.
Require Import Reals Qreals Psatz ClassicalChoice.

Import GRing.Theory.
Local Open Scope ring_scope.
Local Open Scope R_scope.

Section signed_digits.
Inductive SD := minusone | zero | one.

Definition SD2OB sd := match sd with
	| minusone => some false
	| zero => None
	| one => some true
end.

Lemma SD_eqClass: Equality.class_of SD.
Proof.
exists (fun sd sd' => (SD2OB sd == SD2OB sd')%bool).
by case; case; try exact: ReflectT; try exact: ReflectF.
Qed.

Canonical SD_eqType := Equality.Pack SD_eqClass Type.

Lemma SD_count:
	SD \is_countable.
Proof.
exists (fun n => match n with
	| 0%nat => Some minusone
	| S 0 => Some zero
	| S (S 0) => Some one
	| S (S (S n)) => None
end).
by case; [case; [exists 0%nat | exists 1%nat | exists 2%nat] | exists 3%nat].
Qed.

Definition SD2Z sd : Z := match sd with
	| one => 1%Z
	| zero => 0%Z
	| minusone => -1%Z
end.
End signed_digits.

Section SDs.
Fixpoint SDs2Zn (sds: nat -> SD) n := match n with
	| 0%nat => 0%Z
	| m.+1 => (2 * SDs2Zn sds m + SD2Z (sds m))%Z
end.

Lemma SDs2ZnS sds n :
	SDs2Zn sds n.+1 = (2 * SDs2Zn sds n + SD2Z (sds n))%Z.
Proof. by trivial. Qed.

Definition SD2R sd := match sd with
	| one => 1
	| zero => 0
	| minusone => -1
end.

Lemma IZR_SD2Z_SD2R sd: SD2R sd = IZR (SD2Z sd).
Proof. by case: sd. Qed.

Definition SDs2Rn (sds: nat -> SD) n := \sum_(i < n) SD2R (sds i) * /2 ^ i.+1.

Lemma SDs2Rn_SDs2Zn sds n: SDs2Rn sds n = IZR (SDs2Zn sds n) / 2^n.
Proof.
elim: n => [ | n ih]; first by rewrite /SDs2Rn big_ord0 /GRing.zero /=; try lra.
rewrite SDs2ZnS plus_IZR mult_IZR Rdiv_plus_distr Rmult_comm /Rdiv.
rewrite /SDs2Rn in ih.
rewrite /SDs2Rn big_ord_recr /= ih IZR_SD2Z_SD2R Rmult_assoc.
have ->: 2 * / (2 * 2 ^ n) = / 2 ^ n by have lt:= pow_lt 2 n; rewrite Rinv_mult_distr; try lra.
rewrite /GRing.mul/GRing.add/=; try lra.
Qed.

Lemma SDs2Zn_SDs2Rn sds n: IZR (SDs2Zn sds n) = 2 ^ n * SDs2Rn sds n.
Proof.
have lt:= pow_lt 2 n.
by rewrite SDs2Rn_SDs2Zn /Rdiv Rmult_comm Rmult_assoc Rinv_l; try lra.
Qed.

Lemma SDs2Rn0 sds: SDs2Rn sds 0%nat = 0.
Proof. by rewrite /SDs2Rn big_ord0. Qed.

Lemma Rabs_SDs2Rn u n : Rabs (SDs2Rn u n) <= 1 - /2^n.
Proof.
rewrite /SDs2Rn; case: n => [ | n]; first by rewrite big_ord0/= /GRing.zero /=; split_Rabs; lra.
elim: n => [ | n ih].
	rewrite /SDs2Rn big_ord1/= /GRing.mul /=.
	by case: (u 0%nat) => /=; split_Rabs; try lra.
rewrite /SDs2Rn big_ord_recr/=.
have p2lt: 0 < /2^n by apply /Rinv_0_lt_compat/pow_lt; lra.
have p2lt': 0 < 2^n by apply /pow_lt; lra.
apply triang.
have ->: 1 - / (2 * (2 * 2 ^ n)) = 1 - /2^n.+1 + (/2^n.+1 -  / (2 * (2 * 2 ^ n))) by lra.
apply Rplus_le_compat; first exact ih; rewrite !Rinv_mult_distr; try lra.
by case: (u n.+1); rewrite /GRing.mul /= ?Rmult_0_l; split_Rabs; try lra.
Qed.

Lemma SDs2RnS sds n : SDs2Rn sds n.+1 = SDs2Rn sds n + SD2R (sds n) * /2^n.+1.
Proof.
by rewrite /SDs2Rn big_ord_recr /=.
Qed.

Lemma SDs2RSn sds n : SDs2Rn sds n.+1 = /2 * SDs2Rn (fun i => sds i.+1) n + /2 * SD2R (sds 0%nat).
Proof.
rewrite /SDs2Rn big_ord_recl /= addrC.
congr (_ + _); last rewrite Rmult_1_r /GRing.mul /=; try lra.
elim: n => [ | n ih]; first by rewrite !big_ord0 /GRing.zero /=; lra.
rewrite big_ord_recr /= ih [\sum_(i < n.+1) _] big_ord_recr /=.
have ->: bump 0%nat n = n.+1 by rewrite /bump.
rewrite Rmult_plus_distr_l.
congr (_ + _).
have plt:= pow_lt 2 n.
by rewrite !Rinv_mult_distr /GRing.mul /=; try lra.
Qed.

Lemma Rabs_SDs2Rnm sds n m (ineq: (n <= m)%nat):
	Rabs (SDs2Rn sds m - SDs2Rn sds n) <= /2^n  - /2^m.
Proof.
elim: n m ineq sds => [m ineq sds| n ih m ineq].
	rewrite {2}/SDs2Rn big_ord0 Rminus_0_r Rinv_1; exact: Rabs_SDs2Rn.
move => sds; case: m ih ineq => // m ih ineq.
rewrite !SDs2RSn; specialize (ih m ineq (fun i => sds i.+1)).
have lt1:= pow_lt 2n; have lt2:= pow_lt 2 m; rewrite /= !Rinv_mult_distr; split_Rabs; try lra.
Qed.

Lemma Cauchy_crit_eff_SDs2Rn sds :	Cauchy_crit_eff (SDs2Rn sds).
Proof.
apply /Cauchy_crit_eff_suff => n m ineq.
rewrite Rabs_minus_sym; have lt: 0 < /2^m by apply /Rinv_0_lt_compat /pow_lt; lra.
by apply /Rle_trans; first apply Rabs_SDs2Rnm; try lra.
Qed.

Lemma Cauchy_crit_SDs2Rn sds :	Cauchy_crit (SDs2Rn sds).
Proof. exact /Cauchy_crit_eff_Cauchy_crit /Cauchy_crit_eff_SDs2Rn. Qed.

Definition SDs2R := lim o (F2MF SDs2Rn).

Lemma SDs2R_tot: SDs2R \is_total.
Proof.
rewrite /SDs2R F2MF_comp => sds.
have [x /Uncv_lim xprp]:= R_complete _ (Cauchy_crit_SDs2Rn sds).
by exists x.
Qed.

Lemma SDs2R_sing: SDs2R \is_single_valued.
Proof. by apply /comp_sing; [exact /lim_sing | exact /F2MF_sing]. Qed.

Lemma SDs2R_lim_eff: SDs2R =~= lim_eff o (F2MF SDs2Rn).
Proof.
rewrite lim_eff_Cauchy /SDs2R !F2MF_comp => sds x.
split => [limx| [Cauchy limx]]; first by split; first exact: Cauchy_crit_eff_SDs2Rn.
apply lim_exte_lim_eff.
have [y limeffy]:= (Cauchy_conv (SDs2Rn sds)).1 Cauchy.
by rewrite (@lim_sing (SDs2Rn sds) x y) => //; apply lim_exte_lim_eff.
Qed.

Lemma SDs2R_eff sds x: SDs2R sds x <-> lim_eff (SDs2Rn sds) x.
Proof. have:= SDs2R_lim_eff; rewrite F2MF_comp => prp; apply prp. Qed.

Lemma SDs2R_UI u x: SDs2R u x -> -1 <= x <= 1.
Proof.
move => /SDs2R_eff val; move: (val 0%nat) => /=.
rewrite /SDs2Rn big_ord0/= Rminus_0_l Rabs_Ropp; split_Rabs; lra.
Qed.
End SDs.

Section Lists.
Fixpoint SDL2R L:= match L with
	| [::] => 0
	| sd :: K => SDL2R K + SD2R sd * /2 ^ (size L)
end.

Lemma SDL2RS sd L: SDL2R (sd :: L) = SDL2R L + SD2R sd * /2 ^ (size L).+1.
Proof. done. Qed.

Fixpoint SDL2Z L := match L with
	| [::] => 0%Z
	| sd :: K => (2 * SDL2Z K + SD2Z sd)%Z
end.

Lemma SDL2ZS a L: SDL2Z (a :: L) = (2 * SDL2Z L + SD2Z a)%Z.
Proof. done. Qed.

Lemma SDL2Z_SDL2R L: IZR (SDL2Z L) = SDL2R L * 2^(size L).
Proof.
elim: L => [ | a L]; first by rewrite /=; lra.
rewrite SDL2ZS [RHS]/= plus_IZR mult_IZR => -> /=; have lt:= pow_lt 2 (size L).
rewrite Rmult_plus_distr_r Rmult_assoc Rinv_l ?IZR_SD2Z_SD2R; try lra.
Qed.

Lemma SDs2Zn_SDL2Z sds n:
	SDs2Zn sds n = SDL2Z (in_seg sds n).
Proof. by elim: n => // n ih; rewrite SDs2ZnS ih. Qed.

Lemma SDs2Rn_SDL2R sds n:
	SDs2Rn sds n = SDL2R (in_seg sds n).
Proof.
elim: n => [ | n ih]; first by rewrite /SDs2Rn big_ord0.
by rewrite /= SDs2RnS /= size_inseg ih.
Qed.
End Lists.

Section rep_UI.
Definition UI := { x | -1 <= x <= 1}.

Definition rep_UI sds (x: UI):= SDs2R sds (projT1 x).

Lemma rep_UI_tot: rep_UI \is_total.
Proof.
by move => sds; have [x val]:= SDs2R_tot sds; exists (exist _ x (SDs2R_UI sds x val)).
Qed.

Lemma rep_UI_sing: 	rep_UI \is_single_valued.
Proof.
move => sds x y sdsnx sdsny; apply /eq_sub /SDs2R_sing; [apply sdsnx | apply sdsny].
Qed.

Definition rep_UI_inc phi (x: UI) :=
	forall L, Rabs (projT1 x - SDL2R L) <= /2^(size L)
	->
	Rabs (projT1 x - SDL2R (phi L :: L)) <= /2^(size L).+1.

Fixpoint UI_inc_to_UI_rec (Lf: seq SD -> SD) m := match m with
	| 0%nat => [::]
	| S k => (Lf (UI_inc_to_UI_rec Lf k):: UI_inc_to_UI_rec Lf k)
end.

Lemma UI_inc_to_UI_rec_size Lf n:
	size (UI_inc_to_UI_rec Lf n) = n.
Proof. by elim: n => // n /= ->. Qed.

Definition UI_inc_to_UI (Lf: seq SD -> SD) n := Lf (UI_inc_to_UI_rec Lf n).

Lemma UI_inc_to_UI_inseg Lf n:
	in_seg (UI_inc_to_UI Lf) n = UI_inc_to_UI_rec Lf n.
Proof. by elim :n => // n /= ->. Qed.

Lemma UI_inc_to_UI_correct Lf x:
	rep_UI_inc Lf x -> rep_UI (UI_inc_to_UI Lf) x.
Proof.
move: x => [x ineq] Lfnx; rewrite /rep_UI SDs2R_eff; elim => [ | n /=].
	by rewrite /= SDs2Rn0; split_Rabs; try lra.
rewrite SDs2RnS SDs2Rn_SDL2R Rabs_minus_sym UI_inc_to_UI_inseg.
have ltn: 0<2^n by apply pow_lt; lra.
rewrite -{2}(UI_inc_to_UI_rec_size Lf n); try lra; move => ih.
have /=:= Lfnx (UI_inc_to_UI_rec Lf n) ih.
by rewrite UI_inc_to_UI_rec_size Rabs_minus_sym.
Qed.

Lemma rep_UI_inc_sing: rep_UI_inc \is_single_valued.
Proof.
move => Lf x y Lfnx Lfny.
by apply /(rep_UI_sing (UI_inc_to_UI Lf)); apply UI_inc_to_UI_correct.
Qed.

Lemma rep_UI_inc_nc (x: UI):
	(forall q, exists a, Rabs (projT1 x - SDL2R q) <= /2^(size q)
		-> Rabs (projT1 x - SDL2R (a :: q)) <= /2^(size q).+1)
	-> x \from_codom rep_UI_inc.
Proof. by move => R; apply (choice _ R). Qed.

Lemma rep_UI_inc_cotot: is_cotot rep_UI_inc.
Proof.
move => [x ineq].
apply rep_UI_inc_nc => sdL.
case: (classic (x <= SDL2R sdL)) => leq.
	exists minusone => /= ineq'.
have leq':= pow_lt 2 (size sdL).
	rewrite Rinv_mult_distr; try lra.
	have leq'': 0 < /2 ^ (size sdL) by apply Rinv_0_lt_compat; lra.
	by split_Rabs; try lra.
exists one => /= ineq'.
have leq':= pow_lt 2 (size sdL).
rewrite Rinv_mult_distr; try lra.
have leq'': 0 < /2 ^ (size sdL) by apply Rinv_0_lt_compat; lra.
by split_Rabs; try lra.
Qed.

Lemma rep_UI_inc_is_rep: 	rep_UI_inc \is_representation.
Proof. by split; [apply: rep_UI_inc_sing | apply rep_UI_inc_cotot]. Qed.

Definition rep_space_UI_inc :=
@make_rep_space UI (seq SD) SD rep_UI_inc [::] zero (list_count SD_count) (SD_count) rep_UI_inc_is_rep.

Lemma rep_UI_cotot: is_cotot rep_UI.
Proof.
move => x.
have [Lf Lfnx]:= rep_UI_inc_cotot x.
exists (UI_inc_to_UI Lf).
by apply UI_inc_to_UI_correct.
Qed.

Lemma rep_UI_is_rep: rep_UI \is_representation.
Proof. by split; [apply: rep_UI_sing | apply: rep_UI_cotot]. Qed.

Canonical rep_space_UI := @make_rep_space
	UI
	_
	_
	rep_UI
	(some_question _)
	zero
	(countable_questions _)
	SD_count
	rep_UI_is_rep.
End rep_UI.

Section SD_and_SD_inc.
(* The representation rec_SD_inc provides more information about signed digits:
One can extend any valid begining segment of a name in the usual representation
to a full name. Its definition is convenient for proving the signed digit representation
surjective and it is comptuationally equivalent. The equivalence is currently not executable
since I couldn't figure out how to properly do branching on rational numbers.*)

(* This function should do the branching over the rational numbers so it
is executable. *)
Definition UI_to_UI_inc sds L :=
	if is_left (Z_lt_dec (SDs2Zn sds (size L).+1) (2 * SDL2Z L)) then minusone
		else if is_left (Z_lt_dec (2 * SDL2Z L) (SDs2Zn sds (size L).+1)) then one
			else zero.

Fixpoint sds n := match n with
	| 0%nat => one
	| S 0 => zero
	| S (S 0) => minusone
	| S (S (S n)) => sds n
end.

Lemma UI_to_UI_inc_correct sds x:
	rep_UI sds x -> rep_UI_inc (UI_to_UI_inc sds) x.
Proof.
move: x => [x xui] /SDs2R_eff /= sdsnx L /= ineq1.
have g0: 0 < 2 ^ size L by apply pow_lt; lra.
have := sdsnx (size L).+1; rewrite Rabs_minus_sym Rinv_mult_distr; try lra.
move => ineq2.
rewrite /UI_to_UI_inc; case: ifP; case: Z_lt_dec => // lt _.
	move/(Zlt_le_succ _ _)/IZR_le: lt.
	rewrite /Z.succ plus_IZR mult_IZR SDs2Zn_SDs2Rn SDL2Z_SDL2R => /= lt.
	have ineq3: (SDs2Rn sds (size L).+1) <= SDL2R L - /2* /2^size L.
		apply: (Rmult_le_reg_r (2* 2^size L)); try lra.
		rewrite [(_ - _) * _]Rmult_comm Rmult_minus_distr_l.
		by rewrite -Rinv_mult_distr; try lra; rewrite Rinv_r; lra.
	by split_Rabs; try lra.
case: ifP; case: Z_lt_dec => // gt _.
	move/(Zlt_le_succ _ _)/IZR_le: gt.
	rewrite /Z.succ plus_IZR mult_IZR SDs2Zn_SDs2Rn SDL2Z_SDL2R => /= gt.
	have ineq3: (SDL2R L) <= SDs2Rn sds (size L).+1 - /2* /2^size L.
		apply: (Rmult_le_reg_r (2* 2^size L)); try lra.
		rewrite [(_ - _) * _]Rmult_comm Rmult_minus_distr_l.
		by rewrite -Rinv_mult_distr; try lra; rewrite Rinv_r; lra.
	by split_Rabs; try lra.
have eq: (SDs2Zn sds (size L).+1 = 2 * SDL2Z L)%Z by lia.
have:= IZR_eq _ _ eq.
move: eq; rewrite SDs2Zn_SDs2Rn mult_IZR SDL2Z_SDL2R /= => _ eq.
have: (SDs2Rn sds (size L).+1 = SDL2R L).
	apply: (Rmult_eq_reg_l (2 * 2 ^size L)); lra.
by move <-; split_Rabs; try lra.
Qed.

Lemma UI_UI_inc_iso: wisomorphic rep_space_UI rep_space_UI_inc.
Proof.
do 2 exists ((fun x y => x = y)).
split; last split; last by split => x y; apply comp_id_l.
	apply rec_cmpt; exists UI_to_UI_inc => phi x phinx _.
	by exists x; split => //; apply UI_to_UI_inc_correct.
apply rec_cmpt; exists UI_inc_to_UI => phi x phinx _.
by exists x; split => //; apply UI_inc_to_UI_correct.
Qed.
End SD_and_SD_inc.

Section sd_coinduction.
Lemma SDs2R_hd sds x: SDs2R sds x -> - 1 <= 2 * x - SD2R (sds 0%nat) <= 1.
Proof.
move: x => x; rewrite /=/GRing.zero /= SDs2R_eff => unx.
specialize (unx 1%nat); move: unx; rewrite /SDs2Rn big_ord1.
by case: (sds 0%nat) => /=; rewrite /GRing.mul /=; split_Rabs; lra.
Qed.

Lemma SDs2R_tl sds x: SDs2R sds x -> SDs2R (fun n => sds n.+1) (2 * x - SD2R (sds 0%nat)).
Proof.
rewrite !SDs2R_eff => unx n; apply: (Rmult_le_reg_l (/2)); try lra.
rewrite -[/2 * / _]Rinv_mult_distr; try lra; last by have:= pow_lt 2 n; lra.
apply/ Rle_trans; last by apply: unx n.+1.
rewrite {2}/SDs2Rn big_ord_recl /= /SDs2Rn.
suff <- : (/ 2 * \sum_(i < n) SD2R (sds i.+1) * /2 ^ i.+1) = \sum_(i < n) SD2R (sds (bump 0 i)) * / (2 * (2 * 2 ^ i)) by rewrite /GRing.mul /GRing.add/=; split_Rabs; try lra.
elim: n => [ | n ih]; first by rewrite !big_ord0 /GRing.zero /=; lra.
have p2lt: 0 < 2^n by apply pow_lt; lra.
rewrite big_ord_recr/= Rmult_plus_distr_l ih [RHS]big_ord_recr/=.
congr (_ + _).
have -> : bump 0 n = n.+1%nat by trivial.
rewrite !Rinv_mult_distr; try lra.
by rewrite /GRing.mul/=; try lra.
Qed.
End sd_coinduction.

Section output_and_examples.
Definition SDs2Qn sds n := (inject_Z (SDs2Zn sds n) / (2#1)^Z.of_nat n)%Q.
(*Example: Compute Qreduction.Qred (SDs2Qn sds 17). *)
End output_and_examples.

Section all_reals.
Definition ZUI2R (zx: Z * UI) := IZR zx.1 + projT1 zx.2.

Definition count_pos n := match n with
	| 0%nat => None
	| S n => Some (Pos.of_nat n)
end.

Lemma count_pos_sur: count_pos \is_surjective_function.
Proof.
case => [p | ]; last by exists 0%nat.
by exists (Pos.to_nat p).+1; rewrite /count_pos Pos2Nat.id.
Qed.

Lemma Z_count: Z \is_countable.
Proof.
pose count_Z := fix count_Z n := match n with
	| 0%nat => None
	| S 0 => Some Z0
	| S (S 0) => Some (Z.pos xH)
	| S (S (S 0)) => Some (Z.neg xH)
	| S (S n) => match count_Z n with
		| None => None
		| Some Z0 => Some Z0
		| Some (Z.neg p) => Some (Z.pred (Z.neg p))
		| Some (Z.pos p) => Some (Z.succ (Z.pos p))
	end
end.
exists count_Z.
case; last by exists 0%nat.
case => [ | p | p]; first by exists 1%nat.
	rewrite -[p]Pos2Nat.id.
	elim: (Pos.to_nat p) => [ | n [m eq]]; first by exists 2%nat.
	case: n eq => [ | n eq]; first by exists 2%nat.
	exists m.+2.
	Search _ Pos.of_nat.
	rewrite /= eq.
	case: m eq => //; case => // m eq.
	by rewrite Pplus_one_succ_r.
rewrite -[p]Pos2Nat.id.
elim: (Pos.to_nat p) => [ | n [m eq]]; first by exists 3%nat.
case: n eq => [ | n eq]; first by exists 3%nat.
exists m.+2.
Search _ Pos.of_nat.
rewrite /= eq.
case: m eq => //; case => // m eq.
by rewrite Pplus_one_succ_r.
Qed.

Canonical rep_space_Z := @make_rep_space Z rs_one.one Z (@id_rep Z) star Z0 one_count Z_count (@id_rep_is_rep Z).

Definition rep_R := (F2MF ZUI2R) o (rep (rep_space_prod rep_space_Z rep_space_UI)).

Lemma rep_R_sing: rep_R \is_single_valued.
Proof. by apply/ comp_sing; [apply: F2MF_sing | apply /(rep_sing _)]. Qed.

Lemma rep_R_cotot: is_cotot rep_R.
Proof.
move => x; have ineq: -1 <= x - up x <= 1 by have := archimed x; lra.
pose y:UI := (exist _ (x - up x) ineq).
have [phi2 phi2ny]:= rep_UI_cotot y.
pose phi1: names rep_space_Z := (fun _ => up x).
exists (name_pair phi1 (phi2: names rep_space_UI)).
split; last by move => a b; apply F2MF_tot.
exists (up x, y).
split; last by rewrite /F2MF /y /ZUI2R /=; lra.
by rewrite /=/prod_rep/= lprj_pair rprj_pair.
Qed.

Lemma rep_R_is_rep: rep_R \is_representation.
Proof. by split; [apply: rep_R_sing | apply: rep_R_cotot]. Qed.

Canonical rep_space_R := @make_rep_space R _ _ rep_R (some_question _) (some_answer _) (countable_questions _) (countable_answers _) rep_R_is_rep.
End all_reals.


Require Import VST.floyd.proofauto.
Require Import CertiGraph.summatrix.summatrix.
Require Import VST.msl.iter_sepcon.

Local Open Scope logic.

#[local] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition WORD_SIZE := 4.

Definition sum_list (l : list Z) : Z :=
  fold_right Z.add 0 l.

Lemma sum_list_app:
  forall a b, sum_list (a++b) = sum_list a + sum_list b.
Proof. intros. induction a; simpl; lia. Qed.

(* Functional spec of this program *)
Definition sum_mat (m : list (list Z)) : Z :=
  sum_list (map sum_list m).

Lemma sum_mat_app:
  forall a b, sum_mat (a++b) =  sum_mat a + sum_mat b.
Proof.
  intros. induction a; unfold sum_mat in *; simpl; [|rewrite IHa]; lia.
Qed.

Fixpoint Z_inc_list (n: nat) : list Z :=
  match n with
  | O => nil
  | S n' => Z_inc_list n' ++ (Z.of_nat n' :: nil)
  end.

Lemma Z_inc_list_length: forall n, Zlength (Z_inc_list n) = Z.of_nat n.
Proof.
  intros. induction n. trivial.
  simpl Z_inc_list. rewrite Zlength_app. rewrite IHn.
  rewrite Nat2Z.inj_succ. unfold Zlength. simpl. lia.
Qed.

Lemma Z_inc_list_in_iff: forall n v, List.In v (Z_inc_list n) <-> 0 <= v < Z.of_nat n.
Proof.
  induction n; intros; [simpl; intuition|]. rewrite Nat2Z.inj_succ. unfold Z.succ. simpl. rewrite in_app_iff.
  assert (0 <= v < Z.of_nat n + 1 <-> 0 <= v < Z.of_nat n \/ v = Z.of_nat n) by lia. rewrite H. clear H. rewrite IHn. simpl. intuition.
Qed.

Lemma Z_inc_list_eq: forall i len,
    0 <= i < (Z.of_nat len) ->
    i = Znth i (Z_inc_list len).
Proof.
  intros. generalize dependent i. induction len.
  1: intros; exfalso; destruct H; rewrite Nat2Z.inj_0 in H0; lia.
  intros. simpl. rewrite Nat2Z.inj_succ in H. destruct H.
  apply Zlt_succ_le in H0. apply Zle_lt_or_eq in H0. destruct H0.
  - rewrite app_Znth1. apply IHlen. lia. now rewrite Z_inc_list_length.
  - rewrite app_Znth2 by (rewrite Z_inc_list_length; lia).
    rewrite H0 at 2. rewrite Z_inc_list_length. simpl.
    replace (Z.of_nat len - Z.of_nat len) with 0 by lia.
    rewrite Znth_0_cons; trivial.
Qed.

Definition list_address a index size : val :=
  offset_val (index * sizeof (tarray tuint size)) a.

Definition list_rep sh size l contents_mat index :=
  let mylist := (Znth index contents_mat) in
  data_at sh (tarray tuint size) (map Vint (map Int.repr mylist)) (list_address l index size).

Definition matrix_rep sh size contents_mat m : mpred :=
  iter_sepcon (list_rep sh size m contents_mat)
              (Z_inc_list (Z.to_nat (Zlength contents_mat))).

Lemma matrix_unfold: forall sh size contents ptr i,
    0 <= i < (Zlength contents) ->
    matrix_rep sh size contents ptr =
    iter_sepcon (list_rep sh size ptr contents)
            (sublist 0 i (Z_inc_list (Z.to_nat (Zlength contents)))) *
    (list_rep sh size ptr contents i * emp *
           iter_sepcon (list_rep sh size ptr contents)
             (sublist (i + 1) (Zlength contents) (Z_inc_list (Z.to_nat (Zlength contents))))).
Proof.
  intros. unfold matrix_rep.
  replace (Z_inc_list (Z.to_nat (Zlength contents))) with
      (sublist 0 (Zlength contents) (Z_inc_list (Z.to_nat (Zlength contents)))) at 1.
  2: { rewrite sublist_same; trivial.
       rewrite Z_inc_list_length, Z2Nat_id', Z.max_r; trivial.
       apply Zlength_nonneg.
  }
  rewrite (sublist_split 0 i (Zlength contents)),
  (sublist_split i (i+1) (Zlength contents)), (sublist_one i); try lia.
  2, 3, 4: rewrite Z_inc_list_length; rewrite Z2Nat.id; lia.
  rewrite <- (Z_inc_list_eq i (Z.to_nat (Zlength contents))).
  2: rewrite Z2Nat_id', Z.max_r; trivial; apply Zlength_nonneg.
  repeat rewrite iter_sepcon_app. reflexivity.
Qed.

(* The API spec for the sumarray.c program *)
Definition summatrix_spec : ident * funspec :=
 DECLARE _summatrix
         WITH a: val, sh : share, contents_mat : list (list Z)
  PRE [tptr (tarray tuint 2), tint ]
   PROP  (readable_share sh;
          Zlength contents_mat = 2;
          Forall (fun list => Zlength list = 2) contents_mat;
          Forall (fun list => Forall (fun x => 0 <= x <= Int.max_unsigned) list) contents_mat)
   PARAMS (a; Vint (Int.repr 2))
   GLOBALS ()
   SEP (matrix_rep sh 2 contents_mat a)
  POST [ tuint ]
   PROP ()
   LOCAL(temp ret_temp (Vint (Int.repr (sum_mat contents_mat))))
   SEP (matrix_rep sh 2 contents_mat a).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     PROP()
     LOCAL (temp ret_temp (Vint (Int.repr (1+2+3+4))))
     SEP(TT).

Definition Gprog : funspecs :=
        ltac:(with_library prog [summatrix_spec; main_spec]).

Lemma body_summatrix: semax_body Vprog Gprog f_summatrix summatrix_spec.
Proof.
  start_function.
  forward.  (* i = 0; *)
  forward.  (* j = 0; *)
  forward.  (* s = 0; *)
  forward_while
    (EX i: Z,
     PROP  (0 <= i <= 2)
     LOCAL (temp _a a;
            temp _i (Vint (Int.repr i));
            (* temp _j (Vint (Int.repr j)); *)
            temp _n (Vint (Int.repr 2));
            temp _s (Vint (Int.repr (sum_mat (sublist 0 i contents_mat)))))
     SEP   (matrix_rep sh 2 contents_mat a)).
  - Exists 0; entailer!.
  - entailer!.
  - forward.
    forward_while
      (
       EX j: Z,
       PROP (0 <= j <= 2)
       LOCAL (temp _a a;
              temp _i (Vint (Int.repr i));
              temp _j (Vint (Int.repr j));
              temp _n (Vint (Int.repr 2));
              temp _s
                   (Vint
                      (Int.add
                         (Int.repr (sum_list (sublist 0 j (Znth i contents_mat))))
                         (Int.repr (sum_mat (sublist 0 i contents_mat))))))
       SEP (matrix_rep sh 2 contents_mat a)).
    + Exists 0; entailer!.
    + entailer!.
    + rewrite (matrix_unfold _ _ _ _ i) by lia. Intros.
      freeze F := (iter_sepcon (list_rep sh 2 a contents_mat)
                               (sublist 0 i (Z_inc_list (Z.to_nat (Zlength contents_mat))))) (iter_sepcon (list_rep sh 2 a contents_mat)
                                                                                (sublist (i + 1) (Zlength contents_mat)
                                                                                (Z_inc_list (Z.to_nat (Zlength contents_mat))))).
      unfold list_rep.
      (* Okay now I have a simple list-access problem.
       * I have the exact address (list_address) and I want the j'th item.
       *)
      unfold list_address. simpl.
      (* At this point, other examples of reads just work.
       * They just do forward.
       * Refer to VST/progs/sumarray.v
       * The only difference I can see is that
       *  "(offset_val (i * (4 * size)) a)"
       *  is not in LOCAL. "a" is. Should I fix that??
       *)
      Fail forward.
      (* Anyway I tried forward. It failed. So I started
       * doing what it hinted at...
       *)
      assert_PROP (force_val
                     (sem_add_ptr_int tuint Signed
                                      (force_val (sem_add_ptr_int (tarray tuint 2) Signed a (Vint (Int.repr i))))
                                      (Vint (Int.repr j))) = field_address (tarray tuint 2) [ArraySubsc j] (list_address a i 2)).
      (* Btw, From vc.pdf I learnt that field_address actually needs
       * the type of the array (tarray tuint 2),
       * not the type of the j'th item.
       * Okay cool, changed. Let's go.
       *)
      { entailer!. unfold list_address. simpl.
        rewrite field_address_offset.
        1: rewrite offset_offset_val; simpl; f_equal; rep_lia.
        unfold field_compatible in H5. destruct H4 as [? [? [? [? ?]]]].
        unfold field_compatible. split3; [| | split3]; auto.
        unfold legal_nested_field. split; [auto | simpl; lia].
      }
      (* I gave forward what it wanted. Let's go. *)
      assert (Zlength (Znth i contents_mat) = 2).
      { rewrite Forall_forall in H0. apply H0. apply Znth_In. lia. }
      forward. forward. forward.
      Exists (j+1). entailer!.
      * f_equal. f_equal.
        rewrite sublist_last_1; [|lia..].
        rewrite sum_list_app; simpl; lia.
      * thaw F. rewrite (matrix_unfold _ _ _ _ i). entailer!. lia.
    + forward. Exists (i+1).
      entailer!. assert (j = Zlength contents_mat) by lia.
      assert (j = 2) by lia.
      assert (Zlength (Znth i contents_mat) = 2).
      { rewrite Forall_forall in H0. apply H0. apply Znth_In. lia. }
      rewrite (sublist_same 0 j); trivial. 2: now rewrite H6.
      rewrite sublist_last_1; try rep_lia.
      rewrite sum_mat_app. do 2 f_equal.
      unfold sum_mat at 2.
      simpl. lia.
  - unfold POSTCONDITION, abbreviate.
    forward. entailer!.
    assert (i = Zlength contents_mat) by lia.
    rewrite sublist_same; trivial.
Qed.


Require Export A_3_3.

Module A3_5.

(* 3.5 无穷小量与无穷大量 *)

(* 定义1: 无穷小量 *)
Definition Infinitesimal (f : Fun) (x0 : R) := limit f x0 0.

(* 高阶无穷小量 *)
Definition InfinitesimalHigherOrder (f g : Fun) (x0 : R) :=
   Function f /\ Function g /\ (∃ δ, 0 < δ /\ Neighbor0 x0 δ ⊂ dom[f]
  /\ Neighbor0 x0 δ ⊂ dom[g] /\ (∀ x, x ∈ Neighbor0 x0 δ -> g[x] <> 0)) /\
  limit {` λ x y, y = f[x] / g[x] `} x0 0.

(* 等价无穷小 *)
Definition InfinitesimalEquivalent (f g : Fun) (x0 : R) :=
  Function f /\ Function g /\ (∃ δ, 0 < δ /\ Neighbor0 x0 δ ⊂ dom[f]
  /\ Neighbor0 x0 δ ⊂ dom[g] /\ (∀ x, x ∈ Neighbor0 x0 δ -> g[x] <> 0)) /\
  limit {` λ x y, y = f[x] / g[x] `} x0 1.

(* 定理3.12 *)
Theorem Theorem3_12 : ∀ (f g h : Fun) (x0 A : R),
  InfinitesimalEquivalent f g x0
  -> limit {` λ x y, y = f[x] * h[x] `} x0 A
  -> limit {` λ x y, y = g[x] * h[x] `} x0 A.
Proof.
  intros f g h x0 A H7 H8.
  destruct H7 as [H7 [H9 [[δ1 [H10 [H11 [H12 H13]]]] H14]]].
  clear H7. clear H9.
  assert (H15 : Function {` λ x y, y = g [x] / f [x] `}).
  { intros x y z I1 I2. applyAxiomII' I1; applyAxiomII' I2.
    rewrite I2. assumption. }
  assert (H16 : ∃ δ2, δ2 > 0 /\ (∀ x, x ∈ (Neighbor0 x0 δ2)
    -> {` λ x y, y = f[x] / g[x] `}[x] <> 0)).
  { assert (I1 : 1 > 0). lra.
    generalize (Theorem3_4_1 {` λ x y, y = f[x] / g[x] `} x0 1 H14 I1).
    intro I2. assert (I3 : 0 < 1/2 < 1). lra.
    apply I2 in I3 as I4.
    destruct I4 as [δ3 [I4 I5]].
    exists δ3. split; auto. intros x I6.
    apply I5 in I6. lra. }
  destruct H16 as [δ2 [H16 H17]].
  assert (H18 : ∃ δ3, δ3 > 0 /\ (∀ x, x ∈ (Neighbor0 x0 δ3)
    -> f[x] <> 0)).
  { assert (I2 : ∃ δ4, δ4 > 0 /\ δ4 <= δ1 /\ δ4 <= δ2).
    { destruct (Rlt_or_le δ1 δ2) as [I1 | I1].
      - exists δ1. split; lra.
      - exists δ2. split; lra. }
    destruct I2 as [δ4 [I2 [I3 I4]]]. exists δ4. split; auto.
    intros x I5.
    applyAxiomII I5.
    assert (I6 : x ∈ Neighbor0 x0 δ1).
    { apply AxiomII. lra. }
    assert (I7 : x ∈ Neighbor0 x0 δ2).
    { apply AxiomII. lra. }
    apply H13 in I6 as I8. apply H17 in I7 as I9.
    assert (I10 : {` λ x y, y = f [x] / g [x] `} [x] = f[x] / g[x]).
    { apply f_x; try apply H14. apply AxiomII'. reflexivity. }
    rewrite I10 in I9. clear I10. intro I10.
    apply I9. rewrite I10. apply Rmult_0_l. }
  destruct H18 as [δ3 [H18 H19]].
  assert (H20 : limit ({` λ x y, y = g [x] / f [x] `}
    ** {` λ x y, y = f[x] * h[x] `}) x0 A).
  { rewrite <- (Rmult_1_l A). apply Theorem3_7_3; auto.
    assert (I1 : 1 <> 0). lra.
    generalize (Theorem3_7_4' {` λ x y, y = f [x] / g [x] `}
      x0 1 H14 I1). intro I2. rewrite Rinv_1 in I2. unfold limit.
    split; auto. destruct I2 as [I3 [δ4 [I4 [I5 I6]]]].
    assert (I2 : ∃ δ5, δ5 > 0 /\ δ5 <= δ4 /\ δ5 <= δ1 /\ δ5 <= δ3).
    { destruct (Rlt_or_le δ1 δ4) as [J1 | J1].
      - destruct (Rlt_or_le δ1 δ3) as [J2 | J2].
        + exists δ1. lra.
        + exists δ3. lra.
      - destruct (Rlt_or_le δ4 δ3) as [J2 | J2].
        + exists δ4. lra.
        + exists δ3. lra. }
    destruct I2 as [δ5 [I7 [I8 [I9 I10]]]].
    exists δ5. repeat split; auto.
    - intros x J1. apply AxiomII. exists (g[x] / f[x]).
      apply AxiomII'. reflexivity.
    - intros ε J1. apply I6 in J1 as J2.
      destruct J2 as [δ6 [J2 J3]].
      assert (I2 : ∃ δ7, δ7 > 0 /\ δ7 < δ5 /\ δ7 < δ6).
      { destruct (Rlt_or_le δ5 δ6) as [K1 | K1].
        - exists (δ5 / 2). split; lra.
        - exists (δ6 / 2). split; lra. }
      destruct I2 as [δ7 [I2 [I11 I12]]].
      exists δ7. split; try lra.
      intros x J4.
      assert (J5 : 0 < Abs [x - x0] < δ6). lra.
      apply J3 in J5 as J6.
      assert (J7 : (1 /// {` λ x0 y0,
        y0 = f [x0] / g [x0] `}) [x] = g[x] / f[x]).
      { assert (J7 : {` λ x1 y0, y0 = f [x1] / g [x1] `} [x]
          = f[x] / g[x]).
        { apply f_x; try apply H14. apply AxiomII'.
          reflexivity. }
        apply f_x; auto. apply AxiomII'. repeat split.
        - apply AxiomII. exists (f[x] / g[x]).
          apply AxiomII'. reflexivity.
        - rewrite J7. apply Rmult_integral_contrapositive. split.
          + apply H19. apply AxiomII. lra.
          + apply Rinv_neq_0_compat. apply H13.
            apply AxiomII. lra.
        - rewrite J7. field. split.
          + apply H13. apply AxiomII. lra.
          + apply H19. apply AxiomII. lra. }
      rewrite J7 in J6.
      assert (J8 : {` λ x1 y, y = g [x1] / f [x1] `} [x] = g[x] / f[x]).
      { apply f_x; auto. apply AxiomII'. reflexivity. }
      rewrite J8. assumption. }
  unfold limit in H20. destruct H20 as [H20 [δ4 [H21 [H22 H23]]]].
  assert (H24 : Function {` λ x y, y = g [x] * h [x] `}).
  { intros x y z I1 I2. applyAxiomII' I1; applyAxiomII' I2.
    rewrite I2. assumption. }
  split; auto.
  assert (H25 : ∃ δ5, δ5 > 0 /\ δ5 < δ3 /\ δ5 < δ4).
  { destruct (Rlt_or_le δ3 δ4) as [K1 | K1].
    - exists (δ3 / 2). split; lra.
    - exists (δ4 / 2). split; lra. }
  destruct H25 as [δ5 [H25 [H26 H27]]].
  exists δ5. split; auto. split.
  - intros x H28. apply AxiomII. exists (g[x] * h[x]).
    apply AxiomII'. reflexivity.
  - intros ε H28. apply H23 in H28 as H29.
    destruct H29 as [δ6 [H29 H30]].
    assert (H31 : ∃ δ7, δ7 > 0 /\ δ7 < δ5 /\ δ7 < δ6).
    { destruct (Rlt_or_le δ5 δ6) as [K1 | K1].
      - exists (δ5 / 2). split; lra.
      - exists (δ6 / 2). split; lra. }
    destruct H31 as [δ7 [H31 [H32 H33]]].
    exists δ7. split; try lra.
    intros x H34.
    assert (H35 : 0 < Abs [x - x0] < δ6). lra.
    apply H30 in H35 as H36.
    assert (H37 : {` λ x1 y, y = g [x1] * h [x1] `} [x]
      = g[x] * h[x]).
    { apply f_x; auto. apply AxiomII'. reflexivity. }
    rewrite H37.
    assert (H38 : ({` λ x y, y = g [x] / f [x] `} **
      {` λ x y, y = f [x] * h [x] `}) [x] = g[x] * h[x]).
    { apply f_x; auto. apply AxiomII'. repeat split.
      - apply AxiomII. exists (g[x] / f[x]).
        apply AxiomII'. reflexivity.
      - apply AxiomII. exists (f[x] * h[x]).
        apply AxiomII'. reflexivity.
      - assert (I1 : g[x] * h[x] = (g[x] / f[x]) * (f[x] * h[x])).
        { field. apply H19. apply AxiomII. lra. }
        rewrite I1.
        assert (I2 : {` λ x1 y, y = g [x1] / f [x1] `} [x]
          = g[x] / f[x]).
        { apply f_x; auto. apply AxiomII'. reflexivity. }
        assert (I3 : {` λ x1 y, y = f [x1] * h [x1] `} [x]
          = f[x] * h[x]).
        { apply f_x; try apply H8. apply AxiomII'.
          reflexivity. }
        rewrite I2; rewrite I3. reflexivity. }
    rewrite H38 in H36. assumption.
Qed.

(* 无穷大量 *)
Definition gigantic (f : Fun) (x0 : R) :=
  Function f /\ (∃ δ', δ' > 0 /\ Neighbor0 x0 δ' ⊂ dom[f] /\
     (∀ G : R, G > 0 -> ∃ δ, 0 < δ < δ' /\
       (∀ x, 0 < Abs[x-x0] < δ -> G < Abs[f[x]]))).

(* 定理3.13 *)
Theorem Theorem13 : ∀ (f : Fun) (x0 : R),
  (∃ δ', δ' > 0 /\ Neighbor0 x0 δ' ⊂ dom[f] /\
    (∀ x, x ∈ Neighbor0 x0 δ' -> f[x] <> 0))
  -> Infinitesimal f x0 -> gigantic (1 /// f) x0.
Proof.
  intros f x0 [δ' [H0 [H1 H2]]] H3. unfold Infinitesimal in H3.
  unfold limit in H3. destruct H3 as [H3 [δ0' [H4 [H5 H6]]]].
  assert (H7 : Function (1 /// f)).
  { unfold Function. intros x y z I1 I2.
    applyAxiomII' I1; applyAxiomII' I2.
    destruct I2 as [I2 [I3 I4]]. rewrite I4. apply I1. }
  split; auto.
  assert (H8 : ∃ δ1', δ1' > 0 /\ δ1' < δ' /\ δ1' < δ0').
  { destruct (Rlt_or_le δ' δ0') as [K1 | K1].
    - exists (δ' / 2). split; lra.
    - exists (δ0' / 2). split; lra. }
  destruct H8 as [δ1' [H8 [H9 H10]]].
  exists δ1'. assert (H11 : Neighbor0 x0 δ1' ⊂ dom[ 1 /// f]).
  { intros x I1. assert (I2 : x ∈ Neighbor0 x0 δ').
    { apply AxiomII. applyAxiomII I1. lra. }
    apply AxiomII. exists (1 / f[x]). apply AxiomII'.
    repeat split; auto. }
  repeat split; auto.
  intros G H12. apply Rinv_0_lt_compat in H12 as H13.
  apply H6 in H13 as H14. destruct H14 as [δ0 [H14 H15]].
  assert (H16 : ∃ δ, δ > 0 /\ δ < δ0 /\ δ < δ1').
  { destruct (Rlt_or_le δ0 δ1') as [K1 | K1].
    - exists (δ0 / 2). split; lra.
    - exists (δ1' / 2). split; lra. }
  destruct H16 as [δ [H16 [H17 H18]]].
  exists δ. split; try lra. intros x H19.
  assert (H20 : 0 < Abs [x - x0] < δ0). lra.
  apply H15 in H20 as H21.
  assert (H22 : x ∈ Neighbor0 x0 δ').
  { apply AxiomII. lra. }
  assert (H23 : (1 /// f) [x] = 1 / f[x]).
  { apply f_x; auto. apply AxiomII'.
    split; auto. }
  rewrite H23. apply H2 in H22 as H24. rewrite Abs_div; auto.
  assert (H25 : Abs [1] / Abs [f [x]] = / Abs [f [x]]).
  { rewrite Abs_gt; lra. }
  rewrite H25. rewrite Rminus_0_r in H21.
  assert (H26 : 0 < Abs[f[x]] * (/G)).
  { apply Rmult_lt_0_compat; auto.
    apply Abs_not_eq_0; assumption. }
  apply Rinv_lt_contravar in H21; auto.
  rewrite Rinv_involutive in H21;
    [assumption | apply Rgt_not_eq]; assumption.
Qed.

End A3_5.

Export A3_5.


Inductive vec (A : Set) : nat -> Set :=
| vnil : vec A 0
| vcons : A -> forall n : nat, vec A n -> vec A (S n).

Section Vapp.

Variable A : Set.

Fixpoint vapp n (vn : vec A n) m (vm : vec A m) : vec A (n + m) :=
match vn with
| vnil _ => vm
| vcons _ hd _ vn' => vcons _ hd _ (vapp _ vn' _ vm)
end.

Lemma vapp_nil n (vn : vec A n) :
  vapp _ vn _ (@vnil A) = eq_rect _ _ vn _ (plus_n_O n).
Proof.
induction vn.
  simpl.
Require Import Eqdep.
  rewrite <- eq_rect_eq.
  reflexivity.
simpl.
Abort.

End Vapp.

Record vec2 (A : Set) (n : nat) := {
  lst : list A ;
  Hlst : length lst = n }.

Lemma vec2_inj (A : Set) (n : nat) (v1 v2 : vec2 A n) :
  lst _ _ v1 = lst _ _ v2 -> v1 = v2.
Proof.
destruct v1.
destruct v2.
simpl.
intro.
subst lst1.
f_equal.
Require Import ProofIrrelevance.
apply proof_irrelevance.
Qed.

Require Import List.

Section Vapp2.

Variable A : Set.

Definition vapp2 n (vn : vec2 A n) m (vm : vec2 A m) : vec2 A (n + m).
apply Build_vec2 with (app (lst _ _ vn) (lst _ _ vm)).
rewrite app_length.
rewrite (Hlst _ _ vn).
rewrite (Hlst _ _ vm).
reflexivity.
Defined.

Lemma vapp2_nil n (vn : vec2 A n) :
  vapp2 _ vn _ (Build_vec2 A O nil eq_refl) = eq_rect _ _ vn _ (plus_n_O n).
Proof.
apply vec2_inj.
simpl.
rewrite <- app_nil_end.
rewrite <- plus_n_O.
simpl.
reflexivity.
Qed.

End Vapp2.

From Ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
From MathComp Require Import tuple.

Module TupleExample.

Structure tuple_of (n : nat) (T : Type) : Type :=
  Tuple {tval : seq T; _ : size tval == n}.

Definition emp := Tuple O nat nil isT.
Definition one1 := Tuple 1 nat [:: 1] isT.
Definition one2 := Tuple 1 nat [:: 2] isT.

Goal one1 = one2.
rewrite /one1 /one2.
Fail apply val_inj.
Abort.

Fail Check (val one1).

Canonical tuple_subType (n : nat) (T : Type) := [subType for (@tval n T)].

Check (val one1).
Check (@val _ _ _(*(@tuple_subType 1 nat)*) one1).

Goal one1 = one2.
rewrite /one1 /one2.
apply val_inj => /=.
Abort.

Fail Check (one1 == one2).

Fail Check (@eq_op _ one1 one2).

Definition tuple_eqMixin (n : nat) (T : eqType) := [eqMixin of (@tuple_of n T) by <:].

Canonical tuple_eqType n (T : eqType) := EqType (tuple_of n T) (tuple_eqMixin n T).

Check (@eq_op _ (*(tuple_eqType 1 nat_eqType)*) one1 one2).

Check (one1 == one2).

Fail Check (emp == one1).

End TupleExample.

From MathComp Require Import tuple.

Check [tuple of [:: 1; 2; 3]].
Check [seq x * 2 | x <- [:: 1; 2; 3]].
Check [tuple of [seq x * 2 | x <- [:: 1; 2; 3]]].