From stdpp Require Import tactics.
Require Import Reals Psatz Omega Fourier.
From discprob.measure Require Export measures.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop.
Require ClassicalEpsilon.

(* Usually the Borel sigma algebra is defined for more general topological spaces,
   but the Coquelicot hierarchy is oriented around uniform spaces, and in any case
   that will be good enough *)
Definition borel (A: UniformSpace) : sigma_algebra A := minimal_sigma (@open A).

Lemma continuous_inverse_open (A B: UniformSpace) (f: A → B) :
  (∀ x, continuous f x) →
  ∀ U, open U → open (fun_inv f U).
Proof.
  rewrite /open. intros Hcont U Hopen x Hf.
  rewrite /continuous_on in Hcont.
  rewrite /fun_inv. specialize (Hcont x). edestruct Hcont as [eps ?]; first eauto.
  exists eps. auto.
Qed.

Lemma continuous_borel_measurable (A B: UniformSpace) (f: A → B) :
  (∀ x, continuous f x) →
  measurable f (borel A) (borel B).
Proof.
  intros Hcont. apply measurable_generating_sets => U Hopen. apply minimal_sigma_ub.
  by apply continuous_inverse_open.
Qed.

Lemma closed_compl {A: UniformSpace} (U: A → Prop) :
  open U → closed (compl U).
Proof. by apply closed_not. Qed.
Lemma closed_compl' {A: UniformSpace} (U: A → Prop) :
  open (compl U) → closed U.
Proof. intros. eapply closed_ext; last eapply closed_compl; eauto. apply compl_involutive. Qed.
Lemma open_compl {A: UniformSpace} (U: A → Prop) :
  closed U → open (compl U).
Proof. by apply open_not. Qed.
Lemma open_compl' {A: UniformSpace} (U: A → Prop) :
  closed (compl U) → open U.
Proof. intros. eapply open_ext; last eapply open_compl; eauto. apply compl_involutive. Qed.

Hint Resolve closed_compl open_compl closed_compl' open_compl'.

Lemma borel_gen_closed (A: UniformSpace) : eq_sigma (borel A) (minimal_sigma (@closed A)).
Proof.
  rewrite /eq_sigma/eq_prop/borel => U; split; apply minimal_sigma_lub => U' ?;
    rewrite -(compl_involutive U'); apply sigma_closed_complements;
    apply minimal_sigma_ub; auto.
Qed.

Lemma borel_closed (A: UniformSpace) U : closed U → (borel A) U.
Proof.
  intros Hclosed. rewrite borel_gen_closed. by apply minimal_sigma_ub.
Qed.

Section borel_R.

  (* Technically this would be the Borel sigma algebra on the extended reals,
   but we do not have the UniformSpace structure on Rbar *)
  Definition Rbar_sigma : sigma_algebra Rbar :=
    minimal_sigma (λ U, ∃ x, U = (λ z, Rbar_le z x)).

  Lemma Rbar_sigma_p_infty:
    Rbar_sigma {[p_infty]}.
  Proof.
    assert (Hequiv: eq_prop ({[p_infty]}) (intersectF (λ n, compl (Rbar_le^~ (INR n))))).
    { split.
      - inversion 1; subst.
        intros n. rewrite /compl//=.
      - intros Hall. destruct x as [r | |].
        * exfalso.
          destruct (Rle_dec 0 r).
          ** destruct (archimed_pos r) as (n&Hrange); auto.
             rewrite S_INR in Hrange. eapply (Hall (S n)). rewrite S_INR //=.
             nra.
          ** apply (Hall O) => //=. nra.
        * rewrite //=.
        * exfalso. apply (Hall O) => //=.
    }
    rewrite Hequiv.
    apply sigma_closed_intersections => n.
    apply sigma_closed_complements.
    apply minimal_sigma_ub. exists (INR n). auto.
  Qed.

  Lemma Rbar_sigma_m_infty:
    Rbar_sigma {[m_infty]}.
  Proof.
    assert (Hequiv: eq_prop ({[m_infty]}) (intersectF (λ n, Rbar_le^~ -(INR n)))).
    { split.
      - inversion 1; subst.
        intros n. rewrite /compl//=.
      - intros Hall. destruct x as [r | |].
        * exfalso. destruct (Rle_dec 0 r).
          ** exfalso. feed pose proof (Hall (S O)) as H. rewrite //= in H. nra.
          ** destruct (archimed_pos (-r)) as (n'&?); first nra.
             feed pose proof (Hall (S n')) as H'. rewrite S_INR //= in H' H.
             apply Ropp_le_ge_contravar in H'.
             rewrite Ropp_involutive in H'.
             nra.
        * exfalso. destruct (Hall O).
        * done.
    }
    rewrite Hequiv.
    apply sigma_closed_intersections => n.
    apply minimal_sigma_ub. exists (-INR n). auto.
  Qed.

  Lemma borel_gen_closed_ray1 :
    le_prop (minimal_sigma (λ (U: R → Prop), ∃ x y, U = (λ z, x < z <= y)))
            (minimal_sigma (λ (U : R  → Prop), ∃ x, U = (λ z, z <= x))).
  Proof.
    apply minimal_sigma_lub. intros ? (x&y&?); subst.
    assert ((λ z : R, x < z ∧ z <= y) ≡
            (λ z : R, z <= y) ∩ compl (λ z : R, 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 (R_UniformSpace))
    (minimal_sigma (λ (U : R → 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 (bool * (nat * nat * nat))] n) as [(b&(x&y)&N)|];
        last exact ∅.
      set (V := (λ z, match b with
                        | true => (INR x / INR y) - (1/(INR N)) < z ∧
                                  z <= (INR x / INR y)
                        | false => - ((INR x / INR y)) - (1/(INR N)) < z ∧
                                  z <= - (INR x / INR y)
                      end)).
      destruct (ClassicalEpsilon.excluded_middle_informative
                  (V ⊆ U)).
      * exact V.
      * exact ∅.
    }
    {
      split.
      * intros HUz. specialize (HopenU _ HUz).
        destruct HopenU as ((δ&Hpos)&Hdelta).
        destruct (Rle_dec 0 x) as [Hle|Hnle].
        ** 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) as (n&m&(?&?)&?); auto; try nra.
           exists (pickle (true, (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//=/ball//=/AbsRing_ball//=/abs//=.
             rewrite /minus/opp/plus//=.
             assert (z >= z - x) by nra.
             apply Rabs_case => Hcase; try nra.
           }
           rewrite //=. nra.
        ** edestruct (archimed_cor1 δ) as (K&?&?); first by nra.
           assert (0 < / INR K).
           { apply Rinv_0_lt_compat, pos_INR'; done. }
           edestruct (archimed_rat_dense2 (/INR K) x) as (n&m&(?&?)&?); auto; try nra.
           exists (pickle (false, (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//=/ball//=/AbsRing_ball//=/abs//=.
             rewrite /minus/opp/plus//=.
             assert (z >= z + x) by nra.
             apply Rabs_case => Hcase; try nra.
           }
           rewrite //=. nra.
      * intros (n&HUn).
        destruct pickle_inv as [(b&(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 bool * (nat * nat * nat)] i) as
        [(b&(n&m)&K)|] eqn:Heq; rewrite Heq; last by apply sigma_empty_set.
    destruct b.
    * set (V := λ z, INR n / INR m - 1 / INR K < z ∧ z <= 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.
    * set (V := λ z, - (INR n / INR m) - 1 / INR K < z ∧ z <= - (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.
  Qed.

  Lemma borel_gen_open_ray_gt:
    le_prop (borel (R_UniformSpace))
    (minimal_sigma (λ (U : R → Prop), ∃ x, U = (λ z, x < z))).
  Proof.
    etransitivity; first apply borel_gen_closed_ray2.
    apply minimal_sigma_lub => U. intros (x&Heq).
    subst. eapply (sigma_proper _ _ (compl (λ z, x < z))).
    * rewrite /compl//=. split; nra.
    * apply sigma_closed_complements. apply minimal_sigma_ub.
      eexists; eauto.
  Qed.

  Lemma open_ray_borel_gt z:
    borel _ (λ x, z < x).
  Proof.
    apply minimal_sigma_ub.
    apply open_gt.
  Qed.

  Lemma open_ray_borel_lt z:
    borel _ (λ x, x < z).
  Proof.
    apply minimal_sigma_ub.
    apply open_lt.
  Qed.

  Lemma closed_ray_borel_ge z:
    borel _ (λ x, z <= x).
  Proof.
    apply borel_closed. apply closed_compl'.
    eapply open_ext; last eapply (open_lt z).
    intros x => //=. rewrite /compl.
    nra.
  Qed.

  Lemma closed_ray_borel_le z:
    borel _ (λ x, x <= z).
  Proof.
    apply borel_closed. apply closed_compl'.
    eapply open_ext; last eapply (open_gt z).
    intros x => //=. rewrite /compl.
    nra.
  Qed.

  Lemma closed_interval_borel a b:
    borel _ (λ x, a <= x <= b).
  Proof.
    assert ((λ x, a <= x <= b) ≡ (λ x, a <= x) ∩ (λ x, x <= b)) as ->.
    { split; intros; rewrite //=; nra. }
    eapply sigma_closed_pair_intersect; auto using closed_ray_borel_le, closed_ray_borel_ge.
  Qed.

  Lemma borel_equiv_closed_ray :
    eq_sigma (borel (R_UniformSpace))
    (minimal_sigma (λ (U : R → Prop), ∃ x, U = (λ z, z <= x))).
  Proof.
    intros z; split.
    * apply borel_gen_closed_ray2.
    * apply minimal_sigma_lub. intros U (?&Heq). subst.
      apply (closed_ray_borel_le x).
  Qed.

  Lemma measurable_plus {A: Type} (F: sigma_algebra A) (f1 f2: A → R) :
    measurable f1 F (borel _) →
    measurable f2 F (borel _) →
    measurable (λ x, f1 x + f2 x) F (borel _).
  Proof.
    intros Hmeas1 Hmeas2.
    eapply measurable_mono.
    { rewrite /le_sigma; reflexivity. }
    { rewrite /le_sigma/flip. apply borel_gen_open_ray_gt. }
    eapply measurable_generating_sets.
    intros ? (t&->). rewrite /fun_inv.
    cut (eq_prop (λ a, t < f1 a + f2 a)
                 (unionF (λ n, match pickle_inv [countType of (bool * (nat * nat))] n with
                               | None => empty_set
                               | Some (b, (n, m)) =>
                                 let r := if b then INR n / INR m else - (INR n / INR m) in
                                 (fun_inv f1 (λ x, Rlt r x)) ∩ (fun_inv f2  (λ x, Rlt (t - r) x))
                               end))).
    { intros ->. apply sigma_closed_unions => i.
      destruct (pickle_inv) as [(b&(n&m))|]; last apply sigma_empty_set.
      destruct b => //=; apply sigma_closed_pair_intersect;
                      first [ apply Hmeas1 | apply Hmeas2 ]; apply open_ray_borel_gt.
    }
    intros a; split.
    - intros Hlt.
      destruct (Rtotal_order 0 (f1 a)) as [Hgt0|[Heq|Hlt0]].
      * set (δ := Rmin ((f1 a + f2 a) - t) (f1 a / 2)).
        edestruct (archimed_rat_dense1 (δ/2) (f1 a - δ/2)) as (n&m&Hnm&?); rewrite /δ; auto; try nra.
        { apply Rmin_case_strong; intros; try nra. }
        { apply Rmin_case_strong; intros; try nra. }
        exists (pickle (true, (n, m))).
        rewrite pickleK_inv //=; split; rewrite /fun_inv.
        ** nra.
        ** rewrite /δ in Hnm. move: Hnm.
           apply Rmin_case_strong; nra.
      * set (δ := ((f1 a + f2 a) - t) / 2).
        edestruct (archimed_rat_dense2 (δ/2) (-δ/2)) as (n&m&Hnm&?); rewrite /δ; auto; try nra.
        exists (pickle (false, (n, m))).
        rewrite pickleK_inv //=; split; rewrite /fun_inv.
        ** nra.
        ** rewrite /δ in Hnm. move: Hnm.
           rewrite -?Heq //=. nra.
      * set (δ := ((f1 a + f2 a) - t) / 2).
        edestruct (archimed_rat_dense2 (δ/2) (f1 a - δ/2)) as (n&m&Hnm&?); rewrite /δ; auto; try nra.
        exists (pickle (false, (n, m))).
        rewrite pickleK_inv //=; split; rewrite /fun_inv.
        ** nra.
        ** rewrite /δ in Hnm. move: Hnm.
           rewrite -?Heq //=. nra.
    - intros (bnm&Hspec). destruct (pickle_inv) as [(b&(n&m))|].
      * destruct b; rewrite /fun_inv//= in Hspec; destruct Hspec as [H1 H2]; nra.
      * destruct Hspec.
  Qed.

  Lemma measurable_scal {A: Type} (F: sigma_algebra A) (f: A → R) (c: R):
    measurable f F (borel _) →
    measurable (λ x, c * f x) F (borel _).
  Proof.
    intros Hmeas.
    destruct (Rtotal_order 0 c) as [Hgt0|[Heq|Hlt0]].
    - eapply measurable_mono.
      { rewrite /le_sigma; reflexivity. }
      { rewrite /le_sigma/flip. apply borel_gen_open_ray_gt. }
      eapply measurable_generating_sets.
      intros ? (x&->).
      rewrite /fun_inv. eapply (sigma_proper _ _ (λ a, x /c < f a)).
      { intros z; split.
        * intros. eapply (Rmult_lt_reg_r (1/c)). move: Hgt0. clear.
          rewrite /Rinv. apply Rlt_mult_inv_pos; nra.
          field_simplify; nra.
        * intros. eapply (Rmult_lt_reg_r c); first nra.
          field_simplify; nra.
      }
      apply Hmeas, open_ray_borel_gt.
    - subst. intros U HU. rewrite /fun_inv.
      destruct (Classical_Prop.classic (U 0)).
      * eapply sigma_proper; last apply sigma_full.
        intros x; rewrite Rmult_0_l; split; auto.
      * eapply sigma_proper; last apply sigma_empty_set.
        intros x; rewrite Rmult_0_l; split; auto.
        inversion 1.
    - eapply measurable_mono.
      { rewrite /le_sigma; reflexivity. }
      { rewrite /le_sigma/flip. apply borel_gen_open_ray_gt. }
      eapply measurable_generating_sets.
      intros ? (x&->).
      rewrite /fun_inv. eapply (sigma_proper _ _ (λ a, x /c > f a)).
      { intros z; split.
        * intros Hineq%(Rmult_lt_gt_compat_neg_l c); last nra.
          field_simplify in Hineq; nra.
        * intros Hineq%(Rmult_lt_gt_compat_neg_l (1/c)); last first.
          { rewrite /Rdiv Rmult_1_l. apply Rinv_lt_0_compat. nra. }
          field_simplify in Hineq; nra.
      }
      apply: Hmeas. apply open_ray_borel_lt.
  Qed.

  Lemma measurable_square {A: Type} (F: sigma_algebra A) (f: A → R) :
    measurable f F (borel _) →
    measurable (λ x, f x * f x) F (borel _).
  Proof.
    intros Hmeas.
    eapply measurable_mono.
    { rewrite /le_sigma; reflexivity. }
    { rewrite /le_sigma/flip. apply borel_gen_closed_ray2. }
    eapply measurable_generating_sets.
    intros ? (t&->).
    rewrite /fun_inv//=.
    destruct (Rlt_dec t 0) as [Hlt|Hnlt].
    - eapply sigma_proper; last eapply sigma_empty_set.
      intros x; split.
      * intros Hle. assert (f x * f x >= 0).
        { apply Rle_ge. apply Rle_0_sqr. }
        nra.
      * inversion 1.
    - apply Rnot_lt_ge, Rge_le in Hnlt.
      assert (eq_prop (λ a, f a * f a <= t) (fun_inv f (λ a, - sqrt t <= a <= sqrt t))) as ->.
      { rewrite /fun_inv//=. intros a; split.
        * intros Hsqr. apply sqrt_le_1_alt in Hsqr.
          rewrite sqrt_Rsqr_abs in Hsqr.
          move: Hsqr. apply Rabs_case; nra.
        * intros Hrange.
          replace (f a * f a) with (Rsqr (f a)) by auto.
          rewrite (Rsqr_abs (f a)).
          apply sqrt_le_0; try nra.
          ** apply Rle_0_sqr.
          ** rewrite sqrt_Rsqr; last by auto.
             move: Hrange. apply Rabs_case; nra.
      }
      apply Hmeas, closed_interval_borel.
  Qed.

  Lemma measurable_opp {A: Type} (F: sigma_algebra A) (f: A → R) :
    measurable f F (borel _) →
    measurable (λ x, - f x) F (borel _).
  Proof.
    intros. eapply measurable_comp.
    * eauto.
    * apply continuous_borel_measurable. rewrite //=.
      intros x. apply: continuous_opp. apply: continuous_id.
  Qed.

  Lemma measurable_minus {A: Type} (F: sigma_algebra A) (f1 f2: A → R) :
    measurable f1 F (borel _) →
    measurable f2 F (borel _) →
    measurable (λ x, f1 x - f2 x) F (borel _).
  Proof.
    intros Hmeas1 Hmeas2. rewrite /Rminus.
    apply measurable_plus; auto.
    eapply measurable_comp; eauto.
    apply measurable_opp, measurable_id.
  Qed.

  Lemma measurable_mult {A: Type} (F: sigma_algebra A) (f1 f2: A → R) :
    measurable f1 F (borel _) →
    measurable f2 F (borel _) →
    measurable (λ x, f1 x * f2 x) F (borel _).
  Proof.
    intros Hmeas1 Hmeas2.
    assert (∀ x, f1 x * f2 x = /2 * ((f1 x + f2 x) * (f1 x + f2 x)) -
                               /2 * (f1 x * f1 x) - /2 * (f2 x * f2 x)) as Heq.
    { intros x. field. }
    setoid_rewrite Heq.
    repeat (apply measurable_plus || apply measurable_minus ||
            apply measurable_scal || apply measurable_opp ||
            apply measurable_square || auto).
  Qed.

  Ltac measurable := repeat (apply measurable_plus || apply measurable_minus ||
                             apply measurable_scal || apply measurable_opp ||
                             apply measurable_square || apply measurable_mult ||
                             apply measurable_const || auto).

  Lemma measurable_Rabs {A: Type} (F: sigma_algebra A) f1:
    measurable f1 F (borel _) →
    measurable (λ x, Rabs (f1 x)) F (borel _).
  Proof.
    intros Hmeas. eapply measurable_comp; eauto.
    apply continuous_borel_measurable => x.
    apply: continuous_abs.
  Qed.

  Lemma measurable_Rmax {A: Type} (F: sigma_algebra A) (f1 f2: A → R) :
    measurable f1 F (borel _) →
    measurable f2 F (borel _) →
    measurable (λ x, Rmax (f1 x) (f2 x)) F (borel _).
  Proof.
    intros. assert (Heq: ∀ x, Rmax (f1 x) (f2 x) = /2 * ((f1 x + f2 x) + Rabs (f1 x - f2 x))).
    { intros. apply Rmax_case_strong; apply Rabs_case; nra. }
    setoid_rewrite Heq.
    measurable.
    apply measurable_Rabs.
    apply measurable_minus; auto.
  Qed.

  Lemma measurable_Rmin {A: Type} (F: sigma_algebra A) (f1 f2: A → R) :
    measurable f1 F (borel _) →
    measurable f2 F (borel _) →
    measurable (λ x, Rmin (f1 x) (f2 x)) F (borel _).
  Proof.
    intros. assert (Heq: ∀ x, Rmin (f1 x) (f2 x) = /2 * ((f1 x + f2 x) - Rabs (f1 x - f2 x))).
    { intros. apply Rmin_case_strong; apply Rabs_case; nra. }
    setoid_rewrite Heq.
    measurable.
    apply measurable_Rabs.
    apply measurable_minus; auto.
  Qed.

  Lemma measurable_real:
    measurable real (Rbar_sigma) (borel _).
  Proof.
    eapply measurable_mono.
    { rewrite /le_sigma; reflexivity. }
    { rewrite /le_sigma/flip. apply borel_gen_closed_ray2. }
    eapply measurable_generating_sets.
    intros ? (t&->).
    destruct (Rlt_dec t 0).
    - eapply (sigma_proper _ _ (Rbar_le^~ t ∩ compl ({[m_infty]}))).
      * intros x; split.
        ** intros (Hle&Hm); destruct x => //=.
           exfalso. apply Hm. done.
        ** destruct x; rewrite /fun_inv//=; nra.
      * apply sigma_closed_pair_intersect.
        ** eapply minimal_sigma_ub. exists t => //=.
        ** apply sigma_closed_complements, Rbar_sigma_m_infty.
    - eapply (sigma_proper _ _ (Rbar_le^~ t ∪ ({[m_infty]} ∪ {[p_infty]}))).
      * intros x; split.
        ** intros [Hle|[Hm|Hp]]; destruct x => //=; rewrite /fun_inv/real; nra.
        ** rewrite /fun_inv/real//=.
           destruct x => //=; try firstorder.
      * apply sigma_closed_pair_union.
        ** eapply minimal_sigma_ub. exists t => //=.
        ** apply sigma_closed_pair_union.
           *** apply Rbar_sigma_m_infty.
           *** apply Rbar_sigma_p_infty.
  Qed.

  Lemma measurable_Finite:
    measurable Finite (borel _) Rbar_sigma.
  Proof.
    intros.
    eapply measurable_generating_sets.
    intros ? (t&->).
    destruct t as [r | | ].
    - assert (eq_prop (fun_inv Finite (Rbar_le^~ r))
                      (Rle^~ r)) as ->.
      { intros x. split => //=. }
      apply closed_ray_borel_le.
    - eapply sigma_proper; last eapply sigma_full.
      split; auto.
    - eapply sigma_proper; last eapply sigma_empty_set.
      split; auto.
  Qed.

  Lemma Rbar_sigma_real_pt r:
    Rbar_sigma {[Finite r]}.
  Proof.
    assert (eq_prop {[Finite r]}
                    (fun_inv real {[r]} ∩ compl {[p_infty]} ∩ compl {[m_infty]})) as ->.
    { split.
      * inversion 1; subst. rewrite /compl/fun_inv//=.
      * rewrite /compl/fun_inv//=. intros ((Heq&?)&?); destruct x; try firstorder.
        ** inversion Heq as [Heq'].
           rewrite //= in Heq'. subst. done.
    }
    apply sigma_closed_pair_intersect; first apply sigma_closed_pair_intersect.
    * apply measurable_real. apply borel_closed. apply closed_eq.
    * apply sigma_closed_complements, Rbar_sigma_p_infty.
    * apply sigma_closed_complements, Rbar_sigma_m_infty.
  Qed.

  Lemma Rbar_sigma_pt r:
    Rbar_sigma {[r]}.
  Proof.
    destruct r; auto using Rbar_sigma_real_pt, Rbar_sigma_p_infty, Rbar_sigma_m_infty.
  Qed.

  Lemma Rbar_sigma_gen_ge_ray:
    le_prop (minimal_sigma (λ U, ∃ x, U = (λ z, Rbar_le x z))) Rbar_sigma.
  Proof.
    apply minimal_sigma_lub.
    intros ? (x&->).
    assert (eq_prop [eta Rbar_le x] (compl (λ z, Rbar_le z x) ∪ {[x]})) as ->.
    { intros z; split.
      * intros [Hlt|Heq]%Rbar_le_lt_or_eq_dec.
        ** left. by apply Rbar_lt_not_le.
        ** right; subst; done.
      * intros [Hnle|Heq].
        ** apply Rbar_not_le_lt in Hnle. by apply Rbar_lt_le.
        ** inversion Heq; subst; apply Rbar_le_refl.
    }
    apply sigma_closed_pair_union.
    - apply sigma_closed_complements.
      apply minimal_sigma_ub; eexists. reflexivity.
    - apply Rbar_sigma_pt.
  Qed.

  Lemma measurable_Rbar_opp {A: Type} (F: sigma_algebra A) (f: A → Rbar) :
    measurable f F (Rbar_sigma) →
    measurable (λ x, Rbar_opp (f x)) F (Rbar_sigma).
  Proof.
    intros Hmeas.
    apply measurable_generating_sets.
    intros ? (t&->).
    assert (fun_inv (λ x, Rbar_opp (f x)) (Rbar_le^~t) ≡
                    fun_inv f (Rbar_le (Rbar_opp t))) as ->.
    { rewrite /fun_inv//= => x. rewrite -{1}(Rbar_opp_involutive t).
      apply Rbar_opp_le. }
    apply Hmeas. apply Rbar_sigma_gen_ge_ray.
    apply minimal_sigma_ub. eauto.
  Qed.

  Lemma Sup_seq_minor_Rbar_le (u : nat → Rbar) (M : Rbar) (n : nat):
    Rbar_le M (u n) → Rbar_le M (Sup_seq u).
  Proof.
    intros Hle.
    rewrite Rbar_sup_eq_lub. rewrite /Lub.Rbar_lub.
    destruct (Lub.Rbar_ex_lub) as (?&r).
    rewrite /=. eapply Rbar_le_trans; eauto. apply r.  eauto.
  Qed.

  Lemma measurable_Sup {A: Type} (F: sigma_algebra A) (fn : nat → A → Rbar):
    (∀ n, measurable (fn n) F Rbar_sigma) →
    measurable (λ x, Sup_seq (λ n, fn n x)) F Rbar_sigma.
  Proof.
    intros Hmeas.
    eapply measurable_generating_sets.
    intros ? (t&->).
    assert (eq_prop (λ x, Rbar_le (Sup_seq (λ n, fn n x)) t)
                    (intersectF (λ n, fun_inv (fn n) (λ x, Rbar_le x t)))) as ->.
    { split.
      - intros Hsup n. rewrite /fun_inv.
        eapply Rbar_le_trans; eauto.
        eapply Sup_seq_minor_Rbar_le; eauto.
        apply Rbar_le_refl.
      - intros Hle.
        rewrite Rbar_sup_eq_lub. rewrite /Lub.Rbar_lub.
        destruct (Lub.Rbar_ex_lub) as (?&(Hub&Hlub)).
        apply Hlub => //=.
        intros r (?&->); eapply Hle.
    }
    apply sigma_closed_intersections. intros. apply Hmeas.
    apply minimal_sigma_ub. eauto.
  Qed.

  Lemma measurable_Inf {A: Type} (F: sigma_algebra A) (fn : nat → A → Rbar):
    (∀ n, measurable (fn n) F Rbar_sigma) →
    measurable (λ x, Inf_seq (λ n, fn n x)) F Rbar_sigma.
  Proof.
    intros.
    setoid_rewrite Inf_opp_sup.
    apply measurable_Rbar_opp.
    apply measurable_Sup.
    intros n. apply measurable_Rbar_opp. done.
  Qed.

  Lemma measurable_LimSup {A: Type} (F: sigma_algebra A) (fn : nat → A → R):
    (∀ n, measurable (fn n) F (borel _)) →
    measurable (λ x, LimSup_seq (λ n, fn n x)) F Rbar_sigma.
  Proof.
    intros Hmeas.
    setoid_rewrite LimSup_InfSup_seq.
    apply measurable_Inf => n.
    apply measurable_Sup => m.
    eapply measurable_comp; last apply measurable_Finite.
    eauto.
  Qed.

  Lemma measurable_LimInf {A: Type} (F: sigma_algebra A) (fn : nat → A → R):
    (∀ n, measurable (fn n) F (borel _)) →
    measurable (λ x, LimInf_seq (λ n, fn n x)) F Rbar_sigma.
  Proof.
    intros Hmeas.
    setoid_rewrite LimInf_SupInf_seq.
    apply measurable_Sup => m.
    apply measurable_Inf => n.
    eapply measurable_comp; last apply measurable_Finite.
    eauto.
  Qed.

  Lemma measurable_Sup' {A: Type} (F: sigma_algebra A) (fn : nat → A → R):
    (∀ n, measurable (fn n) F (borel _)) →
    measurable (λ x, Sup_seq (λ n, fn n x) : R) F (borel _).
  Proof.
    intros Hmeas. eapply measurable_comp. apply measurable_Sup.
    { intros n. eapply measurable_comp; last apply measurable_Finite.
      eauto. }
    apply measurable_real.
  Qed.

  Lemma measurable_Inf' {A: Type} (F: sigma_algebra A) (fn : nat → A → R):
    (∀ n, measurable (fn n) F (borel _)) →
    measurable (λ x, Inf_seq (λ n, fn n x) : R) F (borel _).
  Proof.
    intros Hmeas. eapply measurable_comp. apply measurable_Inf.
    { intros n. eapply measurable_comp; last apply measurable_Finite.
      eauto. }
    apply measurable_real.
  Qed.

  Lemma measurable_Rbar_div_pos y:
    measurable (Rbar_div_pos^~ y) Rbar_sigma Rbar_sigma.
  Proof.
    apply measurable_generating_sets.
    intros ? (t&->).
    destruct t as [r | | ].
    - assert (fun_inv (Rbar_div_pos^~y) (Rbar_le^~r) ≡
                      Rbar_le^~(r * y)) as ->.
      { rewrite /fun_inv//=; intros [ r' | |] => //=; apply Rle_div_l; destruct y; done. }
      apply minimal_sigma_ub; eauto.
    - eapply sigma_proper; last apply sigma_full.
      intros [ | |] => //=.
    - eapply sigma_proper; last apply Rbar_sigma_m_infty.
      intros [ | |] => //=.
  Qed.

  Lemma measurable_Rbar_plus {A: Type} (F: sigma_algebra A) (f1 f2: A → Rbar) :
    measurable f1 F Rbar_sigma →
    measurable f2 F Rbar_sigma →
    measurable (λ x, Rbar_plus (f1 x) (f2 x)) F Rbar_sigma.
  Proof.
    intros Hmeas1 Hmeas2.
    apply measurable_generating_sets.
    intros ? (t&->).
    destruct t as [r | | ].
    -
      destruct (Rle_dec 0 r) as [Hle0|Hnle0].
      {
        assert (fun_inv (λ x, Rbar_plus (f1 x) (f2 x)) (Rbar_le^~ r) ≡
                        (fun_inv (λ x, Rplus (f1 x) (f2 x)) (Rle^~ r)
                                 ∩ compl (fun_inv f1 ({[p_infty]} ∪ {[m_infty]}))
                                 ∩ compl (fun_inv f2 ({[p_infty]} ∪ {[m_infty]}))) ∪
                        fun_inv f1 {[m_infty]} ∪ fun_inv f2 {[m_infty]}) as ->.
        { intros a; split; rewrite /fun_inv.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            destruct (f1 a), (f2 a); rewrite //=;
                                             try (left; right; firstorder; done);
            try (right; firstorder; done).
            intros Hle. do 2 left. split_and!; auto; firstorder.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            intros [[((Hplus&Hnot1)&Hnot2)|Hinf1]|Hinf2].
            * destruct (f1 a), (f2 a) => //=;
                                           try nra;
                                           try (exfalso; apply Hnot1; firstorder; done);
                                           try (exfalso; apply Hnot2; firstorder; done).
            * inversion Hinf1 as [Heq]. rewrite Heq => //=.
              destruct (f2 a) => //=.
            * inversion Hinf2 as [Heq]. rewrite Heq => //=.
              destruct (f1 a) => //=.
        }
        apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty.
        apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty.
        repeat apply sigma_closed_pair_intersect.
        * apply measurable_plus; eauto using measurable_comp, measurable_real.
          apply closed_ray_borel_le.
        * apply sigma_closed_complements; eapply Hmeas1.
          apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty, Rbar_sigma_p_infty.
        * apply sigma_closed_complements; eapply Hmeas2.
          apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty, Rbar_sigma_p_infty.
      }
      {
        assert (fun_inv (λ x, Rbar_plus (f1 x) (f2 x)) (Rbar_le^~ r) ≡
                        (fun_inv (λ x, Rplus (f1 x) (f2 x)) (Rle^~ r)
                                 ∩ compl (fun_inv f1 ({[p_infty]} ∪ {[m_infty]}))
                                 ∩ compl (fun_inv f2 ({[p_infty]} ∪ {[m_infty]}))) ∪
                        (compl (fun_inv f2 {[p_infty]}) ∩ fun_inv f1 {[m_infty]}) ∪
                        (compl (fun_inv f1 {[p_infty]}) ∩ fun_inv f2 {[m_infty]})) as ->.
        { intros a; split; rewrite /fun_inv.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            destruct (f1 a), (f2 a); rewrite //=;
                                             try (left; right; firstorder; done);
            try (right; firstorder; done).
            intros Hle. do 2 left. split_and!; auto; firstorder.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            intros [[((Hplus&Hnot1)&Hnot2)|(Hn1&Hinf1)]|(Hn2&Hinf2)].
            * destruct (f1 a), (f2 a) => //=;
                                           try nra;
                                           try (exfalso; apply Hnot1; firstorder; done);
                                           try (exfalso; apply Hnot2; firstorder; done).
            * inversion Hinf1 as [Heq]. rewrite Heq => //=.
              destruct (f2 a) => //=. firstorder.
            * inversion Hinf2 as [Heq]. rewrite Heq => //=.
              destruct (f1 a) => //=. firstorder.
        }
        apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty;
        first apply sigma_closed_pair_union; eauto using Rbar_sigma_m_infty;
        first repeat apply sigma_closed_pair_intersect.
        * apply measurable_plus; eauto using measurable_comp, measurable_real.
          apply closed_ray_borel_le.
        * apply sigma_closed_complements; eapply Hmeas1.
          apply sigma_closed_pair_union; eauto using Rbar_sigma_pt.
        * apply sigma_closed_complements; eapply Hmeas2.
          apply sigma_closed_pair_union; eauto using Rbar_sigma_pt.
        * apply sigma_closed_pair_intersect.
          ** apply sigma_closed_complements.
             apply Hmeas2; eauto using Rbar_sigma_pt.
          ** apply Hmeas1; eauto using Rbar_sigma_pt.
        * apply sigma_closed_pair_intersect.
          ** apply sigma_closed_complements.
             apply Hmeas1; eauto using Rbar_sigma_pt.
          ** apply Hmeas2; eauto using Rbar_sigma_pt.
      }
    - eapply sigma_proper; last eapply sigma_full.
      intros x; split; auto. rewrite /fun_inv//=. by destruct (Rbar_plus).
    - assert (fun_inv (λ x, Rbar_plus (f1 x) (f2 x)) (Rbar_le^~ m_infty) ≡
                      (fun_inv f1 (compl {[p_infty]}) ∩
                       fun_inv f2 {[m_infty]}) ∪
                      (fun_inv f2 (compl {[p_infty]}) ∩
                       fun_inv f1 {[m_infty]})) as ->.
      { intros a; split; rewrite /fun_inv.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            destruct (f1 a), (f2 a); firstorder; done.
          - rewrite /base.union/union_Union/union/intersection/intersect_Intersection/intersect/compl.
            destruct (f1 a), (f2 a); firstorder.
      }
      apply sigma_closed_pair_union; apply sigma_closed_pair_intersect.
      * eapply Hmeas1. apply sigma_closed_complements; eauto using Rbar_sigma_pt.
      * eapply Hmeas2. eauto using Rbar_sigma_pt.
      * eapply Hmeas2. apply sigma_closed_complements; eauto using Rbar_sigma_pt.
      * eapply Hmeas1. eauto using Rbar_sigma_pt.
  Qed.

  Lemma measurable_Lim {A: Type} (F: sigma_algebra A) (fn : nat → A → R):
    (∀ n, measurable (fn n) F (borel _)) →
    measurable (λ x, Lim_seq (λ n, fn n x)) F Rbar_sigma.
  Proof.
    intros Hmeas. rewrite /Lim_seq//=.
    eapply (measurable_comp _ (Rbar_div_pos^~{| pos := 2 ; cond_pos := Rlt_R0_R2|}));
      eauto using measurable_Rbar_div_pos.
    apply measurable_Rbar_plus.
    * apply measurable_LimSup. done.
    * apply measurable_LimInf. done.
  Qed.

  Lemma measurable_Lim' {A: Type} (F: sigma_algebra A) (fn : nat → A → R):
    (∀ n, measurable (fn n) F (borel _)) →
    measurable (λ x, real (Lim_seq (λ n, fn n x))) F (borel _).
  Proof.
    intros. eapply measurable_comp; eauto using measurable_real.
    apply measurable_Lim. done.
  Qed.

  Lemma measurable_fun_eq_0 {A: Type} {F: sigma_algebra A} f:
    measurable f F (borel R_UniformSpace) →
    F (λ x, f x = 0).
  Proof.
    intros Hmeas. eapply (Hmeas (λ x, x = 0)).
    apply borel_closed, closed_eq.
  Qed.

  Lemma measurable_fun_eq_0_Rbar {A: Type} {F: sigma_algebra A} f:
    measurable f F Rbar_sigma →
    F (λ x, f x = 0).
  Proof.
    intros Hmeas. eapply (Hmeas (λ x, x = 0)).
    apply Rbar_sigma_pt.
  Qed.

  Lemma measurable_fun_ge {A: Type} {F: sigma_algebra A} f k:
    measurable f F (borel _) →
    F (λ x, k <= f x).
  Proof.
    intros Hmeas. eapply (Hmeas (λ x, k <= x)).
    apply closed_ray_borel_ge.
  Qed.

  Lemma measurable_fun_le_const {A: Type} {F: sigma_algebra A} f k:
    measurable f F (borel _) →
    F (λ x, f x <= k).
  Proof.
    intros Hmeas. eapply (Hmeas (λ x, x <= k)).
    apply closed_ray_borel_le.
  Qed.

  Lemma measurable_fun_lt_p_infty {A: Type} {F: sigma_algebra A} f:
    measurable f F Rbar_sigma →
    F (λ x, Rbar_lt (f x) p_infty).
  Proof.
    intros Hmeas.
    assert ((λ x, Rbar_lt (f x) p_infty)  ≡ compl (fun_inv f {[p_infty]})) as ->.
    { intros x. rewrite /fun_inv/compl//=. split.
      - intros Hlt Heq. inversion Heq as [Heq']. rewrite Heq' in Hlt.
        rewrite //= in Hlt.
      - intros Heq. destruct (f x) => //=. apply Heq. done.
    }
    apply sigma_closed_complements.
    eapply Hmeas.
    apply Rbar_sigma_pt.
  Qed.

  Lemma measurable_fun_eq_inv {A: Type} {F: sigma_algebra A} f g:
    measurable f F (borel R_UniformSpace) →
    measurable g F (borel R_UniformSpace) →
    F (λ x, f x = g x).
  Proof.
    intros Hmeas1 Hmeas2.
    apply (sigma_proper _ _ (λ x, f x - g x = 0)).
    { intros x; split; nra. }
    apply measurable_fun_eq_0. measurable.
  Qed.

  Lemma measurable_fun_le_inv {A: Type} {F: sigma_algebra A} f g:
    measurable f F (borel R_UniformSpace) →
    measurable g F (borel R_UniformSpace) →
    F (λ x, f x <= g x).
  Proof.
    intros Hmeas1 Hmeas2.
    apply (sigma_proper _ _ (λ x, f x - g x <= 0)).
    { intros x; split; nra. }
    apply measurable_fun_le_const. measurable.
  Qed.

  Lemma measurable_fun_eq_inv_Rbar {A: Type} {F: sigma_algebra A} f g:
    measurable f F Rbar_sigma →
    measurable g F Rbar_sigma →
    F (λ x, f x = g x).
  Proof.
    intros Hmeas1 Hmeas2.
    apply (sigma_proper _ _ (λ x, Rbar_minus (f x) (g x) = 0)).
    { intros x; split.
      - destruct (f x), (g x) => //=.
        inversion 1; subst; f_equal; nra.
      - destruct (f x), (g x) => //=.
        intros Heq. inversion Heq; subst. f_equal. nra.
    }
    apply measurable_fun_eq_0_Rbar. rewrite /Rbar_minus.
    apply measurable_Rbar_plus, measurable_Rbar_opp; auto.
  Qed.

  Lemma measure_ex_lim_seq {A: Type} (F: sigma_algebra A) (fn : nat → A → R):
    (∀ n, measurable (fn n) F (borel _)) →
    F (λ x, ex_lim_seq (λ n, fn n x)).
  Proof.
    intros Hmeas.
    eapply sigma_proper.
    { intros x. apply ex_lim_LimSup_LimInf_seq. }
    apply measurable_fun_eq_inv_Rbar; auto using measurable_LimSup, measurable_LimInf.
  Qed.

  Lemma measure_ex_finite_lim_seq {A: Type} (F: sigma_algebra A) (fn : nat → A → R):
    (∀ n, measurable (fn n) F (borel _)) →
    F (λ x, ex_finite_lim_seq (λ n, fn n x)).
  Proof.
    intros Hmeas.
    eapply (sigma_proper _ _ ((λ x, ex_lim_seq (λ n, fn n x))
                                ∩ (fun_inv (λ x, Lim_seq (λ n, fn n x)) (compl {[p_infty]}))
                                ∩ (fun_inv (λ x, Lim_seq (λ n, fn n x)) (compl {[m_infty]})))).
    { intros x. rewrite /fun_inv. split.
      - intros ((Hex&Hlim1)&Hlim2).
        destruct Hex as (v&His).
        destruct v as [r | |].
        * exists r; eauto.
        * rewrite (is_lim_seq_unique _ _ His) //= in Hlim1. exfalso; apply Hlim1; done.
        * rewrite (is_lim_seq_unique _ _ His) //= in Hlim2. exfalso; apply Hlim2; done.
      - intros (v&His).
        split; first split.
        * eexists; eauto.
        * rewrite //= (is_lim_seq_unique _ _ His) //=.
        * rewrite //= (is_lim_seq_unique _ _ His) //=.
    }
    apply sigma_closed_pair_intersect; first apply sigma_closed_pair_intersect.
    - apply measure_ex_lim_seq; auto.
    - apply measurable_Lim; eauto. apply sigma_closed_complements, Rbar_sigma_pt.
    - apply measurable_Lim; eauto. apply sigma_closed_complements, Rbar_sigma_pt.
  Qed.

  Lemma measure_is_lim_seq {A: Type} (F: sigma_algebra A) (fn : nat → A → R) (f: A → Rbar):
    (∀ n, measurable (fn n) F (borel _)) →
    measurable f F Rbar_sigma →
    F (λ x, is_lim_seq (λ n, fn n x) (f x)).
  Proof.
    intros.
    assert (Hequiv: (λ x, is_lim_seq (λ n, fn n x) (f x))
                      ≡ (λ x, ex_lim_seq (λ n, fn n x)) ∩ (λ x, Lim_seq (λ n, fn n x) = f x)).
    {
      intros x. split.
      - intros His; split; first by (eexists; eauto).
        by apply is_lim_seq_unique.
      - intros (Hex&Heq). rewrite -Heq. apply Lim_seq_correct; eauto.
    }
    rewrite Hequiv. apply sigma_closed_pair_intersect.
    - apply measure_ex_lim_seq; eauto.
    - apply measurable_fun_eq_inv_Rbar; eauto using measurable_Lim.
  Qed.

End borel_R.

Ltac measurable := repeat (apply measurable_plus || apply measurable_minus ||
                           apply measurable_scal || apply measurable_opp ||
                           apply measurable_square || apply measurable_mult ||
                           apply measurable_const || apply measurable_real ||
                           apply measurable_Rabs ||
                           apply measurable_Rmax || apply measurable_Rmin ||
                           apply measure_is_lim_seq || apply measure_ex_lim_seq ||
                           apply measure_ex_finite_lim_seq ||
                           apply measurable_fun_le_inv ||
                           apply measurable_fun_eq_inv ||
                           auto).


Require Import Reals.
Require Import Psatz.
Open Local Scope R.
(**Lemma 1.3.8 in Abbott Understanding Analysis. *)
(** Assume s in R is an upper bound for a set A in R. *)
(** then, s = supA iff forall eps > 0 exists a in A s.t. s - eps < a*)

Axiom equality :
  (*equality in R - Theorem 1.2.6 in Abbott*)
  forall x y eps, Rabs (x - y) < eps <-> x = y.

Lemma if_not_ub_then_exists (An : nat -> R) (x : R) :
  not (is_upper_bound (EUn An) x) -> exists a, (EUn An) a /\ x < a.
Proof.
  intros H.
  unfold not in H.

  Admitted.

Lemma Rle_plus_nonneg_forward (x y : R) :
  exists (eps : nonnegreal),
  x <= y -> x = y - eps.
Proof.
Admitted.

Theorem one_three_eight
      (An : nat -> R)
      (s : R)
      (s_is_ub : is_upper_bound (EUn An) s)
      (An_has_ub : has_ub An)
  :
    s = lub An An_has_ub <->
    forall (eps : posreal), exists (a : R), (EUn An) a /\ s - eps < a.
Proof.
  split.
  { intros H eps.
    destruct eps as [eps H__eps]; simpl.
    unfold is_upper_bound in s_is_ub.
    assert (An_has_ub' : has_ub An). apply An_has_ub.
    unfold has_ub, bound, is_upper_bound in An_has_ub';
      destruct An_has_ub' as [m An_has_ub'].
    unfold lub in H; destruct ub_to_lub as [x H'].
    unfold is_lub in H'; destruct H' as [H'1 H'2].
    unfold is_upper_bound in H'1.
    assert (G : not (is_upper_bound (EUn An) (s - eps))).
    { unfold not.
      intros G'.
      specialize (H'2 (s - eps) G').
      rewrite H in H'2.
      lra.
    }

    specialize (H'2 (s - eps)).
    rewrite H in H'2.
    apply if_not_ub_then_exists in G.
    destruct G as [a [G1 G2]]; simpl in G2.
    exists a.
    split.
    - apply G1.
    - apply G2.
  }
  { intros H.
    assert (G : forall (eps : posreal), not (is_upper_bound (EUn An) (s - eps))).
    { unfold not.
      intros eps H'.
      specialize (H eps); destruct H as [a [H1 H2]].
      give_up.
    }
    assert (eps0 : exists (eps : posreal), eps = eps). give_up.
    destruct eps0 as [[eps H__eps] _].
    remember (s - eps) as b.
    specialize (G (mkposreal eps H__eps)); simpl in G.

    unfold lub;
      destruct ub_to_lub as [b' F];
      unfold is_lub in F;
      destruct F as [F1 F2];
      specialize (F2 s s_is_ub).

    destruct F2 as [F2' | F2'].
    - exfalso.
      apply G.
      unfold is_upper_bound in *.
      intros x H__x.
      specialize (s_is_ub x H__x).
      specialize (F1 x H__x).
      specialize (H (mkposreal eps H__eps)); destruct H as [a [H1 H2]]; simpl in H2.
      right.
      remember (Rle_plus_nonneg_forward x s) as E.
      destruct E as [eps' E].
      assert (E' : x <= s -> x = s - eps'). apply E.
      specialize (E' s_is_ub).
      destruct eps' as [eps' H__eps'].
      assert (H0 : eps' = eps). give_up.
      rewrite <- H0.
      simpl in E'.
      apply E'.
    - rewrite F2'. reflexivity.
  }
Admitted.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(* Jean-Francois.Monin@lannion.cnet.fr                                      *)
(* October 1994, Coq V5.8.3                                                 *)
(*                                                                          *)
(****************************************************************************)
(*                                 cps_Nmx.v                                *)
(****************************************************************************)

(*
   Txval is the type of exceptions and is supplied by the user.
   Txval is a dependent type which depends on Txlev, another
   user-defined type representing different levels of exception.

Example :

 Inductive Definition Txlev : Set := l1 : Txlev | l2 : Txlev.
 Inductive Definition Txval : Txlev->Set :=
   e1 : (Txval l1) |
   e2 : nat->(Txval l2).
*)

(*
   The following primitives  should be used in a section
   beginning with

Load DeclareNmx.

*)

Section defcont.

Variable Txlev : Set.
Variable Txval : Txlev -> Set.

Definition Propxg := forall l : Txlev, Txval l -> Prop.

Variable X : Set.
Variable P : Propxg.
Variable e : forall (l : Txlev) (x : Txval l), P l x -> X.

Definition Nmxglob (C : Propxg) (A : Set) :=
  (forall (l : Txlev) (x : Txval l), C l x -> P l x) -> (A -> X) -> X.

Let Nmx := Nmxglob.

Notation "c \/m+ s" := (Nmx c s)
  (at level 85, right associativity, format "c  \/m+  '/  ' s").

Definition Nmx_unit_glob (C : Propxg) (A : Set) (a : A) :
  C \/m+ A :=
  fun (i : forall (l : Txlev) (x : Txval l), C l x -> P l x) (k : A -> X) =>
  k a.

Definition Nmx_raise_glob (C : Propxg) (A : Set) (l : Txlev)
  (x : Txval l) (c : C l x) : C \/m+ A :=
  fun (i : forall (l : Txlev) (x : Txval l), C l x -> P l x) (k : A -> X) =>
  e l x (i l x c).

Definition Nmx_elim_Nmx_glob (A A' : Set) (C C' : Propxg)
  (f : A -> C' \/m+ A')
  (j : forall (l : Txlev) (x : Txval l), C l x -> C' l x)
  (nx : C \/m+ A) : C' \/m+ A' :=
  fun (i : forall (l : Txlev) (x : Txval l), C' l x -> P l x) (k : A' -> X) =>
  nx (fun (l : Txlev) (x : Txval l) (c : C l x) => i l x (j l x c))
    (fun a : A => f a i k).

Definition Nmx_handle_glob (C : Propxg) (A : Set) (Nmx : C \/m+ A) :
  (forall (l : Txlev) (x : Txval l), C l x -> P l x) -> (A -> X) -> X := Nmx.

End defcont.


Require Import CertiGraph.graph.SpaceAdjMatGraph2.
Require Import CertiGraph.dijkstra.dijkstra_env.

(* A separate file with the underlying PQ spec-ed out *)
Require Export CertiGraph.binheap.binary_heap_malloc_spec.
Require Export CertiGraph.binheap.spec_binary_heap_pro.

(* Dijkstra-specific imports *)
Require Import CertiGraph.dijkstra.MathDijkGraph.
Require Export CertiGraph.dijkstra.dijkstra_spec_pure.

(* The first moment we become implementation-specific *)
Require Export CertiGraph.dijkstra.dijkstra2.
Require Import CertiGraph.dijkstra.dijkstra_constants.

Local Open Scope Z_scope.

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

  Definition getCell_spec :=
    DECLARE _getCell
    WITH sh: rshare,
         g: @DijkGG size inf,
         graph_ptr: pointer_val,
         addresses: list val,
         u: V,
         i : V
    PRE [tptr tint, tint, tint]
      PROP (0 <= i < size;
           0 <= u < size;
           size * size <= Int.max_signed)
      PARAMS (pointer_val_val graph_ptr;
           Vint (Int.repr u);
           Vint (Int.repr i))
      GLOBALS ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr))
    POST [tint]
      PROP ()
      RETURN (Vint (Int.repr (Znth i (Znth u (@graph_to_mat size g id)))))
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr)).

  Definition dijkstra_spec :=
    DECLARE _dijkstra
    WITH sh: rshare,
         g: DijkGG,
         graph_ptr : pointer_val,
         addresses : list val,
         dist_ptr : pointer_val,
         prev_ptr : pointer_val,
         src : V
    PRE [tptr tint, tint, tptr tint, tptr tint]

      PROP (vvalid g src;
           (size * size <= Int.max_signed);
           12 * size <= Int.max_unsigned;
           connected_dir g src)
      PARAMS (pointer_val_val graph_ptr;
             Vint (Int.repr src);
             pointer_val_val dist_ptr;
             pointer_val_val prev_ptr)
      GLOBALS ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr);
          data_at_ Tsh (tarray tint size) (pointer_val_val dist_ptr);
          data_at_ Tsh (tarray tint size) (pointer_val_val prev_ptr))
    POST [tvoid]
      EX prev: list V,
      EX dist: list V,
      PROP (forall dst,
               vvalid g dst ->
               @inv_popped size inf g src (VList g) prev dist dst)
      LOCAL ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr);
          data_at Tsh (tarray tint size) (map Vint (map Int.repr prev)) (pointer_val_val prev_ptr);
          data_at Tsh (tarray tint size) (map Vint (map Int.repr dist)) (pointer_val_val dist_ptr)).

  Definition Gprog : funspecs :=
    ltac:(with_library prog [
                       getCell_spec;
                       dijkstra_spec;
                       mallocN_spec;
                       freeN_spec;
                       pq_remove_min_nc_spec;
                       pq_insert_nc_spec;
                       pq_size_spec;
                       pq_make_spec;
                       pq_edit_priority_spec;
                       pq_free_spec]).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Require Import ZArith Ndigits.
Require Import BigNumPrelude.
Require Import Max.
Require Import DoubleType.
Require Import DoubleBase.
Require Import CyclicAxioms.
Require Import DoubleCyclic.

Implicit Arguments mk_zn2z_ops [t].
Implicit Arguments mk_zn2z_ops_karatsuba [t].
Implicit Arguments mk_zn2z_specs [t ops].
Implicit Arguments mk_zn2z_specs_karatsuba [t ops].
Implicit Arguments ZnZ.digits [t].
Implicit Arguments ZnZ.zdigits [t].

(* To compute the necessary height *)

Fixpoint plength (p: positive) : positive :=
  match p with
    xH => xH
  | xO p1 => Psucc (plength p1)
  | xI p1 => Psucc (plength p1)
  end.

Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z.
assert (F: (forall p, 2 ^ (Zpos (Psucc p)) = 2 * 2 ^ Zpos p)%Z).
intros p; replace (Zpos (Psucc p)) with (1 + Zpos p)%Z.
rewrite Zpower_exp; auto with zarith.
rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith.
intros p; elim p; simpl plength; auto.
intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI.
assert (tmp: (forall p, 2 * p = p + p)%Z);
  try repeat rewrite tmp; auto with zarith.
intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1).
assert (tmp: (forall p, 2 * p = p + p)%Z);
  try repeat rewrite tmp; auto with zarith.
rewrite Zpower_1_r; auto with zarith.
Qed.

Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Ppred p)))%Z.
intros p; case (Psucc_pred p); intros H1.
subst; simpl plength.
rewrite Zpower_1_r; auto with zarith.
pattern p at 1; rewrite <- H1.
rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith.
generalize (plength_correct (Ppred p)); auto with zarith.
Qed.

Definition Pdiv p q :=
  match Zdiv (Zpos p) (Zpos q) with
    Zpos q1 => match (Zpos p) - (Zpos q) * (Zpos q1) with
                 Z0 => q1
               | _ => (Psucc q1)
               end
  |  _ => xH
  end.

Theorem Pdiv_le: forall p q,
  Zpos p <= Zpos q * Zpos (Pdiv p q).
intros p q.
unfold Pdiv.
assert (H1: Zpos q > 0); auto with zarith.
assert (H1b: Zpos p >= 0); auto with zarith.
generalize (Z_div_ge0 (Zpos p) (Zpos q) H1 H1b).
generalize (Z_div_mod_eq (Zpos p) (Zpos q) H1); case Zdiv.
  intros HH _; rewrite HH; rewrite Zmult_0_r; rewrite Zmult_1_r; simpl.
case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith.
intros q1 H2.
replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q).
  2: pattern (Zpos p) at 2; rewrite H2; auto with zarith.
generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2;
  case Zmod.
  intros HH _; rewrite HH; auto with zarith.
  intros r1 HH (_,HH1); rewrite HH; rewrite Zpos_succ_morphism.
  unfold Zsucc; rewrite Zmult_plus_distr_r; auto with zarith.
  intros r1 _ (HH,_); case HH; auto.
intros q1 HH; rewrite HH.
unfold Zge; simpl Zcompare; intros HH1; case HH1; auto.
Qed.

Definition is_one p := match p with xH => true | _ => false end.

Theorem is_one_one: forall p, is_one p = true -> p = xH.
intros p; case p; auto; intros p1 H1; discriminate H1.
Qed.

Definition get_height digits p :=
  let r := Pdiv p digits in
   if is_one r then xH else Psucc (plength (Ppred r)).

Theorem get_height_correct:
  forall digits N,
   Zpos N <= Zpos digits * (2 ^ (Zpos (get_height digits N) -1)).
intros digits N.
unfold get_height.
assert (H1 := Pdiv_le N digits).
case_eq (is_one (Pdiv N digits)); intros H2.
rewrite (is_one_one _ H2) in H1.
rewrite Zmult_1_r in H1.
change (2^(1-1))%Z with 1; rewrite Zmult_1_r; auto.
clear H2.
apply Zle_trans with (1 := H1).
apply Zmult_le_compat_l; auto with zarith.
rewrite Zpos_succ_morphism; unfold Zsucc.
rewrite Zplus_comm; rewrite Zminus_plus.
apply plength_pred_correct.
Qed.

Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n.
 fix zn2z_word_comm 2.
 intros w n; case n.
  reflexivity.
  intros n0;simpl.
  case (zn2z_word_comm w n0).
  reflexivity.
Defined.

Fixpoint extend (n:nat) {struct n} : forall w:Type, zn2z w -> word w (S n) :=
 match n return forall w:Type, zn2z w -> word w (S n) with
 | O => fun w x => x
 | S m =>
   let aux := extend m in
   fun w x => WW W0 (aux w x)
 end.

Section ExtendMax.

Open Scope nat_scope.

Fixpoint plusnS (n m: nat) {struct n} : (n + S m = S (n + m))%nat :=
  match n return  (n + S m = S (n + m))%nat with
  | 0 => refl_equal (S m)
  | S n1 =>
      let v := S (S n1 + m) in
      eq_ind_r (fun n => S n = v) (refl_equal v) (plusnS n1 m)
  end.

Fixpoint plusn0 n : n + 0 = n :=
  match n return (n + 0 = n) with
  | 0 => refl_equal 0
  | S n1 =>
      let v := S n1 in
      eq_ind_r (fun n : nat => S n = v) (refl_equal v) (plusn0 n1)
  end.

 Fixpoint diff (m n: nat) {struct m}: nat * nat :=
   match m, n with
     O, n => (O, n)
   | m, O => (m, O)
   | S m1, S n1 => diff m1 n1
   end.

Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n :=
  match m return fst (diff m n) + n = max m n with
  | 0 =>
      match n return (n = max 0 n) with
      | 0 => refl_equal _
      | S n0 => refl_equal _
      end
  | S m1 =>
      match n return (fst (diff (S m1) n) + n = max (S m1) n)
      with
      | 0 => plusn0 _
      | S n1 =>
          let v := fst (diff m1 n1) + n1 in
          let v1 := fst (diff m1 n1) + S n1 in
          eq_ind v (fun n => v1 = S n)
            (eq_ind v1 (fun n => v1 = n) (refl_equal v1) (S v) (plusnS _ _))
            _ (diff_l _ _)
      end
  end.

Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n :=
  match m return (snd (diff m n) + m = max m n) with
  | 0 =>
      match n return (snd (diff 0 n) + 0 = max 0 n) with
      | 0 => refl_equal _
      | S _ => plusn0 _
      end
  | S m =>
      match n return (snd (diff (S m) n) + S m = max (S m) n) with
      | 0 => refl_equal (snd (diff (S m) 0) + S m)
      | S n1 =>
          let v := S (max m n1) in
          eq_ind_r (fun n => n = v)
            (eq_ind_r (fun n => S n = v)
               (refl_equal v) (diff_r _ _)) (plusnS _ _)
      end
  end.

 Variable w: Type.

 Definition castm (m n: nat) (H: m = n) (x: word w (S m)):
     (word w (S n)) :=
 match H in (_ = y) return (word w (S y)) with
 | refl_equal => x
 end.

Variable m: nat.
Variable v: (word w (S m)).

Fixpoint extend_tr (n : nat) {struct n}: (word w (S (n + m))) :=
  match n  return (word w (S (n + m))) with
  | O => v
  | S n1 => WW W0 (extend_tr n1)
  end.

End ExtendMax.

Implicit Arguments extend_tr[w m].
Implicit Arguments castm[w m n].

Section Reduce.

 Variable w : Type.
 Variable nT : Type.
 Variable N0 : nT.
 Variable eq0 : w -> bool.
 Variable reduce_n : w -> nT.
 Variable zn2z_to_Nt : zn2z w -> nT.

 Definition reduce_n1 (x:zn2z w) :=
  match x with
  | W0 => N0
  | WW xh xl =>
    if eq0 xh then reduce_n xl
    else zn2z_to_Nt x
  end.

End Reduce.

Section ReduceRec.

 Variable w : Type.
 Variable nT : Type.
 Variable N0 : nT.
 Variable reduce_1n : zn2z w -> nT.
 Variable c : forall n, word w (S n) -> nT.

 Fixpoint reduce_n (n:nat) : word w (S n) -> nT :=
  match n return word w (S n) -> nT with
  | O => reduce_1n
  | S m => fun x =>
    match x with
    | W0 => N0
    | WW xh xl =>
      match xh with
      | W0 => @reduce_n m xl
      | _ => @c (S m) x
      end
    end
  end.

End ReduceRec.

Section CompareRec.

 Variable wm w : Type.
 Variable w_0 : w.
 Variable compare : w -> w -> comparison.
 Variable compare0_m : wm -> comparison.
 Variable compare_m : wm -> w -> comparison.

 Fixpoint compare0_mn (n:nat) : word wm n -> comparison :=
  match n return word wm n -> comparison with
  | O => compare0_m
  | S m => fun x =>
    match x with
    | W0 => Eq
    | WW xh xl =>
      match compare0_mn m xh with
      | Eq => compare0_mn m xl
      | r  => Lt
      end
    end
  end.

 Variable wm_base: positive.
 Variable wm_to_Z: wm -> Z.
 Variable w_to_Z: w -> Z.
 Variable w_to_Z_0: w_to_Z w_0 = 0.
 Variable spec_compare0_m: forall x,
   compare0_m x = (w_to_Z w_0 ?= wm_to_Z x).
 Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base.

 Let double_to_Z := double_to_Z wm_base wm_to_Z.
 Let double_wB := double_wB wm_base.

 Lemma base_xO: forall n, base (xO n) = (base n)^2.
 Proof.
 intros n1; unfold base.
 rewrite (Zpos_xO n1); rewrite Zmult_comm; rewrite Zpower_mult; auto with zarith.
 Qed.

 Let double_to_Z_pos: forall n x, 0 <= double_to_Z n x < double_wB n :=
   (spec_double_to_Z wm_base wm_to_Z wm_to_Z_pos).

 Lemma spec_compare0_mn: forall n x,
   compare0_mn n x = (0 ?= double_to_Z n x).
 Proof.
  intros n; elim n; clear n; auto.
  intros x; rewrite spec_compare0_m; rewrite w_to_Z_0; auto.
  intros n Hrec x; case x; unfold compare0_mn; fold compare0_mn; auto.
  fold word in *.
  intros xh xl.
  rewrite 2 Hrec.
  simpl double_to_Z.
  set (wB := DoubleBase.double_wB wm_base n).
  case Zcompare_spec; intros Cmp.
  rewrite <- Cmp. reflexivity.
  symmetry. apply Zgt_lt, Zlt_gt. (* ;-) *)
  assert (0 < wB).
   unfold wB, DoubleBase.double_wB, base; auto with zarith.
  change 0 with (0 + 0); apply Zplus_lt_le_compat; auto with zarith.
  apply Zmult_lt_0_compat; auto with zarith.
  case (double_to_Z_pos n xl); auto with zarith.
  case (double_to_Z_pos n xh); intros; exfalso; omega.
  Qed.

 Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison :=
  match n return word wm n -> w -> comparison with
  | O => compare_m
  | S m => fun x y =>
    match x with
    | W0 => compare w_0 y
    | WW xh xl =>
      match compare0_mn m xh with
      | Eq => compare_mn_1 m xl y
      | r  => Gt
      end
    end
  end.

 Variable spec_compare: forall x y,
   compare x y = Zcompare (w_to_Z x) (w_to_Z y).
 Variable spec_compare_m: forall x y,
   compare_m x y = Zcompare (wm_to_Z x) (w_to_Z y).
 Variable wm_base_lt: forall x,
   0 <= w_to_Z x < base (wm_base).

 Let double_wB_lt: forall n x,
   0 <= w_to_Z x < (double_wB n).
 Proof.
 intros n x; elim n; simpl; auto; clear n.
 intros n (H0, H); split; auto.
 apply Zlt_le_trans with (1:= H).
 unfold double_wB, DoubleBase.double_wB; simpl.
 rewrite Pshiftl_nat_S, base_xO.
 set (u := base (Pshiftl_nat wm_base n)).
 assert (0 < u).
  unfold u, base; auto with zarith.
 replace (u^2) with (u * u); simpl; auto with zarith.
 apply Zle_trans with (1 * u); auto with zarith.
 unfold Zpower_pos; simpl; ring.
 Qed.

 Lemma spec_compare_mn_1: forall n x y,
   compare_mn_1 n x y = Zcompare (double_to_Z n x) (w_to_Z y).
 Proof.
 intros n; elim n; simpl; auto; clear n.
 intros n Hrec x; case x; clear x; auto.
 intros y; rewrite spec_compare; rewrite w_to_Z_0. reflexivity.
 intros xh xl y; simpl;
 rewrite spec_compare0_mn, Hrec. case Zcompare_spec.
 intros H1b.
 rewrite <- H1b; rewrite Zmult_0_l; rewrite Zplus_0_l; auto.
 symmetry. apply Zlt_gt.
 case (double_wB_lt n y); intros _ H0.
 apply Zlt_le_trans with (1:= H0).
 fold double_wB.
 case (double_to_Z_pos n xl); intros H1 H2.
 apply Zle_trans with (double_to_Z n xh * double_wB n); auto with zarith.
 apply Zle_trans with (1 * double_wB n); auto with zarith.
 case (double_to_Z_pos n xh); intros; exfalso; omega.
 Qed.

End CompareRec.

Section AddS.

 Variable w wm : Type.
 Variable incr : wm -> carry wm.
 Variable addr : w -> wm -> carry wm.
 Variable injr : w -> zn2z wm.

 Variable w_0 u: w.
 Fixpoint injs  (n:nat): word w (S n) :=
  match n return (word w (S n)) with
    O => WW w_0 u
  | S n1 => (WW W0 (injs n1))
  end.

 Definition adds x y :=
   match y with
    W0 => C0 (injr x)
  | WW hy ly => match addr x ly with
                  C0 z => C0 (WW hy z)
                | C1 z => match incr hy with
                            C0 z1 => C0 (WW z1 z)
                          | C1 z1 => C1 (WW z1 z)
                          end
                 end
   end.

End AddS.

 Fixpoint length_pos x :=
  match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end.

 Theorem length_pos_lt: forall x y,
   (length_pos x < length_pos y)%nat -> Zpos x < Zpos y.
 Proof.
 intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac];
   intros y; case y; clear y; intros y1 H || intros H; simpl length_pos;
   try (rewrite (Zpos_xI x1) || rewrite (Zpos_xO x1));
   try (rewrite (Zpos_xI y1) || rewrite (Zpos_xO y1));
   try (inversion H; fail);
   try (assert (Zpos x1 < Zpos y1); [apply Hrec; apply lt_S_n | idtac]; auto with zarith);
   assert (0 < Zpos y1); auto with zarith; red; auto.
 Qed.

 Theorem cancel_app: forall A B (f g: A -> B) x, f = g -> f x = g x.
 Proof.
 intros A B f g x H; rewrite H; auto.
 Qed.

 Section SimplOp.

 Variable w: Type.

 Theorem digits_zop: forall t (ops : ZnZ.Ops t),
  ZnZ.digits (mk_zn2z_ops ops) = xO (ZnZ.digits ops).
 Proof.
 intros ww x; auto.
 Qed.

 Theorem digits_kzop: forall t (ops : ZnZ.Ops t),
  ZnZ.digits (mk_zn2z_ops_karatsuba ops) = xO (ZnZ.digits ops).
 Proof.
 intros ww x; auto.
 Qed.

 Theorem make_zop: forall t (ops : ZnZ.Ops t),
  @ZnZ.to_Z _ (mk_zn2z_ops ops) =
    fun z => match z with
             | W0 => 0
             | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops)
                                + ZnZ.to_Z xl
             end.
 Proof.
 intros ww x; auto.
 Qed.

 Theorem make_kzop: forall t (ops: ZnZ.Ops t),
  @ZnZ.to_Z _ (mk_zn2z_ops_karatsuba ops) =
    fun z => match z with
             | W0 => 0
             | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops)
                                + ZnZ.to_Z xl
             end.
 Proof.
 intros ww x; auto.
 Qed.

 End SimplOp.

(** Abstract vision of a datatype of arbitrary-large numbers.
    Concrete operations can be derived from these generic
    fonctions, in particular from [iter_t] and [same_level].
*)

Module Type NAbstract.

(** The domains: a sequence of [Z/nZ] structures *)

Parameter dom_t : nat -> Type.
Declare Instance dom_op n : ZnZ.Ops (dom_t n).
Declare Instance dom_spec n : ZnZ.Specs (dom_op n).

Axiom digits_dom_op : forall n,
  ZnZ.digits (dom_op n) = Pshiftl_nat (ZnZ.digits (dom_op 0)) n.

(** The type [t] of arbitrary-large numbers, with abstract constructor [mk_t]
    and destructor [destr_t] and iterator [iter_t] *)

Parameter t : Type.

Parameter mk_t : forall (n:nat), dom_t n -> t.

Inductive View_t : t -> Prop :=
 Mk_t : forall n (x : dom_t n), View_t (mk_t n x).

Axiom destr_t : forall x, View_t x. (* i.e. every x is a (mk_t n xw) *)

Parameter iter_t : forall {A:Type}(f : forall n, dom_t n -> A), t -> A.

Axiom iter_mk_t : forall A (f:forall n, dom_t n -> A),
 forall n x, iter_t f (mk_t n x) = f n x.

(** Conversion to [ZArith] *)

Parameter to_Z : t -> Z.
Local Notation "[ x ]" := (to_Z x).

Axiom spec_mk_t : forall n x, [mk_t n x] = ZnZ.to_Z x.

(** [reduce] is like [mk_t], but try to minimise the level of the number *)

Parameter reduce : forall (n:nat), dom_t n -> t.
Axiom spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x.

(** Number of level in the tree representation of a number.
    NB: This function isn't a morphism for setoid [eq]. *)

Definition level := iter_t (fun n _ => n).

(** [same_level] and its rich specification, indexed by [level] *)

Parameter same_level : forall {A:Type}
 (f : forall n, dom_t n -> dom_t n -> A), t -> t -> A.

Axiom spec_same_level_dep :
  forall res
   (P : nat -> Z -> Z -> res -> Prop)
   (Pantimon : forall n m z z' r, (n <= m)%nat -> P m z z' r -> P n z z' r)
   (f : forall n, dom_t n -> dom_t n -> res)
   (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)),
   forall x y, P (level x) [x] [y] (same_level f x y).

(** [mk_t_S] : building a number of the next level *)

Parameter mk_t_S : forall (n:nat), zn2z (dom_t n) -> t.

Axiom spec_mk_t_S : forall n (x:zn2z (dom_t n)),
  [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x.

Axiom mk_t_S_level : forall n x, level (mk_t_S n x) = S n.

End NAbstract.


Require Import VST.floyd.proofauto.
Require Import triang.
Require Import spec_stdlib.
Require Import spec_fastpile.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope assert.

Fixpoint triang (n: nat) :=
 match n with
 | O => 0
 | S n' => Z.of_nat n + triang n'
 end.

Definition Triang_nth_spec :=
 DECLARE _Triang_nth
 WITH n:Z, gv: globals
 PRE [ _n OF tint ]
    PROP( 0 <= n < 1000)
    LOCAL(temp _n (Vint (Int.repr n)); gvars gv)
    SEP(mem_mgr gv)
 POST[ tint ]
    PROP()
    LOCAL(temp ret_temp (Vint (Int.repr (triang (Z.to_nat n)))))
    SEP(mem_mgr gv).

Definition specs := [Triang_nth_spec].