(** Adapted from "Elements of Set Theory" Chapter 5 **)
(** Coq coding by choukh, July 2020 **)

Require Export ZFC.Elements.EST5_5.

(*** EST第五章6：实数绝对值，非负实数乘法，正实数乘法逆元 ***)

(** 实数绝对值 **)
Definition RealAbs : set → set := λ x, x ∪ -x.
Notation "| r |" := (RealAbs r) : Real_scope.

Lemma realAbs_nonNeg_id : ∀ x, realNonNeg x → |x| = x.
Proof with neauto.
  intros x [Hpos|H0].
  - assert (Hx: x ∈ ℝ) by (apply binRelE2 in Hpos as [_ []]; auto).
    apply realPos_rat0 in Hpos as H0...
    ext q Hq; revgoals.
    apply BUnionI1... apply BUnionE in Hq as []...
    apply SepE in H as [Hq [s [Hs [Hlt H]]]].
    eapply realE2_1 in H; revgoals... apply ratAddInv_ran...
    apply ratPos_neg in H. rewrite ratAddInv_double in H...
    assert (Hnq: ratNeg q) by (eapply ratLt_trans; eauto).
    eapply realE2; revgoals...
  - subst. ext q Hq.
    + apply BUnionE in Hq as []... rewrite realAddInv_0 in H...
    + apply BUnionI1...
Qed.

Lemma realAbs_unsigned_nonNeg : ∀x ∈ ℝ, |x| = x → realNonNeg x.
Proof with neauto.
  intros x Hx Heq. apply realLe... intros q Hq.
  apply SepE in Hq as [Hq Hlt]. rewrite <- Heq.
  destruct (classic (Rat 0 ∈ x)).
  - apply BUnionI1. eapply realE2; revgoals...
  - apply BUnionI2. apply SepI... exists (Rat 0).
    split... split... rewrite ratAddInv_0...
Qed.

Lemma realAbs_nonPos_flip : ∀ x, realNonPos x → |x| = -x.
Proof with neauto.
  intros x [Hneg|Heq].
  - assert (Hx: x ∈ ℝ) by (apply binRelE2 in Hneg as []; auto).
    apply realNeg_pos in Hneg as Hpos.
    apply realPos_rat0 in Hpos as H0; [|apply realAddInv_ran; auto].
    ext q Hq; revgoals.
    apply BUnionI2... apply BUnionE in Hq as [Hqx|]...
    assert (Hq: q ∈ ℚ) by (apply (real_sub_rat x Hx); auto).
    apply SepI... apply SepE in H0 as [_ [s [Hs [Hlt Hout]]]].
    exists s. split... split... eapply ratLt_trans...
    eapply realE2_1... intros H. apply realPos_rat0 in H...
    eapply realLt_irrefl. eapply realLt_trans...
  - subst. ext q Hq.
    + apply BUnionE in Hq as []... rewrite realAddInv_0...
    + apply BUnionI2...
Qed.

Lemma realAbs_flip_nonPos : ∀x ∈ ℝ, |x| = -x → realNonPos x.
Proof with neauto.
  intros x Hx Heq. apply realLe_addInv'...
  rewrite realAddInv_0. apply realLe... apply realAddInv_ran...
  intros q Hq. apply SepE in Hq as [Hq Hlt]. rewrite <- Heq.
  destruct (classic (Rat 0 ∈ x)).
  - apply BUnionI1. eapply realE2; revgoals...
  - apply BUnionI2. apply SepI... exists (Rat 0).
    split... split... rewrite ratAddInv_0...
Qed.

Lemma realAbs_eq_0 : ∀x ∈ ℝ, |x| = Real 0 → x = Real 0.
Proof with nauto.
  intros x Hx H0. destruct (classic (realNonNeg x))...
  rewrite (realAbs_nonNeg_id _ H) in H0...
  apply realNeg_not_nonNeg in H...
  apply realNeg_nonPos in H...
  rewrite (realAbs_nonPos_flip _ H) in H0.
  assert (--x = -Real 0) by congruence.
  rewrite realAddInv_double, realAddInv_0 in H1...
Qed.

Lemma realAbs_unsigned : ∀x ∈ ℝ, | -x | = |x|.
Proof with auto.
  intros x Hx.
  assert (Hx': -x ∈ ℝ) by (apply realAddInv_ran; auto).
  destruct (classic (realNonNeg (-x))).
  - rewrite (realAbs_nonNeg_id _ H).
    apply realNonNeg_nonPos in H...
    rewrite realAddInv_double in H...
    rewrite (realAbs_nonPos_flip _ H)...
  - apply realNeg_not_nonNeg in H...
    apply realNeg_nonPos in H...
    rewrite (realAbs_nonPos_flip _ H), realAddInv_double...
    apply realNonPos_nonNeg in H... rewrite realAddInv_double in H...
    rewrite (realAbs_nonNeg_id _ H)...
Qed.

Lemma realAbs_ran : ∀x ∈ ℝ, |x| ∈ ℝ.
Proof with auto.
  intros x Hx. destruct (classic (realNonNeg x)).
  - apply realAbs_nonNeg_id in H. rewrite H...
  - apply realNeg_not_nonNeg in H...
    apply realNeg_nonPos in H...
    apply realAbs_nonPos_flip in H. rewrite H...
    apply realAddInv_ran...
Qed.

Theorem realAbs_nonNeg : ∀x ∈ ℝ, realNonNeg (|x|).
Proof with neauto.
  intros x Hx. destruct (classic (realNonNeg x)).
  - rewrite (realAbs_nonNeg_id _ H)...
  - apply realNeg_not_nonNeg in H...
    apply realNeg_nonPos in H...
    apply realAbs_nonPos_flip in H as Heq. rewrite Heq.
    apply realNonPos_nonNeg...
Qed.

Lemma realPos_ratPos : ∀x ∈ ℝ,
  realPos x → ∃q ∈ ℚ, q ∈ x ∧ ratPos q.
Proof with auto.
  intros x Hx Hpx. apply realE3... apply realPos_rat0...
Qed.

Lemma realPos_ratNonNeg : ∀x ∈ ℝ,
  realPos x → ∃q ∈ x, ratNonNeg q.
Proof with auto.
  intros x Hx Hpx. exists (Rat 0). split...
  apply realPos_rat0... right...
Qed.

Lemma realNonPos_ratNeg : ∀x ∈ ℝ,
  realNonPos x → ∃q ∈ x, ratNeg q.
Proof with nauto.
  intros x Hx Hnpx. apply realLe in Hnpx...
  apply realE0 in Hx as [r [Hrq Hrx]].
  exists r. split... apply Hnpx in Hrx.
  apply SepE in Hrx as [_ Hnr]...
Qed.

Lemma realNonPos_ratNonPos : ∀x ∈ ℝ,
  realNonPos x → ∃q ∈ x, ratNonPos q.
Proof with nauto.
  intros x Hx Hnpx.
  apply realNonPos_ratNeg in Hnpx as [q [Hqx Hnq]]...
  exists q. split... left...
Qed.

Lemma realE1'_ratPos : ∀x ∈ ℝ, realNonNeg x →
  ∃r ∈ ℚ, (∀q ∈ x, q <𝐪 r) ∧ ratPos r.
Proof with neauto.
  intros x Hx Hnnx. assert (Hx' := Hx).
  apply realE1 in Hx' as [r [Hrq Hrx]].
  exists (r + Rat 1)%q. split... apply ratAdd_ran... split.
  intros q Hq. apply (real_sub_rat _ Hx) in Hq as Hqq.
  assert (Hlt: r <𝐪 (r + Rat 1)%q). {
    rewrite <- (ratAdd_0_r r) at 1...
    apply ratAdd_preserve_lt'... apply ratPos_sn.
  }
  eapply ratLt_trans; revgoals. apply Hlt. eapply realE2_1...
  cut (ratNonNeg r). intros [Hpr|H0].
  unfold ratPos. rewrite <- (ratAdd_0_r (Rat 0))...
  apply ratAdd_preserve_lt_trans... apply ratPos_sn.
  subst. rewrite ratAdd_0_l... destruct Hnnx.
  - left. apply realPos_rat0 in H... eapply realE2_1...
  - subst. destruct (classic (r = Rat 0))... right...
    apply ratLt_connected in H as []...
    exfalso. apply Hrx. apply SepI... left...
Qed.

(** 非负实数乘法 **)
Definition RealNonNegMul : set → set → set := λ x y,
  let P := {p ∊ x × y | ratNonNeg (π1 p) ∧ ratNonNeg (π2 p)} in
  Real 0 ∪ {(π1 p ⋅ π2 p)%q | p ∊ P}.
Notation "x ⋅₊ y" := (RealNonNegMul x y) (at level 45) : Real_scope.

Lemma realNonNegMulI0 : ∀ x y ∈ ℝ, ∀ s, ratNeg s → s ∈ x ⋅₊ y.
Proof with auto.
  intros x Hx y Hy s Hps. apply BUnionI1.
  apply SepI... apply ratNeg_rat...
Qed.

Lemma realNonNegMulI1 : ∀ x y ∈ ℝ, ∀q ∈ x, ∀r ∈ y,
  ratNonNeg q → ratNonNeg r → (q ⋅ r)%q ∈ x ⋅₊ y.
Proof with auto.
  intros x Hx y Hy q Hqx r Hry Hnnq Hnnr.
  apply BUnionI2. apply ReplAx.
  exists <q, r>. split; zfc_simple. apply SepI.
  apply CPrdI... zfc_simple. split...
Qed.

Lemma realNonNegMulE : ∀ x y ∈ ℝ, ∀s ∈ x ⋅₊ y, s ∈ Real 0 ∨
  ∃q ∈ ℚ, ∃r ∈ ℚ, (q ∈ x ∧ r ∈ y) ∧
    (ratNonNeg q ∧ ratNonNeg r) ∧ s = (q ⋅ r)%q.
Proof with auto.
  intros x Hx y Hy s Hs.
  apply BUnionE in Hs as []... right.
  apply ReplAx in H as [p [Hp Hs]].
  apply SepE in Hp as [Hp [H1 H2]].
  apply CPrdE1 in Hp as [q [Hq [r [Hr Hp]]]].
  subst. zfc_simple.
  exists q. split... apply (real_sub_rat _ Hx)...
  exists r. split... apply (real_sub_rat _ Hy)...
Qed.

Lemma realNonNegMul_sub_rat : ∀ x y ∈ ℝ, x ⋅₊ y ∈ 𝒫 ℚ.
Proof with auto.
  intros x Hx y Hy. apply PowerAx. intros s Hs.
  apply realNonNegMulE in Hs as []... apply SepE1 in H...
  destruct H as [q [Hq [r [Hr [_ [_ Heq]]]]]].
  subst. apply ratMul_ran...
Qed.

Close Scope Real_scope.
Open Scope Rat_scope.

Lemma realNonNegMul_ran : ∀ x y ∈ ℝ,
  realNonNeg x → realNonNeg y → (x ⋅₊ y)%r ∈ ℝ.
Proof with neauto.
  intros x Hxr y Hyr Hnnx Hnny.
  apply SepI. apply realNonNegMul_sub_rat... repeat split.
  - apply EmptyNI. destruct (classic (x = Real 0 ∨ y = Real 0)).
    + destruct H.
      * assert (Hnpx: realNonPos x) by (right; auto).
        apply realNonPos_ratNeg in Hnpx as [q [Hqy Hnq]]...
        exists q. apply realNonNegMulI0...
      * assert (Hnpy: realNonPos y) by (right; auto).
        apply realNonPos_ratNeg in Hnpy as [r [Hrx Hnr]]...
        exists r. apply realNonNegMulI0...
    + apply not_or_and in H as [Hx0 Hy0].
      destruct Hnnx; destruct Hnny; [clear Hx0 Hy0|exfalso; auto..].
      apply realPos_ratNonNeg in H as [q [Hq Hnnq]]...
      apply realPos_ratNonNeg in H0 as [r [Hr Hnnr]]...
      exists (q ⋅ r). apply realNonNegMulI1...
  - assert (Hx' := Hxr). assert (Hy' := Hyr).
    apply realE1'_ratPos in Hx' as [q [Hq [H1 Hpq]]]...
    apply realE1'_ratPos in Hy' as [r [Hr [H2 Hpr]]]...
    assert (Hqr : q ⋅ r ∈ ℚ) by (apply ratMul_ran; auto).
    apply ExtNI. exists (q ⋅ r). split... intros H.
    apply (ratLt_irrefl (q ⋅ r))...
    cut (∀p ∈ (x ⋅₊ y)%r, p <𝐪 q ⋅ r). intros Hlt. apply Hlt...
    intros p Hp. apply realNonNegMulE in Hp as []...
    + apply SepE in H0 as [_ H0].
      eapply ratLt_trans. apply H0.
      apply ratMul_pos_prd...
    + destruct H0 as [s [Hsq [t [Htq [[Hs Ht] [[Hnns Hnnt] Heq]]]]]].
      subst. apply H1 in Hs. apply H2 in Ht.
      destruct Hnnt as [Hpt|H0].
      eapply ratMul_preserve_lt_trans...
      subst. rewrite ratMul_0_r_r... apply ratMul_pos_prd...
  - intros p Hp q Hq Hqxy Hlt.
    apply realNonNegMulE in Hqxy as []; auto; [|
      destruct (classic (ratNeg p)) as [|Hnnp]]; auto; [| |
        destruct H as [s [Hsq [t [Htq [[Hs Ht]
          [[[Hps|H0] Hnnt] Heq]]]]]]; revgoals]; subst.
    + apply realNonNegMulI0...
      apply SepE in H as [_ H0]. eapply ratLt_trans...
    + apply realNonNegMulI0...
    + apply realNonNegMulI0...
      rewrite ratMul_0_l in Hlt...
    + assert (Hsq': s ∈ ℚ'). {
        apply nzRatI0... apply rat_neq_0...
      }
      assert (Hrsq: s⁻¹ ∈ ℚ). {
        apply nzRatE1. apply ratMulInv_ran...
      }
      assert (Hprs: ratPos s⁻¹) by (apply ratPos_mulInv; auto).
      assert (Heq: p = s ⋅ (p / s)). {
        rewrite (ratMul_comm p), <- ratMul_assoc,
        ratMulInv_annih, ratMul_1_l...
      }
      assert (Hlt': p / s <𝐪 t). {
        rewrite <- (ratMul_1_r t), <- (ratMulInv_annih s),
          <- ratMul_assoc... apply ratMul_preserve_lt...
        apply ratMul_ran... rewrite ratMul_comm...
      }
      rewrite Heq. apply realNonNegMulI1...
      eapply realE2; revgoals... apply ratMul_ran... left...
      apply ratNonNeg_not_neg in Hnnp as []...
      left. apply ratMul_pos_prd...
      right. subst. rewrite ratMul_0_l...
  - intros p Hp. apply realNonNegMulE in Hp as []...
    + apply SepE in H as [Hpq Hp0].
      assert (Hpd2q: p / Rat 2 ∈ ℚ) by (apply ratMul_ran; nauto).
      assert (Hnpq: - p ∈ ℚ) by (apply ratAddInv_ran; auto).
      exists (p / Rat 2). split.
      * apply realNonNegMulI0... unfold ratNeg.
        rewrite <- (ratMul_1_r (Rat 0)),
          <- (ratMulInv_annih (Rat 2)), <- ratMul_assoc, ratMul_0_l...
        apply ratMul_preserve_lt...
      * apply ratLt_addInv... rewrite <- (ratMul_1_r (-p)),
          <- ratMul_addInv_l, ratMul_comm, (ratMul_comm (-p))...
        apply ratMul_preserve_lt...
        apply ratNeg_pos... apply ratLt_r2_1.
    + destruct H as [s [Hsq [t [Htq [[Hs Ht] [[Hnns Hnnt] Heq]]]]]].
      apply realE3 in Hs as [q [Hqq [Hqx H1]]]...
      apply realE3 in Ht as [r [Hrq [Hry H2]]]...
      assert (Hpq: ratPos q). {
        destruct Hnns. eapply ratLt_trans... subst...
      }
      assert (Hpr: ratPos r). {
        destruct Hnnt. eapply ratLt_trans.
        apply H. apply H2. subst...
      }
      exists (q ⋅ r). split. apply realNonNegMulI1...
      left... left... destruct Hnnt; revgoals; subst.
      * rewrite ratMul_0_r_r... apply ratMul_pos_prd...
      * apply ratMul_preserve_lt_trans...
Qed.

Close Scope Rat_scope.
Open Scope Real_scope.

Lemma realNonNegMul_comm : ∀ x y ∈ ℝ,
  realNonNeg x → realNonNeg y → x ⋅₊ y = y ⋅₊ x.
Proof with auto.
  intros x Hx y Hy Hnnx Hnny.
  ext p Hp.
  - assert (Hpq: p ∈ ℚ). {
      apply real_sub_rat in Hp... apply realNonNegMul_ran...
    }
    apply realNonNegMulE in Hp as []; auto; [|
      destruct (classic (ratNeg p)) as [|Hnnp]]...
    + apply BUnionI1...
    + apply realNonNegMulI0...
    + destruct H as [s [Hsq [t [Htq [[Hs Ht] [[Hnns Hnnt] Heq]]]]]].
      rewrite Heq, ratMul_comm... apply realNonNegMulI1...
  - assert (Hpq: p ∈ ℚ). {
      apply real_sub_rat in Hp... apply realNonNegMul_ran...
    }
    apply realNonNegMulE in Hp as []; auto; [|
      destruct (classic (ratNeg p)) as [|Hnnp]]...
    + apply BUnionI1...
    + apply realNonNegMulI0...
    + destruct H as [s [Hsq [t [Htq [[Hs Ht] [[Hnns Hnnt] Heq]]]]]].
      rewrite Heq, ratMul_comm... apply realNonNegMulI1...
Qed.

Lemma realNonNegMul_0_r_r : ∀x ∈ ℝ, x ⋅₊ Real 0 = Real 0.
Proof with nauto.
  intros x Hx. ext p Hp.
  - apply realNonNegMulE in Hp as []... exfalso.
    destruct H as [_ [_ [t [_ [[_ Ht] [[_ Hnnt] _]]]]]].
    apply SepE in Ht as [Htq Hnt].
    apply ratNonNeg_not_neg in Hnnt...
  - apply BUnionI1...
Qed.

Lemma realNonNegMul_0_l : ∀x ∈ ℝ, Real 0 ⋅₊ x = Real 0.
Proof with nauto.
  intros x Hx. ext p Hp.
  - apply realNonNegMulE in Hp as []... exfalso.
    destruct H as [q [_ [_ [_ [[Hq _] [[Hnnq _] _]]]]]].
    apply SepE in Hq as [Hqq Hnq].
    apply ratNonNeg_not_neg in Hnnq...
  - apply BUnionI1...
Qed.

Lemma realNonNegMul_preserve_le : ∀ x y z ∈ ℝ,
  realNonNeg x → realNonNeg y → realPos z →
  x ≤ y → x ⋅₊ z ≤ y ⋅₊ z.
Proof with eauto.
  intros x Hx y Hy z Hz Hnnx Hnny Hpz Hle.
  apply realPos_nonNeg in Hpz as Hnnz...
  apply realLeE in Hle. apply realLeI.
  apply realNonNegMul_ran... apply realNonNegMul_ran...
  intros p Hp. apply realNonNegMulE in Hp as []...
  - apply BUnionI1...
  - destruct H as [q [_ [r [_ [[Hq Hr] [[Hnnq Hnnr] Heq]]]]]].
    destruct Hnny as [Hpy|Hy0].
    + rewrite Heq. apply realNonNegMulI1...
    + exfalso. subst. apply Hle in Hq.
      apply SepE in Hq as [Hq Hq0].
      apply ratNonNeg_not_neg in Hnnq...
Qed.

Lemma realNonNegMul_nonNeg_prd : ∀ x y ∈ ℝ,
  realNonNeg x → realNonNeg y → realNonNeg (x ⋅₊ y).
Proof with nauto.
  intros x Hxr y Hyr Hnnx Hnny.
  destruct Hnny as [Hpy|Hy0].
  - unfold realNonNeg. rewrite <- (realNonNegMul_0_l y)...
    apply realNonNegMul_preserve_le... right...
  - subst. rewrite realNonNegMul_0_r_r... right...
Qed.

Lemma realNonNegMul_pos_prd : ∀ x y ∈ ℝ,
  realPos x → realPos y → realPos (x ⋅₊ y).
Proof with nauto.
  intros x Hxr y Hyr Hpx Hpy. apply realPos_rat0.
  apply realNonNegMul_ran; auto; apply realPos_nonNeg...
  rewrite <- (ratMul_0_l (Rat 0))... apply realNonNegMulI1...
  apply realPos_rat0... apply realPos_rat0... right... right...
Qed.

Lemma realNonNegMul_assoc : ∀ x y z ∈ ℝ,
  realNonNeg x → realNonNeg y → realNonNeg z →
  (x ⋅₊ y) ⋅₊ z = x ⋅₊ (y ⋅₊ z).
Proof with auto.
  intros x Hx y Hy z Hz Hnnx Hnny Hnnz.
  assert (Hxyr: x ⋅₊ y ∈ ℝ) by (apply realNonNegMul_ran; auto).
  assert (Hyzr: y ⋅₊ z ∈ ℝ) by (apply realNonNegMul_ran; auto).
  ext p Hp.
  - assert (Hpq: p ∈ ℚ). {
      apply real_sub_rat in Hp... apply realNonNegMul_ran...
      apply realNonNegMul_nonNeg_prd...
    }
    apply realNonNegMulE in Hp as []... apply BUnionI1...
    destruct H as [q [_ [t [Htq [[Hq Ht] [[Hnnq Hnnt] Hpeq]]]]]].
    apply realNonNegMulE in Hq as []...
    + exfalso. apply SepE in H as [Hqq Hnq].
      apply ratNonNeg_not_neg in Hnnq...
    + destruct H as [r [Hrq [s [Hsq [[Hr Hs] [[Hnnr Hnns] Hqeq]]]]]].
      assert (Hnnst: ratNonNeg (s ⋅ t)%q)
        by (apply ratMul_nonNeg_prd; auto).
      subst. rewrite ratMul_assoc...
      apply realNonNegMulI1... apply realNonNegMulI1...
  - assert (Hpq: p ∈ ℚ). {
      apply real_sub_rat in Hp... apply realNonNegMul_ran...
      apply realNonNegMul_nonNeg_prd...
    }
    apply realNonNegMulE in Hp as []... apply BUnionI1...
    destruct H as [q [Hqq [t [_ [[Hq Ht] [[Hnnq Hnnt] Hpeq]]]]]].
    apply realNonNegMulE in Ht as []...
    + exfalso. apply SepE in H as [Htq Hnt].
      apply ratNonNeg_not_neg in Hnnt...
    + destruct H as [r [Hrq [s [Hsq [[Hr Hs] [[Hnnr Hnns] Hteq]]]]]].
      assert (Hnnqr: ratNonNeg (q ⋅ r)%q)
        by (apply ratMul_nonNeg_prd; auto).
      subst. rewrite <- ratMul_assoc...
      apply realNonNegMulI1... apply realNonNegMulI1...
Qed.

Lemma realAddE_nonNeg : ∀ x y ∈ ℝ, ∀q ∈ ℚ,
  realPos x → realPos y → ratNonNeg q → q ∈ x + y →
  ∃ r s ∈ ℚ, (r ∈ x ∧ s ∈ y) ∧
    (ratNonNeg r ∧ ratNonNeg s) ∧ (r + s)%q = q.
Proof with neauto.
  intros x Hx y Hy q Hqq Hpx Hpy Hnnq Hq.
  apply ReplAx in Hq as [t [Ht Heq]]. apply CPrdE1 in Ht
    as [r [Hr [s [Hs Ht]]]]. subst. zfc_simple.
  assert (Hrq: r ∈ ℚ) by (eapply real_sub_rat; revgoals; eauto).
  assert (Hsq: s ∈ ℚ) by (eapply real_sub_rat; revgoals; eauto).
  destruct (classic (ratNeg r)); destruct (classic (ratNeg s)).
  - exfalso. apply ratNonNeg_not_neg in Hnnq...
    apply Hnnq. apply ratAdd_neg_sum...
  - exists (Rat 0). split... exists (r + s)%q. repeat split...
    + apply realPos_rat0...
    + cut ((r + s)%q <𝐪 s). intros Hlt. eapply realE2; revgoals...
      rewrite <- (ratAdd_0_l s) at 2... apply ratAdd_preserve_lt...
    + right... + rewrite ratAdd_0_l...
  - exists (r + s)%q. split... exists (Rat 0). repeat split...
    + cut ((r + s)%q <𝐪 r). intros Hlt. eapply realE2; revgoals...
      rewrite <- (ratAdd_0_r r) at 2... apply ratAdd_preserve_lt'...
    + apply realPos_rat0...
    + right... + rewrite ratAdd_0_r...
  - apply ratNonNeg_not_neg in H... apply ratNonNeg_not_neg in H0...
    exists r. split... exists s. split...
Qed.

Lemma realNonNegMul_distr : ∀ x y z ∈ ℝ,
  realNonNeg x → realNonNeg y → realNonNeg z →
  x ⋅₊ (y + z) = x ⋅₊ y + x ⋅₊ z.
Proof with nauto.
  intros x Hx y Hy z Hz Hnnx Hnny Hnnz.
  assert (Hxyr: x ⋅₊ y ∈ ℝ) by (apply realNonNegMul_ran; auto).
  assert (Hxzr: x ⋅₊ z ∈ ℝ) by (apply realNonNegMul_ran; auto).
  assert (Hsumr: y + z ∈ ℝ) by (apply realAdd_ran; auto).
  ext p Hp.
  - apply realNonNegMulE in Hp as []...
    + cut (Real 0 ⊆ x ⋅₊ y + x ⋅₊ z). intros Hsub. apply Hsub...
      apply realLe... apply realAdd_ran...
      apply realAdd_nonNeg_sum; auto;
      apply realNonNegMul_nonNeg_prd...
    + destruct H as [q [Hqq [t [Htq [[Hq Ht] [[Hnnq Hnnt] Hpeq]]]]]].
      destruct Hnny; destruct Hnnz; subst.
      * apply realAddE_nonNeg in Ht
          as [r [Hrq [s [Hsq [[Hr Hs] [[Hnnr Hnns] Heq]]]]]]...
        subst. rewrite ratMul_distr... apply realAddI2...
        apply realNonNegMulI1... apply realNonNegMulI1...
      * rewrite realAdd_0_r in Ht...
        rewrite realNonNegMul_0_r_r, realAdd_0_r...
        apply realNonNegMulI1...
      * rewrite realAdd_0_l in Ht...
        rewrite realNonNegMul_0_r_r, realAdd_0_l...
        apply realNonNegMulI1...
      * exfalso. apply ratNonNeg_not_neg in Hnnt... apply Hnnt.
        rewrite realAdd_0_r in Ht... apply SepE2 in Ht...
  - destruct Hnnx as [Hpx|]; revgoals; [|
      destruct (classic (y = Real 0 ∨ z = Real 0)); [
        destruct H |
        apply not_or_and in H as [Hy0 Hz0];
        destruct Hnny as [Hpy|]; destruct Hnnz as [Hpz|];
          [clear Hy0 Hz0|exfalso; auto..]
    ]]; subst.
    + rewrite realNonNegMul_0_l... rewrite realNonNegMul_0_l,
        realNonNegMul_0_l, realAdd_0_r in Hp...
    + rewrite realAdd_0_l...
      rewrite realNonNegMul_0_r_r, realAdd_0_l in Hp...
    + rewrite realAdd_0_r...
      rewrite realNonNegMul_0_r_r, realAdd_0_r in Hp...
    + assert (Hpq: p ∈ ℚ). {
        apply real_sub_rat in Hp... apply realAdd_ran...
      }
      destruct (classic (ratNeg p)) as [|Hnnp]. apply realNonNegMulI0...
      apply ratNonNeg_not_neg in Hnnp...
      apply realAddE_nonNeg in Hp
        as [q [Hqq [r [Hrq [[Hq Hr] [_ Heq]]]]]];
        auto; [|apply realNonNegMul_pos_prd; auto..].
      Close Scope Real_scope.
      Open Scope Rat_scope.
      apply realNonNegMulE in Hq as [Hq|Hq];
      apply realNonNegMulE in Hr as [Hr|Hr]...
      * exfalso. subst. apply ratNonNeg_not_neg in Hnnp...
        apply Hnnp. apply ratAdd_neg_sum...
        apply SepE2 in Hq... apply SepE2 in Hr...
      * destruct Hr as [s [Hsq [t [Htq [[Hs Ht] [[Hnns Hnnt] Hreq]]]]]].
        destruct Hnns; revgoals; subst.
        rewrite (ratMul_0_l t), ratAdd_0_r... apply BUnionI1...
        assert (Hs': s ∈ ℚ'). {
          apply nzRatI0... apply rat_neq_0...
        }
        assert (Hrsq: s⁻¹ ∈ ℚ). {
          apply nzRatE1. apply ratMulInv_ran...
        }
        assert (Hqsq: q/s ∈ ℚ) by (apply ratMul_ran; auto).
        assert (Hqs0: q/s <𝐪 Rat 0). {
          rewrite ratMul_comm... apply ratMul_neg_prd...
          apply ratPos_mulInv... apply SepE2 in Hq...
        }
        assert (Hnnsum: ratNonNeg (q/s + t)). {
          unfold ratNonNeg.
          rewrite <- (ratMul_1_r t), <- (ratMulInv_annih s),
            <- (ratMul_assoc t Htq s Hsq (s⁻¹)),
            (ratMul_comm t Htq s Hsq),
            <- ratMul_distr', <- (ratMul_0_l s⁻¹); [|auto..].
          apply ratMul_preserve_le... apply ratPos_mulInv...
        }
        replace (q + s ⋅ t) with (s ⋅ (q/s + t)).
        apply realNonNegMulI1... apply realAddI2...
        eapply realE2; revgoals; [eauto|nauto..]. apply realPos_rat0... left...
        rewrite ratMul_distr, (ratMul_comm q Hqq s⁻¹ Hrsq),
          <- (ratMul_assoc s Hsq s⁻¹ Hrsq q Hqq),
          (ratMulInv_annih s), (ratMul_1_l q); [|auto..]...
      * destruct Hq as [s [Hsq [t [Htq [[Hs Ht] [[Hnns Hnnt] Hqeq]]]]]].
        destruct Hnns; revgoals; subst.
        rewrite (ratMul_0_l t), ratAdd_0_l... apply BUnionI1...
        assert (Hs': s ∈ ℚ'). {
          apply nzRatI0... apply rat_neq_0...
        }
        assert (Hrsq: s⁻¹ ∈ ℚ). {
          apply nzRatE1. apply ratMulInv_ran...
        }
        assert (Hrdsq: r/s ∈ ℚ) by (apply ratMul_ran; auto).
        assert (Hrs0: r/s <𝐪 Rat 0). {
          rewrite ratMul_comm... apply ratMul_neg_prd...
          apply ratPos_mulInv... apply SepE2 in Hr...
        }
        assert (Hnnsum: ratNonNeg (t + r/s)). {
          unfold ratNonNeg.
          rewrite <- (ratMul_1_r t), <- (ratMulInv_annih s),
            <- (ratMul_assoc t Htq s Hsq s⁻¹ Hrsq),
            (ratMul_comm t Htq s Hsq),
            <- ratMul_distr', <- (ratMul_0_l s⁻¹); [|auto..].
          apply ratMul_preserve_le; nauto. apply ratPos_mulInv...
        }
        replace (s ⋅ t + r) with (s ⋅ (t + r/s)).
        apply realNonNegMulI1... apply realAddI2...
        eapply realE2; revgoals; [eauto|nauto..].
        apply realPos_rat0... left...
        rewrite ratMul_distr, (ratMul_comm r Hrq s⁻¹ Hrsq),
          <- (ratMul_assoc s Hsq s⁻¹ Hrsq r Hrq),
          (ratMulInv_annih s), (ratMul_1_l r); [|auto..]...
      * destruct Hq as [s [Hsq [t [Htq [[Hs Ht] [[Hnns Hnnt] Hqeq]]]]]].
        destruct Hr as [u [Huq [v [Hvq [[Hu Hv] [[Hnnu Hnnv] Hreq]]]]]].
        destruct Hnns as [Hps|]; revgoals; subst. {
          rewrite (ratMul_0_l t), ratAdd_0_l; [|auto..].
          apply realNonNegMulI1... rewrite <- (ratAdd_0_l v)...
          apply realAddI2... apply realPos_rat0...
        }
        destruct Hnnt as [Hpt|]; revgoals; subst. {
          rewrite (ratMul_0_r_r s), ratAdd_0_l; [|auto..].
          apply realNonNegMulI1... rewrite <- (ratAdd_0_l v)...
          apply realAddI2...
        }
        destruct Hnnu as [Hpu|]; revgoals; subst. {
          rewrite (ratMul_0_l v), ratAdd_0_r; [|auto..].
          apply realNonNegMulI1... rewrite <- (ratAdd_0_r t)...
          apply realAddI2... apply realPos_rat0... left... left...
        }
        destruct Hnnv as [Hpv|]; revgoals; subst. {
          rewrite (ratMul_0_r_r u), ratAdd_0_r; [|auto..].
          apply realNonNegMulI1... rewrite <- (ratAdd_0_r t)...
          apply realAddI2... left... left...
        }
        destruct (classic (s = u)). {
          subst. rewrite <- ratMul_distr...
          apply realNonNegMulI1... apply realAddI2... left...
          apply ratAdd_nonNeg_sum... left... left...
        }
        apply ratLt_connected in H as [Hsu|Hus]... {
          assert (Hu': u ∈ ℚ'). {
            apply nzRatI0... apply rat_neq_0...
          }
          assert (Hruq: u⁻¹ ∈ ℚ). {
            apply nzRatE1. apply ratMulInv_ran...
          }
          assert (Hpru: ratPos u⁻¹) by (apply ratPos_mulInv; auto).
          assert (Hsuq: s/u ∈ ℚ) by (apply ratMul_ran; auto).
          assert (Hsu1: s/u <𝐪 Rat 1). {
            rewrite <- (ratMulInv_annih u)...
            apply ratMul_preserve_lt...
          }
          assert (Hlt: (s/u) ⋅ t <𝐪 t). {
            rewrite <- (ratMul_1_l t) at 2...
            apply ratMul_preserve_lt...
          }
          assert (Hsutq: (s/u) ⋅ t ∈ ℚ) by (apply ratMul_ran; auto).
          assert (Hnnsum: ratNonNeg ((s/u) ⋅ t + v)). {
            left. apply ratAdd_pos_sum...
            apply ratMul_pos_prd... apply ratMul_pos_prd...
          }
          replace (s⋅t + u⋅v) with (u⋅((s/u)⋅t + v)).
          apply realNonNegMulI1... apply realAddI2...
          eapply realE2; revgoals; [eauto|nauto..]. left...
          rewrite ratMul_distr,
            <- (ratMul_assoc u Huq (s/u) Hsuq t Htq),
            (ratMul_comm s Hsq u⁻¹ Hruq),
            <- (ratMul_assoc u Huq u⁻¹ Hruq s Hsq),
            (ratMulInv_annih u), (ratMul_1_l s);
            try apply ratMul_ran...
        } {
          assert (Hs': s ∈ ℚ'). {
            apply nzRatI0... apply rat_neq_0...
          }
          assert (Hrsq: s⁻¹ ∈ ℚ). {
            apply nzRatE1. apply ratMulInv_ran...
          }
          assert (Hprs: ratPos s⁻¹) by (apply ratPos_mulInv; auto).
          assert (Husq: u/s ∈ ℚ) by (apply ratMul_ran; auto).
          assert (Hus1: u/s <𝐪 Rat 1). {
            rewrite <- (ratMulInv_annih s)...
            apply ratMul_preserve_lt...
          }
          assert (Hlt: (u/s) ⋅ v <𝐪 v). {
            rewrite <- (ratMul_1_l v) at 2...
            apply ratMul_preserve_lt...
          }
          assert (Hustq: (u/s) ⋅ v ∈ ℚ) by (apply ratMul_ran; auto).
          assert (Hnnsum: ratNonNeg (t + (u/s) ⋅ v)). {
            left. apply ratAdd_pos_sum...
            apply ratMul_pos_prd... apply ratMul_pos_prd...
          }
          replace (s⋅t + u⋅v) with (s⋅(t + (u/s)⋅v)).
          apply realNonNegMulI1... apply realAddI2...
          eapply realE2; revgoals; [eauto|nauto..]. left...
          rewrite ratMul_distr,
            <- (ratMul_assoc s Hsq (u/s) Husq v Hvq),
            (ratMul_comm u Huq s⁻¹ Hrsq),
            <- (ratMul_assoc s Hsq s⁻¹ Hrsq u Huq),
            (ratMulInv_annih s), (ratMul_1_l u);
            try apply ratMul_ran...
        }
Qed.

Close Scope Rat_scope.
Open Scope Real_scope.

Lemma realNonNegMul_distr' : ∀ x y z ∈ ℝ,
  realNonNeg x → realNonNeg y → realNonNeg z → realNonNeg (y - z) →
  x ⋅₊ (y - z) = x ⋅₊ y - x ⋅₊ z.
Proof with neauto.
  intros x Hx y Hy z Hz Hnnx Hnny Hnnz Hd.
  assert (Hnzr: -z ∈ ℝ) by (apply realAddInv_ran; auto).
  assert (Hxzr: x ⋅₊ z ∈ ℝ) by (apply realNonNegMul_ran; auto).
  assert (Hxyr: x ⋅₊ y ∈ ℝ) by (apply realNonNegMul_ran; auto).
  assert (Hnxzr: -(x ⋅₊ z) ∈ ℝ) by (apply realAddInv_ran; auto).
  assert (Hdr: y - z ∈ ℝ) by (apply realAdd_ran; auto).
  assert (Hxdr: x ⋅₊ (y - z) ∈ ℝ) by (apply realNonNegMul_ran; auto).
  assert (Hdistr: x ⋅₊ y - x ⋅₊ z ∈ ℝ) by (apply realAdd_ran; auto).
  apply (realAdd_cancel _ Hxdr _ Hdistr _ Hxzr).
  rewrite <- realNonNegMul_distr,
    realAdd_assoc, (realAdd_comm (-z)),
    realAddInv_annih, realAdd_0_r,
    realAdd_assoc, (realAdd_comm (-(x ⋅₊ z))),
    realAddInv_annih, realAdd_0_r...
Qed.

Close Scope Real_scope.
Open Scope Rat_scope.

Lemma realNonNegMul_1_r : ∀x ∈ ℝ,
  realNonNeg x → (x ⋅₊ Real 1)%r  = x.
Proof with neauto.
  intros x Hx Hnnx.
  ext p Hp.
  - apply realNonNegMulE in Hp as []...
    + destruct Hnnx as [Hpx|]; [|subst; auto].
      apply SepE in H as [Hpq Hlt].
      eapply realE2; revgoals... apply realPos_rat0...
    + destruct H as [q [Hqq [r [Hrq [[Hq Hr] [[Hnnq Hnnr] Heq]]]]]].
      destruct Hnnq as [Hpq|Hq0]; revgoals; subst.
      rewrite ratMul_0_l... eapply realE2; revgoals...
      rewrite <- (ratMul_1_r q) at 2... apply ratMul_preserve_lt'...
      apply SepE2 in Hr... apply ratMul_ran...
  - destruct (classic (ratNeg p)). apply realNonNegMulI0...
    assert (Hpq: p ∈ ℚ) by (eapply real_sub_rat; eauto).
    apply ratNonNeg_not_neg in H...
    apply realE3 in Hp as [q [Hqq [Hq Hlt]]]...
    assert (Hpoq: ratPos q). {
      destruct H. eapply ratLt_trans... subst...
    }
    assert (Hprq: ratPos q⁻¹)
      by (apply ratPos_mulInv; auto).
    assert (Hqq': q ∈ ℚ'). {
      apply nzRatI0... apply rat_neq_0...
    }
    assert (Hrqq: q⁻¹ ∈ ℚ). {
      apply nzRatE1. apply ratMulInv_ran...
    }
    replace p with (q ⋅ (p/q)).
    apply realNonNegMulI1... apply SepI.
    apply ratMul_ran... rewrite <- (ratMulInv_annih q)...
    apply ratMul_preserve_lt... left...
    apply ratMul_nonNeg_prd... left...
    rewrite (ratMul_comm p), <- ratMul_assoc,
      ratMulInv_annih, ratMul_1_l...
Qed.

Lemma realNonNegMul_1_l : ∀x ∈ ℝ,
  realNonNeg x → (Real 1 ⋅₊ x)%r  = x.
Proof with nauto.
  intros x Hx Hnnx.
  rewrite realNonNegMul_comm, realNonNegMul_1_r...
  left. apply realPos_sn.
Qed.

Close Scope Rat_scope.
Open Scope Real_scope.

(* 正实数乘法逆元 *)
Definition RealPosMulInv : set → set := λ x,
  {r ∊ ℚ | ∃s ∈ ℚ, s ∉ x ∧ (r ⋅ s)%q <𝐪 Rat 1}.
Notation "x ⁻¹⁺" := (RealPosMulInv x) (at level 9) : Real_scope.

Lemma realPosMulInv_sub_rat : ∀x ∈ ℝ, x⁻¹⁺ ∈ 𝒫 ℚ.
Proof with auto.
  intros x Hx. apply PowerAx. intros q Hq.
  unfold RealPosMulInv in Hq. apply SepE1 in Hq...
Qed.

Close Scope Real_scope.
Open Scope Rat_scope.

Lemma ratLt_mulInv': ∀ q r ∈ ℚ, ratPos r → q <𝐪 r⁻¹ ↔ q ⋅ r <𝐪 Rat 1.
Proof with auto.
  intros q Hq r Hr Hpr.
  assert (Hr': r ∈ ℚ'). { apply nzRatI0... apply rat_neq_0... }
  assert (Hrr: r⁻¹ ∈ ℚ). { apply nzRatE1. apply ratMulInv_ran... }
  split; intros.
  - rewrite <- (ratMulInv_annih r), ratMul_comm...
    apply ratMul_preserve_lt'...
  - rewrite <- (ratMulInv_annih r), ratMul_comm in H...
    apply ratMul_preserve_lt' in H...
Qed.

Lemma realPosMulInv_ran : ∀x ∈ ℝ, realPos x → (x⁻¹⁺)%r ∈ ℝ.
Proof with neauto.
  intros x Hx Hpx. apply SepI.
  apply realPosMulInv_sub_rat...
  apply realPos_rat0 in Hpx... repeat split...
  - destruct (classic (x ≤ Real 1)%r).
    + apply realLe in H as Hsub...
      pose proof (realE3 _ Hx _ Hpx) as [q [Hqq [Hqx H0q]]].
      pose proof (realE3 _ Hx _ Hqx) as [r [Hrq [Hrx Hqr]]].
      apply Hsub in Hqx as Hq1. apply SepE in Hq1 as [_ Hq1].
      apply Hsub in Hrx as Hr1. apply SepE in Hr1 as [_ Hr1].
      assert (Hpr: ratPos r) by (eapply ratLt_trans; eauto).
      apply ratLt_mulInv in Hr1... rewrite ratMulInv_1 in Hr1.
      assert (Hr': r ∈ ℚ'). { apply nzRatI0... apply rat_neq_0... }
      assert (Hrr: r⁻¹ ∈ ℚ). { apply nzRatE1. apply ratMulInv_ran... }
      assert (H1x: Rat 1 ∉ x) by (apply realLt_realn'; auto).
      assert (Hrrx: r⁻¹ ∉ x) by (apply (realE2_2 _ Hx (Rat 1)); nauto).
      apply EmptyNI. exists q. apply SepI... exists (r⁻¹).
      repeat split... rewrite <- (ratMulInv_annih r)...
      apply ratMul_preserve_lt... apply ratPos_mulInv...
    + apply not_or_and in H as [].
      apply realLt_connected in H0 as []...
      apply realLt_realn in H0 as H1x...
      pose proof (realE1 _ Hx) as [q [Hqq Hqx]].
      pose proof (rat_archimedean _ Hqq) as [r [Hrq Hqr]].
      assert (H1q: Rat 1 <𝐪 q) by (eapply realE2_1; neauto).
      assert (H1r: Rat 1 <𝐪 r) by (eapply ratLt_trans; eauto).
      assert (Hpr: ratPos r). {
        eapply ratLt_trans; revgoals. apply H1r. apply ratPos_sn.
      }
      assert (Hr': r ∈ ℚ'). { apply nzRatI0... apply rat_neq_0... }
      assert (Hrr: r⁻¹ ∈ ℚ). { apply nzRatE1. apply ratMulInv_ran... }
      apply ratLt_mulInv in H1r as Hr1... rewrite ratMulInv_1 in Hr1.
      apply EmptyNI. exists (r⁻¹). apply SepI... exists q.
      repeat split... rewrite <- (ratMulInv_annih r), ratMul_comm...
      apply ratMul_preserve_lt... apply ratPos_mulInv...
  - pose proof (realE3 _ Hx _ Hpx) as [q [Hqq [Hqx H0q]]].
    assert (Hq': q ∈ ℚ'). { apply nzRatI0... apply rat_neq_0... }
    assert (Hrq: q⁻¹ ∈ ℚ). { apply nzRatE1. apply ratMulInv_ran... }
    apply ExtNI. exists (q⁻¹). split... intros Hrqrx.
    apply SepE in Hrqrx as [_ [s [Hsq [Hsx Hlt]]]].
    rewrite <- (ratMulInv_annih q), ratMul_comm in Hlt...
    apply ratMul_preserve_lt in Hlt; auto; [|apply ratPos_mulInv]...
    apply Hsx. eapply realE2; revgoals...
  - intros p Hpq q Hqq Hp Hlt.
    apply SepE in Hp as [_ [r [Hrq [Hrx Hr1]]]].
    assert (Hpr: ratPos r) by (eapply realE2_1; neauto).
    apply SepI... exists r. repeat split...
    apply ratLt_mulInv' in Hr1...
    apply ratLt_mulInv'... eapply ratLt_trans...
  - intros p Hp. apply SepE in Hp as [Hpq [r [Hrq [Hrx Hpr1]]]].
    assert (Hpr: ratPos r) by (eapply realE2_1; neauto).
    assert (Hr': r ∈ ℚ'). { apply nzRatI0... apply rat_neq_0... }
    assert (Hrr: r⁻¹ ∈ ℚ). { apply nzRatE1. apply ratMulInv_ran... }
    destruct (classic (ratNonPos p)) as [Hnpp|Hpp].
    + apply ratPos_mulInv in Hpr as Hprr.
      apply rat_dense in Hprr as [q [Hqq [Hq1 Hq2]]]...
      exists q. split. apply SepI... exists r. repeat split...
      apply ratLt_mulInv'... destruct Hnpp.
      eapply ratLt_trans... subst...
    + apply ratPos_not_nonPos in Hpp...
      destruct (classic (p <𝐪 Rat 1)) as [Hp1|H1p];
      destruct (classic (r <𝐪 Rat 1)) as [Hr1|H1r].
      * exists (Rat 1). split... apply SepI...
        exists r. repeat split... rewrite ratMul_1_l...
      * apply ratLt_mulInv' in Hpr1...
        apply rat_dense in Hpr1 as [q [Hqq [Hq1 Hq2]]]...
        exists q. split... apply SepI... exists r. repeat split...
        destruct (classic (r = Rat 1)).
        subst. rewrite ratMulInv_1 in Hq2. rewrite ratMul_1_r...
        apply ratLt_connected in H as []...
        exfalso... apply ratLt_mulInv'...
      * apply ratLt_mulInv' in Hpr1...
        apply rat_dense in Hpr1 as [q [Hqq [Hq1 Hq2]]]...
        exists q. split... apply SepI... exists r. repeat split...
        apply ratLt_mulInv'...
      * exfalso. apply H1p. destruct (classic (r = Rat 1)).
        subst. rewrite ratMul_1_r in Hpr1...
        apply ratLt_connected in H as []... exfalso...
        apply ratLt_mulInv in H... rewrite ratMulInv_1 in H.
        apply ratLt_mulInv' in Hpr1... eapply ratLt_trans...
Qed.

Lemma ex5_19' : ∀x ∈ ℝ, ∀p ∈ ℚ, realPos x → Rat 1 <𝐪 p →
  ∃q ∈ ℚ, ratPos q ∧ q ∈ x ∧ p ⋅ q ∉ x.
Proof with nauto.
  intros x Hx p Hp Hpx H1p. apply realPos_rat0 in Hpx...
  pose proof (realE3 _ Hx _ Hpx) as [r [Hr [Hrx Hpr]]].
  set (p - Rat 1) as p'.
  set (p' ⋅ r / Rat 3) as s.
  assert (Hp': p' ∈ ℚ) by (apply ratAdd_ran; nauto).
  assert (Hs: s ∈ ℚ). {
    apply ratMul_ran. apply ratMul_ran... nauto.
  }
  assert (Hpp': ratPos p'). {
    unfold ratPos. rewrite <- (ratAddInv_annih (Rat 1))...
    apply ratAdd_preserve_lt...
  }
  assert (Hps: ratPos s). {
    apply ratMul_pos_prd. apply ratMul_ran... nauto.
    apply ratMul_pos_prd... nauto.
  }
  pose proof (ex5_19 _ Hx _ Hs Hps) as [t [Ht [Htx Hleft]]].
  destruct (classic (r / Rat 3 <𝐪 t)).
  - assert (Hnt: -t ∈ ℚ) by (apply ratAddInv_ran; auto).
    assert (Hst: s + t ∈ ℚ) by (apply ratAdd_ran; auto).
    assert (Hpt: p ⋅ t ∈ ℚ) by (apply ratMul_ran; auto).
    cut (s + t <𝐪 p ⋅ t). intros Hlt.
    * exists t. repeat split; [auto| |auto|].
      eapply ratLt_trans; revgoals; [eauto|apply ratMul_pos_prd]...
      eapply realE2_2; revgoals; [apply Hlt|..]; assumption.
    * eapply ratAdd_preserve_lt; swap 1 3; [apply Hnt|auto..|].
      rewrite ratAdd_assoc, ratAddInv_annih, ratAdd_0_r; [|auto..].
      rewrite <- (ratMul_1_l t) at 2; [|auto..].
      rewrite <- ratMul_addInv_l, <- ratMul_distr'; [|nauto..].
      unfold s. rewrite ratMul_assoc; [|nauto..]. subst p'.
      apply ratMul_preserve_lt'; [apply ratMul_ran|..]...
  - exists (r / Rat 2). repeat split.
    + apply ratMul_ran... + apply ratMul_pos_prd...
    + cut (r / Rat 2 <𝐪 r). intros Hlt.
      * eapply realE2; swap 1 5; [apply Hlt| |auto..].
        apply ratMul_ran...
      * rewrite ratMul_comm... rewrite <- (ratMul_1_l r) at 2.
        apply ratMul_preserve_lt... apply ratLt_r2_1. auto.
    + cut (s + t <𝐪 p ⋅ (r / Rat 2)). intros Hlt.
      * eapply realE2_2; swap 1 5; [apply Hlt|..|auto|auto].
        apply ratAdd_ran... apply ratMul_ran; [auto|apply ratMul_ran]...
      * assert (H1: r / Rat 3 ∈ ℚ) by (apply ratMul_ran; nauto).
        assert (H2: -(r / Rat 3) ∈ ℚ) by (apply ratAddInv_ran; nauto).
        assert (H3: p ⋅ r ∈ ℚ) by (apply ratMul_ran; auto).
        assert (H4: p ⋅ r / Rat 3 ∈ ℚ) by (apply ratMul_ran; nauto).
        assert (H5: - Rat 1 ∈ ℚ) by nauto.
        assert (H6: - Rat 1 + p ∈ ℚ) by (apply ratAdd_ran; auto).
        rewrite ratAdd_comm; [|auto..]. unfold s, p'.
        rewrite (ratAdd_comm p Hp (-Rat 1)),
          (ratMul_assoc (-Rat 1 + p) H6 r Hr (Rat 3)⁻¹),
          (ratMul_distr' (r / Rat 3) H1 (-Rat 1) H5 p Hp),
          <- (ratMul_assoc (-Rat 1) H5 r Hr (Rat 3)⁻¹),
          <- (ratMul_assoc p Hp r Hr (Rat 3)⁻¹),
          <- (ratMul_assoc p Hp r Hr (Rat 2)⁻¹),
          (ratMul_addInv_l (Rat 1) (rat_n 1) r), (ratMul_1_l r),
          (ratMul_addInv_l r Hr (Rat 3)⁻¹),
          <- (ratAdd_assoc t Ht (-(r/Rat 3)) H2 (p⋅r/Rat 3));
          clear H5 H6; [|nauto..].
        replace (p⋅r/Rat 2) with (p⋅r / Rat 6 + p⋅r / Rat 3). {
          apply ratAdd_preserve_lt. apply ratAdd_ran...
          repeat apply ratMul_ran... repeat apply ratMul_ran...
          cut (ratPos (p⋅r / Rat 6)). intros Hp6.
          - destruct (classic (t = r / Rat 3)).
            + subst. rewrite ratAddInv_annih; assumption.
            + eapply ratLt_trans; revgoals. apply Hp6.
              apply ratLt_connected in H0 as []; [|exfalso|auto..]...
              rewrite <- (ratAddInv_annih (r/Rat 3)); [|auto].
              apply ratAdd_preserve_lt...
          - apply ratMul_pos_prd; [auto|nauto|..|nauto].
            apply ratMul_pos_prd... eapply ratLt_trans.
            apply ratPos_sn. apply H1p.
        } {
          rewrite <- ratMul_distr...
          cut ((Rat 6)⁻¹ + (Rat 3)⁻¹ = (Rat 2)⁻¹). congruence.
          apply ratAdd_r6_r3_r2.
        }
Qed.

Theorem realPosMulInv_annih : ∀x ∈ ℝ,
  realPos x → (x ⋅₊ x⁻¹⁺)%r = Real 1.
Proof with neauto.
  intros x Hx Hposx.
  assert (Hx': (x⁻¹⁺)%r ∈ ℝ) by (apply realPosMulInv_ran; auto).
  ext p Hp.
  - apply realNonNegMulE in Hp as [Hp0|Hp]...
    + apply SepE in Hp0 as [Hpq Hp0]. apply SepI...
      eapply ratLt_trans... apply ratPos_sn.
    + destruct Hp as [q [Hqq [r [Hrq [[Hq Hr] [[Hnnq Hnnr] Heq]]]]]].
      subst p. apply SepI. apply ratMul_ran...
      destruct Hnnq; destruct Hnnr; revgoals; subst.
      * rewrite ratMul_0_l... apply ratPos_sn.
      * rewrite ratMul_0_l... apply ratPos_sn.
      * rewrite ratMul_0_r_r... apply ratPos_sn.
      * apply SepE in Hr as [_ [s [Hsq [Hsx Hlt]]]].
        assert (Hqs: q <𝐪 s) by (eapply realE2_1; revgoals; eauto).
        assert (Hps: ratPos s) by (eapply ratLt_trans; revgoals; eauto).
        rewrite ratMul_comm in Hlt... apply ratLt_mulInv' in Hlt...
        apply ratLt_mulInv'... eapply ratLt_trans...
  - apply SepE in Hp as [Hpq Hp1].
    destruct (classic (p = Rat 0)). {
      apply realPos_rat0 in Hposx...
      subst p. rewrite <- (ratMul_0_l (Rat 0))...
      apply realNonNegMulI1; auto; [|right..]...
      pose proof (realE1 _ Hx) as [q [Hqq Hqx]].
      apply SepI... exists q. repeat split... rewrite ratMul_0_l...
    }
    apply ratLt_connected in H as [Hnp|Hpp]... {
      eapply realNonNegMulI0...
    }
    assert (Hpq': p ∈ ℚ'). { apply nzRatI0... apply rat_neq_0... }
    assert (Hrpq: p⁻¹ ∈ ℚ). { apply nzRatE1. apply ratMulInv_ran... }
    assert (Hprp: ratPos p⁻¹) by (apply ratPos_mulInv; auto).
    apply ratLt_mulInv in Hp1... rewrite ratMulInv_1 in Hp1.
    pose proof (ex5_19' _ Hx _ Hrpq Hposx Hp1) as [q [Hqq [Hposq [Hqx Hs]]]].
    pose proof (realE3 _ Hx _ Hqx) as [r [Hrq [Hrx Hqr]]].
    assert (Hposr: ratPos r) by (eapply ratLt_trans; eauto).
    assert (Hrq': r ∈ ℚ'). { apply nzRatI0... apply rat_neq_0... }
    assert (Hrrq: r⁻¹ ∈ ℚ). { apply nzRatE1. apply ratMulInv_ran... }
    assert (Hsq: q / p ∈ ℚ) by (apply ratMul_ran; auto).
    assert (Htq: p / r ∈ ℚ) by (apply ratMul_ran; auto).
    assert (Hpt: ratPos (p / r)). {
      apply ratMul_pos_prd... apply ratPos_mulInv...
    }
    rewrite <- (ratMul_1_l p), <- (ratMulInv_annih r),
      ratMul_assoc, (ratMul_comm (r⁻¹))...
    apply realNonNegMulI1; auto; revgoals; [left|left|]...
    apply SepI. apply ratMul_ran... exists (q / p). repeat split...
    rewrite ratMul_comm... rewrite (ratMul_comm (p / r))...
    apply ratLt_mulInv'... rewrite ratMulInv_quot...
    apply ratMul_preserve_lt...
Qed.

Lemma realPos_posMulInv : ∀x ∈ ℝ, realPos x → realPos (x⁻¹⁺)%r.
Proof with neauto.
  intros x Hx Hpx. apply realPos_rat0 in Hpx as H0x...
  apply binRelI... apply realPosMulInv_ran...
  pose proof (realE1 _ Hx) as [q [Hqq Hqx]].
  assert (Hposq: ratPos q) by (eapply realE2_1; neauto). split.
  - intros p Hp. apply SepE in Hp as [Hpq Hnp].
    apply SepI... exists q. repeat split... eapply ratLt_trans.
    rewrite ratMul_comm... apply ratMul_neg_prd... apply ratPos_sn.
  - pose proof (rat_archimedean _ Hqq) as [r [Hrq Hqr]].
    assert (Hposr: ratPos r) by (eapply ratLt_trans; eauto).
    assert (Hr': r ∈ ℚ'). { apply nzRatI0... apply rat_neq_0... }
    assert (Hrr: r⁻¹ ∈ ℚ). { apply nzRatE1. apply ratMulInv_ran... }
    assert (Hposrr: ratPos r⁻¹) by (apply ratPos_mulInv; auto).
    cut (r⁻¹ ∈ (x⁻¹⁺)%r). intros Hrqrx.
    intros H. rewrite <- H in Hrqrx.
    apply SepE in Hrqrx as [_ Hnrr].
    eapply ratLt_irrefl. eapply ratLt_trans...
    apply SepI... exists q. repeat split... rewrite ratMul_comm...
    apply ratLt_mulInv'... rewrite ratMulInv_double...
Qed.

Close Scope Rat_scope.
Open Scope Real_scope.

Lemma realPosMulInv_double : ∀x ∈ ℝ, realPos x → x⁻¹⁺⁻¹⁺ = x.
Proof with auto.
  intros x Hx Hpx.
  assert (Hr: x⁻¹⁺ ∈ ℝ) by (apply realPosMulInv_ran; auto).
  assert (Hpr: realPos x⁻¹⁺) by (apply realPos_posMulInv; auto).
  assert (Hrr: x⁻¹⁺⁻¹⁺ ∈ ℝ) by (apply realPosMulInv_ran; auto).
  assert (Hprr: realPos x⁻¹⁺⁻¹⁺) by (apply realPos_posMulInv; auto).
  rewrite <- (realNonNegMul_1_r (x⁻¹⁺⁻¹⁺)), <- (realPosMulInv_annih x),
    realNonNegMul_comm, realNonNegMul_assoc, realPosMulInv_annih,
    realNonNegMul_1_r; try left...
  apply realNonNegMul_ran; try left...
  apply realNonNegMul_pos_prd...
Qed.


Require Import Lia.
Require Import ZArith.
Require Import PLF.LibTactics.
Require Import CoqTactical.SimplMatch.
Require Import CoqRefinements.Tactics.
Require Import CoqRefinements.Types.
Require Import Program.Utils. (* for 'dec' *)

Open Scope Z_scope.

(* Refined Int Functions *)
Definition add {P Q} (m:Int P)  (n:Int Q) :=
exist _ (` m + ` n) eq_refl
: Int (fun v => v = ` m + ` n).

Definition sub {P Q} (m:Int P) (n:Int Q) :=
  exist _ (` m - ` n) eq_refl
: Int (fun v => v = ` m - ` n).

Definition mul {P Q} (m:Int P) (n:Int Q) :=
  exist _ (` m * ` n) eq_refl
:Int (fun v => v = ` m * ` n).

Definition eq_p {P Q} (m:Int P) (n:Int Q) :=
  (Z.eqb (` m) (` n)):bool.

Definition neq_p {P Q} (m:Int P) (n:Int Q) :=
  negb (Z.eqb (` m) (` n)):bool.

Definition leq_p {P Q} (m:Int P) (n:Int Q) :=
 Z.leb (` m) (` n).

Definition geq_p {P Q} (m:Int P) (n:Int Q) :=
 Z.geb (` m) (` n).

Definition lt_p {P Q} (m:Int P) (n:Int Q) :=
 Z.ltb (` m) (` n).

Definition gt_p {P Q} (m:Int P) (n:Int Q) :=
Z.gtb (` m) (` n).

Definition eq {P Q} (m:Int P) (n:Int Q) :=
  exist _ (eq_p m n) eq_refl
:@Bool ( eq_p m n).

Check Z.eqb.

Definition neq {P Q} (m:Int P) (n:Int Q) :=
  exist _ (neq_p m n) eq_refl
:@Bool (neq_p m n).

Definition leq {P Q} (m:Int P) (n:Int Q) :=
  exist _ (leq_p m n) eq_refl
:@Bool ( leq_p m n).

Definition geq {P Q} (m:Int P) (n:Int Q) :=
exist _ (geq_p m n) eq_refl
:@Bool ( geq_p m n).

Definition lt {P Q} (m:Int P) (n:Int Q) :=
  exist _ (lt_p m n) eq_refl
:@Bool ( lt_p m n).

Definition gt {P Q} (m:Int P) (n:Int Q) :=
  exist _ (gt_p m n) eq_refl
:@Bool ( gt_p m n).

(* TESTS *)
Definition ge5_ge0 (n:{v:Z| v>=5}) : {v:Z| v>=0}. upcast n. Defined.

Definition add_nats_nat (m n:Nat):Nat.
infer (add m n).
Defined.

Notation refl := (fun v => v = v).

Notation rInt := (Int refl).
Definition max (x y: rInt) :=
  match dec(` x >? ` y) with
  | left e => ltac:(infer x)
  | right e => ltac: (infer y)
  end  : {v:Z | v>= ` x /\ v >= ` y}.

Definition abs (x:rInt) :=
  match dec (` x >=? 0) with
  | left e => ltac:(infer x)
  | right e => ltac:(infer (sub (triv 0) x))
  end
: {v:Z | v>= 0 /\  v >= (` x) }.
Require Import ssreflect.

Definition sub_5_4_nat: {v:Z | v<>0}. upcast (sub (triv 5) (triv 4)). Defined.

Definition mul_nats_nat (m n:Nat):Nat.
infer (mul m n).
Defined.

Definition gem1_ltm1_nat (m:{v:Z| v>= -1}) (H: ` m > -1): Nat. exists (`m). lia. Defined.


Require Export TopologicalSpaces.
Require Export Nets.
Require Export FilterLimits.
Require Export Continuity.

Definition compact (X:TopologicalSpace) :=
  forall C:Family (point_set X),
    (forall U:Ensemble (point_set X), In C U -> open U) ->
    FamilyUnion C = Full_set ->
    exists C':Family (point_set X),
      Finite _ C' /\ Included C' C /\
      FamilyUnion C' = Full_set.

Lemma compactness_on_indexed_covers:
  forall (X:TopologicalSpace) (A:Type) (C:IndexedFamily A (point_set X)),
    compact X ->
    (forall a:A, open (C a)) -> IndexedUnion C = Full_set ->
  exists A':Ensemble A, Finite _ A' /\
    IndexedUnion (fun a':{a':A | In A' a'} => C (proj1_sig a')) = Full_set.
Proof.
intros.
pose (cover := ImageFamily C).
destruct (H cover) as [subcover].
intros.
destruct H2.
rewrite H3; apply H0.
unfold cover; rewrite <- indexed_to_family_union; trivial.
destruct H2 as [? []].
destruct (finite_choice _ _
  (fun (U:{U:Ensemble (point_set X) | In subcover U}) (a:A) =>
      proj1_sig U = C a)) as [choice_fun].
apply Finite_ens_type; trivial.
destruct x as [U].
simpl.
apply H3 in i.
destruct i.
exists x; trivial.

exists (Im Full_set choice_fun).
split.
apply FiniteT_img.
apply Finite_ens_type; trivial.
intros; apply classic.
apply Extensionality_Ensembles; split; red; intros.
constructor.
rewrite <- H4 in H6.
destruct H6.
assert (In (Im Full_set choice_fun) (choice_fun (exist _ S H6))).
exists (exist _ S H6).
constructor.
trivial.
exists (exist _ (choice_fun (exist _ S H6)) H8).
simpl.
rewrite <- H5.
simpl.
trivial.
Qed.

Lemma compact_finite_nonempty_closed_intersection:
  forall X:TopologicalSpace, compact X ->
  forall F:Family (point_set X),
    (forall G:Ensemble (point_set X), In F G -> closed G) ->
    (forall F':Family (point_set X), Finite _ F' -> Included F' F ->
     Inhabited (FamilyIntersection F')) ->
    Inhabited (FamilyIntersection F).
Proof.
intros.
apply NNPP; red; intro.
pose (C := [ U:Ensemble (point_set X) | In F (Complement U) ]).
refine (let H3:=(H C _ _) in _).
intros.
destruct H3.
apply H0 in H3.
apply closed_complement_open; trivial.
apply Extensionality_Ensembles; split; red; intros.
constructor.
apply NNPP; red; intro.
contradiction H2.
exists x.
constructor.
intros.
apply NNPP; red; intro.
contradiction H4.
exists (Complement S).
constructor.
rewrite Complement_Complement; trivial.
exact H6.

destruct H3 as [C' [? [? ?]]].
pose (F' := [G : Ensemble (point_set X) | In C' (Complement G)]).
refine (let H6 := (H1 F' _ _) in _).
assert (F' = Im C' Complement).
apply Extensionality_Ensembles; split; red; intros.
destruct H6.
exists (Complement x); trivial.
symmetry; apply Complement_Complement.
destruct H6.
constructor.
rewrite H7; rewrite Complement_Complement; trivial.
rewrite H6; apply finite_image.
assumption.

red; intros.
destruct H6.
apply H4 in H6.
destruct H6.
rewrite Complement_Complement in H6; trivial.

destruct H6 as [x0].
destruct H6.
assert (In (FamilyUnion C') x).
rewrite H5; constructor.
destruct H7.
assert (In (Complement S) x).
apply H6.
constructor.
rewrite Complement_Complement; trivial.
contradiction H9.
Qed.

Lemma finite_nonempty_closed_intersection_impl_compact:
  forall X:TopologicalSpace,
  (forall F:Family (point_set X),
    (forall G:Ensemble (point_set X), In F G -> closed G) ->
    (forall F':Family (point_set X), Finite _ F' -> Included F' F ->
     Inhabited (FamilyIntersection F')) ->
    Inhabited (FamilyIntersection F)) ->
  compact X.
Proof.
intros.
red; intros.
apply NNPP; red; intro.
pose (F := [ G:Ensemble (point_set X) | In C (Complement G) ]).
refine (let H3 := (H F _ _) in _).
intros.
destruct H3.
apply H0; trivial.
intros.
apply NNPP; red; intro.
contradiction H2.
exists [ U:Ensemble (point_set X) | In F' (Complement U) ].
repeat split.
assert ([U:Ensemble (point_set X) | In F' (Complement U)] =
  Im F' Complement).
apply Extensionality_Ensembles; split; red; intros.
destruct H6.
exists (Complement x); trivial.
symmetry; apply Complement_Complement.
constructor.
destruct H6.
rewrite H7; rewrite Complement_Complement; trivial.
rewrite H6; apply finite_image; trivial.

red; intros.
destruct H6.
apply H4 in H6.
destruct H6.
rewrite Complement_Complement in H6; trivial.

apply Extensionality_Ensembles; split; red; intros.
constructor.
apply NNPP; red; intro.
contradiction H5.
exists x.
constructor.
intros.
apply NNPP; red; intro.
contradiction H7.
exists (Complement S).
constructor.
rewrite Complement_Complement; trivial.
exact H9.

destruct H3.
assert (In (FamilyUnion C) x).
rewrite H1; constructor.
destruct H4.
assert (In (Complement S) x).
destruct H3.
apply H3.
constructor.
rewrite Complement_Complement; trivial.
contradiction H6.
Qed.

Lemma compact_impl_filter_cluster_point:
  forall X:TopologicalSpace, compact X ->
    forall F:Filter (point_set X), exists x0:point_set X,
    filter_cluster_point F x0.
Proof.
intros.
pose proof (compact_finite_nonempty_closed_intersection
  _ H [ G:Ensemble (point_set X) | In (filter_family F) G /\
                                   closed G ]) as [x0].
intros.
destruct H0 as [[]]; trivial.
intros.
assert (closed (FamilyIntersection F')).
apply closed_family_intersection.
intros.
apply H1 in H2.
destruct H2 as [[]]; trivial.
assert (In (filter_family F) (FamilyIntersection F')).
clear H2.
induction H0.
rewrite empty_family_intersection.
apply filter_full.
replace (FamilyIntersection (Add A x)) with
  (Intersection (FamilyIntersection A) x).
apply filter_intersection.
apply IHFinite.
auto with sets.
assert (In (Add A x) x) by (right; constructor).
apply H1 in H3.
destruct H3 as [[]]; trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H3.
constructor.
intros.
destruct H5.
destruct H3.
apply H3; trivial.
destruct H5; trivial.
destruct H3.
constructor.
constructor; intros.
apply H3.
auto with sets.
apply H3.
auto with sets.
apply NNPP; intro.
contradiction (filter_empty _ F).
replace (@Empty_set (point_set X)) with (FamilyIntersection F'); trivial.
apply Extensionality_Ensembles; split; red; intros.
contradiction H4.
exists x; trivial.
destruct H5.

exists x0.
red; intros.
destruct H0.
apply H0.
constructor.
split.
apply filter_upward_closed with S; trivial.
apply closure_inflationary.
apply closure_closed.
Qed.

Lemma filter_cluster_point_impl_compact:
  forall X:TopologicalSpace,
    (forall F:Filter (point_set X), exists x0:point_set X,
      filter_cluster_point F x0) -> compact X.
Proof.
intros.
apply finite_nonempty_closed_intersection_impl_compact.
intros.
let H:=fresh in
  refine (let H:=_ in let filt := Build_Filter_from_subbasis F H in _).
intros.
rewrite indexed_to_family_intersection.
apply H1.
apply FiniteT_img; trivial.
intros; apply classic.
red; intros.
destruct H4.
rewrite H5; apply H3.
assert (filter_subbasis filt F) by apply filter_from_subbasis_subbasis.
destruct (H filt) as [x0].
exists x0.
constructor; intros.
assert (closed S) by (apply H0; trivial).
assert (In (filter_family filt) S).
apply (filter_subbasis_elements _ _ H3); trivial.
pose proof (H4 _ H7).
rewrite closure_fixes_closed in H8; trivial.
Qed.

Lemma ultrafilter_limit_impl_compact:
  forall X:TopologicalSpace,
    (forall U:Filter (point_set X), ultrafilter U ->
      exists x0:point_set X, filter_limit U x0) -> compact X.
Proof.
intros.
apply filter_cluster_point_impl_compact.
intros.
destruct (ultrafilter_extension F) as [U].
destruct H0.
destruct (H _ H1) as [x0].
exists x0.
red; intros.
apply filter_limit_is_cluster_point in H2.
apply H0 in H3.
apply H2; trivial.
Qed.

Lemma compact_impl_net_cluster_point:
  forall X:TopologicalSpace, compact X ->
    forall (I:DirectedSet) (x:Net I X), inhabited (DS_set I) ->
    exists x0:point_set X, net_cluster_point x x0.
Proof.
Require Import FiltersAndNets.
intros.
destruct (compact_impl_filter_cluster_point
  _ H (tail_filter x H0)) as [x0].
exists x0.
apply tail_filter_cluster_point_impl_net_cluster_point with H0.
apply H1.
Qed.

Lemma net_cluster_point_impl_compact: forall X:TopologicalSpace,
  (forall (I:DirectedSet) (x:Net I X), inhabited (DS_set I) ->
    exists x0:point_set X, net_cluster_point x x0) ->
  compact X.
Proof.
intros.
apply filter_cluster_point_impl_compact.
intros.
destruct (H _ (filter_to_net _ F)) as [x0].
cut (inhabited (point_set X)).
intro.
destruct H0 as [x].
exists.
simpl.
apply Build_filter_to_net_DS_set with Full_set x.
apply filter_full.
constructor.
apply NNPP; intro.
contradiction (filter_empty _ F).
replace (@Empty_set (point_set X)) with (@Full_set (point_set X)).
apply filter_full.
apply Extensionality_Ensembles; split; red; intros.
contradiction H0.
exists; exact x.
destruct H1.

exists x0.
apply filter_to_net_cluster_point_impl_filter_cluster_point.
trivial.
Qed.

Require Export SeparatednessAxioms.
Require Export SubspaceTopology.

Lemma compact_closed: forall (X:TopologicalSpace)
  (S:Ensemble (point_set X)), Hausdorff X ->
  compact (SubspaceTopology S) -> closed S.
Proof.
intros.
destruct (classic (Inhabited S)).
assert (closure S = S).
apply Extensionality_Ensembles; split.
red; intros.
destruct (net_limits_determine_topology _ _ H2) as [I0 [y []]].
pose (yS (i:DS_set I0) := exist (fun x:point_set X => In S x) (y i) (H3 i)).
assert (inhabited (point_set (SubspaceTopology S))).
destruct H1.
exists.
exists x0; trivial.
assert (inhabited (DS_set I0)) as HinhI0.
red in H4.
destruct (H4 Full_set) as [i0]; auto with topology.
constructor.
pose proof (compact_impl_net_cluster_point
  (SubspaceTopology S) H0 _ yS HinhI0).
destruct H6 as [[x0]].
apply net_cluster_point_impl_subnet_converges in H6.
destruct H6 as [J [y' []]].
destruct H6.
assert (net_limit (fun j:DS_set J => y (h j)) x0).
apply continuous_func_preserves_net_limits with
  (f:=subspace_inc S) (Y:=X) in H7.
simpl in H7.
assumption.
apply continuous_func_continuous_everywhere.
apply subspace_inc_continuous.
assert (net_limit (fun j:DS_set J => y (h j)) x).
apply subnet_limit with I0 y; trivial.
constructor; trivial.
assert (x = x0).
exact (Hausdorff_impl_net_limit_unique _ H _ _ H10 H9).
rewrite H11; trivial.
destruct (H4 Full_set).
apply open_full.
constructor.
exists; exact x1.
destruct H1.

apply closure_inflationary.
rewrite <- H2; apply closure_closed.

red.
assert (Complement S = Full_set).
apply Extensionality_Ensembles; split; red; intros.
constructor.
red; intro.
contradiction H1; exists x; trivial.
rewrite H2; apply open_full.
Qed.

Lemma closed_compact: forall (X:TopologicalSpace) (S:Ensemble (point_set X)),
  compact X -> closed S -> compact (SubspaceTopology S).
Proof.
intros.
apply net_cluster_point_impl_compact.
intros.
destruct (compact_impl_net_cluster_point _ H
  _ (fun i:DS_set I => subspace_inc _ (x i))) as [x0].
trivial.
assert (In S x0).
rewrite <- (closure_fixes_closed S); trivial.
apply net_cluster_point_in_closure with
  (2:=H2).
destruct H1 as [i0].
exists i0.
intros.
destruct (x j).
simpl.
trivial.
exists (exist _ x0 H3).
red; intros.
red; intros.
destruct (subspace_topology_topology _ _ _ H4) as [V []].
rewrite H7 in H5.
destruct H5.
simpl in H5.
destruct (H2 V H6 H5 i) as [j []]; trivial.
exists j; split; trivial.
rewrite H7.
constructor.
trivial.
Qed.

Lemma compact_image: forall {X Y:TopologicalSpace}
  (f:point_set X->point_set Y),
  compact X -> continuous f -> surjective f -> compact Y.
Proof.
intros.
red; intros.
pose (B := fun U:{U:Ensemble (point_set Y) | In C U} =>
           inverse_image f (proj1_sig U)).
destruct (compactness_on_indexed_covers _ _ B H) as [subcover].
destruct a as [U].
unfold B; simpl.
apply H0.
apply H2; trivial.
apply Extensionality_Ensembles; split; red; intros.
constructor.
assert (In (FamilyUnion C) (f x)).
rewrite H3; constructor.
inversion_clear H5 as [V].
exists (exist _ V H6).
unfold B; simpl.
constructor; trivial.
destruct H4.

exists (Im subcover (@proj1_sig _ (fun U:Ensemble (point_set Y) => In C U))).
repeat split.
apply finite_image; trivial.
red; intros V ?.
destruct H6 as [[U]].
simpl in H7.
congruence.
apply Extensionality_Ensembles; split; red; intros y ?.
constructor.
destruct (H1 y) as [x].
assert (In (IndexedUnion
  (fun a':{a' | In subcover a'} => B (proj1_sig a'))) x).
rewrite H5; constructor.
destruct H8 as [[[U]]].
exists U.
simpl in H8.
exists (exist _ U i); trivial.
unfold B in H8; simpl in H8.
destruct H8.
congruence.
Qed.

Lemma compact_Hausdorff_impl_normal_sep: forall X:TopologicalSpace,
  compact X -> Hausdorff X -> normal_sep X.
Proof.
intros.
assert (T3_sep X).
Require Import ClassicalChoice.
destruct (choice (fun (xy:{xy:point_set X * point_set X |
                  let (x,y):=xy in x <> y})
  (UV:Ensemble (point_set X) * Ensemble (point_set X)) =>
  match xy with | exist (x,y) i =>
    let (U,V):=UV in
  open U /\ open V /\ In U x /\ In V y /\ Intersection U V = Empty_set
  end)) as
[choice_fun].
destruct x as [[x y] i].
destruct (H0 _ _ i) as [U [V]].
exists (U, V); trivial.

pose (choice_fun_U := fun (x y:point_set X)
  (Hineq:x<>y) => fst (choice_fun (exist _ (x,y) Hineq))).
pose (choice_fun_V := fun (x y:point_set X)
  (Hineq:x<>y) => snd (choice_fun (exist _ (x,y) Hineq))).
assert (forall (x y:point_set X) (Hineq:x<>y),
  open (choice_fun_U x y Hineq) /\
  open (choice_fun_V x y Hineq) /\
  In (choice_fun_U x y Hineq) x /\
  In (choice_fun_V x y Hineq) y /\
  Intersection (choice_fun_U x y Hineq) (choice_fun_V x y Hineq) = Empty_set).
intros.
unfold choice_fun_U; unfold choice_fun_V.
pose proof (H1 (exist _ (x,y) Hineq)).
destruct (choice_fun (exist _ (x,y) Hineq)).
exact H2.
clearbody choice_fun_U choice_fun_V; clear choice_fun H1.

split.
apply Hausdorff_impl_T1_sep; trivial.
intros.
pose proof (closed_compact _ _ H H1).
assert (forall y:point_set X, In F y -> x <> y).
intros.
congruence.
pose (cover := fun (y:point_set (SubspaceTopology F)) =>
  let (y,i):=y in inverse_image (subspace_inc F)
                     (choice_fun_V x y (H5 y i))).
destruct (compactness_on_indexed_covers _ _ cover H4) as [subcover].
destruct a as [y i].
apply subspace_inc_continuous.
apply H2.
apply Extensionality_Ensembles; split; red; intros y ?.
constructor.
exists y.
destruct y as [y i].
simpl.
constructor.
simpl.
apply H2.
destruct H6.

exists (IndexedIntersection
  (fun y:{y:point_set (SubspaceTopology F) | In subcover y} =>
    let (y,_):=y in let (y,i):=y in choice_fun_U x y (H5 y i))).
exists (IndexedUnion
  (fun y:{y:point_set (SubspaceTopology F) | In subcover y} =>
    let (y,_):=y in let (y,i):=y in choice_fun_V x y (H5 y i))).
repeat split.
apply open_finite_indexed_intersection.
apply Finite_ens_type; trivial.
destruct a as [[y]].
apply H2.
apply open_indexed_union.
destruct a as [[y]].
apply H2.
destruct a as [[y]].
apply H2.
red; intros y ?.
assert (In (IndexedUnion
  (fun y:{y:point_set (SubspaceTopology F) | In subcover y} =>
    cover (proj1_sig y))) (exist _ y H8)).
rewrite H7; constructor.
remember (exist (In F) y H8) as ysig.
destruct H9 as [[y']].
rewrite Heqysig in H9; clear x0 Heqysig.
simpl in H9.
destruct y' as [y'].
simpl in H9.
destruct H9.
simpl in H9.
exists (exist _ (exist _ y' i0) i).
trivial.

apply Extensionality_Ensembles; split; auto with sets; red; intros y ?.
destruct H8.
destruct H8.
destruct H9.
pose proof (H8 a).
destruct a as [[y]].
replace (@Empty_set (point_set X)) with
  (Intersection (choice_fun_U x y (H5 y i))
                (choice_fun_V x y (H5 y i))).
constructor; trivial.
apply H2.

destruct (choice (fun (xF:{p:point_set X * Ensemble (point_set X) |
                        let (x,F):=p in closed F /\ ~ In F x})
  (UV:Ensemble (point_set X) * Ensemble (point_set X)) =>
  let (p,i):=xF in let (x,F):=p in
  let (U,V):=UV in
  open U /\ open V /\ In U x /\ Included F V /\
  Intersection U V = Empty_set)) as [choice_fun].
destruct x as [[x F] []].
destruct H1.
destruct (H4 x F H2 H3) as [U [V]].
exists (U,V); trivial.

pose (choice_fun_U := fun (x:point_set X) (F:Ensemble (point_set X))
  (HC:closed F) (Hni:~ In F x) =>
  fst (choice_fun (exist _ (x,F) (conj HC Hni)))).
pose (choice_fun_V := fun (x:point_set X) (F:Ensemble (point_set X))
  (HC:closed F) (Hni:~ In F x) =>
  snd (choice_fun (exist _ (x,F) (conj HC Hni)))).
assert (forall (x:point_set X) (F:Ensemble (point_set X))
  (HC:closed F) (Hni:~ In F x),
  open (choice_fun_U x F HC Hni) /\
  open (choice_fun_V x F HC Hni) /\
  In (choice_fun_U x F HC Hni) x /\
  Included F (choice_fun_V x F HC Hni) /\
  Intersection (choice_fun_U x F HC Hni) (choice_fun_V x F HC Hni) =
     Empty_set).
intros.
pose proof (H2 (exist _ (x,F) (conj HC Hni))).
unfold choice_fun_U; unfold choice_fun_V;
  destruct (choice_fun (exist _ (x,F) (conj HC Hni))); trivial.
clearbody choice_fun_U choice_fun_V; clear choice_fun H2.
split.
apply H1.
intros.
pose proof (closed_compact _ _ H H2).
assert (forall x:point_set X, In F x -> ~ In G x).
intros.
intro.
absurd (In Empty_set x).
red; destruct 1.
rewrite <- H5; split; trivial.

pose (cover := fun x:point_set (SubspaceTopology F) =>
  let (x,i):=x in inverse_image (subspace_inc F)
                   (choice_fun_U x G H4 (H7 x i))).
destruct (compactness_on_indexed_covers _ _ cover H6) as [subcover].
destruct a as [x i].
apply subspace_inc_continuous.
apply H3.
apply Extensionality_Ensembles; split; red; intros.
constructor.
exists x.
destruct x.
simpl cover.
constructor.
simpl.
apply H3.
destruct H8.

exists (IndexedUnion
  (fun x:{x:point_set (SubspaceTopology F) | In subcover x} =>
     let (x,i):=proj1_sig x in choice_fun_U x G H4 (H7 x i))).
exists (IndexedIntersection
  (fun x:{x:point_set (SubspaceTopology F) | In subcover x} =>
     let (x,i):=proj1_sig x in choice_fun_V x G H4 (H7 x i))).
repeat split.
apply open_indexed_union.
destruct a as [[x]].
simpl.
apply H3.
apply open_finite_indexed_intersection.
apply Finite_ens_type; trivial.
destruct a as [[x]].
simpl.
apply H3.
intros x ?.
assert (In (@Full_set (point_set (SubspaceTopology F))) (exist _ x H10))
  by constructor.
rewrite <- H9 in H11.
remember (exist _ x H10) as xsig.
destruct H11.
destruct a as [x'].
destruct x' as [x'].
rewrite Heqxsig in H11; clear x0 Heqxsig.
simpl in H11.
destruct H11.
simpl in H11.
exists (exist _ (exist _ x' i0) i).
simpl.
trivial.
destruct a as [x'].
simpl.
destruct x' as [x'].
assert (Included G (choice_fun_V x' G H4 (H7 x' i0))) by apply H3.
auto.

apply Extensionality_Ensembles; split; auto with sets; red; intros.
destruct H10.
destruct H10.
destruct H11.
pose proof (H11 a).
destruct a as [[x']].
simpl in H12.
simpl in H10.
replace (@Empty_set (point_set X)) with (Intersection
  (choice_fun_U x' G H4 (H7 x' i))
  (choice_fun_V x' G H4 (H7 x' i))).
constructor; trivial.
apply H3.
Qed.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
(* Definitions and theory of natural numbers that is useful in cryptographi proofs. *)

Set Implicit Arguments.

Require Export Arith.
Require Export Omega.
Require Export Arith.Div2.
Require Export Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.NArith.BinNat.

Lemma mult_same_r : forall n1 n2 n3,
  n3 > 0 ->
  n1 * n3 = n2 * n3 ->
  n1 = n2.

  induction n1; destruct n2; intuition; simpl in *.
  remember (n2 * n3) as x.
  omega.
  remember (n1 * n3) as x.
  omega.

  f_equal.
  eapply IHn1; eauto.

  eapply plus_reg_l. eauto.
Qed.

Lemma mult_same_l : forall n3 n1 n2,
  n3 > 0 ->
  n3 * n1 = n3 * n2 ->
  n1 = n2.

  intuition.
  eapply mult_same_r; eauto.
  rewrite mult_comm.
  rewrite (mult_comm n2 n3).
  trivial.
Qed.

Lemma mult_gt_0 : forall n1 n2,
  n1 > 0 ->
  n2 > 0 ->
  n1 * n2 > 0.
  destruct n1; intuition; simpl in *.
  remember (n1 * n2) as x.
  omega.
Qed.

Lemma minus_eq_compat : forall n1 n2 n3 n4,
  n1 = n2 ->
  n3 = n4 ->
  n1 - n3 = n2 - n4.

  intuition.
Qed.

Lemma plus_eq_compat : forall n1 n2 n3 n4,
  n1 = n2 ->
  n3 = n4 ->
  n1 + n3 = n2 + n4.

  intuition.
Qed.

Lemma minus_diag_eq : forall n1 n2,
  n1 = n2 ->
  n1 - n2 = 0.

  intuition.
Qed.

Lemma le_eq : forall n1 n2,
  n1 = n2 ->
  n1 <= n2.

  intuition.
Qed.

Lemma minus_add_assoc : forall n1 n2 n3,
  (n3 <= n2)%nat ->
  (n1 + (n2 - n3) = n1 + n2 - n3)%nat.

  intuition.
Qed.

Class nz (a : nat) := {
  agz : a > 0
}.

Instance nz_nat : forall (n : nat), nz (S n).
intuition.
econstructor.
omega.
Defined.

Definition posnat := {n : nat | n > 0}.

Definition posnatToNat(p : posnat) :=
  match p with
    | exist _ n _ => n
  end.

Inductive posnatEq : posnat -> posnat -> Prop :=
  | posnatEq_intro :
    forall (n1 n2 : nat) pf1 pf2,
      n1 = n2 ->
      posnatEq (exist _ n1 pf1) (exist _ n2 pf2).

Definition posnatMult(p1 p2 : posnat) : posnat :=
    match (p1, p2) with
      | (exist _ n1 pf1, exist _ n2 pf2) =>
        (exist (fun n => n > 0) (n1 * n2) (mult_gt_0 pf1 pf2))
    end.

Lemma posnatMult_comm : forall p1 p2,
  (posnatEq (posnatMult p1 p2) (posnatMult p2 p1)).

  intuition.
  unfold posnatMult.
  destruct p1; destruct p2.
  econstructor.
  apply mult_comm.
Qed.

Coercion posnatToNat : posnat >-> nat.

Lemma posnat_pos : forall (p : posnat),
  p > 0.

  intuition.
  destruct p.
  unfold posnatToNat.
  trivial.
Qed.

Instance nz_posnat : forall (p : posnat),
  nz p.

intuition.
econstructor.
eapply posnat_pos.

Qed.

Definition natToPosnat(n : nat)(pf : nz n) :=
  (exist (fun x => x > 0) n agz).

Notation "'pos' x" := (@natToPosnat x _) (at level 40).

Fixpoint expnat n1 n2 :=
  match n2 with
    | 0 => 1
    | S n2' =>
      n1 * (expnat n1 n2')
  end.

Theorem expnat_pos : forall x n,
  x > 0 ->
  expnat x n > 0.

  induction n; intuition; simpl in *.
  remember (x * expnat x n) as y.
  assert (y <> 0); try omega.
  intuition; subst.
  apply mult_is_O in H1.
  destruct H1; omega.

Qed.

Lemma div2_le : forall n,
  le (div2 n) n.

  intuition.

  eapply PeanoNat.Nat.div2_decr.
  omega.

Qed.

Lemma div2_ge_double : forall n,
  n >= (div2 n) + (div2 n).

  intuition.
  destruct (Even.even_odd_dec n).

  rewrite (even_double n) at 1.
  unfold double.
  omega.
  trivial.
  rewrite (odd_double n) at 1.
  unfold double.
  omega.
  trivial.
Qed.

Local Open Scope N_scope.
Definition modNat (n : nat)(p : posnat) : nat :=
  N.to_nat ((N.of_nat n) mod (N.of_nat p)).

Lemma modNat_plus : forall n1 n2 p,
    (modNat (n1 + n2) p = modNat ((modNat n1 p) + n2) p)%nat.

  unfold modNat.

  intuition.
  rewrite Nnat.Nat2N.inj_add.

  rewrite <- N.add_mod_idemp_l.
  f_equal.
  rewrite <- (Nnat.Nat2N.id n2) at 2.
  rewrite Nnat.Nat2N.inj_add.
  repeat rewrite Nnat.N2Nat.id.
  trivial.

  destruct p.
  simpl.

  destruct x;
  simpl.
  omega.

  Lemma Npos_nz : forall p,
    Npos p <> N0.

    destruct p; intuition; simpl in *.
    inversion H.
    inversion H.
    inversion H.
  Qed.

  apply Npos_nz.

Qed.

Lemma modNat_arg_eq : forall (p : posnat),
  modNat p p = O.

  intuition.
  unfold modNat.
  rewrite N.mod_same.
  trivial.
  unfold N.of_nat, posnatToNat.
  destruct p.
  destruct x.
  omega.
  apply Npos_nz.

Qed.

Lemma of_nat_ge_0 : forall n,
  0 <= N.of_nat n.

  intuition.
  unfold N.of_nat.
  destruct n.
  intuition.

  simpl.
  unfold N.le.
  case_eq ((0 ?= N.pos (Pos.of_succ_nat n))); intuition;
    try discriminate.
Qed.

Lemma of_posnat_gt_0 : forall (p : posnat),
  0 < N.of_nat p.

  intuition.
  unfold N.of_nat, posnatToNat.
  destruct p.
  destruct x.
  omega.
  destruct x; intuition; simpl in *.

  case_eq (N.compare 0 1)%N; intuition.
  inversion H.
  inversion H.

  case_eq (N.compare 0 (N.pos (Pos.succ (Pos.of_succ_nat x))))%N; intuition.
  inversion H.
  inversion H.
Qed.

Lemma modNat_lt : forall x p, (modNat x p < p)%nat.

  intuition.
  unfold modNat.
  assert (N.of_nat x mod N.of_nat p < N.of_nat p)%N.
  apply N.mod_bound_pos.
  apply of_nat_ge_0.
  apply of_posnat_gt_0.

  specialize (Nnat.N2Nat.inj_compare); intuition.
  rewrite <- (Nnat.Nat2N.id p) at 2.
  apply nat_compare_lt.
  rewrite <- H0.
  apply N.compare_lt_iff.
  trivial.

Qed.

Lemma modNat_eq : forall (n : posnat) x, (x < n -> modNat x n = x)%nat.

  intuition.
  unfold modNat.
  rewrite N.mod_small.
  apply Nnat.Nat2N.id.
  specialize (Nnat.N2Nat.inj_compare); intuition.
  specialize (N.compare_lt_iff (N.of_nat x) (N.of_nat n)); intuition.
  apply H2.
  rewrite H0.
  repeat rewrite Nnat.Nat2N.id.
  apply nat_compare_lt.
  trivial.
Qed.

Definition modNatAddInverse (n : nat)(p : posnat) :=
  (p - (modNat n p))%nat.

Lemma modNatAddInverse_correct_gen : forall x y p,
  modNat x p = modNat y p ->
  modNat (x + modNatAddInverse y p) p = O.

  intuition.
  unfold modNatAddInverse.
  rewrite <- H.
  rewrite modNat_plus.
  rewrite minus_add_assoc.
  rewrite (plus_comm).
  rewrite <- minus_add_assoc.
  rewrite minus_diag.
  rewrite plus_0_r.
  apply modNat_arg_eq.

  trivial.

  assert (modNat x p < p)%nat.
  apply modNat_lt.
  omega.

Qed.

Lemma modNatAddInverse_correct : forall n p,
    modNat (n + modNatAddInverse n p) p = O.

  intuition.
  eapply modNatAddInverse_correct_gen.
  trivial.

Qed.

Lemma modNat_correct : forall x (p : posnat),
  exists k, (x = k * p + modNat x p)%nat.

  intuition.
  unfold modNat in *.
  assert (p > 0)%nat.
  eapply posnat_pos.
  assert (posnatToNat p <> 0)%nat.
  omega.
  assert (N.of_nat p <> 0%N).
  intuition.
  eapply H0.

  rewrite <- Nnat.Nat2N.id.
  rewrite <- (Nnat.Nat2N.id p).
  f_equal.
  trivial.

  exists (N.to_nat (N.of_nat x / N.of_nat p)).
  rewrite N.mod_eq; trivial.

  rewrite <- (Nnat.Nat2N.id p) at 2.
  rewrite <- Nnat.N2Nat.inj_mul.
  rewrite <- Nnat.N2Nat.inj_add.
  rewrite N.mul_comm.
  remember (N.of_nat p * (N.of_nat x / N.of_nat p)) as z.
  rewrite N.add_sub_assoc.
  rewrite N.add_comm.
  rewrite N.add_sub.
  rewrite Nnat.Nat2N.id.
  trivial.

  subst.
  eapply N.mul_div_le.
  trivial.
Qed.

Lemma modNat_divides : forall x p,
  modNat x p = O ->
  exists k, (x = k * p)%nat.

  intuition.
  destruct (modNat_correct x p).
  rewrite H in H0.
  econstructor.
  rewrite plus_0_r in H0.
  eauto.
Qed.

Local Open Scope nat_scope.
Lemma modNatAddInverse_sum_0 : forall x y p,
  modNat (x + (modNatAddInverse y p)) p = O ->
  modNat x p = modNat y p.

  intuition.

  assert (modNat x p < p).
  eapply modNat_lt.
  assert (modNat y p < p).
  eapply modNat_lt.

  rewrite modNat_plus in H.
  unfold modNatAddInverse in *.
  rewrite minus_add_assoc in H; intuition.
  rewrite plus_comm in H.

  apply modNat_divides in H.
  destruct H.

  remember (modNat x p) as a.
  remember (modNat y p) as b.
  assert (p + a >= p).
  omega.
  assert (p + a < 2 * p)%nat.
  omega.
  assert (p + a - b < 2 * p).
  omega.
  assert (p + a - b > 0).
  omega.

  assert (x0 * p > 0).
  omega.
  assert (x0 * p < 2 * p).
  omega.

  destruct x0.
  omega.
  destruct x0.

  simpl in H.
  rewrite plus_0_r in H.
  omega.

  assert (p > 0).
  eapply posnat_pos.
  simpl in H7.
  remember (x0 * p)%nat as c.
  omega.
Qed.

Lemma modNat_correct_if : forall x y z (p : posnat),
  x * p + y = z ->
  modNat z p = modNat y p.

  induction x; intuition; simpl in *.
  subst.
  trivial.

  assert (x * p + (y + p) = z).
  omega.
  apply IHx in H0.

  rewrite H0.
  rewrite plus_comm.
  rewrite modNat_plus.
  rewrite modNat_arg_eq.
  rewrite plus_0_l.
  trivial.
Qed.

Lemma modNat_mult : forall x (p : posnat),
  modNat (x * p) p = 0.

  induction x; intuition; simpl in *.
  rewrite modNat_plus.
  rewrite modNat_arg_eq.
  rewrite plus_0_l.
  eauto.

Qed.

Lemma modNat_add_same_l : forall x y z p,
  modNat (x + y) p = modNat (x + z) p ->
  modNat y p = modNat z p.

  induction x; intuition; simpl in *.
  assert (S (x + y) = x + S y).
  omega.
  rewrite H0 in H.
  clear H0.
  assert (S (x + z) = x + S z).
  omega.
  rewrite H0 in H.
  clear H0.
  apply IHx in H.

  destruct (modNat_correct (S y) p).
  destruct (modNat_correct (S z) p).
  rewrite H in H0.

  assert (S y - x0 * p = modNat (S z) p).
  omega.
  assert (S z - x1 * p = modNat (S z) p).
  omega.
  rewrite <- H2 in H3.

  assert (z - x1 * p = y - x0 * p).
  omega.

  assert (x1 * p + y = x0 * p + z).
  omega.

  apply modNat_correct_if in H5.
  rewrite modNat_plus in H5.

  rewrite modNat_mult in H5.
  rewrite plus_0_l in H5.
  auto.

Qed.

Lemma modNat_add_same_r : forall x y z p,
  modNat (y + x) p = modNat (z + x) p ->
  modNat y p = modNat z p.

  intuition.
  eapply (modNat_add_same_l x y z).
  rewrite plus_comm.
  rewrite H.
  rewrite plus_comm.
  trivial.
Qed.

Lemma expnat_base_S : forall n k,
  ((expnat k n) + n * (expnat k (pred n)) <= expnat (S k) n)%nat.

  induction n; intuition.
  simpl in *.
  eapply le_trans.
  Focus 2.
  eapply plus_le_compat.
  eapply IHn.
  eapply mult_le_compat.
  eapply le_refl.
  eapply IHn.

  rewrite mult_plus_distr_l.
  repeat rewrite mult_assoc.
  repeat rewrite plus_assoc.
  eapply plus_le_compat.
  rewrite plus_comm.
  eapply plus_le_compat.
  rewrite <- (plus_0_r (expnat k n)) at 1.
  eapply plus_le_compat.
  omega.
  intuition.
  intuition.

  rewrite (mult_comm k n).
  rewrite <- (mult_assoc n).
  destruct n; simpl; intuition.
Qed.

Lemma expnat_base_S_same : forall n,
  n > 0 ->
  (2 * (expnat n n) <= expnat (S n) n)%nat.

  intuition.
  simpl in *.
  rewrite plus_0_r.
  eapply le_trans.
  Focus 2.
  eapply expnat_base_S.
  destruct n; simpl.
  omega.
  intuition.
Qed.

Lemma sqrt_le_lin_gen : forall a b,
  (a <= b ->
    Nat.sqrt a <= b)%nat.

  intuition.
  eapply le_trans.
  eapply Nat.sqrt_le_lin.
  trivial.
Qed.

Lemma div2_le_mono : forall n1 n2,
  (n1 <= n2 ->
    div2 n1 <= div2 n2)%nat.

  induction n1; intuition.
  destruct n2.
  omega.
  destruct (Even.even_odd_dec n1).
  destruct (Even.even_odd_dec n2).
  repeat rewrite <- even_div2; trivial.
  eapply IHn1.
  omega.

  rewrite <- even_div2; trivial.
  rewrite <- odd_div2; trivial.
  econstructor.
  eapply IHn1.
  omega.

  destruct (Even.even_odd_dec n2).
  destruct (lt_dec n1 n2).
  assert (n1 <= (S n2))%nat.
  omega.
  destruct n2.
  omega.
  rewrite <- odd_div2; trivial.
  rewrite <- even_div2.
  rewrite <- odd_div2.
  eapply le_n_S.
  eapply IHn1.
  omega.
  inversion e.
  trivial.
  trivial.
  assert (n1 = n2).
  omega.
  subst.
  exfalso.
  eapply Even.not_even_and_odd; eauto.

  rewrite <- odd_div2; trivial.
  rewrite <- odd_div2; trivial.
  eapply le_n_S.
  eapply IHn1.
  omega.

Qed.

Lemma div2_ge : forall n n',
  n >= n' ->
  forall x,
    (n' = 2 * x)%nat ->
    div2 n >= x.

  induction 1; intuition; subst; simpl in *.
  specialize (div2_double x); intuition; simpl in *.
  rewrite H.
  omega.

  destruct m.
  omega.
  destruct (Even.even_odd_dec m).
  rewrite even_div2.
  assert (div2 (S m) >= x).
  eapply IHle.
  trivial.
  omega.
  trivial.

  rewrite odd_div2.

  eapply IHle.
  trivial.
  trivial.
Qed.

Instance expnat_nz : forall k n (p : nz n),
  nz (expnat n k).

intuition.

induction k; intuition; simpl in *.
econstructor.
omega.
econstructor.
edestruct IHk; eauto.
destruct p.
eapply mult_gt_0; intuition.

Qed.

Lemma expnat_2_ge_1 : forall n,
  (1 <= expnat 2 n)%nat.

  induction n; intuition; simpl in *.
  omega.
Qed.

Lemma le_expnat_2 : forall n,
  (n <= expnat 2 n)%nat.

  induction n; intuition; simpl in *.
  rewrite plus_0_r.
  assert (S n = 1 + n)%nat.
  omega.
  rewrite H.
  eapply plus_le_compat.
  eapply expnat_2_ge_1.
  trivial.

Qed.

Lemma expnat_1 : forall k,
  expnat 1%nat k = 1%nat.

  induction k; intuition; simpl in *.
  rewrite plus_0_r.
  trivial.

Qed.

Theorem expnat_base_le :
  forall k n1 n2,
    n1 <= n2 ->
    expnat n1 k <=
    expnat n2 k.

  induction k; intuition; simpl in *.
  eapply mult_le_compat; intuition.

Qed.

Theorem expnat_double_le :
  forall k n,
    n >= 2 ->
    expnat n (S k) >= 2 * expnat n k.

  induction k; intuition; simpl in *.
  omega.
  rewrite plus_0_r.
  rewrite <- mult_plus_distr_l.
  eapply mult_le_compat.
  trivial.
  rewrite <- plus_0_r at 1.
  rewrite <- plus_assoc.
  eapply IHk.
  trivial.
Qed.

Theorem nat_half_plus :
  forall x,
    x > 1 ->
    exists a b,
      a > 0 /\ b <= 1 /\ x = 2 * a + b.

  induction x; intuition; simpl in *.
  omega.

  destruct (eq_nat_dec x 1); subst.
  exists 1.
  exists 0.
  intuition; omega.

  edestruct (IHx).
  omega.
  destruct H0.
  intuition.
  destruct x1.
  rewrite plus_0_r in H3.
  exists x0.
  exists 1.
  subst.
  intuition; omega.

  exists (S x0).
  exists 0.
  subst.
  intuition.

Qed.

Theorem log2_div2 :
  forall x y,
    S y = Nat.log2 x ->
    Nat.log2 (div2 x) = y.

  intuition.
  specialize (Nat.log2_double); intuition.

  destruct (@nat_half_plus x).
  eapply Nat.log2_lt_cancel.
  rewrite Nat.log2_1.
  omega.
  destruct H1.
  intuition.
  subst.
  destruct x1.
  rewrite plus_0_r in *.
  rewrite div2_double.
  rewrite H0 in H.
  omega.
  omega.

  destruct x1.

  rewrite plus_comm.
  rewrite div2_double_plus_one.

  rewrite Nat.log2_succ_double in H.
  omega.
  omega.

  omega.

Qed.

Lemma log2_0 :
  Nat.log2 0 = 0.
  trivial.
Qed.

Theorem expnat_0 :
  forall k,
    k > 0 ->
    expnat 0 k = 0.

  induction k; intuition; simpl in *.

Qed.

Theorem expnat_plus :
  forall k1 k2 n,
    expnat n (k1 + k2) = expnat n k1 * expnat n k2.

  induction k1; simpl in *; intuition.
  rewrite IHk1.
  rewrite mult_assoc.
  trivial.

Qed.

Theorem expnat_ge_1 :
  forall k n,
    n > 0 ->
    1 <= expnat n k.

  induction k; intuition; simpl in *.
  rewrite <- mult_1_r at 1.
  eapply mult_le_compat.
  omega.
  eauto.
Qed.

Theorem expnat_exp_le :
  forall n2 n4 n,
    (n2 > 0 \/ n > 0) ->
    n2 <= n4 ->
    expnat n n2 <= expnat n n4.

  induction n2; destruct n4; simpl in *; intuition.
  rewrite <- mult_1_l at 1.
  eapply mult_le_compat.
  omega.
  eapply expnat_ge_1; trivial.

  destruct (eq_nat_dec n 0); subst.
  simpl; intuition.
  eapply mult_le_compat; intuition.

Qed.

Lemma mult_lt_compat :
  forall a b c d,
    a < b ->
    c < d ->
    a * c < b * d.

  intuition.
  eapply le_lt_trans.
  eapply mult_le_compat.
  assert (a <= b).
  omega.
  eapply H1.
  eapply le_refl.
  eapply mult_lt_compat_l.
  trivial.
  omega.
Qed.

Theorem orb_same_eq_if :
  forall a b c,
    (a = false -> b = c) ->
    orb a b = orb a c.

  intuition.
  destruct a; trivial; intuition.

Qed.


(*************** Verify that Ah_inverse is a normal matrix *****************)

Require Import Reals Psatz Omega.
Require Import Coquelicot.Hierarchy.
Require Import linear_algebra.
Require Import Ah_inverse.

Lemma inverse_is_normal (a b:R): forall (N:nat),
  Mmult (inverse_A N a b ) (mat_transpose N (inverse_A N a b )) =
  Mmult (mat_transpose N (inverse_A N a b )) (inverse_A N a b ).
Proof.
intros.
apply (is_normal_mat N (inverse_A N a b )).
unfold symmetric_mat.
unfold mat_transpose. unfold inverse_A. apply mk_matrix_ext.
intros.
assert (coeff_mat 0
        (mk_matrix N N
           (fun i0 j0 : nat =>
            if i0 <=? j0
            then 1 / a * (-1) ^ (i0 + j0) * (Mk i0 (b / a) * Mk (N - j0 - 1) (b / a) * / Mk N (b / a))
            else 1 / a * (-1) ^ (i0 + j0) * (Mk j0 (b / a) * Mk (N - i0 - 1) (b / a)) * / Mk N (b / a))) j i=
            (fun i0 j0 : nat =>
            if i0 <=? j0
            then 1 / a * (-1) ^ (i0 + j0) * (Mk i0 (b / a) * Mk (N - j0 - 1) (b / a) * / Mk N (b / a))
            else 1 / a * (-1) ^ (i0 + j0) * (Mk j0 (b / a) * Mk (N - i0 - 1) (b / a)) * / Mk N (b / a)) j i).
{ apply (coeff_mat_bij 0  (fun i0 j0 : nat =>
            if i0 <=? j0
            then 1 / a * (-1) ^ (i0 + j0) * (Mk i0 (b / a) * Mk (N - j0 - 1) (b / a) * / Mk N (b / a))
            else 1 / a * (-1) ^ (i0 + j0) * (Mk j0 (b / a) * Mk (N - i0 - 1) (b / a)) * / Mk N (b / a)) j i).
  omega. omega.
} rewrite H1.
assert ( i=j \/ (i<j)%nat \/ (i>j)%nat). { omega. }
destruct H2.
+ rewrite H2. assert (j <=? j=true).
  { apply leb_correct. omega. }
  rewrite H3. reflexivity.
+ destruct H2.
  assert (i <=? j=true). { apply leb_correct. omega. } rewrite H3.
  assert (j <=? i=false). { apply leb_correct_conv. omega. } rewrite H4.
  assert ((i + j)%nat=(j + i)%nat ). { omega. } rewrite H5. nra.
+ assert ( i <=? j=false). { apply leb_correct_conv. omega. } rewrite H3.
  assert (j <=? i=true). { apply leb_correct. omega. } rewrite H4.
  assert ((i + j)%nat=(j + i)%nat ). { omega. } rewrite H5. nra.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) : natural := plus lf2 Zero.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) : natural := Succ (plus Zero lf2).


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require Reals.Rbasic_fun.
Require Reals.Rtrigo_def.
Require Reals.Rtrigo1.
Require Reals.Ratan.
Require BuiltIn.
Require real.Real.
Require real.Abs.
Require real.Square.

Require Import Reals.

(* Why3 comment *)
(* cos is replaced with (Reals.Rtrigo_def.cos x) by the coq driver *)

(* Why3 comment *)
(* sin is replaced with (Reals.Rtrigo_def.sin x) by the coq driver *)

(* Why3 goal *)
Lemma Pythagorean_identity :
forall (x:R),
 (((Reals.RIneq.Rsqr (Reals.Rtrigo_def.cos x)) + (Reals.RIneq.Rsqr (Reals.Rtrigo_def.sin x)))%R = 1%R).
Proof.
intros x.
rewrite Rplus_comm.
apply sin2_cos2.
Qed.

(* Why3 goal *)
Lemma Cos_le_one :
forall (x:R), ((Reals.Rbasic_fun.Rabs (Reals.Rtrigo_def.cos x)) <= 1%R)%R.
Proof.
intros x.
apply Abs.Abs_le.
apply COS_bound.
Qed.

(* Why3 goal *)
Lemma Sin_le_one :
forall (x:R), ((Reals.Rbasic_fun.Rabs (Reals.Rtrigo_def.sin x)) <= 1%R)%R.
Proof.
intros x.
apply Abs.Abs_le.
apply SIN_bound.
Qed.

(* Why3 goal *)
Lemma Cos_0 :
((Reals.Rtrigo_def.cos 0%R) = 1%R).
Proof.
apply cos_0.
Qed.

(* Why3 goal *)
Lemma Sin_0 :
((Reals.Rtrigo_def.sin 0%R) = 0%R).
Proof.
apply sin_0.
Qed.

(* Why3 comment *)
(* pi is replaced with Reals.Rtrigo1.PI by the coq driver *)

(* Why3 goal *)
Lemma Pi_double_precision_bounds :
((7074237752028440 / 2251799813685248)%R < Reals.Rtrigo1.PI)%R
/\ (Reals.Rtrigo1.PI < (7074237752028441 / 2251799813685248)%R)%R.
Proof.
replace PI with (4 * (PI / 4))%R by field.
rewrite <- atan_1.
admit. (* to avoid a dependency on CoqInterval *)
(*
Require Import Interval_tactic.
split ; interval with (i_prec 55).
*)
Admitted.

(* Why3 goal *)
Lemma Cos_pi :
((Reals.Rtrigo_def.cos Reals.Rtrigo1.PI) = (-1%R)%R).
Proof.
apply cos_PI.
Qed.

(* Why3 goal *)
Lemma Sin_pi :
((Reals.Rtrigo_def.sin Reals.Rtrigo1.PI) = 0%R).
Proof.
apply sin_PI.
Qed.

(* Why3 goal *)
Lemma Cos_pi2 :
((Reals.Rtrigo_def.cos ((05 / 10)%R * Reals.Rtrigo1.PI)%R) = 0%R).
Proof.
replace (5 / 10 * PI)%R with (PI / 2)%R by field.
apply cos_PI2.
Qed.

(* Why3 goal *)
Lemma Sin_pi2 :
((Reals.Rtrigo_def.sin ((05 / 10)%R * Reals.Rtrigo1.PI)%R) = 1%R).
Proof.
replace (5 / 10 * PI)%R with (PI / 2)%R by field.
apply sin_PI2.
Qed.

(* Why3 goal *)
Lemma Cos_plus_pi :
forall (x:R),
 ((Reals.Rtrigo_def.cos (x + Reals.Rtrigo1.PI)%R) = (-(Reals.Rtrigo_def.cos x))%R).
Proof.
intros x.
apply neg_cos.
Qed.

(* Why3 goal *)
Lemma Sin_plus_pi :
forall (x:R),
 ((Reals.Rtrigo_def.sin (x + Reals.Rtrigo1.PI)%R) = (-(Reals.Rtrigo_def.sin x))%R).
Proof.
intros x.
apply neg_sin.
Qed.

(* Why3 goal *)
Lemma Cos_plus_pi2 :
forall (x:R),
 ((Reals.Rtrigo_def.cos (x + ((05 / 10)%R * Reals.Rtrigo1.PI)%R)%R) = (-(Reals.Rtrigo_def.sin x))%R).
Proof.
intros x.
rewrite cos_sin.
replace (PI / 2 + (x + 5 / 10 * PI))%R with (x + PI)%R by field.
apply neg_sin.
Qed.

(* Why3 goal *)
Lemma Sin_plus_pi2 :
forall (x:R),
 ((Reals.Rtrigo_def.sin (x + ((05 / 10)%R * Reals.Rtrigo1.PI)%R)%R) = (Reals.Rtrigo_def.cos x)).
Proof.
intros x.
rewrite cos_sin.
apply f_equal.
field.
Qed.

(* Why3 goal *)
Lemma Cos_neg :
forall (x:R), ((Reals.Rtrigo_def.cos (-x)%R) = (Reals.Rtrigo_def.cos x)).
Proof.
intros x.
apply cos_neg.
Qed.

(* Why3 goal *)
Lemma Sin_neg :
forall (x:R), ((Reals.Rtrigo_def.sin (-x)%R) = (-(Reals.Rtrigo_def.sin x))%R).
Proof.
intros x.
apply sin_neg.
Qed.

(* Why3 goal *)
Lemma Cos_sum :
forall (x:R) (y:R),
 ((Reals.Rtrigo_def.cos (x + y)%R) = (((Reals.Rtrigo_def.cos x) * (Reals.Rtrigo_def.cos y))%R - ((Reals.Rtrigo_def.sin x) * (Reals.Rtrigo_def.sin y))%R)%R).
Proof.
intros x y.
apply cos_plus.
Qed.

(* Why3 goal *)
Lemma Sin_sum :
forall (x:R) (y:R),
 ((Reals.Rtrigo_def.sin (x + y)%R) = (((Reals.Rtrigo_def.sin x) * (Reals.Rtrigo_def.cos y))%R + ((Reals.Rtrigo_def.cos x) * (Reals.Rtrigo_def.sin y))%R)%R).
Proof.
intros x y.
apply sin_plus.
Qed.

(* Why3 goal *)
Lemma tan_def :
  forall (x:R),
   ((Reals.Rtrigo1.tan x) = ((Reals.Rtrigo_def.sin x) / (Reals.Rtrigo_def.cos x))%R).
Proof.
intros x.
apply eq_refl.
Qed.

(* Why3 comment *)
(* atan is replaced with (Reals.Ratan.atan x) by the coq driver *)

(* Why3 goal *)
Lemma Tan_atan :
forall (x:R), ((Reals.Rtrigo1.tan (Reals.Ratan.atan x)) = x).
Proof.
intros x.
apply atan_right_inv.
Qed.