Require Export A_3_2.

Module A3_3.

(* 3.3 函数极限存在的条件 *)

(* 定理3.8 归结原则 *)
Theorem Theorem3_8 : ∀ (f : Fun) (x0 δ' A : R), Function f
  -> δ' > 0 -> Neighbor0 x0 δ' ⊂ dom[f]
  -> limit f x0 A
  <-> ∀ (x : Seq), IsSeq x -> ran[x] ⊂ Neighbor0 x0 δ'
    -> limit_seq x x0
    -> limit_seq {` λ n v, v = f[x[n]] `} A.
Proof.
  intros f x0 δ' A H0 H1 H2. split.
  - intro H3. destruct H3 as [H3 [δ1' [H4 [H5 H6]]]].
    intros x H7 H8 H9. unfold limit_seq.
    assert (H10 : IsSeq {` λ n v, v = f[x[n]] `} ).
    { unfold IsSeq. split.
      - unfold Function. intros x1 y1 z1 I1 I2.
        applyAxiomII' I1. applyAxiomII' I2.
        rewrite I2; auto.
      - apply AxiomI. intro z; split; intro I1.
        + apply AxiomII. reflexivity.
        + apply AxiomII. exists (f[x[z]]).
          apply AxiomII'. reflexivity. }
    split; auto. intros ε H11.
    apply H6 in H11 as H12.
    destruct H12 as [δ [[H12 H13] H14]].
    apply H9 in H12 as H15.
    destruct H15 as [N H15]. exists N.
    intros n H16. apply H15 in H16 as H17.
    assert (H18 : Abs[x[n] - x0] > 0).
    { assert (I2 : x[n] ∈ ran[x]).
      { destruct H7 as [I2 I3].
        apply fx_ran; auto. rewrite I3.
        apply AxiomII. reflexivity. }
      apply H8 in I2. applyAxiomII I2.
      apply I2. }
    assert (H19 : 0 < Abs[x[n] - x0] < δ). lra.
    apply H14 in H19.
    assert (H20 : {` λ(n0 : nat)(v : R),
      v = f [x [n0]] `} [n] = f[x[n]]).
    { apply f_x; try apply H10. apply AxiomII'.
      reflexivity. }
    rewrite H20. apply H19.
  - intro H3. apply NNPP. intro H4.
    unfold limit in H4. apply not_and_or in H4.
    destruct H4 as [H4 | H4]; auto.
    apply not_ex_all_not with (n := δ') in H4.
    apply not_and_or in H4;
    destruct H4 as [H4 | H4]; auto.
    apply not_and_or in H4;
    destruct H4 as [H4 | H4]; auto.
    apply not_all_ex_not in H4.
    destruct H4 as [ε0 H4]. apply imply_to_and in H4.
    destruct H4 as [H4 H5].
    assert (H6 : ∀ δ, ~ (0 < δ < δ' /\
      (∀x : R,0 < Abs [x - x0] < δ -> Abs [f [x] - A] < ε0))).
    { apply not_ex_all_not; apply H5. }
    assert (H7 : ∃ (x : Seq), x = {` λ n v, v =
      cR \{λ u, 0 < Abs [u - x0] < δ'/(INR (n + 2))
      /\ Abs [f [u] - A] >= ε0 \} `}).
    { exists ({` λ n v, v =
      cR \{λ u, 0 < Abs [u - x0] < δ'/(INR (n + 2))
      /\ Abs [f [u] - A] >= ε0 \} `}); reflexivity. }
    destruct H7 as [x H7].
    assert (H8 : IsSeq x).
    { split.
      - unfold Function. rewrite H7. intros x1 y1 z1 I1 I2.
        applyAxiomII' I1; applyAxiomII' I2.
        rewrite I2; apply I1.
      - apply AxiomI. intro z; split; intro I1.
        + apply AxiomII. reflexivity.
        + apply AxiomII. exists (cR \{λ u, 0 < Abs [u - x0]
            < δ'/(INR (z + 2)) /\ Abs [f [u] - A] >= ε0 \}).
          rewrite H7. apply AxiomII'. reflexivity. }
    generalize H8. intro H9.
    destruct H9 as [H9 H10].
    assert (H11 : ∀δ : R, 0 < δ < δ'
      -> NotEmpty \{λ u, 0 < Abs [u - x0] < δ
        /\ Abs [f [u] - A] >= ε0 \}).
    { intros δ I1. generalize (H6 δ). intro I2.
      apply not_and_or in I2.
      destruct I2 as [I2 | I2]; [exfalso; auto | idtac].
      apply not_all_ex_not in I2.
      destruct I2 as [u I2].
      apply imply_to_and in I2.
      destruct I2 as [I2 I3].
      exists u. apply AxiomII.
      split; auto; lra. }
    assert (H12 : ∀ n, 0 < δ' / INR (n + 2) < δ').
    { intro n. assert (I1 : 2 <= INR (n + 2)).
      { assert (I1 : 2 = INR (2%nat)).
        { simpl. field. }
        rewrite I1. apply le_INR.
        rewrite Nat.add_comm. apply Nat.le_add_r. }
      assert (I2 : INR (n + 2) > 1). lra.
      assert (I3 : 0 < 1 * INR (n + 2)). lra.
      apply Rinv_lt_contravar in I2; auto.
      apply Rmult_lt_compat_l with (r := δ') in I2; auto.
      assert (I4 : δ' * / 1 = δ'). field.
      rewrite I4 in I2. split; auto.
      apply Rmult_gt_0_compat; auto.
      apply Rinv_0_lt_compat. lra. }
    assert (H13 : ran[x] ⊂ Neighbor0 x0 δ').
    { intros u I1. applyAxiomII I1.
      destruct I1 as [n I1].
      rewrite H7 in I1. applyAxiomII' I1.
      generalize (H12 n). intro I2.
      apply H11 in I2 as I3.
      apply AxiomcR in I3. rewrite <- I1 in I3.
      applyAxiomII I3. destruct I3 as [I3 I4].
      apply AxiomII. lra. }
    assert (H14 : limit_seq x x0).
    { split; auto. intros ε I1.
      assert (I2 : ∃ N, δ' / INR (N + 2) < ε).
      { generalize (Archimedes ε δ' I1 H1).
        intros [N J1]. exists N.
        rewrite Rmult_comm in J1.
        assert (J2 : INR (N + 2) > INR N).
        { apply lt_INR. apply Nat.lt_add_pos_r.
          apply Nat.lt_0_2. }
        generalize (pos_INR N). intro J3.
        assert (J4 : 0 < INR (N + 2)). lra.
        apply Rmult_lt_compat_l with (r := ε) in J2; auto.
        assert (J5 : δ' < ε * INR (N + 2)). lra.
        apply Rinv_0_lt_compat in J4 as J6.
        apply Rmult_lt_compat_r with
          (r := / INR (N + 2)) in J5; auto.
        assert (J7 : ε * INR (N + 2) * /INR (N + 2) = ε).
        field. lra.
        rewrite J7 in J5. apply J5. }
      destruct I2 as [N I2]. exists N.
      intros n I3. assert (I4 : n ∈ dom[x]).
      { rewrite H10. apply AxiomII. reflexivity. }
      apply x_fx in I4 as I5; auto.
      pattern x at 2 in I5.
      rewrite H7 in I5. applyAxiomII' I5.
      generalize (H12 n). intro I6.
      apply H11 in I6 as I7.
      apply AxiomcR in I7. rewrite <- I5 in I7.
      applyAxiomII I7. destruct I7 as [I7 I8].
      assert (I9 : δ' / INR (n + 2) < δ' / INR (N + 2)).
      { apply Rmult_lt_compat_l; auto.
        assert (I9 : INR (n + 2) > INR (N + 2)).
        { apply lt_INR. apply plus_lt_compat_r.
          apply I3. }
        generalize (pos_INR N). intro I10.
        assert (I11 : INR (N + 2) > INR N).
        { apply lt_INR. apply Nat.lt_add_pos_r.
          apply Nat.lt_0_2. }
        apply Rinv_lt_contravar; auto.
        apply Rmult_gt_0_compat; lra. }
      lra. }
    generalize (H3 x H8 H13 H14). intros [H15 H16].
    generalize (H16 ε0 H4). intros [N H17].
    assert (H18 : (S N) ∈ dom[x]).
    { rewrite H10. apply AxiomII. reflexivity. }
    apply x_fx in H18 as H19; auto.
    pattern x at 2 in H19.
    rewrite H7 in H19. apply -> AxiomII' in H19.
    lazy beta in H19.
    generalize (H12 (S N)). intro H20.
    apply H11 in H20. apply AxiomcR in H20.
    rewrite <- H19 in H20.
    apply -> AxiomII in H20. lazy beta in H20.
    destruct H20 as [H20 H21].
    generalize (gt_Sn_n N). intro H22.
    apply H17 in H22.
    assert (H23 : {` λ n v, v = f[x[n]] `} [S N]
      = f[x[S N]]).
    { apply f_x; try apply H15. apply AxiomII'.
      reflexivity. }
    rewrite H23 in H22. lra.
Qed.

Theorem Theorem3_8' : ∀ (f : Fun) (x0 A : R), Function f
  -> x0 ∈ dom[f] -> f[x0] = A -> limit f x0 A
  -> ∀ (x : Seq), IsSeq x -> ran[x] ⊂ dom[f]
    -> limit_seq x x0
    -> limit_seq {` λ n v, v = f[x[n]] `} A.
Proof.
  intros f x0 A H0 H1 H2 H3.
  destruct H3 as [H3 [δ1' [H4 [H5 H6]]]].
  intros x H7 H8 H9. unfold limit_seq.
  assert (H10 : IsSeq {` λ n v, v = f[x[n]] `} ).
  { unfold IsSeq. split.
    - unfold Function. intros x1 y1 z1 I1 I2.
      applyAxiomII' I1. applyAxiomII' I2.
      rewrite I2; auto.
    - apply AxiomI. intro z; split; intro I1.
      + apply AxiomII. reflexivity.
      + apply AxiomII. exists (f[x[z]]).
        apply AxiomII'. reflexivity. }
  split; auto. intros ε H11.
  apply H6 in H11 as H12.
  destruct H12 as [δ [[H12 H13] H14]].
  apply H9 in H12 as H15.
  destruct H15 as [N H15]. exists N.
  intros n H16. apply H15 in H16 as H17.
  assert (H18 : Abs[x[n] - x0] >= 0).
  { apply Abs_Rge0. }
  assert (H19 : 0 <= Abs[x[n] - x0] < δ). lra.
  assert (H21 : Abs [f [x[n]] - A] < ε).
  { assert (I1 : 0 < Abs [x [n] - x0] < δ \/ Abs [x [n] - x0] = 0).
    lra. destruct I1 as [I1 | I1].
    - apply H14 in I1. assumption.
    - assert (I2 : x[n] - x0 = 0).
      { apply NNPP. intro J1. apply Abs_not_eq_0 in J1. lra. }
      apply Rminus_diag_uniq_sym in I2.
      rewrite <- I2. rewrite H2. unfold Rminus. rewrite Rplus_opp_r.
      rewrite Abs_ge; lra. }
  assert (H20 : {` λ(n0 : nat)(v : R),
    v = f [x [n0]] `} [n] = f[x[n]]).
  { apply f_x; try apply H10. apply AxiomII'.
    reflexivity. }
  rewrite H20. assumption.
Qed.

Theorem Theorem3_8_1' : ∀ (f : Fun) (x0 A : R), Function f
  -> x0 ∈ dom[f] -> f[x0] = A -> limit_pos f x0 A
  -> ∀ (x : Seq), IsSeq x -> ran[x] ⊂ dom[f]
    -> (∀ n, x0 <= x[n])
    -> limit_seq x x0
    -> limit_seq {` λ n v, v = f[x[n]] `} A.
Proof.
  intros f x0 A H0 H1 H2 H3.
  destruct H3 as [H3 [δ1' [H4 [H5 H6]]]].
  intros x H7 H8 H8' H9. unfold limit_seq.
  assert (H10 : IsSeq {` λ n v, v = f[x[n]] `} ).
  { unfold IsSeq. split.
    - unfold Function. intros x1 y1 z1 I1 I2.
      applyAxiomII' I1. applyAxiomII' I2.
      rewrite I2; auto.
    - apply AxiomI. intro z; split; intro I1.
      + apply AxiomII. reflexivity.
      + apply AxiomII. exists (f[x[z]]).
        apply AxiomII'. reflexivity. }
  split; auto. intros ε H11.
  apply H6 in H11 as H12.
  destruct H12 as [δ [[H12 H13] H14]].
  apply H9 in H12 as H15.
  destruct H15 as [N H15]. exists N.
  intros n H16. apply H15 in H16 as H17.
  assert (H19 : x0 <= x[n] < x0 + δ).
  { apply Abs_R in H17. generalize (H8' n); intro I1. lra. }
  assert (H21 : Abs [f [x[n]] - A] < ε).
  { assert (I1 : x0 < x[n] < x0 + δ \/ x[n] = x0).
    lra. destruct I1 as [I1 | I1].
    - apply H14 in I1. assumption.
    - rewrite I1. rewrite H2. unfold Rminus. rewrite Rplus_opp_r.
      rewrite Abs_ge; lra. }
  assert (H20 : {` λ(n0 : nat)(v : R),
    v = f [x [n0]] `} [n] = f[x[n]]).
  { apply f_x; try apply H10. apply AxiomII'.
    reflexivity. }
  rewrite H20. assumption.
Qed.

Theorem Theorem3_8_2' : ∀ (f : Fun) (x0 A : R), Function f
  -> x0 ∈ dom[f] -> f[x0] = A -> limit_neg f x0 A
  -> ∀ (x : Seq), IsSeq x -> ran[x] ⊂ dom[f]
    -> (∀ n, x[n] <= x0)
    -> limit_seq x x0
    -> limit_seq {` λ n v, v = f[x[n]] `} A.
Proof.
  intros f x0 A H0 H1 H2 H3.
  destruct H3 as [H3 [δ1' [H4 [H5 H6]]]].
  intros x H7 H8 H8' H9. unfold limit_seq.
  assert (H10 : IsSeq {` λ n v, v = f[x[n]] `} ).
  { unfold IsSeq. split.
    - unfold Function. intros x1 y1 z1 I1 I2.
      applyAxiomII' I1. applyAxiomII' I2.
      rewrite I2; auto.
    - apply AxiomI. intro z; split; intro I1.
      + apply AxiomII. reflexivity.
      + apply AxiomII. exists (f[x[z]]).
        apply AxiomII'. reflexivity. }
  split; auto. intros ε H11.
  apply H6 in H11 as H12.
  destruct H12 as [δ [[H12 H13] H14]].
  apply H9 in H12 as H15.
  destruct H15 as [N H15]. exists N.
  intros n H16. apply H15 in H16 as H17.
  assert (H19 : x0 - δ < x[n] <= x0 ).
  { apply Abs_R in H17. generalize (H8' n); intro I1. lra. }
  assert (H21 : Abs [f [x[n]] - A] < ε).
  { assert (I1 : x0 - δ < x[n] < x0 \/ x[n] = x0).
    lra. destruct I1 as [I1 | I1].
    - apply H14 in I1. assumption.
    - rewrite I1. rewrite H2. unfold Rminus. rewrite Rplus_opp_r.
      rewrite Abs_ge; lra. }
  assert (H20 : {` λ(n0 : nat)(v : R),
    v = f [x [n0]] `} [n] = f[x[n]]).
  { apply f_x; try apply H10. apply AxiomII'.
    reflexivity. }
  rewrite H20. assumption.
Qed.

Theorem Theorem3_8_1 : ∀ (f : Fun) (x0 δ' A : R), Function f
  -> δ' > 0 -> rightNeighbor0 x0 δ' ⊂ dom[f]
  -> limit_pos f x0 A
  -> ∀ (x : Seq), IsSeq x -> ran[x] ⊂ rightNeighbor0 x0 δ'
    -> limit_seq x x0
    -> limit_seq {` λ n v, v = f[x[n]] `} A.
Proof.
  intros f x0 δ' A H0 H1 H2 H3.
  destruct H3 as [H3 [δ1' [H4 [H5 H6]]]].
  intros x H7 H8 H9. unfold limit_seq.
  assert (H10 : IsSeq {` λ n v, v = f[x[n]] `} ).
  { unfold IsSeq. split.
    - unfold Function. intros x1 y1 z1 I1 I2.
      applyAxiomII' I1. applyAxiomII' I2.
      rewrite I2; auto.
    - apply AxiomI. intro z; split; intro I1.
      + apply AxiomII. reflexivity.
      + apply AxiomII. exists (f[x[z]]).
        apply AxiomII'. reflexivity. }
  split; auto. intros ε H11.
  apply H6 in H11 as H12.
  destruct H12 as [δ [[H12 H13] H14]].
  apply H9 in H12 as H15.
  destruct H15 as [N H15]. exists N.
  intros n H16. apply H15 in H16 as H17.
  assert (H18 : x0 < x[n]).
  { assert (I2 : x[n] ∈ ran[x]).
    { destruct H7 as [I2 I3].
      apply fx_ran; auto. rewrite I3.
      apply AxiomII. reflexivity. }
    apply H8 in I2. applyAxiomII I2. lra. }
  apply Abs_R in H17.
  assert (H19 : x0 < x[n] < x0 + δ). lra.
  apply H14 in H19.
  assert (H20 : {` λ(n0 : nat)(v : R),
    v = f [x [n0]] `} [n] = f[x[n]]).
  { apply f_x; try apply H10. apply AxiomII'.
    reflexivity. }
  rewrite H20. apply H19.
Qed.

Theorem Theorem3_8_2 : ∀ (f : Fun) (x0 δ' A : R), Function f
  -> δ' > 0 -> leftNeighbor0 x0 δ' ⊂ dom[f]
  -> limit_neg f x0 A
  -> ∀ (x : Seq), IsSeq x -> ran[x] ⊂ leftNeighbor0 x0 δ'
    -> limit_seq x x0
    -> limit_seq {` λ n v, v = f[x[n]] `} A.
Proof.
  intros f x0 δ' A H0 H1 H2 H3.
  destruct H3 as [H3 [δ1' [H4 [H5 H6]]]].
  intros x H7 H8 H9. unfold limit_seq.
  assert (H10 : IsSeq {` λ n v, v = f[x[n]] `} ).
  { unfold IsSeq. split.
    - unfold Function. intros x1 y1 z1 I1 I2.
      applyAxiomII' I1. applyAxiomII' I2.
      rewrite I2; auto.
    - apply AxiomI. intro z; split; intro I1.
      + apply AxiomII. reflexivity.
      + apply AxiomII. exists (f[x[z]]).
        apply AxiomII'. reflexivity. }
  split; auto. intros ε H11.
  apply H6 in H11 as H12.
  destruct H12 as [δ [[H12 H13] H14]].
  apply H9 in H12 as H15.
  destruct H15 as [N H15]. exists N.
  intros n H16. apply H15 in H16 as H17.
  assert (H18 : x[n] < x0).
  { assert (I2 : x[n] ∈ ran[x]).
    { destruct H7 as [I2 I3].
      apply fx_ran; auto. rewrite I3.
      apply AxiomII. reflexivity. }
    apply H8 in I2. applyAxiomII I2. lra. }
  apply Abs_R in H17.
  assert (H19 : x0 - δ < x[n] < x0). lra.
  apply H14 in H19.
  assert (H20 : {` λ(n0 : nat)(v : R),
    v = f [x [n0]] `} [n] = f[x[n]]).
  { apply f_x; try apply H10. apply AxiomII'.
    reflexivity. }
  rewrite H20. apply H19.
Qed.

(* 定理3.9 归结原则(右极限) *)

Fixpoint Fun_Theorem3_9 (f : Fun) (n : nat) (x0 δ' A ε0 : R) :=
  match n with
  | O => cR \{λ u, x0 < u < x0 + δ'/2
      /\ Abs [f [u] - A] >= ε0 \}
  | S n' => cR \{λ u, x0 < u < x0 +
      ((Fun_Theorem3_9 f n' x0 δ' A ε0)-x0)/(INR (n' + 3))
      /\ Abs [f [u] - A] >= ε0 \}
  end.

(* 归结原则(右极限) *)
Theorem Theorem3_9 : ∀ (f : Fun) (x0 δ' A : R), Function f
  -> δ' > 0 -> rightNeighbor0 x0 δ' ⊂ dom[f]
  ->
    limit_pos f x0 A
  <->
    ∀ (x : Seq), DecreaseSeq x -> ran[x] ⊂ rightNeighbor0 x0 δ'
    -> limit_seq x x0
    -> limit_seq {` λ n v, v = f[x[n]] `} A.
Proof.
  intros f x0 δ' A H0 H1 H2. split.
  - intro H3. destruct H3 as [H3 [δ1' [H4 [H5 H6]]]].
    intros x [H7 H30] H8 H9. unfold limit_seq.
    assert (H10 : IsSeq {` λ n v, v = f[x[n]] `} ).
    { unfold IsSeq. split.
      - unfold Function. intros x1 y1 z1 I1 I2.
        applyAxiomII' I1. applyAxiomII' I2.
        rewrite I2; auto.
      - apply AxiomI. intro z; split; intro I1.
        + apply AxiomII. reflexivity.
        + apply AxiomII. exists (f[x[z]]).
          apply AxiomII'. reflexivity. }
    split; auto. intros ε H11.
    apply H6 in H11 as H12.
    destruct H12 as [δ [[H12 H13] H14]].
    apply H9 in H12 as H15.
    destruct H15 as [N H15]. exists N.
    intros n H16. apply H15 in H16 as H17.
    assert (H18 : x[n] - x0 > 0).
    { assert (I2 : x[n] ∈ ran[x]).
      { destruct H7 as [I2 I3].
        apply fx_ran; auto. rewrite I3.
        apply AxiomII. reflexivity. }
      apply H8 in I2. applyAxiomII I2.
      lra. }
    assert (H19 : x0 < x[n] < x0 + δ).
    { rewrite Abs_gt in H17; auto. lra. }
    apply H14 in H19.
    assert (H20 : {` λ(n0 : nat)(v : R),
      v = f [x [n0]] `} [n] = f[x[n]]).
    { apply f_x; try apply H10. apply AxiomII'.
      reflexivity. }
    rewrite H20. apply H19.
  - intro H3. apply NNPP. intro H4.
    unfold limit in H4. apply not_and_or in H4.
    destruct H4 as [H4 | H4]; auto.
    apply not_ex_all_not with (n := δ') in H4.
    apply not_and_or in H4;
    destruct H4 as [H4 | H4]; auto.
    apply not_and_or in H4;
    destruct H4 as [H4 | H4]; auto.
    apply not_all_ex_not in H4.
    destruct H4 as [ε0 H4]. apply imply_to_and in H4.
    destruct H4 as [H4 H5].
    assert (H6 : ∀ δ, ~ (0 < δ < δ' /\
      (∀x : R,x0 < x < x0 + δ -> Abs [f [x] - A] < ε0))).
    { apply not_ex_all_not; apply H5. }
    assert (H7 : ∃ (x : Seq), x =
      {` λ n v, v = Fun_Theorem3_9 f n x0 δ' A ε0 `}).
    { exists ({` λ n v, v =
      Fun_Theorem3_9 f n x0 δ' A ε0 `}); reflexivity. }
    destruct H7 as [x H7].
    assert (H8 : IsSeq x).
    { split.
      - unfold Function. rewrite H7.
        intros x1 y1 z1 J1 J2.
        applyAxiomII' J1. applyAxiomII' J2.
        rewrite J2. apply J1.
      - apply AxiomI. intro z; split; intro J1.
        + apply AxiomII. reflexivity.
        + apply AxiomII.
          exists (Fun_Theorem3_9 f z x0 δ' A ε0).
          rewrite H7. apply AxiomII'.
          reflexivity. }
    assert (H9 : ∀ n, x[n] = Fun_Theorem3_9 f n x0 δ' A ε0).
    { intro n. apply f_x; try apply H8.
      rewrite H7. apply AxiomII'.
      reflexivity. }
    assert (H10 : ∀ n, x0 < (Fun_Theorem3_9 f n x0 δ' A ε0) < x0 + δ'
      /\ NotEmpty \{λ u, x0 < u < x0 +
        ((Fun_Theorem3_9 f n x0 δ' A ε0)-x0)/(INR (n + 3))
        /\ Abs [f [u] - A] >= ε0 \}).
    { intro n. induction n as [|n IHn].
      - assert (I1 : x0 < Fun_Theorem3_9 f 0 x0 δ' A ε0 < x0 + δ').
        { simpl. generalize (H6 (δ'/2)). intro I1.
          apply not_and_or in I1.
          destruct I1 as [I1 | I1]; try lra.
          apply not_all_ex_not in I1.
          destruct I1 as [xn I1]. apply imply_to_and in I1.
          assert (I2 : NotEmpty \{ λ u : R, x0 < u < x0 + δ' / 2
              /\ Abs [f [u] - A] >= ε0 \}).
          { exists xn. apply AxiomII. split; lra. }
          apply AxiomcR in I2 as I3.
          applyAxiomII I3. lra. }
        split; auto. generalize (H6
          (((Fun_Theorem3_9 f 0 x0 δ' A ε0)-x0)/3)).
        intro I2. apply not_and_or in I2.
        destruct I2 as [I2 | I2]; try lra.
        apply not_all_ex_not in I2.
        destruct I2 as [xn I2].
        apply imply_to_and in I2.
        exists xn. apply AxiomII.
        assert (I3 : INR(0+3) = 3).
        { simpl. field. }
        rewrite I3. split; lra.
      - destruct IHn as [IHn1 IHn2].
        assert (I1 : x0 < Fun_Theorem3_9
            f (S n) x0 δ' A ε0 < x0 + δ').
        { apply AxiomcR in IHn2. applyAxiomII IHn2.
          simpl. split; try lra.
          assert (I1 : (Fun_Theorem3_9 f n x0 δ' A ε0 - x0)
            / INR (n + 3) < (Fun_Theorem3_9 f n x0 δ' A ε0 - x0)).
          { assert (J1 : (Fun_Theorem3_9 f n x0 δ' A ε0 - x0) > 0).
            lra. assert (J2 : INR (n+3) > 1).
            { assert (K1 : 1 = INR 1).
              { simpl. reflexivity. }
              rewrite K1. apply lt_INR.
              apply Nat.lt_lt_add_l.
              apply lt_n_S. apply Nat.lt_0_2. }
            assert (J3 : 0 < 1*INR (n+3)).
            { apply Rmult_gt_0_compat; try apply Rlt_0_1.
              lra. }
            apply Rinv_lt_contravar in J2; auto.
            apply Rmult_lt_compat_l with
              (r := (Fun_Theorem3_9 f n x0 δ' A ε0 - x0))
               in J2; auto. lra. }
          lra. }
        split; auto. generalize (H6
          (((Fun_Theorem3_9 f (S n) x0 δ' A ε0)-x0)/INR (S n + 3))).
        intro I2. apply not_and_or in I2.
        destruct I2 as [I2 | I2].
        + exfalso. apply I2.
          assert (I3 : (Fun_Theorem3_9 f (S n) x0 δ' A ε0 - x0)
            / INR ((S n) + 3) < (Fun_Theorem3_9 f (S n) x0 δ' A ε0 - x0)).
          { assert (J1 : (Fun_Theorem3_9 f (S n) x0 δ' A ε0 - x0) > 0).
            lra. assert (J2 : INR ((S n)+3) > 1).
            { assert (K1 : 1 = INR 1).
              { simpl. reflexivity. }
              rewrite K1. apply lt_INR.
              apply Nat.lt_lt_add_l.
              apply lt_n_S. apply Nat.lt_0_2. }
            assert (J3 : 0 < 1*INR ((S n)+3)).
            { apply Rmult_gt_0_compat; try apply Rlt_0_1.
              lra. }
            apply Rinv_lt_contravar in J2; auto.
            apply Rmult_lt_compat_l with
              (r := (Fun_Theorem3_9 f (S n) x0 δ' A ε0 - x0))
               in J2; auto. lra. }
          split; try lra. assert (I4 : INR (S n + 3) > 0).
          { assert (J1 : 0 = (INR 0%nat)). reflexivity.
            rewrite J1. apply lt_INR.
            apply lt_plus_trans. apply gt_Sn_O. }
          apply Rinv_0_lt_compat in I4.
          apply Rmult_gt_0_compat; lra.
        + apply not_all_ex_not in I2.
          destruct I2 as [xn I2].
          apply imply_to_and in I2.
          exists xn. apply AxiomII.
          split; lra. }
    assert (H11 : DecreaseSeq x).
    { split; auto.
      intro n. rewrite H9. rewrite H9.
      simpl. generalize (H10 n). intro I1.
      destruct I1 as [I1 I2].
      apply AxiomcR in I2. applyAxiomII I2.
      assert (I3 : (Fun_Theorem3_9 f n x0 δ' A ε0 - x0)
            / INR (n + 3) < (Fun_Theorem3_9 f n x0 δ' A ε0 - x0)).
      { assert (J1 : (Fun_Theorem3_9 f n x0 δ' A ε0 - x0) > 0).
        lra. assert (J2 : INR (n+3) > 1).
        { assert (K1 : 1 = INR 1).
          { simpl. reflexivity. }
          rewrite K1. apply lt_INR.
          apply Nat.lt_lt_add_l.
          apply lt_n_S. apply Nat.lt_0_2. }
        assert (J3 : 0 < 1*INR (n+3)).
        { apply Rmult_gt_0_compat; try apply Rlt_0_1.
          lra. }
        apply Rinv_lt_contravar in J2; auto.
        apply Rmult_lt_compat_l with
          (r := (Fun_Theorem3_9 f n x0 δ' A ε0 - x0))
           in J2; auto. lra. }
      lra. }
    assert (H12 : ran[ x] ⊂ rightNeighbor0 x0 δ').
    { intros z I1. applyAxiomII I1.
      destruct I1 as [n I1]. apply f_x in I1; try apply H8.
      rewrite <- I1. rewrite H9. apply AxiomII.
      apply H10. }
    assert (H13 : ∀ n, x0 < x[n] < x0 + δ'/(INR (n+2))).
    { intro n. rewrite H9. induction n as [|n IHn].
      - simpl. generalize (H10 0%nat). intro I1.
        destruct I1 as [I1 I2].
        assert (I3 : NotEmpty \{ λ u : R,x0 < u < x0 + δ' / 2
          /\ Abs [f [u] - A] >= ε0 \}).
        { destruct I2 as [xn I2]. exists xn.
          apply -> AxiomII in I2. lazy beta in I2.
          destruct I2 as [I2 I3]. apply AxiomII.
          split; auto. assert (I4 : INR (0+3) = 3).
          { simpl. field. }
          rewrite I4 in I2. lra. }
        apply AxiomcR in I3. applyAxiomII I3. lra.
      - simpl Fun_Theorem3_9.
        assert (I1 : (S n + 2 = n + 3)%nat).
        { assert (J1 : (3 = 1 + 2)%nat). reflexivity.
          rewrite J1. rewrite plus_assoc.
          assert (J2 : (S n = n + 1)%nat).
          { rewrite Nat.add_comm. reflexivity. }
          rewrite J2. reflexivity. }
        rewrite I1. generalize (H10 n). intro I2.
        destruct I2 as [I2 I3].
        apply AxiomcR in I3. applyAxiomII I3.
        assert (I4 : (Fun_Theorem3_9 f n x0 δ' A ε0 - x0)
          / INR (n + 3) < δ' / INR (n + 3)).
        { assert (J1 : INR (n + 3) > 0).
          { assert (K1 : 0 = INR 0).
            { simpl. reflexivity. }
            rewrite K1. apply lt_INR.
            apply Nat.lt_lt_add_l.
            apply Nat.lt_lt_succ_r.
            apply Nat.lt_0_2. }
          apply Rinv_0_lt_compat in J1.
          apply Rmult_lt_compat_r; auto. lra. }
        lra. }
    assert (H14 : limit_seq x x0).
    { split; auto. intros ε I1.
      generalize (Archimedes ε δ'). intro I2.
      generalize (I2 I1 H1). intro I3.
      destruct I3 as [N I3]. exists N.
      intros n I4. generalize (H13 n).
      intro I5. assert (I6 : INR (n + 2) > INR N).
      { apply lt_INR. apply lt_plus_trans. apply I4. }
      assert (I7 : x[n] - x0 > 0). lra.
      rewrite Abs_gt; auto.
      assert (I8 : 0 < INR N).
      { destruct (pos_INR N) as [J1 | J1]; auto.
        exfalso. rewrite <- J1 in I3.
        rewrite Rmult_0_l in I3. lra. }
      assert (I9 : 0 < INR (n + 2)). lra.
      assert (I10 : 0 < (INR N) * (INR (n + 2))).
      { apply Rmult_gt_0_compat; auto. }
      apply Rinv_lt_contravar in I6; auto.
      assert (I11 : δ' / INR (n + 2) < δ' / INR N).
      { apply Rmult_lt_compat_l; auto. }
      assert (I12 : δ' / INR N < ε).
      { apply Rmult_lt_reg_r with (r := INR N); auto.
        unfold Rdiv. rewrite Rmult_assoc.
        rewrite Rinv_l; lra. }
      lra. }
    generalize (H3 x H11 H12 H14). intro H15.
    unfold limit_seq in H15. destruct H15 as [H15 H16].
    generalize (H16 ε0 H4). intro H17.
    destruct H17 as [N H17].
    generalize (H17 (S N) (gt_Sn_n N)). intro H18.
    assert (H19 : {` λ n v, v = f [x [n]] `} [S N]
      = f[x[S N]]).
    { apply f_x; try apply H15. apply AxiomII'.
      reflexivity. }
    rewrite H19 in H18. generalize (H9 (S N)).
    intro H20. simpl in H20.
    generalize (H10 N). intros [H21 H22].
    apply AxiomcR in H22. rewrite <- H20 in H22.
    applyAxiomII H22. lra.
Qed.

(* 定理3.10 单调有界定理 *)
Theorem Theorem3_10 : ∀ (f : Fun) (x0 δ' : R),
  δ' > 0
  -> IntervalMonotonicFun f (rightNeighbor0 x0 δ')
  -> IntervalBoundedFun f (rightNeighbor0 x0 δ')
  -> (∃ A, limit_pos f x0 A).
Proof.
  intros f x0 δ' H0 [H1 | H1] [H2 [H3 [M H4]]].
  - assert (H5 : ∃ Range, Range = \{ λ y,
        ∃ x, (x ∈ rightNeighbor0 x0 δ') /\ y = f[x] \}).
    { exists \{ λ y, ∃ x, (x ∈ rightNeighbor0 x0 δ')
        /\ y = f[x] \}; reflexivity. }
    destruct H5 as [Range H5].
    assert (H6 : NotEmpty Range).
    { exists (f[x0+δ'/2]). rewrite H5.
      apply AxiomII. exists (x0+δ'/2).
      split; auto. apply AxiomII. split; lra. }
    assert (H7 : (∃ L, Lower Range L)).
    { exists (-M). unfold Lower. intros y I1.
      rewrite H5 in I1. applyAxiomII I1.
      destruct I1 as [x [I1 I2]].
      rewrite I2. apply H4 in I1.
      apply Abs_le_R in I1. lra. }
    apply Sup_inf_principle in H6 as [H8 H9].
    apply H9 in H7. destruct H7 as [A [H7 H10]].
    exists A. unfold limit_pos. split; auto.
    exists δ'. repeat split; auto.
    intros ε H11. assert (H12 : A + ε > A). lra.
    apply H10 in H12 as H13.
    destruct H13 as [y' [H13 H14]].
    unfold Lower in H7. apply H7 in H13 as H15.
    rewrite H5 in H13. applyAxiomII H13.
    destruct H13 as [x' [H13 H16]].
    exists (x'-x0). applyAxiomII H13.
    split; try lra. intros x H17. apply Abs_R.
    unfold IntervalIncreaseFun in H1.
    destruct H1 as [H1 [H18 H19]].
    assert (H20 : x ∈ rightNeighbor0 x0 δ').
    { apply AxiomII. lra. }
    assert (H21 : x' ∈ rightNeighbor0 x0 δ').
    { apply AxiomII. lra. }
    generalize (H19 x x' H20 H21). intro H22.
    assert (H23 : f[x] ∈ Range).
    { rewrite H5. apply AxiomII. exists x.
      split; auto. }
    apply H7 in H23. lra.
  - assert (H5 : ∃ Range, Range = \{ λ y,
        ∃ x, (x ∈ rightNeighbor0 x0 δ') /\ y = f[x] \}).
    { exists \{ λ y, ∃ x, (x ∈ rightNeighbor0 x0 δ')
        /\ y = f[x] \}; reflexivity. }
    destruct H5 as [Range H5].
    assert (H6 : NotEmpty Range).
    { exists (f[x0+δ'/2]). rewrite H5.
      apply AxiomII. exists (x0+δ'/2).
      split; auto. apply AxiomII. split; lra. }
    assert (H7 : (∃ M, Upper Range M)).
    { exists M. unfold Upper. intros y I1.
      rewrite H5 in I1. applyAxiomII I1.
      destruct I1 as [x [I1 I2]].
      rewrite I2. apply H4 in I1.
      apply Abs_le_R in I1. lra. }
    apply Sup_inf_principle in H6 as [H8 H9].
    apply H8 in H7. destruct H7 as [A [H7 H10]].
    exists A. unfold limit_pos. split; auto.
    exists δ'. repeat split; auto.
    intros ε H11. assert (H12 : A - ε < A). lra.
    apply H10 in H12 as H13.
    destruct H13 as [y' [H13 H14]].
    unfold Upper in H7. apply H7 in H13 as H15.
    rewrite H5 in H13. applyAxiomII H13.
    destruct H13 as [x' [H13 H16]].
    exists (x'-x0). applyAxiomII H13.
    split; try lra. intros x H17. apply Abs_R.
    unfold IntervalDecreaseFun in H1.
    destruct H1 as [H1 [H18 H19]].
    assert (H20 : x ∈ rightNeighbor0 x0 δ').
    { apply AxiomII. lra. }
    assert (H21 : x' ∈ rightNeighbor0 x0 δ').
    { apply AxiomII. lra. }
    generalize (H19 x x' H20 H21). intro H22.
    assert (H23 : f[x] ∈ Range).
    { rewrite H5. apply AxiomII. exists x.
      split; auto. }
    apply H7 in H23. lra.
Qed.

(* 定理3.11 柯西准则 *)
Theorem Theorem3_11 : ∀ (f : Fun) (x0 δ' : R), δ' > 0 -> Function f
  -> Neighbor0 x0 δ' ⊂ dom[f]
  ->
    (∃ A, limit f x0 A)
  <-> (∀ ε, ε > 0 -> (∃ δ, 0 < δ < δ' /\
        (∀ x' x'', x' ∈ Neighbor0 x0 δ -> x'' ∈ Neighbor0 x0 δ
          -> Abs[f[x'] - f[x'']] < ε))).
Proof.
  intros f x0 δ' H0 H1 H2. split; intro H3.
  - destruct H3 as [A H3].
    destruct H3 as [H3 [δ1' [H4 [H5 H6]]]].
    intros ε H7. assert (H8 : ε / 2 > 0). lra.
    apply H6 in H8 as H9.
    assert (H10 : ∃δ : R,0 < δ < δ' /\
      (∀x : R,0 < Abs [x - x0] < δ -> Abs [f [x] - A] < ε / 2)).
    { destruct H9 as [δ [I1 I2]].
      destruct (Rlt_or_le δ' δ1') as [I3 | I3].
      - destruct (Rlt_or_le δ δ') as [I4 | I4].
        + exists δ. split; auto; lra.
        + exists (δ' / 2). split; try lra.
          intros x I5. apply I2. lra.
      - exists δ. split; try lra. intros x I4.
        apply I2. apply I4. }
    destruct H10 as [δ [H10 H11]]. exists δ. split; auto.
    intros x' x'' H12 H13.
    applyAxiomII H12. applyAxiomII H13.
    apply H11 in H12. apply H11 in H13.
    assert (H14 : f[x'] - f[x''] = (f[x']-A)-(f[x'']-A)).
    field. rewrite H14.
    generalize (Abs_minus_le (f[x']-A) (f[x'']-A)).
    intro H15. lra.
  - assert (H4 : ∀ (x : Seq), IsSeq x -> ran[x] ⊂ Neighbor0 x0 δ'
      -> limit_seq x x0 -> Convergence {` λ n v, v = f[x[n]] `}).
    { intros x I1 I2 I3.
      assert (I4 : IsSeq {` λ n v, v = f[x[n]] `}).
      { split.
        - unfold Function. intros x1 y1 z1 J1 J2.
          applyAxiomII' J1; applyAxiomII' J2.
          rewrite J2. assumption.
        - apply AxiomI. intro z; split; intro J1.
          + apply AxiomII. reflexivity.
          + apply AxiomII. exists (f[x[z]]). apply AxiomII'.
            reflexivity. }
      apply Theorem2_11; auto.
      intros ε I5. apply H3 in I5 as I6.
      destruct I6 as [δ [I6 I7]]. unfold limit_seq in I3.
      destruct I3 as [I3 I8]. destruct I6 as [I6 I9].
      apply I8 in I6 as I10. destruct I10 as [N I10].
      exists N. intros n m I11 I12. apply I10 in I11 as I13.
      apply I10 in I12 as I14.
      assert (I15 : ∀ n,  {` λ n0 v, v = f [x [n0]] `} [n] = f[x[n]]).
      { intro n0. apply f_x; try apply I4. apply AxiomII'.
        reflexivity. }
      rewrite I15. rewrite I15.
      assert (I16 : ∀ n, Abs [x [n] - x0] > 0).
      { intro n0.
        assert (J1 : x[n0] ∈ ran[x]).
        { apply fx_ran; try apply I1. destruct I1 as [I1 J1].
          rewrite J1. apply AxiomII. reflexivity. }
        apply I2 in J1. applyAxiomII J1.
        apply J1. }
      apply I7; apply AxiomII; split; try lra; apply I16. }
    assert (H5 : ∃ x1, x1 = {` λ n v, v = x0 + δ' / (INR (S (S n))) `}).
    { exists {` λ n v, v = x0 + δ' / (INR (S (S n))) `}.
      reflexivity. }
    destruct H5 as [x1 H5].
    assert (H6 : IsSeq x1).
    { unfold IsSeq. split.
      - unfold Function. rewrite H5. intros x y z I1 I2.
        applyAxiomII' I1. applyAxiomII' I2.
        rewrite I2. apply I1.
      - apply AxiomI. intro n; split; intro I1.
        + apply AxiomII. reflexivity.
        + apply AxiomII. exists (x0 + δ' / (INR (S (S n)))).
          rewrite H5. apply AxiomII'.
          reflexivity. }
    assert (H7 : ran[x1] ⊂ Neighbor0 x0 δ').
    { intros y I1. applyAxiomII I1. destruct I1 as [n I1].
      rewrite H5 in I1. apply -> AxiomII' in I1.
      assert (I2 : y = x0 + δ' / (INR (S (S n)))).
      { apply I1. }
      rewrite I2. apply AxiomII.
      assert (I4 : δ' / INR (S (S n)) > 0).
      { rewrite S_INR. apply Rdiv_lt_0_compat; auto.
        generalize (pos_INR (S n)). intro I4. lra. }
      assert (I3 : x0 + δ' / INR (S (S n)) - x0 = δ' / INR (S (S n))).
      lra. rewrite I3.
      split.
      - apply Abs_not_eq_0. apply Rgt_not_eq.
        auto.
      - apply Abs_gt in I4 as I5. rewrite I5. rewrite S_INR.
        rewrite S_INR. generalize (pos_INR n). intro I6.
        assert (I7 : INR n + 1 + 1 > 1). lra.
        unfold Rdiv. assert (I8 : 1 <= 1). right. reflexivity.
        apply Rinv_1_lt_contravar in I7 as I9; auto.
        rewrite Rinv_1 in I9.
        apply Rmult_lt_compat_l with (r := δ') in I9; auto.
        rewrite Rmult_1_r in I9. assumption. }
    assert (H8 : limit_seq x1 x0).
    { split; auto. intros ε I1.
      generalize (Archimedes ε δ' I1 H0).
      intro I2. destruct I2 as [N I2].
      exists N. intros n I3.
      assert (I4 : x1[n] = x0 + δ' / INR (S (S n))).
      { apply f_x; try apply H6. rewrite H5.
        apply AxiomII'. reflexivity. }
      rewrite I4.
      assert (I5 : x0 + δ' / INR (S (S n)) - x0 = δ' / INR (S (S n))).
      lra. rewrite I5.
      assert (I6 : δ' / INR (S (S n)) > 0).
      { rewrite S_INR. apply Rdiv_lt_0_compat; auto.
        generalize (pos_INR (S n)). intro I7. lra. }
      apply Abs_gt in I6. rewrite I6.
      rewrite S_INR. rewrite S_INR.
      assert (I7 : (INR n + 1 + 1) * ε > INR N * ε).
      { apply Rmult_gt_compat_r; auto.
        assert (I8 : INR n > INR N).
        { apply lt_INR. apply I3. }
        lra. }
      generalize (Rgt_trans ((INR n + 1 + 1) * ε) (INR N * ε) δ' I7 I2).
      intro I8. assert (I9 : (INR n + 1 + 1) > 0).
      { generalize (pos_INR n). intro I9. lra. }
      unfold Rdiv. apply Rinv_0_lt_compat in I9 as I10.
      apply Rmult_gt_compat_r with (r := / (INR n + 1 + 1)) in I8; auto.
      assert (I11 : (INR n + 1 + 1) * ε * / (INR n + 1 + 1)
        = ε).
      field. lra. rewrite I11 in I8. apply I8. }
    generalize (H4 x1 H6 H7 H8). intro H9.
    destruct H9 as [A H9]. exists A.
    apply (Theorem3_8 f x0 δ' A H1 H0 H2).
    intros x H10 H11 H12.
    assert (H13 : ∃ z, z = {` λ n v, ∃ m,
      ((n = m + m)%nat /\ v = x1[m]) \/
        ((n = m + m + 1)%nat /\ v = x[m]) `}).
    { exists {` λ n v, ∃ m, ((n = m + m)%nat /\ v = x1[m]) \/
        ((n = m + m + 1)%nat /\ v = x[m]) `}. reflexivity. }
    destruct H13 as [z H13].
    assert (H14 : ∀ n : nat, ∃ m, (n = m + m \/ n = m + m + 1)%nat).
    { intro n. induction n as [|n IHn].
      - exists 0%nat. left. simpl. reflexivity.
      - destruct IHn as [m [IHn | IHn]].
        + exists m. right. rewrite IHn. rewrite Nat.add_1_r.
          reflexivity.
        + exists (S m). left. rewrite IHn. rewrite Nat.add_1_r.
          simpl. rewrite (Nat.add_comm m (S m)).
          simpl. reflexivity. }
    assert (H15 : ∀ n m1 m2, (n = m1 + m1)%nat ->
      (n = m2 + m2 + 1)%nat -> False).
    { intros n m1 m2 I1 I2. rewrite I1 in I2.
      assert (I3 : (m1 + m1 - (m2 + m2))%nat = 1%nat).
      { rewrite I2. rewrite minus_plus. reflexivity. }
      assert (I4 : ∀ k, (2 * k = k + k)%nat).
      { intro k. induction k as [|k IHk].
        - simpl. reflexivity.
        - simpl. rewrite <- plus_n_O. reflexivity. }
      rewrite <- I4 in I3. rewrite <- I4 in I3.
      rewrite <- Nat.mul_sub_distr_l in I3.
      assert (I5 : ∀ k, (2 * k = 1)%nat -> False).
      { intros k J1. destruct k as [|k].
        - simpl in J1. discriminate.
        - generalize (gt_Sn_O k). intro J2.
          apply lt_le_S in J2 as J3.
          assert (J4 : (2 * S k > S k)%nat).
          { rewrite I4.
            apply plus_gt_compat_l with (p := S k) in J2.
            rewrite <- plus_n_O in J2. apply J2. }
          generalize (Nat.le_lt_trans 1%nat (S k) (2 * S k)%nat J3 J4).
          intro J5. apply Nat.lt_neq in J5. apply J5.
          rewrite J1. reflexivity. }
      apply (I5 (m1 - m2)%nat). assumption. }
    assert (H16 : ∀ k, (2 * k = k + k)%nat).
    { intro k. induction k as [|k IHk].
      - simpl. reflexivity.
      - simpl. rewrite <- plus_n_O. reflexivity. }
    assert (H17 : IsSeq z).
    { rewrite H13. split.
      - intros n v1 v2 I1 I2. applyAxiomII' I1. applyAxiomII' I2.
        destruct I1 as [m1 I1]. destruct I2 as [m2 I2].
        destruct I1 as [I1 | I1].
        + destruct I2 as [I2 | I2].
          * destruct I1 as [I1 I3]. destruct I2 as [I2 I4].
            assert (I5 : m1 = m2).
            { rewrite I1 in I2. apply NNPP. intro I5.
              apply not_eq in I5. destruct I5 as [I5 | I5].
              - generalize (plus_lt_compat m1 m2 m1 m2 I5 I5).
                intro I6. apply Nat.lt_neq in I6. auto.
              - generalize (plus_lt_compat m2 m1 m2 m1 I5 I5).
                intro I6. apply Nat.lt_neq in I6. apply I6.
                rewrite I2. reflexivity. }
            rewrite I4. rewrite <- I5. assumption.
          * destruct I1 as [I1 I3]. destruct I2 as [I2 I4].
            exfalso. apply (H15 n m1 m2); auto.
        + destruct I2 as [I2 | I2].
          * destruct I1 as [I1 I3]. destruct I2 as [I2 I4].
            exfalso. apply (H15 n m2 m1); auto.
          * destruct I1 as [I1 I3]. destruct I2 as [I2 I4].
            assert (I5 : m1 = m2).
            { rewrite I1 in I2. apply NNPP. intro I5.
              apply not_eq in I5. destruct I5 as [I5 | I5].
              - apply plus_lt_compat_r with (p := 1%nat) in I5 as I6.
                generalize (plus_lt_compat
                  m1 m2 (m1 + 1)%nat (m2 + 1)%nat I5 I6).
                intro I7. rewrite <- plus_assoc_reverse in I7.
                rewrite <- plus_assoc_reverse in I7.
                apply Nat.lt_neq in I7. auto.
              - apply plus_lt_compat_r with (p := 1%nat) in I5 as I6.
                generalize (plus_lt_compat
                  m2 m1 (m2 + 1)%nat (m1 + 1)%nat I5 I6).
                intro I7. rewrite <- plus_assoc_reverse in I7.
                rewrite <- plus_assoc_reverse in I7.
                apply Nat.lt_neq in I7. auto. }
            rewrite I4. rewrite <- I5. assumption.
      - apply AxiomI. intro k; split; intro I1.
        + apply AxiomII. reflexivity.
        + apply AxiomII. generalize (H14 k). intro I2.
          destruct I2 as [m [I2 | I2]].
          * exists (x1[m]). apply AxiomII'. exists m.
            left. split; auto.
          * exists (x[m]). apply AxiomII'. exists m.
            right. split; auto. }
    assert (H18 : ran[z] ⊂ Neighbor0 x0 δ').
    { intros v I1. applyAxiomII I1. destruct I1 as [k I1].
      rewrite H13 in I1. applyAxiomII' I1.
      destruct I1 as [m [[I1 I2] | [I1 I2]]].
      - apply H7. rewrite I2. destruct H6 as [H6 I3].
        apply fx_ran; auto. rewrite I3. apply AxiomII.
        reflexivity.
      - apply H11. rewrite I2. destruct H10 as [H10 I3].
        apply fx_ran; auto. rewrite I3. apply AxiomII.
        reflexivity. }
    assert (H19 : limit_seq z x0).
    { split; auto. intros ε I1. apply H8 in I1 as I2.
      apply H12 in I1 as I3. destruct I3 as [N2 I3].
      destruct I2 as [N1 I2].
      generalize (Max_nat_2 (N1 + N1)%nat (N2 + N2 + 1)%nat).
      intro I4. destruct I4 as [N [I4 I5]].
      exists N. intros n I6. generalize (H14 n).
      destruct H17 as [H17 I7].
      intros [m [I8 | I8]].
      - assert (I9 : z[n] = x1[m]).
        { apply f_x; auto. rewrite H13.
          apply AxiomII'. exists m. left. split; auto. }
        rewrite I9. generalize (Nat.lt_trans (N1 + N1)%nat N n I4 I6).
        intro I10. rewrite I8 in I10.
        assert (I11 : (N1 < m)%nat).
        { apply NNPP. intro J1. apply not_lt in J1.
          generalize (plus_le_compat m N1 m N1 J1 J1).
          intro J2. apply lt_not_le in I10. auto. }
        apply I2. assumption.
      - assert (I9 : z[n] = x[m]).
        { apply f_x; auto. rewrite H13.
          apply AxiomII'. exists m. right. split; auto. }
        rewrite I9. generalize (Nat.lt_trans
          (N2 + N2 + 1)%nat N n I5 I6).
        intro I10. rewrite I8 in I10.
        assert (I11 : (N2 < m)%nat).
        { apply NNPP. intro J1. apply not_lt in J1.
          apply plus_le_compat_r with (p := 1%nat) in J1 as J2.
          generalize (plus_le_compat m N2 (m + 1)%nat
            (N2 + 1)%nat J1 J2).
          rewrite <- plus_assoc_reverse.
          rewrite <- plus_assoc_reverse.
          intro J3.  apply lt_not_le in I10. auto. }
        apply I3. assumption. }
    generalize (H4 x H10 H11 H12). intro H20.
    generalize (H4 z H17 H18 H19). intros [B H21].
    assert (H22 : SubSeq {` λ (n : nat)(v : R), v = f [z [n]] `}
      {` λ(n : nat)(v : R), v = f [x1 [n]] `}).
    { unfold SubSeq. destruct H20 as [C [H20 H22]].
      destruct H21 as [H21 H23]. destruct H9 as [H9 H24].
      split; [idtac | split]; auto.
      exists {` λ m n, n = (m + m)%nat `}.
      assert (I1 : StrictlyIncreaseFun_nat
        {` λ m n, n = (m + m)%nat `}).
      { unfold StrictlyIncreaseFun_nat. split.
        - unfold Function. intros m n1 n2 I1 I2.
          applyAxiomII' I1. applyAxiomII' I2.
          rewrite I2. assumption.
        - intros m1 m2 n1 n2 I1 I2 I3.
          applyAxiomII' I1. applyAxiomII' I2.
          rewrite I1. rewrite I2.
          apply plus_lt_compat; auto. }
      split; auto. split.
      - apply AxiomI. intro n; split; intro I2.
        + apply AxiomII. reflexivity.
        + apply AxiomII. exists (n + n)%nat.
          apply AxiomII'. reflexivity.
      - intro n. assert (I2 : {` λ n0 v, v = f [x1 [n0]] `} [n]
          = f[x1[n]]).
        { apply f_x; try apply H9. apply AxiomII'.
          reflexivity. }
        rewrite I2. assert (I3 : {` λ m n0, n0 = (m + m)%nat `}
          \[ n \] = (n + n)%nat).
        { apply f_x_N; try apply I1. apply AxiomII'.
          reflexivity. }
        rewrite I3. assert (I4 : {` λ n0 v, v = f [z [n0]] `}
          [(n + n)%nat] = f[z[(n + n)%nat]]).
        { apply f_x; try apply H21. apply AxiomII'.
          reflexivity. }
        rewrite I4. assert (I5 : z[(n + n)%nat] = x1[n]).
        { apply f_x; try apply H17. rewrite H13.
          apply AxiomII'. exists n. left. split; reflexivity. }
        rewrite I5. reflexivity. }
    assert (H23 : SubSeq {` λ (n : nat)(v : R), v = f [z [n]] `}
      {` λ(n : nat)(v : R), v = f [x [n]] `}).
    { unfold SubSeq. destruct H20 as [C [H20 H23]].
      destruct H21 as [H21 H24].
      split; [idtac | split]; auto.
      exists {` λ m n, n = (m + m + 1)%nat `}.
      assert (I1 : StrictlyIncreaseFun_nat
        {` λ m n, n = (m + m + 1)%nat `}).
      { unfold StrictlyIncreaseFun_nat. split.
        - unfold Function. intros m n1 n2 I1 I2.
          applyAxiomII' I1. applyAxiomII' I2.
          rewrite I2. assumption.
        - intros m1 m2 n1 n2 I1 I2 I3.
          applyAxiomII' I1. applyAxiomII' I2.
          rewrite I1. rewrite I2.
          generalize (plus_lt_compat_r m1 n1 1%nat I3).
          intro I4. rewrite plus_assoc_reverse.
          rewrite plus_assoc_reverse.
          apply plus_lt_compat; auto. }
      split; auto. split.
      - apply AxiomI. intro n; split; intro I2.
        + apply AxiomII. reflexivity.
        + apply AxiomII. exists (n + n + 1)%nat.
          apply AxiomII'. reflexivity.
      - intro n. assert (I2 : {` λ n0 v, v = f [x [n0]] `} [n]
          = f[x[n]]).
        { apply f_x; try apply H20. apply AxiomII'.
          reflexivity. }
        rewrite I2. assert (I3 : {` λ m n0, n0 = (m + m + 1)%nat `}
          \[ n \] = (n + n + 1)%nat).
        { apply f_x_N; try apply I1. apply AxiomII'.
          reflexivity. }
        rewrite I3. assert (I4 : {` λ n0 v, v = f [z [n0]] `}
          [(n + n + 1)%nat] = f[z[(n + n + 1)%nat]]).
        { apply f_x; try apply H21. apply AxiomII'.
          reflexivity. }
        rewrite I4. assert (I5 : z[(n + n + 1)%nat] = x[n]).
        { apply f_x; try apply H17. rewrite H13.
          apply AxiomII'. exists n. right. split; reflexivity. }
        rewrite I5. reflexivity. }
    generalize (SubSeqEqual {` λ n v, v = f [z [n]] `} B H21).
    intro H24. apply H24 in H22. apply H24 in H23.
    generalize (Theorem2_2 {` λ n v, v = f [x1 [n]] `} A B H9 H22).
    intro H25. rewrite H25. assumption.
Qed.

End A3_3.

Export A3_3.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.QArith.QArith Coq.QArith.Qabs.
Require Import Coq.QArith.Qpower Coq.QArith.Qround.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.order.TotalOrder.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

(** Positive rational numbers *)

Definition Qpos: Set := sig (Qlt 0).
Definition QposEq (a b:Qpos) := Qeq (proj1_sig a) (proj1_sig b).
Lemma QposEq_refl : forall a : Qpos, QposEq a a.
Proof.
  reflexivity.
Qed.
Lemma Qpos_ispos : forall a:Qpos, 0 < proj1_sig a.
Proof.
  intros. destruct a; exact q.
Qed.
Lemma Qpos_nonneg : forall a:Qpos, 0 <= proj1_sig a.
Proof.
  intros. apply Qlt_le_weak. destruct a; exact q.
Qed.
Lemma Qpos_nonzero : forall a:Qpos, ~(proj1_sig a == 0).
Proof.
  intros. intro abs. destruct a. simpl in abs.
  rewrite abs in q. exact (Qlt_irrefl 0 q).
Qed.
Definition Qpos_plus (x y:Qpos) : Qpos.
Proof.
  exists (proj1_sig x + proj1_sig y).
  apply (Qle_lt_trans _ (0+0) _ (Qle_refl _)).
  apply Qplus_lt_le_compat. destruct x; assumption.
  apply Qlt_le_weak; destruct y; assumption.
Defined.
Definition Qpos_mult (x y:Qpos) : Qpos.
Proof.
  exists (proj1_sig x * proj1_sig y).
  apply (Qle_lt_trans _ (proj1_sig x * 0)).
  rewrite Qmult_0_r. apply Qle_refl.
  apply Qmult_lt_l. destruct x; assumption.
  destruct y; assumption.
Defined.
Bind Scope Qpos_scope with Qpos.
Delimit Scope Qpos_scope with Qpos.

Notation "a # b" := (exist (Qlt 0) (Qmake (Z.pos a) b) eq_refl) (at level 55, no associativity) : Qpos_scope.
Infix "+" := Qpos_plus : Qpos_scope.
Infix "*" := Qpos_mult : Qpos_scope.

Definition comparison_eq_dec (a b: comparison): { a = b } + { a <> b}.
 destruct a, b; try (left; reflexivity); try (right; discriminate).
Defined.
Lemma Zlt_hprop (a b: Z) (p q: (a < b)%Z): p = q.
Proof.
 unfold Z.lt in *. destruct p. intros.
 apply (Eqdep_dec.K_dec_set comparison_eq_dec).
 reflexivity.
Qed.
Lemma Qpos_hprop (a b: Qpos)
  : proj1_sig a = proj1_sig b -> a = b.
Proof.
 destruct a, b. intros H. simpl in H. subst x0.
 f_equal. exact (Zlt_hprop _ _ q q0).
Qed.

Lemma Qpos_red_ispos : forall a:Qpos, 0 < Qred (proj1_sig a).
Proof.
  destruct a. simpl.
  rewrite -> Qred_correct. exact q.
Qed.
Definition Qpos_red (a:Qpos) : Qpos
  := exist _ (Qred (proj1_sig a)) (Qpos_red_ispos a).
(* By reducing, we get true equality *)
Lemma Qpos_red_eq : forall (a b : Qpos), QposEq a b -> Qpos_red a = Qpos_red b.
Proof.
 intros p q H.
 apply Qpos_hprop. simpl.
 apply Qred_complete. exact H.
Qed.

Definition Qpos_sum (l:list Qpos) : Q := List.fold_right
(fun (x:Qpos) (y:Q) => proj1_sig x + y) 0%Q l.
Lemma Qpos_sum_nonneg : forall l, 0 <= Qpos_sum l.
Proof.
 induction l. apply Qle_refl.
 simpl. apply (Qle_trans _ (0+0) _ (Qle_refl _)).
 apply Qplus_le_compat.
 destruct a. apply Qlt_le_weak, q. exact IHl.
Qed.
Definition Qpos_sub (a b : Q)
  : a < b
    -> {c : Qpos | b == a + proj1_sig c}.
Proof.
  intro H. assert (0 < b - a).
  { apply (Qplus_lt_l _ _ a).
    destruct a,b. simpl. ring_simplify. exact H. }
  exists (exist _ _ H0).
  destruct a,b; unfold QposEq; simpl. ring_simplify. reflexivity.
Defined.
Definition QabsQpos (x : Q) : Qpos :=
  match x with
  | 0 # _ => exist (Qlt 0) (1#1) eq_refl
  | (Zpos an) # ad => exist (Qlt 0) (Z.pos an # ad) eq_refl
  | (Zneg an) # ad => exist (Qlt 0) (Z.pos an # ad) eq_refl
  end.
Definition Qpos_inv (x : Qpos) : Qpos.
Proof.
  exists (/ proj1_sig x). destruct x.
  apply Qinv_lt_0_compat, q.
Defined.
Lemma Qpos_power_ispos : forall (x:Qpos) (z : Z), 0 < proj1_sig x^z.
Proof.
 intros x z.
 assert (0 < proj1_sig x) as xpos by (destruct x; exact q).
 destruct (Qle_lt_or_eq
             _ _ (Qpower_pos (proj1_sig x) z (Qlt_le_weak _ _ xpos)));[assumption|].
 destruct z.
   discriminate H.
  elim (Qpower_not_0_positive (proj1_sig x) p).
  destruct x. intro abs. simpl in abs. clear H xpos. rewrite abs in q.
  exact (Qlt_irrefl 0 q).
  symmetry; assumption.
 elim (Qpower_not_0_positive (/proj1_sig x) p).
  change (~proj1_sig (Qpos_inv x) == 0).
  destruct (Qpos_inv x). intro abs. simpl in abs. clear H xpos. rewrite abs in q.
  exact (Qlt_irrefl 0 q).
 change ((/proj1_sig x)^Z.pos p==0).
 rewrite -> Qinv_power.
 symmetry; assumption.
Qed.
Definition Qpos_power (x:Qpos) (z:Z) : Qpos
  := exist _ _ (Qpos_power_ispos x z).

Definition Qpos_ceiling (q: Qpos): positive :=
  match Qceiling (proj1_sig q) with
  | Zpos p => p
  | _ => 1%positive (* impossible *)
  end.
Lemma Qpos_mult_le_compat : forall (a b : Qpos) (c d : Q),
    proj1_sig a <= c
    -> proj1_sig b <= d
    -> proj1_sig a * proj1_sig b <= c * d.
Proof.
  intros. apply (Qle_trans _ (c * proj1_sig b)).
  apply Qmult_le_compat_r. exact H. apply Qpos_nonneg.
  rewrite Qmult_comm. rewrite (Qmult_comm c).
  apply Qmult_le_compat_r. exact H0.
  apply (Qle_trans _ (proj1_sig a)).
  apply Qpos_nonneg. exact H.
Qed.

(**
** Example of a Total Order: <Qpos, Qpos_le, Qpos_min, Qpos_max>
*)

Definition Qpos_le_total (x y : Qpos)
  : {proj1_sig x <= proj1_sig y} + {proj1_sig y <= proj1_sig x} :=
match Qlt_le_dec_fast (proj1_sig x) (proj1_sig y) with
| left p => left _ (Qlt_le_weak _ _ p)
| right p => right _ p
end.

Lemma Qpos_eq_le_def : forall (x y: Qpos),
    proj1_sig x == proj1_sig y
    <-> proj1_sig x <= proj1_sig y /\ proj1_sig y <= proj1_sig x.
Proof.
 intros.
 split.
  intros H; rewrite -> H.
  firstorder using Qle_refl.
 firstorder using Qle_antisym.
Qed.

Definition Qpos_monotone : (Qpos -> Qpos) -> Prop
  := Default.monotone (fun (x y:Qpos) => proj1_sig x <= proj1_sig y).
Definition Qpos_antitone : (Qpos -> Qpos) -> Prop
  := Default.antitone (fun (x y:Qpos) => proj1_sig x <= proj1_sig y).
Definition Qpos_min : Qpos -> Qpos -> Qpos := Default.min _ _ Qpos_le_total.
Definition Qpos_max : Qpos -> Qpos -> Qpos := Default.max _ _ Qpos_le_total.

Definition Qpos_min_case :
  forall (x y:Qpos) (P : Qpos -> Type),
    (proj1_sig x <= proj1_sig y -> P x) -> (proj1_sig y <= proj1_sig x -> P y) -> P (Qpos_min x y) :=
 Default.min_case _ _ Qpos_le_total.
Definition Qpos_max_case :
  forall (x y:Qpos) (P : Qpos -> Type),
    (proj1_sig y <= proj1_sig x -> P x) -> (proj1_sig x <= proj1_sig y -> P y) -> P (Qpos_max x y) :=
 Default.max_case _ _ Qpos_le_total.

Definition QposTotalOrder : TotalOrder.
Proof.
 apply makeTotalOrder with
     Qpos QposEq (fun (x y:Qpos) => proj1_sig x <= proj1_sig y)
     Qpos_monotone Qpos_antitone Qpos_min Qpos_max.
          exact Qpos_eq_le_def.
         intros; apply Qle_refl.
        intros x y z; apply Qle_trans.
       exact Qpos_le_total.
      firstorder using PartialOrder.Default.monotone_def.
     firstorder using PartialOrder.Default.antitone_def.
    apply (TotalOrder.Default.min_def1 _ _ _ Qpos_eq_le_def Qpos_le_total).
   apply (TotalOrder.Default.min_def2 _ _ _ Qpos_eq_le_def Qpos_le_total).
  apply (TotalOrder.Default.max_def1 _ _ _ Qpos_eq_le_def Qpos_le_total).
 apply (TotalOrder.Default.max_def2 _ _ _ Qpos_eq_le_def Qpos_le_total).
Defined.
(* begin hide *)
Add Morphism Qpos_min
    with signature QposEq ==> QposEq ==> QposEq
      as Qpos_min_compat.
Proof.
  exact (@meet_compat QposTotalOrder).
Qed.

Add Morphism Qpos_max
    with signature QposEq ==> QposEq ==> QposEq
      as Qpos_max_compat.
Proof.
 exact (@join_compat QposTotalOrder).
Qed.
(* end hide *)
Section QTotalOrder.

Let Qto := QposTotalOrder.

Definition Qpos_min_lb_l : forall x y : Qpos, proj1_sig (Qpos_min x y) <= proj1_sig x
  := @meet_lb_l Qto.
Definition Qpos_min_lb_r : forall x y : Qpos, proj1_sig (Qpos_min x y) <= proj1_sig y
  := @meet_lb_r Qto.
Definition Qpos_min_glb : forall x y z : Qpos,
    proj1_sig z <= proj1_sig x -> proj1_sig z <= proj1_sig y -> proj1_sig z <= proj1_sig (Qpos_min x y)
  := @meet_glb Qto.
Definition Qpos_min_comm : forall x y : Qpos, QposEq (Qpos_min x y) (Qpos_min y x)
  := @meet_comm Qto.
Definition Qpos_min_assoc : forall x y z : Qpos, QposEq (Qpos_min x (Qpos_min y z)) (Qpos_min (Qpos_min x y) z)
  := @meet_assoc Qto.
Definition Qpos_min_idem : forall x : Qpos, QposEq (Qpos_min x x) x
  := @meet_idem Qto.
Definition Qpos_le_min_l : forall x y : Qpos, proj1_sig x <= proj1_sig y <-> QposEq (Qpos_min x y) x
  := @le_meet_l Qto.
Definition Qpos_le_min_r : forall x y : Qpos, proj1_sig y <= proj1_sig x <-> QposEq (Qpos_min x y) y
  := @le_meet_r Qto.
Definition Qpos_min_irred : forall x y: Qpos, {QposEq (Qpos_min x y) x} + {QposEq (Qpos_min x y) y}
  := @meet_irred Qto.
Definition Qpos_min_monotone_r : forall a : Qpos, Qpos_monotone (Qpos_min a) :=
 @meet_monotone_r Qto.
Definition Qpos_min_monotone_l : forall a : Qpos, Qpos_monotone (fun x => Qpos_min x a) :=
 @meet_monotone_l Qto.
Definition Qpos_min_le_compat :
  forall w x y z : Qpos, proj1_sig w <= proj1_sig y -> proj1_sig x <= proj1_sig z
                    -> proj1_sig (Qpos_min w x) <= proj1_sig (Qpos_min y z) :=
 @meet_le_compat Qto.

Definition Qpos_max_ub_l : forall x y : Qpos, proj1_sig x <= proj1_sig (Qpos_max x y)
  := @join_ub_l Qto.
Definition Qpos_max_ub_r : forall x y : Qpos, proj1_sig y <= proj1_sig (Qpos_max x y)
  := @join_ub_r Qto.
Definition Qpos_max_glb : forall x y z : Qpos, proj1_sig x <= proj1_sig z -> proj1_sig y <= proj1_sig z -> proj1_sig (Qpos_max x y) <= proj1_sig z
  := @join_lub Qto.
Definition Qpos_max_comm : forall x y : Qpos, QposEq (Qpos_max x y) (Qpos_max y x)
  := @join_comm Qto.
Definition Qpos_max_assoc : forall x y z : Qpos, QposEq (Qpos_max x (Qpos_max y z)) (Qpos_max (Qpos_max x y) z)
  := @join_assoc Qto.
Definition Qpos_max_idem : forall x : Qpos, QposEq (Qpos_max x x) x := @join_idem Qto.
Definition Qpos_le_max_l : forall x y : Qpos, proj1_sig y <= proj1_sig x <-> QposEq (Qpos_max x y) x
  := @le_join_l Qto.
Definition Qpos_le_max_r : forall x y : Qpos, proj1_sig x <= proj1_sig y <-> QposEq (Qpos_max x y) y
  := @le_join_r Qto.
Definition Qpos_max_irred : forall x y: Qpos, {QposEq (Qpos_max x y) x} + {QposEq (Qpos_max x y) y} := @join_irred Qto.
Definition Qpos_max_monotone_r : forall a : Qpos, Qpos_monotone (Qpos_max a) :=
 @join_monotone_r Qto.
Definition Qpos_max_monotone_l : forall a : Qpos, Qpos_monotone (fun x => Qpos_max x a) :=
 @join_monotone_l Qto.
Definition Qpos_max_le_compat :
 forall w x y z : Qpos, proj1_sig w<=proj1_sig y -> proj1_sig x<=proj1_sig z -> proj1_sig (Qpos_max w x) <= proj1_sig (Qpos_max y z) :=
 @join_le_compat Qto.

Definition Qpos_min_max_absorb_l_l : forall x y : Qpos, QposEq (Qpos_min x (Qpos_max x y)) x
  := @meet_join_absorb_l_l Qto.
Definition Qpos_max_min_absorb_l_l : forall x y : Qpos, QposEq (Qpos_max x (Qpos_min x y)) x :=
 @join_meet_absorb_l_l Qto.
Definition Qpos_min_max_absorb_l_r : forall x y : Qpos, QposEq (Qpos_min x (Qpos_max y x)) x :=
 @meet_join_absorb_l_r Qto.
Definition Qpos_max_min_absorb_l_r : forall x y : Qpos, QposEq (Qpos_max x (Qpos_min y x)) x :=
 @join_meet_absorb_l_r Qto.
Definition Qpos_min_max_absorb_r_l : forall x y : Qpos, QposEq (Qpos_min (Qpos_max x y) x) x :=
 @meet_join_absorb_r_l Qto.
Definition Qpos_max_min_absorb_r_l : forall x y : Qpos, QposEq (Qpos_max (Qpos_min x y) x) x :=
 @join_meet_absorb_r_l Qto.
Definition Qpos_min_max_absorb_r_r : forall x y : Qpos, QposEq (Qpos_min (Qpos_max y x) x) x :=
 @meet_join_absorb_r_r Qto.
Definition Qpos_max_min_absorb_r_r : forall x y : Qpos, QposEq (Qpos_max (Qpos_min y x) x) x :=
 @join_meet_absorb_r_r Qto.

Definition Qpos_min_max_eq : forall x y : Qpos,
    QposEq (Qpos_min x y) (Qpos_max x y) -> QposEq x y :=
 @meet_join_eq Qto.

Definition Qpos_max_min_distr_r : forall x y z : Qpos,
    QposEq (Qpos_max x (Qpos_min y z)) (Qpos_min (Qpos_max x y) (Qpos_max x z))
  := @join_meet_distr_r Qto.
Definition Qpos_max_min_distr_l : forall x y z : Qpos,
    QposEq (Qpos_max (Qpos_min y z) x) (Qpos_min (Qpos_max y x) (Qpos_max z x))
  := @join_meet_distr_l Qto.
Definition Qpos_min_max_distr_r : forall x y z : Qpos,
    QposEq (Qpos_min x (Qpos_max y z)) (Qpos_max (Qpos_min x y) (Qpos_min x z))
  := @meet_join_distr_r Qto.
Definition Qpos_min_max_distr_l : forall x y z : Qpos,
    QposEq (Qpos_min (Qpos_max y z) x) (Qpos_max (Qpos_min y x) (Qpos_min z x))
  := @meet_join_distr_l Qto.

(*I don't know who wants modularity laws, but here they are *)
Definition Qpos_max_min_modular_r : forall x y z : Qpos,
    QposEq (Qpos_max x (Qpos_min y (Qpos_max x z))) (Qpos_min (Qpos_max x y) (Qpos_max x z))
  := @join_meet_modular_r Qto.
Definition Qpos_max_min_modular_l : forall x y z : Qpos,
    QposEq (Qpos_max (Qpos_min (Qpos_max x z) y) z) (Qpos_min (Qpos_max x z) (Qpos_max y z))
  := @join_meet_modular_l Qto.
Definition Qpos_min_max_modular_r : forall x y z : Qpos,
    QposEq (Qpos_min x (Qpos_max y (Qpos_min x z))) (Qpos_max (Qpos_min x y) (Qpos_min x z))
  := @meet_join_modular_r Qto.
Definition Qpos_min_max_modular_l : forall x y z : Qpos,
    QposEq (Qpos_min (Qpos_max (Qpos_min x z) y) z) (Qpos_max (Qpos_min x z) (Qpos_min y z))
  := @meet_join_modular_l Qto.

Definition Qpos_min_max_disassoc : forall x y z : Qpos,
    proj1_sig (Qpos_min (Qpos_max x y) z) <= proj1_sig (Qpos_max x (Qpos_min y z))
  := @meet_join_disassoc Qto.

Lemma Qplus_monotone_r : forall a, Qpos_monotone (Qpos_plus a).
Proof.
 intros a x y Hxy.
 repeat rewrite -> Q_Qpos_plus.
 apply Qplus_le_compat. apply Qle_refl. assumption.
Qed.
Lemma Qplus_monotone_l : forall a, Qpos_monotone (fun x => Qpos_plus x a).
Proof.
 intros a x y Hxy.
 repeat rewrite Q_Qpos_plus.
 apply Qplus_le_compat. assumption. apply Qle_refl.
Qed.

Local Open Scope Qpos_scope.

Definition Qpos_min_plus_distr_r :
  forall x y z : Qpos, QposEq (Qpos_plus x (Qpos_min y z)) (Qpos_min (Qpos_plus x y) (Qpos_plus x z))
  := fun a => @monotone_meet_distr Qto _ (Qplus_monotone_r a).
Definition Qpos_min_plus_distr_l :
  forall x y z : Qpos, QposEq (Qpos_plus (Qpos_min y z) x) (Qpos_min (Qpos_plus y x) (Qpos_plus z x))
  := fun a => @monotone_meet_distr Qto _ (Qplus_monotone_l a).
Definition Qpos_max_plus_distr_r :
  forall x y z : Qpos, QposEq (Qpos_plus x (Qpos_max y z)) (Qpos_max (Qpos_plus x y) (Qpos_plus x z))
  := fun a => @monotone_join_distr Qto _ (Qplus_monotone_r a).
Definition Qpos_max_plus_distr_l :
  forall x y z : Qpos, QposEq (Qpos_plus (Qpos_max y z) x) (Qpos_max (Qpos_plus y x) (Qpos_plus z x))
  := fun a => @monotone_join_distr Qto _ (Qplus_monotone_l a).

End QTotalOrder.

Lemma Q_Qpos_min : forall (x y:Qpos),
    proj1_sig (Qpos_min x y) == Qmin (proj1_sig x) (proj1_sig y).
Proof.
 intros x y.
 unfold Qpos_min.
 unfold Qmin.
 unfold Default.min.
 destruct (Qpos_le_total x y) as [H|H]; destruct (Qle_total (proj1_sig x) (proj1_sig y)) as [H0|H0]; try reflexivity;
   apply Qle_antisym; auto.
Qed.
(* begin hide *)
#[global]
Hint Rewrite Q_Qpos_min : QposElim.
(* end hide *)
Lemma Q_Qpos_max : forall (x y:Qpos),
    proj1_sig (Qpos_max x y) == Qmax (proj1_sig x) (proj1_sig y).
Proof.
 intros x y.
 unfold Qpos_max.
 unfold Qmax.
 unfold Default.max.
 destruct (Qpos_le_total y x) as [H|H];
   destruct (Qle_total (proj1_sig y) (proj1_sig x)) as [H0|H0]; try reflexivity;
   apply Qle_antisym; auto.
Qed.
(* begin hide *)
#[global]
Hint Rewrite Q_Qpos_max : QposElim.
(* end hide *)

Lemma Qpos_min_mult_distr_r : forall x y z : Qpos,
    QposEq (Qpos_mult  x (Qpos_min y z)) (Qpos_min (Qpos_mult x y) (Qpos_mult x z)).
Proof.
  intros x y z. unfold QposEq. rewrite Q_Qpos_min.
  simpl. rewrite Q_Qpos_min.
  apply Qmin_mult_pos_distr_r.
  apply Qlt_le_weak. destruct x. exact q.
Qed.
Lemma Qpos_min_mult_distr_l : forall x y z : Qpos,
    QposEq (Qpos_mult (Qpos_min y z) x) (Qpos_min (Qpos_mult y x) (Qpos_mult z x)).
Proof.
  intros x y z. unfold QposEq. rewrite Q_Qpos_min.
  simpl. rewrite Q_Qpos_min.
  apply Qmin_mult_pos_distr_l.
  apply Qlt_le_weak. destruct x. exact q.
Qed.
Lemma Qpos_max_mult_distr_r : forall x y z : Qpos,
    QposEq (Qpos_mult x (Qpos_max y z)) (Qpos_max (Qpos_mult x y) (Qpos_mult x z)).
Proof.
  intros x y z. unfold QposEq. rewrite Q_Qpos_max.
  simpl. rewrite Q_Qpos_max.
  apply Qmax_mult_pos_distr_r.
  apply Qlt_le_weak. destruct x. exact q.
Qed.
Lemma Qpos_max_mult_distr_l : forall x y z : Qpos,
    QposEq (Qpos_mult (Qpos_max y z) x) (Qpos_max (Qpos_mult y x) (Qpos_mult z x)).
Proof.
  intros x y z. unfold QposEq. rewrite Q_Qpos_max.
  simpl. rewrite Q_Qpos_max.
  apply Qmax_mult_pos_distr_l.
  apply Qlt_le_weak. destruct x. exact q.
Qed.


From mathcomp Require Import all_ssreflect.
Require Import all_core.
Require Import FunctionalExtensionality ClassicalFacts ClassicalChoice Psatz.
Require Import Morphisms.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section RS.

Definition is_rep S T (delta: S ->> T):=
	delta \is_surjective_partial_function.
Notation "delta '\is_representation'" := (is_rep delta) (at level 2).

Definition trans X B B' T (delta: B ->> X) (delta': B' ->> X) := delta' o T \tightens delta /\ T \is_single_valued.

Notation "T '\translates' delta '\to' delta'" := (trans T delta delta') (at level 2).

Notation "delta '\is_translatable_to' delta'" := (exists T, T \translates delta \to delta') (at level 2).

Lemma trans_cotot X B B' (delta: B ->> X) (delta': B' ->> X):
	delta \is_representation -> delta \is_translatable_to delta' -> is_cotot delta'.
Proof.
move => [sing cotot] [T [trans singT]] x.
have [phi phinx]:= cotot x.
have [ | [y phiny] prp]:= trans phi; first by exists x.
have [[Tphi [TphiTphi Tphiny subs]]]:= phiny.
by exists Tphi; rewrite (sing phi x y); last apply prp.
Qed.

Notation "delta '\is_equivalent_to' delta'":=
	(delta \is_translatable_to delta' /\ delta' \is_translatable_to delta) (at level 2).

(*
Lemma trans_sing X B B' (delta: B ->> X) (delta': B' ->> X):
	delta \is_representation -> delta \is_equivalent_to delta' -> delta' \is_representation.
Proof.
move => [sing cotot] [[T [trans singT]] [T' [trans' singT']]].
split; last by apply/ trans_cotot; [split; first by apply sing | exists T].
move => phi x y phinx phiny.
apply /(@sing _ x y).
have [ | [z phinz] prp]:= trans' phi; first by exists x.
have [[Tphi [TphiTphi Tphinz _]]]:= phinz.
have: z = x.
apply /(@sing _ z x); first by apply Tphinz.
have [psi psinx]:= cotot x.
have : delta o T' phi x.
	split.
		exists Tphi; split => //.
		have [ | [z' phinz'] prp']:= trans Tphi; first by exists z.
		have [[Tphi' [TphiTphi' Tphinz' _]]]:= phinz'.
		apply prp'.
		split.
			exists phi.

			split.
		ahve :
		exists
rewrite prp.
have eq	: z = x by apply /(@sing phi z x); first apply prp.

have := prp z.
have [psi psinx]:= cotot x.
Admitted.
*)

Definition rec_trans X B B' T (delta: B ->> X) (delta': B' ->> X) := delta o (F2MF T) \tightens delta'.

Notation "T '\translates' delta '\to' delta' '\recursively'" := (rec_trans T delta delta') (at level 2).

Notation "delta '\is_recursively_translatable_to' delta'" := ({T | T \translates delta \to delta' \recursively}) (at level 2).

Definition rec_equivalent X B B' (delta: B ->> X) (delta': B' ->> X):=
	(delta \is_recursively_translatable_to delta', delta' \is_recursively_translatable_to delta).

(* To construct a represented space it is necessary to provide a proof that the
representation is actually a representation. The names have to be of the form
Q -> A where Q and A are countable and A is inhabited. This must also be proven. *)
Structure rep_space := make_rep_space {
  space :> Type;
  questions: Type;
  answers: Type;
  delta: (questions -> answers) ->> space;
  some_question: questions;
	some_answer: answers;
  countable_questions: questions \is_countable;
  countable_answers: answers \is_countable;
  representation_is_valid : delta \is_representation
}.
End RS.
Notation "delta '\is_representation'" := (is_rep delta) (at level 2).
Notation "T '\translates' delta '\to' delta'" := (trans T delta delta') (at level 2).
Notation "delta '\is_translatable_to' delta'" := (exists T, T \translates delta \to delta') (at level 2).
Notation "delta '\is_equivalent_to' delta'":=
	(delta \is_translatable_to delta' /\ delta' \is_translatable_to delta) (at level 2).
Notation "T '\translates' delta '\to' delta' '\recursively'" := (rec_trans T delta delta') (at level 2).
Notation "delta '\is_recursively_translatable_to' delta'" := ({T | T \translates delta \to delta' \recursively}) (at level 2).
Notation names X := ((questions X) -> (answers X)).
Notation rep := @delta.
Notation "phi '\is_name_of' x" := (delta phi x) (at level 2).
Notation rep_valid X := (@representation_is_valid X).
Notation rep_sur X := (rep_valid X).2.
Notation rep_sing X := (rep_valid X).1.

Section REALIZERS.
(* This is the abstract definition of what it means to be a realizer. The more usable definitions
for special cases are frlzr and rrlzr and can be found below*)

Definition rlzr (X Y: rep_space) (F: (names X) ->> (names Y)) (f: X ->> Y) :=
	(rep Y) o F \tightens (f o (rep X)).
Notation "f '\is_realized_by' F" := (rlzr F f) (at level 2).
Notation "F '\is_realizer_of' f" := (rlzr F f) (at level 2).

Global Instance rlzr_prpr (X Y: rep_space):
	Proper (@equiv (names X) (names Y) ==> @equiv (space X) (space Y) ==> iff) (@rlzr X Y).
Proof. by move => F G FeG f g feg; rewrite /rlzr FeG feg. Qed.

Definition frlzr (X Y: rep_space) (F: (names X) -> (names Y)) (f: X -> Y) :=
	forall phi x, (rep X) phi x -> ((rep Y) (F phi) (f x)).
Notation "F '\is_realizer_function_for' f":= (frlzr F f) (at level 2).

Lemma frlzr_rlzr (X Y: rep_space) F (f: X -> Y):
	F \is_realizer_function_for f <-> (F2MF F) \is_realizer_of (F2MF f).
Proof.
split => [rlzr phi [fx [[x [phinx eq]] prop]] | mfrlzr phi x phinx].
	split => [ | y [[Fphi [FphiFphi Fphiny]] prop']].
		exists (f x);	split => [ | Fphi FphiFphi].
			by exists (F phi); split => //; apply rlzr.
		by exists (f x); rewrite -FphiFphi; exact: rlzr.
	apply tot_comp; first exact: F2MF_tot; exists x.
	split => //; rewrite -FphiFphi in Fphiny.
	by apply: (rep_sing Y); [apply rlzr | apply/ Fphiny ].
have exte: ((delta (r:=Y)) o (F2MF F)) \extends ((F2MF f) o (delta (r:=X))).
	apply/ exte_tight => //; apply: comp_sing; try exact: F2MF_sing.
		exact: (rep_sing X).
	exact: (rep_sing Y).
have Fphinfx: ((F2MF f) o (delta (r:=X))) phi (f x) by apply tot_comp; [exact: F2MF_tot | exists x].
have [Fphi [eq Fphifx]]:= (exte phi (f x) Fphinfx).1.
by rewrite eq.
Qed.

Global Instance frlzr_prpr (X Y: rep_space):
	Proper (@eqfun (names Y) (names X) ==> @eqfun (space Y) (space X) ==> iff) (@frlzr X Y).
Proof.
move => F G FeG f g feg.
have eq: (F2MF F) =~= (F2MF G) by move => s; rewrite /F2MF (FeG s).
have eq': (F2MF f) =~= (F2MF g) by move => s; rewrite /F2MF (feg s).
by rewrite !frlzr_rlzr eq eq'.
Qed.

Lemma mfrlzr_rlzr (X Y: rep_space) F (f: X ->> Y) (somey: Y): f \is_single_valued -> f \is_total ->
	(exists g, g \is_choice_for f /\ F \is_realizer_function_for g) <-> (F2MF F) \is_realizer_of f.
Proof.
split => [[g [icf rlzr]] | mfrlzr].
	rewrite -((@sing_tot_F2MF_icf X Y f g H H0).1 icf).
	exact/ frlzr_rlzr.
have [g eq]:= ((F2MF_sing_tot f (somey)).1 (conj H H0)).
exists g; split; first by apply sing_tot_F2MF_icf.
by apply/ frlzr_rlzr; rewrite eq.
Qed.

Lemma icf_rlzr (X Y: rep_space) F (f: X ->> Y):
	F \is_realizer_of f -> forall G, G \is_choice_for F -> (F2MF G) \is_realizer_of f.
Proof.
move => rlzr G icf.
apply/ tight_trans; last by apply rlzr.
exact/ tight_comp_r/icf_F2MF_tight.
Qed.

Lemma tight_rlzr (X Y: rep_space) G F (f: X ->> Y):
	G \tightens F -> F \is_realizer_of f -> G \is_realizer_of f.
Proof.
by move => GtF Frf; apply/ tight_trans; [apply/tight_comp_r/ GtF | apply Frf].
Qed.

Lemma rlzr_comp (X Y Z: rep_space) G F (f: X ->> Y) (g: Y ->> Z):
	G \is_realizer_of g -> F \is_realizer_of f -> (G o F) \is_realizer_of (g o f).
Proof.
move => Grg Frf.
rewrite /rlzr -comp_assoc.
apply/ tight_trans; first by apply /tight_comp_l; apply Grg.
apply/ tight_trans.
	rewrite comp_assoc.
	by apply /tight_comp_r; apply Frf.
by rewrite comp_assoc.
Qed.

Lemma rlzr_dom (X Y: rep_space) (f: X ->> Y) F:
	F \is_realizer_of f -> forall phi x, phi \is_name_of x -> x \from_dom f -> phi \from_dom F.
Proof.
move => rlzr phi x phinx [y fxy].
have phifd: phi \from_dom (f o (delta (r:=X))).
	exists y; split; first by exists x.
	move => x' phinx'.
	by rewrite (rep_sing X phi x' x); first by exists y.
have [y' [[Fphi [FphiFphi Fphiny']]] _]:= (rlzr phi phifd).1.
by exists Fphi.
Qed.

Lemma rlzr_val_sing (X Y: rep_space) (f: X ->> Y) F: f \is_single_valued -> F \is_realizer_of f ->
	forall phi x Fphi y, phi \is_name_of x -> f x y -> F phi Fphi -> Fphi \is_name_of y.
Proof.
move => sing Frf phi x Fphi y phinx fxy FphiFphi.
have phifd: phi \from_dom (f o (delta (r:=X))).
	by exists y; split => [ | x' phinx']; [exists x | rewrite (rep_sing X phi x' x); first exists y].
have [[y' [[Fphi' [FphiFphi' Fphi'ny']] prop]] cond]:= (Frf phi phifd).
have [z Fphinz]:= (prop Fphi FphiFphi).
have phinz: (delta (r:=Y)) o F phi z by split => [ | n H]; [exists Fphi | apply prop].
have [[x' [phinx' fx'z]]prp] := cond z phinz.
rewrite (sing x y z) => //.
by rewrite (rep_sing X phi x x').
Qed.

Lemma sing_rlzr (X Y: rep_space) (f: X ->> Y) F: F \is_single_valued -> f \is_single_valued ->
	F \is_realizer_of f
	<->
	(forall phi x, phi \is_name_of x -> x \from_dom f -> phi \from_dom F)
		/\
	(forall phi x Fphi y, phi \is_name_of x -> f x y -> F phi Fphi -> Fphi \is_name_of y).
Proof.
move => Fsing fsing.
split; first by move => Frf; split; [exact: rlzr_dom | exact: rlzr_val_sing].
move => [prp cnd] phi [y [[x [phinx fxy]] _]].
have xfd: x \from_dom f by exists y.
have [Fphi FphiFphi]:= prp phi x phinx xfd.
have Fphiny:= cnd phi x Fphi y phinx fxy FphiFphi.
split.
	exists y; split; first by exists Fphi.
	move => Fphi' FphiFphi'; exists y.
	by rewrite (Fsing phi Fphi' Fphi).
move => y' [[Fphi' [FphiFphi' Fphi'ny']] _].
split; last by move => x'; exists y; rewrite (rep_sing X phi x' x).
exists x; split => //.
rewrite (Fsing phi Fphi' Fphi) in Fphi'ny' => //.
by rewrite (rep_sing Y Fphi y' y).
Qed.

Definition rrlzr (X Y: rep_space) (F: (names X) -> (names Y)) (f: X ->> Y) :=
	(forall phi x, phi \is_name_of x -> x \from_dom f ->
		exists y, (F phi) \is_name_of y /\ f x y).
Notation "F '\is_rec_realizer_of' f":= (rrlzr F f) (at level 2).

Lemma rrlzr_rlzr (X Y: rep_space) (f: X ->> Y) F:
	F \is_rec_realizer_of f <-> (F2MF F) \is_realizer_of f.
Proof.
split.
	move => prop phi [y [[x [phinx fxy]] prp]].
	have xfd: x \from_dom f by exists y.
	have [y' [Fphiny' fxy']]:= prop phi x phinx xfd.
	split.
		exists y'; split; first by exists (F phi).
		by move => Fphi <-; exists y'.
	move => y'' [[Fphi [<- Fphiny'']]cnd].
	split; first by exists x; rewrite (rep_sing Y (F phi) y'' y').
	by move => x' phinx'; rewrite (rep_sing X phi x' x).
move => Frf phi x phinx [y fxy].
have phifd: phi \from_dom (f o (delta (r:=X))).
	exists y; split; first by exists x.
	by move => x' phinx'; rewrite (rep_sing X phi x' x) => //; exists y.
have [[y' [[Fphi [<- Fphiny']] prp]] cnd]:= (Frf phi phifd).
have phiny': (delta (r:=Y)) o (F2MF F) phi y'.
	by split; [exists (F phi) | move => Fphi' <-; exists y'].
have [[x' [phinx' fx'y']]prp']:= cnd y' phiny'.
by exists y'; split => //; rewrite (rep_sing X phi x x').
Qed.

Global Instance rrlzr_prpr (X Y: rep_space):
	Proper (@eqfun (names Y) (names X) ==> @equiv (space X) (space Y) ==> iff) (@rrlzr X Y).
Proof.
move => F G FeG f g feg.
have eq: (F2MF F) =~= (F2MF G) by move => s; rewrite /F2MF (FeG s).
by rewrite !rrlzr_rlzr eq feg.
Qed.

Lemma rlzr_F2MF (X Y: rep_space) (f: X -> Y) F:
	F \is_realizer_of (F2MF f)
	<->
	forall phi x, phi \is_name_of x -> phi \from_dom F /\ forall Fphi, F phi Fphi -> Fphi \is_name_of (f x).
Proof.
split.
	split; first by apply/ rlzr_dom; [apply H | apply H0 | apply F2MF_tot ].
	by intros; apply/ rlzr_val_sing; [apply F2MF_sing | apply H | apply H0 | | ].
move => prp phi [_ [[x [phinx _]] _]].
split.
	exists (f x).
	split; last by move => Fphi FphiFphi; exists (f x); apply (prp phi x phinx).2.
	have [Fphi FphiFphi]:= (prp phi x phinx).1.
	by exists Fphi; split => //; apply (prp phi x phinx).2.
move => y [[Fphi [FphiFphi Fphiny]] cnd].
split; last by move => a b; exact: F2MF_tot.
by exists x; split; last by rewrite (rep_sing Y Fphi y (f x)); last by apply (prp phi x phinx).2.
Qed.

Lemma frlzr_sing X Y:
	(@frlzr X Y) \is_single_valued.
Proof.
move => F f g Frf Frg.
apply functional_extensionality => x.
have [phi phinx]:= (rep_sur X x).
by apply/ (rep_sing Y); [apply: (Frf phi x) | apply: (Frg phi x)].
Qed.

Lemma frlzr_cotot X Y:
	is_cotot (@frlzr X Y).
Proof.
move => f.
set R :=(fun phi psi => phi \from_dom (rep X) -> forall x, (rep X) phi x -> (rep Y) psi (f x)).
have Rtot: R \is_total => [phi | ].
	case: (classic (phi \from_dom (rep X))) => [[x phinx] | nfd].
		have [psi psiny]:= (rep_sur Y (f x)).
		by exists psi => _ x' phinx'; rewrite -(rep_sing X phi x x').
	by exists (fun q => some_answer Y) => fd; exfalso; apply nfd.
have [F Fcond]:= (choice R Rtot).
by exists F => phi x phinx; apply Fcond => //; exists x.
Qed.

Lemma frlzr_sur X Y:
	is_cotot (@frlzr X Y).
Proof. exact: frlzr_cotot. Qed.

Lemma frlzr_sur_par_fun X Y:
	(@frlzr X Y) \is_surjective_partial_function.
Proof. split; [exact: frlzr_sing | exact: frlzr_sur]. Qed.

Lemma frlzr_rep X Y:
  (@frlzr X Y) \is_representation.
Proof. exact: frlzr_sur_par_fun. Qed.

Definition hcr (X Y : rep_space) (f : X ->> Y) :=
	exists F, F \is_realizer_of f /\ F \is_continuous.
Notation "f '\has_continuous_realizer'":= (hcr f) (at level 2).

Global Instance hcr_prpr (X Y: rep_space):
	Proper (@equiv (space X) (space Y) ==> iff) (@hcr X Y).
Proof. by move => f g feg; split; move => [F [Frf Fcont]]; exists F; [rewrite -feg | rewrite feg]. Qed.

Lemma comp_hcr (X Y Z: rep_space) (f: X ->> Y) (g: Y ->> Z):
	f \has_continuous_realizer -> g \has_continuous_realizer -> (g o f) \has_continuous_realizer.
Proof.
move => [F [Frf Fcont]] [G [Grg Gcont]].
exists (G o F); split; first by apply rlzr_comp.
by apply/ cont_comp.
Qed.

Lemma comp_hcr_fun (X Y Z: rep_space) (f: X -> Y) (g: Y -> Z):
	(F2MF f) \has_continuous_realizer -> (F2MF g) \has_continuous_realizer -> (F2MF (fun x => g (f x))) \has_continuous_realizer.
Proof.
have ->: (F2MF (fun x => g (f x))) =~= (F2MF g) o (F2MF f) by rewrite F2MF_comp.
exact: comp_hcr.
Qed.
End REALIZERS.
Notation "f '\has_continuous_realizer'":= (hcr f) (at level 2).
Notation "f '\is_realized_by' F" := (rlzr F f) (at level 2).
Notation "F '\is_realizer_of' f" := (rlzr F f) (at level 2).
Notation "F '\is_realizer_function_for' f" := (frlzr F f) (at level 2).
Notation "F '\is_rec_realizer_of' f":= (rrlzr F f) (at level 2).

Section DEFINITIONS.

Definition is_rec_elt (X: rep_space) (x: X) :=
	{phi| phi \is_name_of x}.

Definition is_cmpt_elt (X: rep_space) (x: X) :=
	{phi: nat -> _ | exists psi, (meval phi) =~= F2MF psi /\ psi \is_name_of x}.

Definition is_cmpt (X Y: rep_space) (f: X ->> Y) :=
	{M | (eval M) \is_realizer_of f}.

Definition is_mon_cmpt (X Y: rep_space) (f: X ->> Y) :=
	{M | M \is_monotone_oracle_machine /\ (eval M) \is_realizer_of f}.

Definition is_rec (X Y: rep_space) (f: X ->> Y) :=
	{F | F \is_rec_realizer_of f}.

Definition is_cmpt_fun (X Y: rep_space) (f: X -> Y) :=
	{M | (eval M) \is_realizer_of (F2MF f)}.

Definition is_rec_fun (X Y: rep_space) (f: X -> Y) :=
	{M | M \is_realizer_function_for f}.
End DEFINITIONS.

Notation opU psi:=(eval (fun n phi q' => U n psi phi q')).
Notation "x '\is_recursive_element'" := (is_rec_elt x) (at level 2).
Notation "x '\is_computable_element'" := (is_cmpt_elt x) (at level 2).
Notation "f '\is_computable'" := (is_cmpt f) (at level 2).
Notation "f '\is_monotone_computable'" := (is_mon_cmpt f) (at level 2).
Notation "f '\is_recursive'" := (is_rec f) (at level 2).
Notation "f '\is_recursive_function'" := (is_rec_fun f) (at level 2).
Notation "f '\is_computable_function'" := (is_cmpt_fun f) (at level 2).


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export sequents_equality.
Require Export per_props_equality.
Require Export per_props4.
(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)

(* !!MOVE *)
Lemma inhabited_approx {o} :
  forall lib (t1 t2 : @CTerm o),
    inhabited_type lib (mkc_approx t1 t2)
    <=> (t1) ~<~( lib)(t2).
Proof.
  introv.
  split; intro h.
  - unfold inhabited_type in h; exrepnd.
    rw <- @equality_in_approx in h0; sp.
  - unfold inhabited_type.
    exists (@mkc_axiom o).
    apply equality_in_approx; dands; spcast; auto;
    apply computes_to_valc_refl; eauto 3 with slow.
Qed.

(*
   H |- a <= b = c <= d

     By approxExtensionalEquality

     H |- a <= b <=> b <= a
 *)
Definition rule_approx_extensional_equality {o}
           (H : barehypotheses)
           (i : nat)
           (a b c d e : @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_approx a b) (mk_approx c d) (mk_uni i))))
    [ mk_baresequent H (mk_concl (mk_iff (mk_approx a b) (mk_approx c d)) e)
    ]
    [].

Lemma rule_approx_extensional_equality_true {o} :
  forall lib (H : barehypotheses) (i : nat)
         (a b c d e : @NTerm o),
    rule_true lib (rule_approx_extensional_equality H i a b c d e).
Proof.
  unfold rule_approx_extensional_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract H (mk_conclax (mk_equality (mk_approx a b) (mk_approx c b) (mk_uni i)))) as cs.
  clear hyp1.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* we now start proving the sequent *)
  vr_seq_true.

  lsubst_tac.
  rw @member_eq.
  rw <- @member_equality_iff.

  pose proof (teq_and_eq_if_equality
                lib
                (mk_uni i)
                (mk_approx a b)
                (mk_approx c d)
                s1 s2 H wT w1 w2 c1 c0 c2 c3 cT cT0) as h.
  lsubst_tac.
  apply h; auto; clear h.

  { apply tequality_mkc_uni. }

  { clear dependent s1.
    clear dependent s2.
    introv hf sim.

    vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1.
    exrepnd.
    lsubst_tac.
    apply equality_in_iff in hyp1; exrepnd; spcast.
    pose proof (hyp6 mkc_axiom mkc_axiom) as h1.
    pose proof (hyp1 mkc_axiom mkc_axiom) as h2.
    clear hyp1 hyp4 hyp5 hyp6.
    allrw <- @equality_in_approx.
    apply tequality_mkc_iff in hyp0; repnd.
    allrw @tequality_mkc_approx.
    allrw @inhabited_approx.

    clear hyp2 hyp3.

    apply mkc_approx_equality_in_uni.
    split; intro h.

    - autodimp h1 hyp; repnd; dands; auto;
      try (spcast; apply computes_to_valc_refl; eauto 3 with slow).
      autodimp hyp4 hyp.
      apply hyp4; auto.

    - autodimp hyp0 hyp.

      { exists (@mkc_id o).
        apply equality_in_fun; dands.

        - apply tequality_mkc_approx; sp.

        - introv inh.
          apply tequality_mkc_approx; sp.

        - introv ea.
          allrw <- @equality_in_approx; repnd.
          dands; tcsp.

          + autodimp h1 hyp; repnd; dands; auto;
            try (spcast; apply computes_to_valc_refl; eauto 3 with slow).

          + spcast.
            allrw @computes_to_valc_iff_reduces_toc; repnd; dands; auto.
            eapply reduces_toc_trans;[apply reduces_toc_apply_id|]; auto.

          + spcast.
            allrw @computes_to_valc_iff_reduces_toc; repnd; dands; auto.
            eapply reduces_toc_trans;[apply reduces_toc_apply_id|]; auto.
      }

      apply hyp0 in h; clear hyp0.
      autodimp h2 hyp; repnd; dands; auto; spcast;
      apply computes_to_valc_refl; eauto 3 with slow.
  }
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.

Import ListNotations.

Set Printing Parentheses.

Inductive typ : Set :=
| typ_int : typ
| typ_top : typ
| typ_arrow : typ -> typ -> typ
| typ_and : typ -> typ -> typ.

Hint Constructors typ : core.

Notation "A → B" := (typ_arrow A B) (at level 20).
Notation "A & B" := (typ_and A B) (at level 20).

Inductive trm : Set :=
| trm_int : nat -> trm
| trm_bvar : nat -> trm
| trm_fvar : var -> trm
| trm_abs : trm -> typ -> typ -> trm
| trm_app : trm -> trm -> trm
| trm_merge : trm -> trm -> trm
| trm_anno : trm -> typ -> trm.

Hint Constructors trm : core.

Notation "e ∷ A" := (trm_anno e A) (at level 20).
Notation "ƛ. e ∷ A → B" := (trm_abs e A B) (at level 20).

Coercion trm_fvar : atom >-> trm.

Definition ctx : Set := list (var * typ).

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_int n => trm_int n
  | trm_bvar i => if k == i then u else (trm_bvar i)
  | trm_fvar x => trm_fvar x
  | trm_abs t1 A B => trm_abs (open_rec (S k) u t1) A B
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_merge t1 t2 => trm_merge (open_rec k u t1) (open_rec k u t2)
  | trm_anno t1 A => trm_anno (open_rec k u t1) A
  end.

Definition open t u := open_rec 0 u t.

Inductive pvalue : trm -> Prop :=
| pvalue_nat : forall (n : nat), pvalue (trm_int n)
| pvalue_abs : forall (e : trm) (A B : typ), pvalue (trm_abs e A B).

Inductive value : trm -> Prop :=
| value_anno : forall (A : typ) (e : trm),
    pvalue e -> value (trm_anno e A)
| value_merge : forall (v1 v2 : trm),
    value v1 -> value v2 -> value (trm_merge v1 v2).

Hint Constructors pvalue : core.
Hint Constructors value : core.

Inductive toplike : typ -> Prop :=
| tl_top : toplike typ_top
| tl_and : forall (A B : typ), toplike A -> toplike B -> toplike (typ_and A B)
| tl_arrow : forall (A B : typ), toplike B -> toplike (typ_arrow A B).

Hint Constructors toplike : core.

Inductive ordinary : typ -> Prop :=
| ord_top : ordinary typ_top
| ord_int : ordinary typ_int
| ord_arrow : forall (A B : typ), ordinary (typ_arrow A B).

Hint Constructors ordinary : core.

Inductive sub : typ -> typ -> Prop :=
| sub_int :
    sub typ_int typ_int
| sub_top : forall (A:typ),
    sub A typ_top
| sub_top_arr : forall (A B C : typ),
    sub typ_top C -> sub A (typ_arrow B C)
| sub_arrow : forall (A B C D:typ),
    sub C A -> sub B D -> sub (typ_arrow A B) (typ_arrow C D)
| sub_and : forall (A B C:typ),
    sub A B -> sub A C -> sub A (typ_and B C)
| sub_and_l : forall (A B C:typ),
    sub A C -> sub (typ_and A B) C
| sub_and_r : forall (A B C:typ),
    sub B C -> sub (typ_and A B) C.

Hint Constructors sub : core.

Notation "A <: B" := (sub A B) (at level 40).

Definition arg := list typ.

Inductive auxas : arg -> typ -> typ -> Prop :=
| aas_refl : forall (A : typ),
    auxas nil A A
| aas_fun : forall (A B C D : typ) (S : arg),
    sub C A ->
    auxas S B D ->
    auxas (cons C S) (typ_arrow A B) (typ_arrow C D)
| aas_and_l : forall (A B C D: typ) (S : arg),
    auxas (cons C S) A D ->
    auxas (cons C S) (typ_and A B) D
| aas_and_r : forall (A B C D: typ) (S : arg),
    auxas (cons C S) B D ->
    auxas (cons C S) (typ_and A B) D.

Inductive appsub : arg -> typ -> typ -> Prop :=
| as_refl : forall (A : typ),
    appsub nil A A
| as_fun : forall (A B C D : typ) (S : arg),
    sub C A ->
    appsub S B D ->
    appsub (cons C S) (typ_arrow A B) (typ_arrow C D)
| as_and_l : forall (A B C D: typ) (S : arg),
    appsub (cons C S) A D ->
    not (auxas (cons C S) B D) ->
    appsub (cons C S) (typ_and A B) D
| as_and_r : forall (A B C D: typ) (S : arg),
    appsub (cons C S) B D ->
    not (auxas (cons C S) A D) ->
    appsub (cons C S) (typ_and A B) D.

(* aux lemmas needed *)
(* Fixpoint appsub' (T : arg) (t : typ) : option typ := *)
(*   match T, t with *)
(*   | nil, A => Some A *)
(*   | (cons C T'), (typ_arrow A B) => if (sub C A) then (appsub' T' B) else None *)
(*   | (cons C T'), (typ_and A B) => match (appsub' (cons C T') B) with *)
(*                                 | None => appsub' (cons C T') A *)
(*                                 | _ => None *)
(*                                 end *)
(*   | (cons C T'), (typ_and A B) => match (appsub' (cons C T') A) with *)
(*                                 | None => appsub' (cons C T') B *)
(*                                 | _ => None *)
(*                                 end *)
(*   | _, _ => None *)
(*   end. *)

Hint Constructors appsub : core.

Notation "S ⊢ A <: B" := (appsub S A B) (at level 40).
Notation "S ➤ A <: B" := (auxas S A B) (at level 40).

Definition disjoint_spec A B :=
  forall (C : typ), sub A C -> sub B C -> toplike C.

Inductive disjoint : typ -> typ -> Prop :=
| disj_top_l : forall (A : typ),
    disjoint typ_top A
| disj_top_r : forall (A : typ),
    disjoint A typ_top
| disjoint_and_l : forall (A1 A2 B : typ),
    disjoint A1 B -> disjoint A2 B ->
    disjoint (typ_and A1 A2) B
| disjoint_and_r : forall (A B1 B2 : typ),
    disjoint A B1 -> disjoint A B2 ->
    disjoint A (typ_and B1 B2)
| disjoint_int_arr : forall (A1 A2 : typ),
    disjoint typ_int (typ_arrow A1 A2)
| disjoint_arr_int : forall (A1 A2 : typ),
    disjoint (typ_arrow A1 A2) typ_int
| disjoint_arr_arr : forall (A1 A2 B1 B2 : typ),
    disjoint B1 B2 ->
    disjoint (typ_arrow A1 B1) (typ_arrow A2 B2).

Hint Constructors disjoint : core.

Inductive typedred : trm -> typ -> trm -> Prop :=
| tred_int_anno : forall (n : nat) (A : typ),
    sub A typ_int ->
    typedred (trm_anno (trm_int n) A) typ_int (trm_anno (trm_int n) typ_int)
| tred_top : forall (A : typ) (v : trm),
    toplike A -> ordinary A ->
    typedred v A (trm_anno (trm_int 1) A)
| tred_arrow_anno : forall (A B C D E : typ) (e : trm),
    not (toplike D) -> sub E (typ_arrow C D) ->
    typedred (trm_anno (trm_abs e A B) E)
             (typ_arrow C D)
             (trm_anno (trm_abs e A B) (typ_arrow C D))
| tred_merge_l : forall (v1 v2 v1': trm) (A : typ),
    typedred v1 A v1' -> ordinary A ->
    typedred (trm_merge v1 v2) A v1'
| tred_merge_r : forall (v1 v2 v2': trm) (A : typ),
    typedred v2 A v2' -> ordinary A ->
    typedred (trm_merge v1 v2) A v2'
| tred_and : forall (v1 v2 v : trm) (A B : typ),
    typedred v A v1 ->
    typedred v B v2 ->
    typedred v (typ_and A B) (trm_merge v1 v2).

Hint Constructors typedred : core.

Notation "e ~->> A e'" := (typedred e A e') (at level 68).

Definition consistency_spec e1 e2 :=
  forall (A : typ) (e1' e2' : trm), typedred e1 A e1' -> typedred e2 A e2' -> e1' = e2'.

Inductive typing : ctx -> arg -> trm -> typ -> Prop :=
| typing_int : forall (T : ctx) (n : nat),
    uniq T -> typing T nil (trm_int n) typ_int
| typing_var : forall (T : ctx) (x : var) (A : typ),
    uniq T -> binds x A T -> typing T nil (trm_fvar x) A
| typing_lam1 : forall (L : vars) (T : ctx) (A B : typ) (e : trm),
    (forall x, x \notin L -> (typing ((x ~ A) ++ T)) nil (open e (trm_fvar x)) B) ->
    typing T nil (trm_abs e A B) (typ_arrow A B)
| typing_lam2 : forall (L : vars) (S : arg) (T : ctx) (A B C : typ) (e : trm),
    (forall x, x \notin L -> (typing ((x ~ A) ++ T)) nil (open e (trm_fvar x)) B) ->
    appsub (cons C S) (typ_arrow A B) (typ_arrow A B) ->
    typing T (cons C S) (trm_abs e A B) (typ_arrow A B)
| typing_anno : forall (S : arg) (T : ctx) (A B C : typ) (e : trm),
    typing T nil e C -> sub C A -> appsub S A B ->
    typing T S (trm_anno e A) B
| typing_app : forall (S : arg) (T : ctx) (A B : typ) (e1 e2 : trm),
    typing T nil e2 A ->
    typing T (cons A S) e1 (typ_arrow A B) ->
    typing T S (trm_app e1 e2) B
| typing_merge : forall (T : ctx) (A B : typ) (e1 e2 : trm),
    disjoint_spec A B ->
    typing T nil e1 A ->
    typing T nil e2 B ->
    typing T nil (trm_merge e1 e2) (typ_and A B)
| typing_merge_value : forall (T : ctx) (A B : typ) (v1 v2 : trm),
    value v1 -> value v2 ->
    consistency_spec v1 v2 ->
    typing nil nil v1 A ->
    typing nil nil v2 B ->
    typing T nil (trm_merge v1 v2) (typ_and A B)
| typing_merge_pick : forall (T : ctx) (S : arg) (A B C : typ) (e1 e2 : trm),
    typing T nil (trm_merge e1 e2) B ->
    appsub (cons A S) B C ->
    typing T (cons A S) (trm_merge e1 e2) C.

Hint Constructors typing : core.

Notation "T S ⊢ e ⇒ A" := (typing T S e A) (at level 50).

Inductive ptype : trm -> typ -> Prop :=
| ptype_int : forall (n : nat),
    ptype (trm_int n) typ_int
| ptype_anno : forall (e : trm) (A : typ),
    ptype (trm_anno e A) A
| ptype_merge : forall (e1 e2 : trm) (A B : typ),
    ptype e1 A ->
    ptype e2 B ->
    ptype (trm_merge e1 e2) (typ_and A B).

Hint Constructors ptype : core.

Inductive papp : trm -> trm -> trm -> Prop :=
| papp_top : forall (v vl : trm) (A : typ),
    ptype v A ->
    toplike A ->
    papp v vl (trm_anno (trm_int 1) A)
| papp_abs_anno : forall (A B C D : typ) (e v v' : trm),
    typedred v C v' ->
    not (toplike D) ->
    papp (trm_anno (trm_abs e A B) (typ_arrow C D)) v
         (trm_anno (open e v') D)
| papp_merge_l : forall (A B C : typ) (v1 v2 v vl e : trm),
    ptype v1 A -> ptype vl B -> ptype (trm_merge v1 v2) C ->
    appsub (cons B nil) C A ->
    not (toplike C) ->
    papp v1 vl e ->
    papp (trm_merge v1 v2) vl e
| papp_merge_r : forall (A B C : typ) (v1 v2 v vl e : trm),
    ptype v2 A -> ptype vl B -> ptype (trm_merge v1 v2) C ->
    appsub (cons B nil) C A ->
    not (toplike C) ->
    papp v2 vl e ->
    papp (trm_merge v1 v2) vl e.

Hint Constructors papp : core.

Notation "v ◐ vl ~-> e" := (papp v vl e) (at level 69).

Inductive step : trm -> trm -> Prop :=
| step_int_anno : forall (n : nat),
    step (trm_int n) (trm_anno (trm_int n) typ_int)
| step_abs_anno : forall (e : trm) (A B : typ),
    step (trm_abs e A B) (trm_anno (trm_abs e A B) (typ_arrow A B))
| step_papp : forall (v vl e : trm),
    value v -> value vl ->
    papp v vl e ->
    step (trm_app v vl) e
| step_anno_value : forall (v v' : trm) (A : typ),
    value v -> typedred v A v' ->
    step (trm_anno v A) v'
| step_anno : forall (e e' : trm) (A : typ),
    not (value (trm_anno e A)) ->
    step e e' -> step (trm_anno e A) (trm_anno e' A)
| step_app_l : forall (e1 e2 e1' : trm),
    step e1 e1' -> step (trm_app e1 e2) (trm_app e1' e2)
| step_app_r : forall (v e2 e2' : trm),
    value v -> step e2 e2' -> step (trm_app v e2) (trm_app v e2')
| step_merge_l : forall (e1 e2 e1' : trm),
    step e1 e1' ->
    step (trm_merge e1 e2) (trm_merge e1' e2)
| step_merge_r : forall (v e2 e2' : trm),
    value v -> step e2 e2' ->
    step (trm_merge v e2) (trm_merge v e2').

Hint Constructors step : core.
Notation "e ~-> e'" := (step e e') (at level 68).