Require Export A_14_2.

Lemma factorial_lt_0_r : ∀ n, 1 <= INR (n!).
Proof.
  intro n. assert (H0 : 1 = INR (1%nat)).
  { simpl. reflexivity. }
  rewrite H0.
  apply le_INR. induction n as [|n IHn].
  - simpl. apply le_n.
  - simpl. apply le_plus_trans; assumption.
Qed.

(* 定理: 用来定义正弦函数的级数是收敛的 *)
Theorem SinSeries : ∀ x, ConSer {` λ k v, v =
  (-1)^^k * x^^(S (2*k)%nat) / INR ((S (2*k)%nat)!) `}.
Proof.
  intro x.
  assert (H0 : ∃ u, u = {` λ k v, v =
    (pow (-1) k) * (pow x (S (2 * k)%nat))
    / INR ((S (2 * k)%nat)!) `} ).
  { exists {` λ k v, v =
    (pow (-1) k) * (pow x (S (2 * k)%nat))
    / INR ((S (2 * k)%nat)!) `}; reflexivity. }
  destruct H0 as [u H0].
  assert (H1 : IsSeq u ).
  { rewrite H0. split.
    - intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
      rewrite I2. assumption.
    - apply AxiomI. intro k; split; intro I1; apply AxiomII;
      applyAxiomII I1; auto.
      exists ((pow (-1) k) * (pow x (S (2 * k)%nat))
        / INR ((S (2 * k)%nat)!)).
      apply AxiomII'. reflexivity. }
  assert (H2 : ∀ k, u[k] = (pow (-1) k)
    * (pow x (S (2 * k)%nat)) / INR ((S (2 * k)%nat)!)).
  { intro k. apply f_x; try apply H1. rewrite H0.
    apply AxiomII'. reflexivity. }
  assert (H9 : ∀ k, 0 < INR (S (2 * k) !)).
  { intro k. apply lt_0_INR. apply Lemma6_3_1. }
  destruct classic with (P := x = 0) as [H6 | H6].
  - rewrite H6 in *. assert (H3 : ∀ k, pow 0 (S k) = 0).
    { intro k. induction k as [|k IHk]; simpl; field. }
    exists 0. rewrite <- H0.
    generalize (SeriesSeq u); intros H4.
    split; auto. intros ε H5. exists 0%nat. intros n H7.
    rewrite SeriesValue; auto.
    assert (H8 : ∀ k, Σ u k = 0).
    { intro k. induction k as [|k IHk].
      - simpl. rewrite H2. rewrite H3. field.
        apply Rgt_not_eq. apply H9.
      - simpl. rewrite H2. rewrite H3. rewrite IHk.
        field. apply Rgt_not_eq. apply H9. }
    rewrite H8. rewrite Abs_ge; lra.
  - rewrite <- H0. apply Theorem12_12.
    unfold AbsoluteCon.
    assert (H3 : ∃ absu, absu = {` λ k v, v = Abs[u[k]] `}).
    { exists {` λ k v, v = Abs[u[k]] `}; reflexivity. }
    destruct H3 as [absu H3]. rewrite <- H3.
    assert (H4 : IsSeq absu ).
    { rewrite H3. split.
      - intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
        rewrite I2. assumption.
      - apply AxiomI. intro k; split; intro I1; apply AxiomII;
        applyAxiomII I1; auto.
        exists (Abs[u[k]]).
        apply AxiomII'. reflexivity. }
    assert (H5 : ∀ k, absu[k] = Abs[u[k]]).
    { intro k. apply f_x; try apply H4. rewrite H3.
      apply AxiomII'. reflexivity. }
    assert (H20 : ∀ a k, a <> 0 -> pow a k <> 0).
    { intros a k J1. induction k as [|k IHk].
      - simpl. lra.
      - simpl. apply Rmult_integral_contrapositive_currified; auto. }
    assert (H7 : ∀ n : nat,0 < absu [n]).
    { intro n. rewrite H5. rewrite H2.
      apply Abs_not_eq_0.
      assert (I1 : / INR (S (2 * n) !) <> 0).
      { apply Rinv_neq_0_compat. apply Rgt_not_eq. apply H9. }
      apply Rmult_integral_contrapositive_currified; auto.
      apply Rmult_integral_contrapositive_currified.
      - apply H20. lra.
      - apply H20. assumption. }
    apply Theorem12_7_3; auto. exists 0. split; try lra.
    assert (H8 : ∃ u', u' = {` λ n v, v = absu [S n] / absu [n] `}).
    { exists {` λ n v, v = absu [S n] / absu [n] `}; reflexivity. }
    destruct H8 as [u' H8].
    rewrite <- H8. assert (H10 : IsSeq u').
    { rewrite H8. split.
      - intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
        rewrite I2. assumption.
      - apply AxiomI. intro k; split; intro I1; apply AxiomII;
        applyAxiomII I1; auto.
        exists (absu [S k] / absu [k]).
        apply AxiomII'. reflexivity. }
    assert (H11 : ∀ k, u'[k] = absu [S k] / absu [k]).
    { intro k. apply f_x; try apply H10. rewrite H8.
      apply AxiomII'. reflexivity. }
    split; auto. intros ε H12.
    assert (H13 : 0 < x * x).
    { apply Rdichotomy in H6. destruct H6 as [H6 | H6].
      - apply Ropp_0_gt_lt_contravar in H6.
        assert (I1 : x * x = (-x) * (-x)). field.
        rewrite I1. apply Rmult_lt_0_compat; auto.
      - apply Rmult_lt_0_compat; auto. }
    generalize (Archimedes ε (x * x) H12 H13).
    intros [N H14]. exists N. intros n H15.
    assert (H16 : 0 < u'[n]).
    { rewrite H11. apply Rdiv_lt_0_compat; apply H7. }
    rewrite Rminus_0_r. rewrite Abs_gt; auto.
    rewrite H11. rewrite H5. rewrite H5.
    assert (H17 : ∀ k, u[k] <> 0).
    { intros k I1. generalize (H7 k). intro I2.
      apply Rlt_not_eq in I2. apply I2.
      rewrite H5. rewrite I1. rewrite Abs_ge; lra. }
    rewrite <- Abs_div; auto.
    assert (H18 : ∀ a k, a <> 0 -> (pow a (S k)) / (pow a k) = a).
    { intros a k I1. simpl. field. apply H20; assumption. }
    rewrite H2. rewrite H2.
    assert (H19 : pow (-1) (S n) * pow x (S (2 * S n))
      / INR (S (2 * S n) !) / (pow (-1) n * pow x (S (2 * n))
      / INR (S (2 * n) !)) = pow (-1) (S n) / pow (-1) n
      * (pow x (S (2 * S n)) / pow x (S (2 * n)))
      / (INR (S (2 * S n) !) / INR (S (2 * n) !)) ).
    { field. repeat split.
      - apply Rgt_not_eq. apply lt_0_INR.
        apply Lemma6_3_1.
      - apply H20. assumption.
      - apply H20; lra.
      - apply Rgt_not_eq. apply lt_0_INR.
        apply Lemma6_3_1. }
    rewrite H19; clear H19.
    rewrite H18; try lra.
    assert (H19 : S (2 * S n) = S (S (S (2 * n)))).
    { simpl. rewrite Nat.add_succ_r. reflexivity. }
    assert (H21 : pow x (S (2 * S n)) / pow x (S (2 * n)) = x * x).
    { rewrite H19. simpl. field. split; auto. }
    rewrite H21. clear H21. rewrite H19.
    assert (H21 : S (S (S (2 * n))) ! =
      ((S (S (S (2 * n)))) * (S (S (2 * n))) * S (2 * n) !)%nat).
    { assert (I1 : ∀ k, (S k)! = ((S k) * k!)%nat).
      { intro k. simpl. reflexivity. }
      rewrite I1. rewrite I1. apply Nat.mul_assoc. }
    rewrite H21. clear H21. rewrite mult_INR.
    assert (H21 : INR (S (S (S (2 * n))) *
      S (S (2 * n))) * INR (S (2 * n) !) /
      INR (S (2 * n) !) = INR (S (S (S (2 * n))) *
      S (S (2 * n)))).
    { field. apply not_0_INR. apply Nat.neq_sym.
      apply lt_0_neq. apply Lemma6_3_1. }
    rewrite H21. clear H21.
    assert (H21 : 0 < INR (S (S (S (2 * n))) *
      S (S (2 * n)))).
    { apply lt_0_INR. apply Nat.mul_pos_pos; apply Nat.lt_0_succ. }
    rewrite Abs_div; try apply Rgt_not_eq; auto.
    rewrite Abs_mult. rewrite Abs_lt; try lra.
    rewrite Abs_gt; try lra. rewrite Abs_gt; try lra.
    assert (H22 : - -1 * (x * x) = x * x). field.
    rewrite H22. clear H22.
    assert (H22 : INR n < INR (S (S (S (2 * n))) * S (S (2 * n)))).
    { apply lt_INR. pattern n at 1. rewrite <- Nat.mul_1_r.
      apply Nat.mul_lt_mono.
      - simpl. apply Nat.lt_lt_succ_r. apply Nat.lt_lt_succ_r.
        apply le_lt_n_Sm. apply Nat.le_add_r.
      - apply lt_n_S. apply Nat.lt_0_succ. }
    assert (H23 : 0 < INR n).
    { apply lt_0_INR. apply Nat.lt_lt_0 with (n := N). assumption. }
    apply Rmult_gt_reg_l with
      (r := INR (S (S (S (2 * n))) * S (S (2 * n)))); try lra.
    assert (H24 : INR (S (S (S (2 * n))) * S (S (2 * n))) *
      (x * x / INR (S (S (S (2 * n))) * S (S (2 * n)))) = x * x).
    field; try lra. rewrite H24. clear H24.
    apply Rmult_lt_compat_r with (r := ε) in H22; auto.
    apply Rlt_trans with (r2 := INR n * ε); auto.
    apply lt_INR in H15.
    apply Rmult_lt_compat_r with (r := ε) in H15; auto.
    lra.
Qed.

(* 定义正弦函数 *)
Definition sin := {` λ x y, limit_seq (Series {` λ k v,
    v = (-1)^^k * x^^(S (2*k)%nat)
    / INR ((S (2*k)%nat)!) `}) y `}.

(* 定理: sin是一个函数 *)
Theorem sin_function : Function sin.
Proof.
  intros x y z H0 H1. applyAxiomII' H0. applyAxiomII' H1.
  eapply Theorem2_2; eauto.
Qed.

(* 定理: sin的定义域为全体实数 *)
Theorem sin_dom : dom[sin] = Full R.
Proof.
  apply AxiomI. intro x; split; intro H0;
  apply AxiomII; applyAxiomII H0; auto.
  generalize (SinSeries x). intros [y H1].
  exists y. apply AxiomII'. assumption.
Qed.

Theorem sin_value : ∀ x, limit_seq (Series {` λ k v,
    v = (-1)^^k * x^^(S (2*k)%nat)
    / INR ((S (2*k)%nat)!) `}) sin[x].
Proof.
  intro x. assert (H0 : x ∈ dom[sin]).
  { rewrite sin_dom. apply AxiomII. reflexivity. }
  apply x_fx in H0; try apply sin_function.
  applyAxiomII' H0. assumption.
Qed.

Lemma pow_2 : ∀ x k, x^^(2*k) = (x*x)^^k.
Proof.
  intros x k. induction k as [|k IHk].
  - simpl. reflexivity.
  - assert (H0 : (2 * S k = S (S (2 * k)))%nat).
    { simpl. rewrite Nat.add_succ_r. reflexivity. }
    rewrite H0. simpl. simpl in IHk. rewrite IHk.
    rewrite Rmult_assoc. reflexivity.
Qed.

(* 定理: (sin x) / x 当x趋向于0时，极限为1 (利用函数极限的迫敛性证明) *)
Theorem sin_div_x : limit {` λ x y, x <> 0 /\ y = sin[x] / x `} 0 1.
Proof.
  assert (H0 : ∃ g, g = {` λ x y, limit_seq (Series {` λ k v,
    v = 1 * (x*x)^^k `}) y `}).
  { exists {` λ x y, limit_seq (Series {` λ k v,
      v = 1 * (x*x)^^k `}) y `}; reflexivity. }
  destruct H0 as [g H0].
  assert (H1 : ∃ f, f = {` λ x y, limit_seq (Series {` λ k v,
    (k = 0%nat /\ v = 1) \/
    ((0 < k)%nat /\ v = - 1 * (x*x)^^k) `}) y `}).
  { exists {` λ x y, limit_seq (Series {` λ k v,
    (k = 0%nat /\ v = 1) \/
    ((0 < k)%nat /\ v = - 1 * (x*x)^^k) `}) y `};
    reflexivity. }
  destruct H1 as [f H1].
  assert (H2 : ∃ h, h = {` λ x y, x <> 0 /\ y = sin[x] / x `}).
  { exists {` λ x y, x <> 0 /\ y = sin[x] / x `}; reflexivity. }
  destruct H2 as [h H2].
  assert (H3 : Function h).
  { rewrite H2.
    intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
    destruct I2 as [I2 I3]. rewrite I3. apply I1. }
  assert (H4 : Function g).
  { rewrite H0.
    intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
    eapply Theorem2_2; eauto. }
  assert (H5 : Function f).
  { rewrite H1.
    intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
    eapply Theorem2_2; eauto. }
  assert (H6 : ∀ x, IsSeq {` λ k v, v = 1 * (x*x)^^k `}).
  { intro x. split.
    - intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
      rewrite I2. assumption.
    - apply AxiomI. intro k; split; intro I1; apply AxiomII;
      applyAxiomII I1; auto.
      exists (1 * pow (x * x) k).
      apply AxiomII'. reflexivity. }
  assert (H7 : ∀ x, IsSeq {` λ k v, (k = 0%nat /\ v = 1) \/
    ((0 < k)%nat /\ v = - 1 * (x*x)^^k) `}).
  { intro x. split.
    - intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
      destruct I1 as [I1 | I1].
      + destruct I2 as [I2 | I2].
        * destruct I2 as [I2 I3]. rewrite I3. apply I1.
        * exfalso. destruct I2 as [I2 I3].
          destruct I1 as [I1 I4]. apply lt_0_neq in I2.
          apply I2. rewrite I1. reflexivity.
      + destruct I2 as [I2 | I2].
        * exfalso. destruct I2 as [I2 I3].
          destruct I1 as [I1 I4]. apply lt_0_neq in I1.
          apply I1. rewrite I2. reflexivity.
        * destruct I2 as [I2 I3]. rewrite I3. apply I1.
    - apply AxiomI. intro k; split; intro I1; apply AxiomII;
      applyAxiomII I1; auto.
      destruct classic with (P := k = 0%nat) as [I2 | I2].
      + exists 1. apply AxiomII'. left. auto.
      + apply Nat.neq_sym in I2. apply neq_0_lt in I2.
        exists (- 1 * pow (x * x) k). apply AxiomII'.
        right. auto. }
  assert (H8 : ∀ x n, {` λ k v, v = 1 * pow (x * x) k `} [n]
    = 1 * (x*x)^^n).
  { intros x n. apply f_x; try apply H6.
    apply AxiomII'. reflexivity. }
  assert (H9 : ∀ x, IsSeq {` λ k v, v = - 1 * (x*x)^^k `}).
  { intro x. split.
    - intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
      rewrite I2. assumption.
    - apply AxiomI. intro k; split; intro I1; apply AxiomII;
      applyAxiomII I1; auto.
      exists (- 1 * pow (x * x) k).
      apply AxiomII'. reflexivity. }
  assert (H10 : ∀ x n, {` λ k v, v = - 1 * (x*x)^^k `} [n]
    = - 1 * (x*x)^^n).
  { intros x n. apply f_x; try apply H9.
    apply AxiomII'. reflexivity. }
  assert (H11 : ∀ x, IsSeq {` λ k v,
    v = (pow (-1) k) * (pow x ((2 * k)%nat))
    / INR ((S (2 * k)%nat)!) `}).
  { intro x. split.
    - intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
      rewrite I2. assumption.
    - apply AxiomI. intro k; split; intro I1; apply AxiomII;
      applyAxiomII I1; auto.
      exists ((pow (-1) k) * (pow x ((2 * k)%nat))
        / INR ((S (2 * k)%nat)!)).
      apply AxiomII'. reflexivity. }
  assert (H12 : ∀ x n, {` λ k v, v =
    (pow (-1) k) * (pow x ((2 * k)%nat))
    / INR ((S (2 * k)%nat)!) `} [n]
    = (pow (-1) n) * (pow x ((2 * n)%nat))
    / INR ((S (2 * n)%nat)!)).
  { intros x n. apply f_x; try apply H11.
    apply AxiomII'. reflexivity. }
  assert (H13 : ∀ x, IsSeq {` λ k v,
    v = (pow (-1) k) * (pow x (S (2 * k)%nat))
    / INR ((S (2 * k)%nat)!) `}).
  { intro x. split.
    - intros x0 y0 z0 I1 I2. applyAxiomII' I1; applyAxiomII' I2.
      rewrite I2. assumption.
    - apply AxiomI. intro k; split; intro I1; apply AxiomII;
      applyAxiomII I1; auto.
      exists ((pow (-1) k) * (pow x (S (2 * k)%nat))
        / INR ((S (2 * k)%nat)!)).
      apply AxiomII'. reflexivity. }
  assert (H14 : ∀ x n, {` λ k v, v =
    (pow (-1) k) * (pow x (S (2 * k)%nat))
    / INR ((S (2 * k)%nat)!) `} [n]
    = (pow (-1) n) * (pow x (S (2 * n)%nat))
    / INR ((S (2 * n)%nat)!)).
  { intros x n. apply f_x; try apply H13.
    apply AxiomII'. reflexivity. }
  assert (H15 : ∀ x, x <> 0 -> limit_seq (Series {` λ k v,
    v = (-1)^^k * x^^((2*k)%nat)
    / INR ((S (2*k)%nat)!) `}) (sin[x] / x)).
  { intros x I1.
    generalize (SeriesSeq {` λ k v, v = (-1) ^^ k *
      x ^^ (2 * k) / INR ((S (2 * k)) !) `}); intros I2.
    split; auto.
    intros ε I3. generalize (sin_value x); intros [I4 I5].
    assert (I6 : 0 < ε * Abs[x]).
    { apply Rmult_lt_0_compat; auto.
      apply Abs_not_eq_0. assumption. }
    apply I5 in I6 as I7. destruct I7 as [N I7].
    exists N. intros n I8. rewrite SeriesValue; auto.
    apply I7 in I8 as I9. rewrite SeriesValue in I9; auto.
    assert (I10 : ∀ m, Σ {` λ k v, v =
      (pow (-1) k) * (pow x ((2 * k)%nat))
      / INR ((S (2 * k)%nat)!) `} m =
      (Σ {` λ k v,
      v = (pow (-1) k) * (pow x (S (2 * k)%nat))
      / INR ((S (2 * k)%nat)!) `} m) / x).
    { intro m. induction m as [|m IHm].
      - simpl. rewrite H12. simpl in H14. rewrite H14.
        simpl. field. assumption.
      - simpl. simpl in IHm. rewrite IHm. rewrite Rdiv_plus_distr.
        apply Rplus_eq_compat_l. simpl in H12.
        rewrite H12. simpl in H14. rewrite H14.
        field. split; auto.
        assert (J1 : INR ((S (2 * (S m))%nat)!) <> 0).
        { apply not_0_INR. apply Nat.neq_sym. apply lt_0_neq.
          apply Lemma6_3_1. }
        simpl in J1. simpl. assumption. }
    rewrite I10. rewrite <- Rdiv_minus_distr.
    rewrite Abs_div; auto. apply Abs_not_eq_0 in I1.
    apply Rmult_lt_reg_r with (r := Abs[x]); auto.
    assert (I11 : Abs[Σ {` λ k v, v =
      (pow (-1) k) * (pow x (S (2 * k)%nat))
      / INR ((S (2 * k)%nat)!) `} n - sin[x]] / Abs[x] * Abs[x]
      = Abs[Σ {` λ k v, v =
      (pow (-1) k) * (pow x (S (2 * k)%nat))
      / INR ((S (2 * k)%nat)!) `} n - sin[x]]).
    { field. apply Rgt_not_eq. assumption. }
    rewrite I11. assumption. }
  assert (H16 : \{ λ x, -1 < x < 1 \} ⊂ dom[g]).
  { intros x I1. applyAxiomII I1. apply AxiomII.
    exists (1 / (1 - x * x)). rewrite H0. apply AxiomII'.
    apply SeriesProportionalSequence.
    destruct (Rlt_or_le x 0) as [I2 | I2].
    - apply Ropp_0_gt_lt_contravar in I2 as I4.
      assert (I3 : x * x = (-x) * (-x)). field.
      rewrite I3. split.
      + generalize (Rmult_lt_0_compat (-x) (-x) I4 I4).
        lra.
      + assert (I5 : 1 = 1 * 1). field. rewrite I5.
        apply Rmult_gt_0_lt_compat; lra.
    - split.
      + generalize (Rmult_le_pos x x I2 I2). lra.
      + assert (I5 : 1 = 1 * 1). field. rewrite I5.
        apply Rmult_le_0_lt_compat; lra. }
  assert (H17 : IsSeq {` λ k1 v1, v1 = 2 `}).
  { split.
    - intros x0 y0 z0 J1 J2. applyAxiomII' J1; applyAxiomII' J2.
      rewrite J2. assumption.
    - apply AxiomI. intro z; split; intro J1; apply AxiomII;
      applyAxiomII J1; auto.
      exists (2).
      apply AxiomII'. reflexivity. }
  assert (H18 : ∀ (k : nat), {` λ k1 v1, v1 = 2 `} [k] = 2).
  { intro k1. apply f_x; try apply H17.
    apply AxiomII'. reflexivity. }
  assert (H19 : ∀ x, (Series {` λ k v,
    (k = 0%nat /\ v = 1) \/
    ((0 < k)%nat /\ v = - 1 * pow (x * x) k) `})
    = {` λ k v, v = {` λ k1 v1, v1 = 2 `} [k] +
      (Series {` λ k2 v2, v2 = - 1 * pow (x * x) k2 `}) [k] `} ).
  { intro x. apply AxiomI. intros [k v].
    assert (I3 : ∀ m, Σ {` λ k v, (k = 0%nat /\ v = 1) \/
      ((0 < k)%nat /\ v = - 1 * pow (x * x) k) `} m =
      2 + Σ {` λ k2 v2, v2 = - 1 * pow (x * x) k2 `} m).
    { intro m. induction m as [|m IHm].
      - simpl. rewrite H10.
        assert (J1 : {` λ k v, (k = 0%nat /\ v = 1) \/
          ((0 < k)%nat /\ v = - 1 * pow (x * x) k) `} [0%nat] = 1).
        { apply f_x; try apply H7. apply AxiomII'. left.
          split; reflexivity. }
        rewrite J1. simpl. field.
      - simpl. rewrite <- Rplus_assoc. rewrite <- IHm.
        apply Rplus_eq_compat_l. rewrite H10.
        apply f_x; try apply H7. apply AxiomII'. right.
        split; auto. apply Nat.lt_0_succ. }
    split; intro I4; apply AxiomII'; applyAxiomII' I4.
    - rewrite H18. rewrite SeriesValue; auto. rewrite I4.
      clear I4. apply I3.
    - rewrite H18 in I4. rewrite SeriesValue in I4; auto.
      rewrite I3. assumption. }
  assert (H20 : ∀ x, -1 < x < 1 -> -1 < x * x < 1).
  { intros x I1. destruct (Rlt_or_le x 0) as [I2 | I2].
    - apply Ropp_0_gt_lt_contravar in I2 as I4.
      assert (I3 : x * x = (-x) * (-x)). field.
      rewrite I3. split.
      + generalize (Rmult_lt_0_compat (-x) (-x) I4 I4).
        lra.
      + assert (I5 : 1 = 1 * 1). field. rewrite I5.
        apply Rmult_gt_0_lt_compat; lra.
    - split.
      + generalize (Rmult_le_pos x x I2 I2). lra.
      + assert (I5 : 1 = 1 * 1). field. rewrite I5.
        apply Rmult_le_0_lt_compat; lra. }
  assert (H21 : \{ λ x, -1 < x < 1 \} ⊂ dom[f]).
  { intros x I1. applyAxiomII I1. apply AxiomII.
    exists (2 + (-1) / (1 - x * x)). rewrite H1.
    apply AxiomII'. rewrite H19. apply Theorem2_7_1'.
    - split; auto. intros ε I2. exists 0%nat.
      intros n I3. rewrite H18. rewrite Abs_ge; lra.
    - apply SeriesProportionalSequence.
      auto. }
  assert (H22 : limit g 0 1).
  { unfold limit. split; auto. exists 1. repeat split.
    - lra.
    - intros x I1. applyAxiomII I1. apply H16.
      apply AxiomII. rewrite Rminus_0_r in I1.
      destruct (Rlt_or_le x 0) as [I2 | I2].
      + rewrite Abs_lt in I1; auto. lra.
      + apply Rle_ge in I2. rewrite Abs_ge in I1; auto.
        lra.
    - intros ε I1. exists (ε / (1 + ε)).
      assert (I4 : 0 < ε / (1 + ε) < 1).
      { split.
        * apply Rdiv_lt_0_compat; lra.
        * apply Rmult_lt_reg_r with (r := 1 + ε); try lra.
          assert (J1 : ε / (1 + ε) * (1 + ε) = ε).
          { field. lra. }
          rewrite J1. lra. }
      split; auto. intros x I2. rewrite Rminus_0_r in I2.
      assert (I3 : 0 < Abs[x] < 1). lra.
      assert (I5 : -1 < x < 1).
      { destruct (Rlt_or_le x 0) as [J2 | J2].
        - rewrite Abs_lt in I3; auto. lra.
        - apply Rle_ge in J2. rewrite Abs_ge in I3; auto.
          lra. }
      assert (I6 : g[x] = 1 / (1 - x *x)).
      { apply f_x; auto. rewrite H0. apply AxiomII'.
        apply SeriesProportionalSequence. apply H20.
        auto. }
      assert (I7 : 0 < x * x < 1).
      { destruct (Rlt_or_le x 0) as [J1 | J1].
        - apply Ropp_0_gt_lt_contravar in J1 as J2.
          assert (J3 : x * x = (-x) * (-x)). field.
          rewrite J3. split.
          + apply Rmult_lt_0_compat; auto.
          + assert (J4 : 1 = 1 * 1). field. rewrite J4.
            apply Rmult_gt_0_lt_compat; lra.
        - split.
          + apply Rle_ge in J1 as J2. rewrite Abs_ge in I3; auto.
            apply Rmult_lt_0_compat; apply I3.
          + assert (J2 : 1 = 1 * 1). field. rewrite J2.
            apply Rmult_le_0_lt_compat; lra. }
      assert (I8 : 0 < g[x] - 1).
      { assert (J1 : g[x] - 1 = x * x / (1 - x * x)).
        { rewrite I6. field. lra. }
        rewrite J1. apply Rdiv_lt_0_compat; lra. }
      rewrite Abs_gt; auto. rewrite I6.
      apply Rplus_lt_reg_l with (r := 1).
      assert (I9 : 1 + (1 / (1 - x * x) - 1)
        = 1 / (1 - x * x)). field; lra.
      rewrite I9. clear I9.
      rewrite <- (Rinv_involutive (1 + ε)); try lra.
      unfold Rdiv. rewrite Rmult_1_l.
      assert (I9 : 0 < / (1 + ε) * (1 - x * x)).
      { apply Rmult_lt_0_compat; try lra.
        apply Rinv_0_lt_compat. lra. }
      apply Rinv_lt_contravar; auto.
      assert (I10 : x * x < 1 - / (1 + ε)).
      { assert (J1 : 1 - / (1 + ε) = ε / (1 + ε)).
        { field. lra. }
        rewrite J1.
        assert (J2 : x * x <= Abs[x]).
        { destruct (Rlt_or_le x 0) as [J3 | J3].
          - apply Ropp_0_gt_lt_contravar in J3 as J4.
            assert (J5 : x * x = (-x) * (-x)). field.
            rewrite J5. rewrite Abs_lt in *; auto.
            pattern (-x) at 3. rewrite <- Rmult_1_r.
            apply Rmult_le_compat_l; lra.
          - apply Rle_ge in J3 as J4.
            rewrite Abs_ge in *; auto.
            pattern (x) at 3. rewrite <- Rmult_1_r.
            apply Rmult_le_compat_l; lra. }
        lra. }
      lra. }
  assert (H23 : limit f 0 1).
  { unfold limit. split; auto. exists 1. repeat split.
    - lra.
    - intros x I1. applyAxiomII I1. apply H21.
      apply AxiomII. rewrite Rminus_0_r in I1.
      destruct (Rlt_or_le x 0) as [I2 | I2].
      + rewrite Abs_lt in I1; auto. lra.
      + apply Rle_ge in I2. rewrite Abs_ge in I1; auto.
        lra.
    - intros ε I1. exists (ε / (1 + ε)).
      assert (I4 : 0 < ε / (1 + ε) < 1).
      { split.
        * apply Rdiv_lt_0_compat; lra.
        * apply Rmult_lt_reg_r with (r := 1 + ε); try lra.
          assert (J1 : ε / (1 + ε) * (1 + ε) = ε).
          { field. lra. }
          rewrite J1. lra. }
      split; auto. intros x I2. rewrite Rminus_0_r in I2.
      assert (I3 : 0 < Abs[x] < 1). lra.
      assert (I5 : -1 < x < 1).
      { destruct (Rlt_or_le x 0) as [J2 | J2].
        - rewrite Abs_lt in I3; auto. lra.
        - apply Rle_ge in J2. rewrite Abs_ge in I3; auto.
          lra. }
      assert (I6 : f[x] = 2 + (- 1) / (1 - x*x)).
      { apply f_x; auto. rewrite H1. apply AxiomII'.
        rewrite H19. apply Theorem2_7_1'.
        - split; auto. intros ε' J1. exists 0%nat.
          intros n J2. rewrite H18. rewrite Abs_ge; lra.
        - apply SeriesProportionalSequence. apply H20.
          auto. }
      assert (I7 : 0 < x * x < 1).
      { destruct (Rlt_or_le x 0) as [J1 | J1].
        - apply Ropp_0_gt_lt_contravar in J1 as J2.
          assert (J3 : x * x = (-x) * (-x)). field.
          rewrite J3. split.
          + apply Rmult_lt_0_compat; auto.
          + assert (J4 : 1 = 1 * 1). field. rewrite J4.
            apply Rmult_gt_0_lt_compat; lra.
        - split.
          + apply Rle_ge in J1 as J2. rewrite Abs_ge in I3; auto.
            apply Rmult_lt_0_compat; apply I3.
          + assert (J2 : 1 = 1 * 1). field. rewrite J2.
            apply Rmult_le_0_lt_compat; lra. }
      assert (I8 : f[x] - 1 < 0).
      { assert (J1 : f[x] - 1 = - (x * x / (1 - x * x))).
        { rewrite I6. field. lra. }
        rewrite J1. apply Ropp_lt_gt_0_contravar.
        apply Rdiv_lt_0_compat; lra. }
      rewrite Abs_lt; auto. rewrite I6.
      apply Rplus_lt_reg_l with (r := 1).
      assert (I9 : 1 + - (2 + -1 / (1 - x * x) - 1)
        = 1 / (1 - x * x)). field; lra.
      rewrite I9. clear I9.
      rewrite <- (Rinv_involutive (1 + ε)); try lra.
      unfold Rdiv. rewrite Rmult_1_l.
      assert (I9 : 0 < / (1 + ε) * (1 - x * x)).
      { apply Rmult_lt_0_compat; try lra.
        apply Rinv_0_lt_compat. lra. }
      apply Rinv_lt_contravar; auto.
      assert (I10 : x * x < 1 - / (1 + ε)).
      { assert (J1 : 1 - / (1 + ε) = ε / (1 + ε)).
        { field. lra. }
        rewrite J1.
        assert (J2 : x * x <= Abs[x]).
        { destruct (Rlt_or_le x 0) as [J3 | J3].
          - apply Ropp_0_gt_lt_contravar in J3 as J4.
            assert (J5 : x * x = (-x) * (-x)). field.
            rewrite J5. rewrite Abs_lt in *; auto.
            pattern (-x) at 3. rewrite <- Rmult_1_r.
            apply Rmult_le_compat_l; lra.
          - apply Rle_ge in J3 as J4.
            rewrite Abs_ge in *; auto.
            pattern (x) at 3. rewrite <- Rmult_1_r.
            apply Rmult_le_compat_l; lra. }
        lra. }
      lra. }
  assert (H24 : Function {` λ x y, x <> 0 /\ y = sin[x] / x `}).
  { intros x y z I1 I2. applyAxiomII' I1; applyAxiomII' I2.
    destruct I2 as [I2 I3]. rewrite I3. apply I1. }
  apply (Theorem3_6 f g); auto.
  exists 1.
  assert (H25 : Neighbor0 0 1 ⊂
    dom[{` λ x y, x <> 0 /\ y = sin[x] / x `}]).
  { intros x I1. applyAxiomII I1. apply AxiomII.
    exists (sin[x] / x). apply AxiomII'. split; auto.
    destruct (Rlt_or_le x 0) as [I2 | I2].
    - lra.
    - apply Rle_ge in I2. rewrite Rminus_0_r in I1.
      rewrite Abs_ge in I1; auto. lra. }
  split; [lra | split]; auto. intros x H26.
  applyAxiomII H26. rewrite Rminus_0_r in H26.
  assert (H27 : -1 < x < 0 \/ 0 < x < 1).
  { destruct (Rlt_or_le x 0) as [I1 | I1].
    - rewrite Abs_lt in H26; auto. left; lra.
    - apply Rle_ge in I1. rewrite Abs_ge in H26; auto. }
  assert (H28 : x <> 0). lra.
  assert (H29 : {` λ x0 y, x0 <> 0 /\ y = sin[x0] / x0`} [x]
    = sin[x] / x).
  { apply f_x; auto. apply AxiomII'. split; auto. }
  rewrite H29. generalize (H15 x H28). intro H30.
  apply lim_a in H30 as H31.
  assert (H32 : ∃ u1, u1 = {` λ(k : nat)(v : R),
    v = pow (-1) k * pow x (2 * k) / INR (S (2 * k) !) `}).
  { exists {` λ(k : nat)(v : R),
      v = pow (-1) k * pow x (2 * k) / INR (S (2 * k) !) `}; auto. }
  destruct H32 as [u1 H32]. rewrite <- H32 in *.
  assert (H33 : ∃ u0, u0 = {` λ k v, (k = 0%nat /\ v = 1) \/
    ((0 < k)%nat /\ v = - 1 * pow (x * x) k) `}).
  { exists {` λ k v, (k = 0%nat /\ v = 1) \/
    ((0 < k)%nat /\ v = - 1 * pow (x * x) k) `}; reflexivity. }
  destruct H33 as [u0 H33].
  assert (H34 : ∃ u2, u2 = {` λ k v, v = 1 * (pow (x * x) k) `}).
  { exists {` λ k v, v = 1 * (pow (x * x) k) `}; reflexivity. }
  destruct H34 as [u2 H34].
  generalize (H11 x). intro H35. rewrite <- H32 in H35.
  generalize (H7 x). intro H36. rewrite <- H33 in H36.
  generalize (H6 x). intro H37. rewrite <- H34 in H37.
  assert (H38 : ∀ n, pow (-1) n = 1 \/ pow (-1) n = -1).
  { intro n. induction n as [|n IHn].
    - left. simpl. reflexivity.
    - destruct IHn as [IHn | IHn].
      + right. simpl. rewrite IHn. field.
      + left. simpl. rewrite IHn. field. }
  assert (H39 : 0 < x * x < 1).
  { destruct H27 as [H27 | H27].
    - destruct H27 as [J1 J2].
      apply Ropp_0_gt_lt_contravar in J2 as J3.
      assert (J4 : x * x = (-x) * (-x)). field.
      rewrite J4. split.
      + apply Rmult_lt_0_compat; auto.
      + assert (J5 : 1 = 1 * 1). field. rewrite J5.
        apply Rmult_gt_0_lt_compat; lra.
    - destruct H27 as [J1 J2].
      split.
      + apply Rmult_lt_0_compat; apply J1.
      + assert (J3 : 1 = 1 * 1). field. rewrite J3.
        apply Rmult_le_0_lt_compat; lra. }
  assert (H40 : ∀ n, 0 < pow (x * x) n).
  { intro n. induction n as [|n IHn].
    - simpl. lra.
    - simpl. apply Rmult_lt_0_compat; auto. apply H39. }
  split.
  - assert (I1 : [x, f[x]] ∈ f).
    { apply x_fx; auto. apply H21. apply AxiomII. lra. }
    pattern f at 2 in I1. rewrite H1 in I1.
    applyAxiomII' I1. rewrite <- H33 in I1.
    apply lim_a in I1 as I2.
    rewrite <- I2. rewrite <- H31. apply Theorem2_5.
    + exists f[x]. auto.
    + exists (sin[x] / x); auto.
    + exists 0%nat. intros n I3. clear I3.
      induction n as [|n IHn].
      * rewrite SeriesValue; auto. rewrite SeriesValue; auto.
        simpl. rewrite H33. rewrite H32. rewrite H12.
        assert (I3 : {` λ k v, k = 0%nat /\ v = 1
          \/ (0 < k)%nat /\ v = -1 * pow (x * x) k `} [0%nat] = 1).
        { apply f_x; try apply H7. apply AxiomII'.
          left. split; reflexivity. }
        rewrite I3. simpl. lra.
      * rewrite SeriesValue; auto. rewrite SeriesValue; auto.
        simpl. rewrite SeriesValue in IHn; auto.
        rewrite SeriesValue in IHn; auto.
        apply Rplus_le_compat; auto. rewrite H32.
        rewrite H12.
        assert (I3 : u0[S n] = -1 * pow (x * x) (S n)).
        { apply f_x; try apply H36. rewrite H33.
          apply AxiomII'. right. split; auto.
          apply Nat.lt_0_succ. }
        rewrite I3. rewrite pow_2. generalize (H38 (S n)).
        intro I4. destruct I4 as [I4 | I4].
        -- rewrite I4. apply Rle_trans with (r2 := 0).
          ++ left. assert (I5 : -1 * pow (x * x) (S n)
            = - pow (x * x) (S n)).
            field. rewrite I5. apply Ropp_lt_gt_0_contravar.
            apply H40.
          ++ left. apply Rdiv_lt_0_compat.
            ** generalize (H40 (S n)). intro I5. lra.
            ** generalize (factorial_lt_0_r (S (2 * S n)));
              intro I5. lra.
        -- rewrite I4. assert (I5 : -1 * pow (x * x) (S n)
             = - (pow (x * x) (S n) * (/ 1))).
           field. rewrite I5.
           assert (I6 : - (pow (x * x) (S n) * (/ 1)) / INR (S (2 * S n) !)
             = - (pow (x * x) (S n) / INR (S (2 * S n) !))).
           { field. generalize (factorial_lt_0_r (S (2 * S n)));
             intro I6. lra. }
           rewrite I6. apply Ropp_le_contravar. unfold Rdiv.
           apply Rmult_le_compat_l.
           ++ left. apply H40.
           ++ apply Rinv_le_contravar; [lra | apply factorial_lt_0_r].
  - assert (I1 : [x, g[x]] ∈ g).
    { apply x_fx; auto. apply H16. apply AxiomII. lra. }
    pattern g at 2 in I1. rewrite H0 in I1.
    applyAxiomII' I1. rewrite <- H34 in I1.
    apply lim_a in I1 as I2.
    rewrite <- I2. rewrite <- H31. apply Theorem2_5.
    + exists (sin[x] / x); auto.
    + exists g[x]. auto.
    + exists 0%nat. intros n I3. clear I3.
      induction n as [|n IHn].
      * rewrite SeriesValue; auto. rewrite SeriesValue; auto.
        simpl. rewrite H34. rewrite H32. rewrite H12.
        assert (I3 : {` λ k v, v = 1 * pow (x * x) k `} [0%nat] = 1).
        { apply f_x; try apply H6. apply AxiomII'. simpl. field. }
        rewrite I3. simpl. lra.
      * rewrite SeriesValue; auto. rewrite SeriesValue; auto.
        simpl. rewrite SeriesValue in IHn; auto.
        rewrite SeriesValue in IHn; auto.
        apply Rplus_le_compat; auto. rewrite H32.
        rewrite H12.
        assert (I3 : u2[S n] = 1 * pow (x * x) (S n)).
        { apply f_x; try apply H37. rewrite H34.
          apply AxiomII'. reflexivity. }
        rewrite I3. rewrite pow_2. generalize (H38 (S n)).
        intro I4. destruct I4 as [I4 | I4].
        -- rewrite I4. unfold Rdiv.
          rewrite Rmult_1_l.
          assert (I5 : pow (x * x) (S n) = pow (x * x) (S n) * / 1).
          field. pattern (pow (x * x) (S n)) at 2.
          rewrite I5. apply Rmult_le_compat_l.
          ++ left. apply H40.
          ++ apply Rinv_le_contravar; [lra | apply factorial_lt_0_r].
        -- rewrite I4. apply Rle_trans with (r2 := 0).
          ++ left. assert (I5 : -1 * pow (x * x) (S n)
              / INR (S (2 * S n) !) = - (pow (x * x) (S n)
              / INR (S (2 * S n) !))).
            { field. generalize (factorial_lt_0_r (S (2 * S n)));
              intro I5. lra. }
            rewrite I5. apply Ropp_lt_gt_0_contravar.
            apply Rdiv_lt_0_compat.
            ** generalize (H40 (S n)). intro I6. lra.
            ** generalize (factorial_lt_0_r (S (2 * S n)));
              intro I6. lra.
          ++ left. rewrite Rmult_1_l. apply H40.
Qed.


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

(*i $Id: PartSum.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import Rcomplete.
Require Import Max.
Open Local Scope R_scope.

Lemma tech1 :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> 0 < An n) -> 0 < sum_f_R0 An N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; apply H; apply le_n.
  simpl in |- *; apply Rplus_lt_0_compat.
  apply HrecN; intros; apply H; apply le_S; assumption.
  apply H; apply le_n.
Qed.

(* Chasles' relation *)
Lemma tech2 :
  forall (An:nat -> R) (m n:nat),
    (m < n)%nat ->
    sum_f_R0 An n =
    sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m).
Proof.
  intros; induction  n as [| n Hrecn].
  elim (lt_n_O _ H).
  cut ((m < n)%nat \/ m = n).
  intro; elim H0; intro.
  replace (sum_f_R0 An (S n)) with (sum_f_R0 An n + An (S n));
  [ idtac | reflexivity ].
  replace (S n - S m)%nat with (S (n - S m)).
  replace (sum_f_R0 (fun i:nat => An (S m + i)%nat) (S (n - S m))) with
  (sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m) +
    An (S m + S (n - S m))%nat); [ idtac | reflexivity ].
  replace (S m + S (n - S m))%nat with (S n).
  rewrite (Hrecn H1).
  ring.
  apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite S_INR;
    rewrite minus_INR.
  rewrite S_INR; ring.
  apply lt_le_S; assumption.
  apply INR_eq; rewrite S_INR; repeat rewrite minus_INR.
  repeat rewrite S_INR; ring.
  apply le_n_S; apply lt_le_weak; assumption.
  apply lt_le_S; assumption.
  rewrite H1; rewrite <- minus_n_n; simpl in |- *.
  replace (n + 0)%nat with n; [ reflexivity | ring ].
  inversion H.
  right; reflexivity.
  left; apply lt_le_trans with (S m); [ apply lt_n_Sn | assumption ].
Qed.

(* Sum of geometric sequences *)
Lemma tech3 :
  forall (k:R) (N:nat),
    k <> 1 -> sum_f_R0 (fun i:nat => k ^ i) N = (1 - k ^ S N) / (1 - k).
Proof.
  intros; cut (1 - k <> 0).
  intro; induction  N as [| N HrecN].
  simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
  reflexivity.
  apply H0.
  replace (sum_f_R0 (fun i:nat => k ^ i) (S N)) with
  (sum_f_R0 (fun i:nat => k ^ i) N + k ^ S N); [ idtac | reflexivity ];
  rewrite HrecN;
    replace ((1 - k ^ S N) / (1 - k) + k ^ S N) with
    ((1 - k ^ S N + (1 - k) * k ^ S N) / (1 - k)).
  apply Rmult_eq_reg_l with (1 - k).
  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ (1 - k)));
    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
      [ do 2 rewrite Rmult_1_l; simpl in |- *; ring | apply H0 ].
  apply H0.
  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k));
    repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; reflexivity.
  apply H0.
  apply Rminus_eq_contra; red in |- *; intro; elim H; symmetry  in |- *;
    assumption.
Qed.

Lemma tech4 :
  forall (An:nat -> R) (k:R) (N:nat),
    0 <= k -> (forall i:nat, An (S i) < k * An i) -> An N <= An 0%nat * k ^ N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; right; ring.
  apply Rle_trans with (k * An N).
  left; apply (H0 N).
  replace (S N) with (N + 1)%nat; [ idtac | ring ].
  rewrite pow_add; simpl in |- *; rewrite Rmult_1_r;
    replace (An 0%nat * (k ^ N * k)) with (k * (An 0%nat * k ^ N));
    [ idtac | ring ]; apply Rmult_le_compat_l.
  assumption.
  apply HrecN.
Qed.

Lemma tech5 :
  forall (An:nat -> R) (N:nat), sum_f_R0 An (S N) = sum_f_R0 An N + An (S N).
Proof.
  intros; reflexivity.
Qed.

Lemma tech6 :
  forall (An:nat -> R) (k:R) (N:nat),
    0 <= k ->
    (forall i:nat, An (S i) < k * An i) ->
    sum_f_R0 An N <= An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; right; ring.
  apply Rle_trans with (An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N + An (S N)).
  rewrite tech5; do 2 rewrite <- (Rplus_comm (An (S N)));
    apply Rplus_le_compat_l.
  apply HrecN.
  rewrite tech5; rewrite Rmult_plus_distr_l; apply Rplus_le_compat_l.
  apply tech4; assumption.
Qed.

Lemma tech7 : forall r1 r2:R, r1 <> 0 -> r2 <> 0 -> r1 <> r2 -> / r1 <> / r2.
Proof.
  intros; red in |- *; intro.
  assert (H3 := Rmult_eq_compat_l r1 _ _ H2).
  rewrite <- Rinv_r_sym in H3; [ idtac | assumption ].
  assert (H4 := Rmult_eq_compat_l r2 _ _ H3).
  rewrite Rmult_1_r in H4; rewrite <- Rmult_assoc in H4.
  rewrite Rinv_r_simpl_m in H4; [ idtac | assumption ].
  elim H1; symmetry  in |- *; assumption.
Qed.

Lemma tech11 :
  forall (An Bn Cn:nat -> R) (N:nat),
    (forall i:nat, An i = Bn i - Cn i) ->
    sum_f_R0 An N = sum_f_R0 Bn N - sum_f_R0 Cn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; apply H.
  do 3 rewrite tech5; rewrite HrecN; rewrite (H (S N)); ring.
Qed.

Lemma tech12 :
  forall (An:nat -> R) (x l:R),
    Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l ->
    Pser An x l.
Proof.
  intros; unfold Pser in |- *; unfold infinite_sum in |- *; unfold Un_cv in H;
    assumption.
Qed.

Lemma scal_sum :
  forall (An:nat -> R) (N:nat) (x:R),
    x * sum_f_R0 An N = sum_f_R0 (fun i:nat => An i * x) N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; ring.
  do 2 rewrite tech5.
  rewrite Rmult_plus_distr_l; rewrite <- HrecN; ring.
Qed.

Lemma decomp_sum :
  forall (An:nat -> R) (N:nat),
    (0 < N)%nat ->
    sum_f_R0 An N = An 0%nat + sum_f_R0 (fun i:nat => An (S i)) (pred N).
Proof.
  intros; induction  N as [| N HrecN].
  elim (lt_irrefl _ H).
  cut ((0 < N)%nat \/ N = 0%nat).
  intro; elim H0; intro.
  cut (S (pred N) = pred (S N)).
  intro; rewrite <- H2.
  do 2 rewrite tech5.
  replace (S (S (pred N))) with (S N).
  rewrite (HrecN H1); ring.
  rewrite H2; simpl in |- *; reflexivity.
  assert (H2 := O_or_S N).
  elim H2; intros.
  elim a; intros.
  rewrite <- p.
  simpl in |- *; reflexivity.
  rewrite <- b in H1; elim (lt_irrefl _ H1).
  rewrite H1; simpl in |- *; reflexivity.
  inversion H.
  right; reflexivity.
  left; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
Qed.

Lemma plus_sum :
  forall (An Bn:nat -> R) (N:nat),
    sum_f_R0 (fun i:nat => An i + Bn i) N = sum_f_R0 An N + sum_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; ring.
  do 3 rewrite tech5; rewrite HrecN; ring.
Qed.

Lemma sum_eq :
  forall (An Bn:nat -> R) (N:nat),
    (forall i:nat, (i <= N)%nat -> An i = Bn i) ->
    sum_f_R0 An N = sum_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; apply H; apply le_n.
  do 2 rewrite tech5; rewrite HrecN.
  rewrite (H (S N)); [ reflexivity | apply le_n ].
  intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ].
Qed.

(* Unicity of the limit defined by convergent series *)
Lemma uniqueness_sum :
  forall (An:nat -> R) (l1 l2:R),
    infinite_sum An l1 -> infinite_sum An l2 -> l1 = l2.
Proof.
  unfold infinite_sum in |- *; intros.
  case (Req_dec l1 l2); intro.
  assumption.
  cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ].
  elim (H (Rabs ((l1 - l2) / 2)) H2); intros.
  elim (H0 (Rabs ((l1 - l2) / 2)) H2); intros.
  set (N := max x0 x); cut (N >= x0)%nat.
  cut (N >= x)%nat.
  intros; assert (H7 := H3 N H5); assert (H8 := H4 N H6).
  cut (Rabs (l1 - l2) <= R_dist (sum_f_R0 An N) l1 + R_dist (sum_f_R0 An N) l2).
  intro; assert (H10 := Rplus_lt_compat _ _ _ _ H7 H8);
    assert (H11 := Rle_lt_trans _ _ _ H9 H10); unfold Rdiv in H11;
      rewrite Rabs_mult in H11.
  cut (Rabs (/ 2) = / 2).
  intro; rewrite H12 in H11; assert (H13 := double_var); unfold Rdiv in H13;
    rewrite <- H13 in H11.
  elim (Rlt_irrefl _ H11).
  apply Rabs_right; left; change (0 < / 2) in |- *; apply Rinv_0_lt_compat;
    cut (0%nat <> 2%nat);
      [ intro H20; generalize (lt_INR_0 2 (neq_O_lt 2 H20)); unfold INR in |- *;
        intro; assumption
        | discriminate ].
  unfold R_dist in |- *; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1));
    rewrite Ropp_minus_distr'.
  replace (l1 - l2) with (l1 - sum_f_R0 An N + (sum_f_R0 An N - l2));
  [ idtac | ring ].
  apply Rabs_triang.
  unfold ge in |- *; unfold N in |- *; apply le_max_r.
  unfold ge in |- *; unfold N in |- *; apply le_max_l.
  unfold Rdiv in |- *; apply prod_neq_R0.
  apply Rminus_eq_contra; assumption.
  apply Rinv_neq_0_compat; discrR.
Qed.

Lemma minus_sum :
  forall (An Bn:nat -> R) (N:nat),
    sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; ring.
  do 3 rewrite tech5; rewrite HrecN; ring.
Qed.

Lemma sum_decomposition :
  forall (An:nat -> R) (N:nat),
    sum_f_R0 (fun l:nat => An (2 * l)%nat) (S N) +
    sum_f_R0 (fun l:nat => An (S (2 * l))) N = sum_f_R0 An (2 * S N).
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; ring.
  rewrite tech5.
  rewrite (tech5 (fun l:nat => An (S (2 * l))) N).
  replace (2 * S (S N))%nat with (S (S (2 * S N))).
  rewrite (tech5 An (S (2 * S N))).
  rewrite (tech5 An (2 * S N)).
  rewrite <- HrecN.
  ring.
  ring.
Qed.

Lemma sum_Rle :
  forall (An Bn:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> An n <= Bn n) ->
    sum_f_R0 An N <= sum_f_R0 Bn N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; apply H.
  apply le_n.
  do 2 rewrite tech5.
  apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
  apply Rplus_le_compat_l.
  apply H.
  apply le_n.
  do 2 rewrite <- (Rplus_comm (Bn (S N))).
  apply Rplus_le_compat_l.
  apply HrecN.
  intros; apply H.
  apply le_trans with N; [ assumption | apply le_n_Sn ].
Qed.

Lemma Rsum_abs :
  forall (An:nat -> R) (N:nat),
    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun l:nat => Rabs (An l)) N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *.
  right; reflexivity.
  do 2 rewrite tech5.
  apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
  apply Rabs_triang.
  do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
  apply Rplus_le_compat_l.
  apply HrecN.
Qed.

Lemma sum_cte :
  forall (x:R) (N:nat), sum_f_R0 (fun _:nat => x) N = x * INR (S N).
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; ring.
  rewrite tech5.
  rewrite HrecN; repeat rewrite S_INR; ring.
Qed.

(**********)
Lemma sum_growing :
  forall (An Bn:nat -> R) (N:nat),
    (forall n:nat, An n <= Bn n) -> sum_f_R0 An N <= sum_f_R0 Bn N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; apply H.
  do 2 rewrite tech5.
  apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
  apply Rplus_le_compat_l; apply H.
  do 2 rewrite <- (Rplus_comm (Bn (S N))).
  apply Rplus_le_compat_l; apply HrecN.
Qed.

(**********)
Lemma Rabs_triang_gen :
  forall (An:nat -> R) (N:nat),
    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *.
  right; reflexivity.
  do 2 rewrite tech5.
  apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
  apply Rabs_triang.
  do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
  apply Rplus_le_compat_l; apply HrecN.
Qed.

(**********)
Lemma cond_pos_sum :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, 0 <= An n) -> 0 <= sum_f_R0 An N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl in |- *; apply H.
  rewrite tech5.
  apply Rplus_le_le_0_compat.
  apply HrecN.
  apply H.
Qed.

(* Cauchy's criterion for series *)
Definition Cauchy_crit_series (An:nat -> R) : Prop :=
  Cauchy_crit (fun N:nat => sum_f_R0 An N).

(* If (|An|) satisfies the Cauchy's criterion for series, then (An) too *)
Lemma cauchy_abs :
  forall An:nat -> R,
    Cauchy_crit_series (fun i:nat => Rabs (An i)) -> Cauchy_crit_series An.
Proof.
  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
  intros.
  elim (H eps H0); intros.
  exists x.
  intros.
  cut
    (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
      R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
      (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
  intro.
  apply Rle_lt_trans with
    (R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
      (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
  assumption.
  apply H1; assumption.
  assert (H4 := lt_eq_lt_dec n m).
  elim H4; intro.
  elim a; intro.
  rewrite (tech2 An n m); [ idtac | assumption ].
  rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ].
  unfold R_dist in |- *.
  unfold Rminus in |- *.
  do 2 rewrite Ropp_plus_distr.
  do 2 rewrite <- Rplus_assoc.
  do 2 rewrite Rplus_opp_r.
  do 2 rewrite Rplus_0_l.
  do 2 rewrite Rabs_Ropp.
  rewrite
    (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S n + i)%nat)) (m - S n)))
    .
  set (Bn := fun i:nat => An (S n + i)%nat).
  replace (fun i:nat => Rabs (An (S n + i)%nat)) with
  (fun i:nat => Rabs (Bn i)).
  apply Rabs_triang_gen.
  unfold Bn in |- *; reflexivity.
  apply Rle_ge.
  apply cond_pos_sum.
  intro; apply Rabs_pos.
  rewrite b.
  unfold R_dist in |- *.
  unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
  rewrite Rabs_R0; right; reflexivity.
  rewrite (tech2 An m n); [ idtac | assumption ].
  rewrite (tech2 (fun i:nat => Rabs (An i)) m n); [ idtac | assumption ].
  unfold R_dist in |- *.
  unfold Rminus in |- *.
  do 2 rewrite Rplus_assoc.
  rewrite (Rplus_comm (sum_f_R0 An m)).
  rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
  do 2 rewrite Rplus_assoc.
  do 2 rewrite Rplus_opp_l.
  do 2 rewrite Rplus_0_r.
  rewrite
    (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S m + i)%nat)) (n - S m)))
    .
  set (Bn := fun i:nat => An (S m + i)%nat).
  replace (fun i:nat => Rabs (An (S m + i)%nat)) with
  (fun i:nat => Rabs (Bn i)).
  apply Rabs_triang_gen.
  unfold Bn in |- *; reflexivity.
  apply Rle_ge.
  apply cond_pos_sum.
  intro; apply Rabs_pos.
Qed.

(**********)
Lemma cv_cauchy_1 :
  forall An:nat -> R,
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } ->
    Cauchy_crit_series An.
Proof.
  intros An X.
  elim X; intros.
  unfold Un_cv in p.
  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
  intros.
  cut (0 < eps / 2).
  intro.
  elim (p (eps / 2) H0); intros.
  exists x0.
  intros.
  apply Rle_lt_trans with (R_dist (sum_f_R0 An n) x + R_dist (sum_f_R0 An m) x).
  unfold R_dist in |- *.
  replace (sum_f_R0 An n - sum_f_R0 An m) with
  (sum_f_R0 An n - x + - (sum_f_R0 An m - x)); [ idtac | ring ].
  rewrite <- (Rabs_Ropp (sum_f_R0 An m - x)).
  apply Rabs_triang.
  apply Rlt_le_trans with (eps / 2 + eps / 2).
  apply Rplus_lt_compat.
  apply H1; assumption.
  apply H1; assumption.
  right; symmetry  in |- *; apply double_var.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
Qed.

Lemma cv_cauchy_2 :
  forall An:nat -> R,
    Cauchy_crit_series An ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }.
Proof.
  intros.
  apply R_complete.
  unfold Cauchy_crit_series in H.
  exact H.
Qed.

(**********)
Lemma sum_eq_R0 :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> An n = 0) -> sum_f_R0 An N = 0.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; apply H; apply le_n.
  rewrite tech5; rewrite HrecN;
    [ rewrite Rplus_0_l; apply H; apply le_n
      | intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ] ].
Qed.

Definition SP (fn:nat -> R -> R) (N:nat) (x:R) : R :=
  sum_f_R0 (fun k:nat => fn k x) N.

(**********)
Lemma sum_incr :
  forall (An:nat -> R) (N:nat) (l:R),
    Un_cv (fun n:nat => sum_f_R0 An n) l ->
    (forall n:nat, 0 <= An n) -> sum_f_R0 An N <= l.
Proof.
  intros; case (total_order_T (sum_f_R0 An N) l); intro.
  elim s; intro.
  left; apply a.
  right; apply b.
  cut (Un_growing (fun n:nat => sum_f_R0 An n)).
  intro; set (l1 := sum_f_R0 An N) in r.
  unfold Un_cv in H; cut (0 < l1 - l).
  intro; elim (H _ H2); intros.
  set (N0 := max x N); cut (N0 >= x)%nat.
  intro; assert (H5 := H3 N0 H4).
  cut (l1 <= sum_f_R0 An N0).
  intro; unfold R_dist in H5; rewrite Rabs_right in H5.
  cut (sum_f_R0 An N0 < l1).
  intro; elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H7 H6)).
  apply Rplus_lt_reg_r with (- l).
  do 2 rewrite (Rplus_comm (- l)).
  apply H5.
  apply Rle_ge; apply Rplus_le_reg_l with l.
  rewrite Rplus_0_r; replace (l + (sum_f_R0 An N0 - l)) with (sum_f_R0 An N0);
    [ idtac | ring ]; apply Rle_trans with l1.
  left; apply r.
  apply H6.
  unfold l1 in |- *; apply Rge_le;
    apply (growing_prop (fun k:nat => sum_f_R0 An k)).
  apply H1.
  unfold ge, N0 in |- *; apply le_max_r.
  unfold ge, N0 in |- *; apply le_max_l.
  apply Rplus_lt_reg_r with l; rewrite Rplus_0_r;
    replace (l + (l1 - l)) with l1; [ apply r | ring ].
  unfold Un_growing in |- *; intro; simpl in |- *;
    pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
      apply Rplus_le_compat_l; apply H0.
Qed.

(**********)
Lemma sum_cv_maj :
  forall (An:nat -> R) (fn:nat -> R -> R) (x l1 l2:R),
    Un_cv (fun n:nat => SP fn n x) l1 ->
    Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
    (forall n:nat, Rabs (fn n x) <= An n) -> Rabs l1 <= l2.
Proof.
  intros; case (total_order_T (Rabs l1) l2); intro.
  elim s; intro.
  left; apply a.
  right; apply b.
  cut (forall n0:nat, Rabs (SP fn n0 x) <= sum_f_R0 An n0).
  intro; cut (0 < (Rabs l1 - l2) / 2).
  intro; unfold Un_cv in H, H0.
  elim (H _ H3); intros Na H4.
  elim (H0 _ H3); intros Nb H5.
  set (N := max Na Nb).
  unfold R_dist in H4, H5.
  cut (Rabs (sum_f_R0 An N - l2) < (Rabs l1 - l2) / 2).
  intro; cut (Rabs (Rabs l1 - Rabs (SP fn N x)) < (Rabs l1 - l2) / 2).
  intro; cut (sum_f_R0 An N < (Rabs l1 + l2) / 2).
  intro; cut ((Rabs l1 + l2) / 2 < Rabs (SP fn N x)).
  intro; cut (sum_f_R0 An N < Rabs (SP fn N x)).
  intro; assert (H11 := H2 N).
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)).
  apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption.
  case (Rcase_abs (Rabs l1 - Rabs (SP fn N x))); intro.
  apply Rlt_trans with (Rabs l1).
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply r.
  discrR.
  apply (Rminus_lt _ _ r0).
  rewrite (Rabs_right _ r0) in H7.
  apply Rplus_lt_reg_r with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
  replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with
  (Rabs l1 - Rabs (SP fn N x)).
  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
    rewrite Rplus_0_r; apply H7.
  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
    rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l;
      repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1 in |- *;
        rewrite double_var; unfold Rdiv in |- *; ring.
  case (Rcase_abs (sum_f_R0 An N - l2)); intro.
  apply Rlt_trans with l2.
  apply (Rminus_lt _ _ r0).
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  rewrite (double l2); unfold Rdiv in |- *; rewrite (Rmult_comm 2);
    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l;
    apply r.
  discrR.
  rewrite (Rabs_right _ r0) in H6; apply Rplus_lt_reg_r with (- l2).
  replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2).
  rewrite Rplus_comm; apply H6.
  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
    rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_r;
      pattern l2 at 2 in |- *; rewrite double_var;
        repeat rewrite (Rmult_comm (/ 2)); rewrite Ropp_plus_distr;
          unfold Rdiv in |- *; ring.
  apply Rle_lt_trans with (Rabs (SP fn N x - l1)).
  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply Rabs_triang_inv2.
  apply H4; unfold ge, N in |- *; apply le_max_l.
  apply H5; unfold ge, N in |- *; apply le_max_r.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  apply Rplus_lt_reg_r with l2.
  rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1);
    [ apply r | ring ].
  apply Rinv_0_lt_compat; prove_sup0.
  intros; induction  n0 as [| n0 Hrecn0].
  unfold SP in |- *; simpl in |- *; apply H1.
  unfold SP in |- *; simpl in |- *.
  apply Rle_trans with
    (Rabs (sum_f_R0 (fun k:nat => fn k x) n0) + Rabs (fn (S n0) x)).
  apply Rabs_triang.
  apply Rle_trans with (sum_f_R0 An n0 + Rabs (fn (S n0) x)).
  do 2 rewrite <- (Rplus_comm (Rabs (fn (S n0) x))).
  apply Rplus_le_compat_l; apply Hrecn0.
  apply Rplus_le_compat_l; apply H1.
Qed.


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.Isomorphism.
Require Import CT.Instance.Category.FunctorCategory.
Require Import CT.Instance.Functor.ComposeFunctor.
Require Import CT.Instance.Functor.IdentityFunctor.
Require Import CT.Instance.Isomorphism.
Require Import CT.Instance.NaturalTransformation.NaturalIsomorphism.
Require Import CT.Instance.NaturalTransformation.IdentityNaturalTransformation.

Record CategoryEquivalence (C D : Category) :=
  { F : Functor C D;
    G : Functor D C;
    ceq_nat_iso1 : NaturalIsomorphism (ComposeFunctor G F) (@IdentityFunctor D);
    ceq_nat_iso2 : NaturalIsomorphism (ComposeFunctor F G) (@IdentityFunctor C)
  }.

(** Equivalence of categories forms an equivalence relation. *)
Section CategoryEquivalence.
  Context {A B C : Category}.
  Section CategoryEquivalenceReflexivity.
    Program Definition category_equiv_refl_nat_iso :
      NaturalIsomorphism (ComposeFunctor (@IdentityFunctor C)
                                         (@IdentityFunctor C))
                         (@IdentityFunctor C).
    Proof.
      rewrite comp_identity_identity.
      apply IdentityIso.
      trivial.
      trivial.
    Qed.

    Program Definition CategoryEquivalenceReflexivity : CategoryEquivalence C C :=
      {| F := @IdentityFunctor C;
         G := @IdentityFunctor C;
         ceq_nat_iso1 := category_equiv_refl_nat_iso;
         ceq_nat_iso2 := category_equiv_refl_nat_iso
      |}.
  End CategoryEquivalenceReflexivity.

  Section CategoryEquivalenceSymmetry.
    Theorem CategoryEquivalenceSymmetry :
      CategoryEquivalence A B ->
      CategoryEquivalence B A.
    Proof.
      intros.
      destruct X.
      exists G0 F0.
      trivial.
      trivial.
    Qed.
  End CategoryEquivalenceSymmetry.

  Section CategoryEquivalenceTransitivity.
    Theorem CategoryEquivalenceTransitivity :
      CategoryEquivalence A B ->
      CategoryEquivalence B C ->
      CategoryEquivalence A C.
    Proof.
      intros.
      destruct X, X0.
      exists (ComposeFunctor F0 F1) (ComposeFunctor G1 G0).
      replace (ComposeFunctor (ComposeFunctor G1 G0) (ComposeFunctor F0 F1)) with
              (ComposeFunctor (ComposeFunctor G1 (ComposeFunctor G0 F0)) F1).
      Focus 2.
      rewrite functor_comp_assoc.
      rewrite functor_comp_assoc.
      trivial.
      admit. (* UGH! *)
    Admitted.
  End CategoryEquivalenceTransitivity.
End CategoryEquivalence.


Require Import Coq.Strings.String.
Require Import Coq.FSets.FMapWeakList.
Require Import Coq.Structures.Equalities.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.omega.Omega.
Require Import Coq.FSets.FSetWeakList.
Require Import Coq.Bool.Bool.

Open Scope string_scope.

Definition atom := string.

Print DecidableType.

Module StringMiniDec.
    Definition t := string.
    Definition eq_dec := string_dec.
End StringMiniDec.

Module StringDec := Equalities.Make_UDT(StringMiniDec).
Module Gamma := FMapWeakList.Make(StringDec).

Inductive term :=
| t_var : atom -> term
| t_app : term -> term -> term
| t_abs : atom -> term -> term
| t_pair : term -> term -> term
| t_unit : term.

(** Substitute v for x in e, assuming v is a closed term. *)
Fixpoint subst_closed (e : term) (v : term) (x : atom) :=
  match e with
  | t_var x' => if string_dec x' x then v else e
  | t_app e1 e2 => t_app (subst_closed e1 v x) (subst_closed e2 v x)
  | t_abs x' t => if string_dec x' x then e else t_abs x' (subst_closed t v x)
  | t_pair e1 e2 => t_pair (subst_closed e1 v x) (subst_closed e2 v x)
  | t_unit => e
  end.

Notation "[ v ~> x ] e" := (subst_closed e v x) (at level 68).
Notation "e1 @ e2" := (t_app e1 e2) (at level 99, right associativity).

Definition id :term := t_abs "x" (t_var "x").
Definition w : term := t_abs "x" (t_var "x" @ t_var "x").
Definition ww : term := w @ w.

Eval compute in ([ id ~> "x" ] id).
Eval compute in ([ id ~> "y" ] (t_var "y")).
Eval compute in ([ id ~> "y" ] (t_var "x")).

Inductive value : term -> Prop :=
| v_abs : forall x t, value (t_abs x t)
| v_pair : forall v1 v2, value v1 -> value v2 -> value (t_pair v1 v2)
| v_unit : value t_unit.

Hint Constructors value.

Module AtomSet := FSetWeakList.Make(StringDec).

Fixpoint fvars (e : term) : AtomSet.t :=
  match e with
  | t_var x => AtomSet.singleton x
  | t_app e1 e2 => AtomSet.union (fvars e1) (fvars e2)
  | t_abs x e => AtomSet.remove x (fvars e)
  | t_pair e1 e2 => AtomSet.union (fvars e1) (fvars e2)
  | t_unit => AtomSet.empty
  end.

Inductive closed : term -> Prop :=
| c_abs : forall x t, AtomSet.Subset (fvars t) (AtomSet.singleton x) -> closed (t_abs x t)
| c_app : forall e1 e2, closed e1 -> closed e2 -> closed (e1 @ e2)
| c_pair : forall e1 e2, closed e1 -> closed e2 -> closed (t_pair e1 e2)
| c_unit : closed t_unit.

Hint Constructors closed.

Inductive step : term -> term -> Prop :=
| s_beta : forall x t v, value v -> step (t_app (t_abs x t) v) ([v ~> x] t)
| s_app1 : forall e11 e12 e2, step e11 e12 -> step (e11 @ e2) (e12 @ e2)
| s_app2 : forall x t e21 e22, step e21 e22 -> step ((t_abs x t) @ e21) ((t_abs x t) @ e22)
| s_pair1 : forall e11 e12 e2, step e11 e12 -> step (t_pair e11 e2) (t_pair e12 e2)
| s_pair2 : forall v1 e21 e22, value v1 -> step e21 e22 -> step (t_pair v1 e21) (t_pair v1 e22).

Hint Constructors step.

Lemma omega_steps : step ww ww.
Proof.
  apply s_beta.
  constructor.
Qed.

Inductive ty_name :=
| tn_unit : ty_name
| tn_top : ty_name
| tn_bottom : ty_name
| tn_pair : ty_name -> ty_name -> ty_name
| tn_arrow : ty_name -> ty_name -> ty_name.

Definition type := nat -> term -> Prop.

Class ValidType (t : type) (n : ty_name) : Type :=
  {
    contains_value : forall k v, t k v -> value v;
    closed_under_decreasing_index : forall k v j, j <= k -> t k v -> t j v;
  }.

Ltac trivial_ty_proof t := (unfold t; intros; subst; auto).

Definition ty_unit : type := fun k v => v = t_unit.
Instance ty_unit_valid : ValidType ty_unit tn_unit := {}.
Proof.
  trivial_ty_proof ty_unit.
  trivial_ty_proof ty_unit.
Defined.

Definition ty_top : type := fun k v => value v.
Instance ty_top_valid : ValidType ty_top tn_top := {}.
Proof.
  trivial_ty_proof ty_top.
  trivial_ty_proof ty_top.
Defined.

Definition ty_bottom : type := fun k _ => False.
Instance ty_bottom_valid : ValidType ty_bottom tn_bottom := {}.
Proof.
  trivial_ty_proof ty_bottom; exfalso; auto.
  trivial_ty_proof ty_bottom; exfalso; auto.
Defined.

Definition ty_pair t1 t2 : type :=
  fun k t => exists v1 v2, value v1 /\ value v2 /\ t = t_pair v1 v2 /\ forall j, j < k -> t1 j v1 /\ t2 j v2.
Instance ty_pair_valid
         t1 t2 tn1 tn2
         `{ValidType t1 tn1}
         `{ValidType t2 tn2} : ValidType (ty_pair t1 t2) (tn_pair tn1 tn2) := {}.
Proof.
  - unfold ty_pair; intros.
    destruct H1 as [v1 [v2 [Hv1 [Hv2 [Heq Ht]]]]].
    subst; constructor; auto.
  - unfold ty_pair; intros.
    destruct H2 as [v1 [v2 [Hv1 [Hv2 [Heq Ht]]]]].
    subst.
    exists v1, v2.
    split; auto.
    split; auto.
    split; auto.
    intros p Hp.
    assert (p < k) by omega.
    apply Ht; auto.
Defined.

Definition ty_arrow (t1 : type) (t2 : type) : type :=
  fun k t => exists x e, t = t_abs x e /\ (forall j v, j < k -> t1 j v -> t2 j ([v ~> x] e)).
Instance ty_arrow_valid
         t1 t2 tn1 tn2
         `{ValidType t1 tn1}
         `{ValidType t2 tn2} : ValidType (ty_arrow t1 t2) (tn_arrow tn1 tn2) := {}.
Proof.
  - unfold ty_arrow; intros.
    destruct H1 as [x [e [Heq _]]].
    subst; auto.
  - unfold ty_arrow; intros.
    destruct H2 as [x [e [Heq Ht]]].
    subst.
    exists x, e.
    split; auto.
    intros p v Hp Htv.
    assert (p < k) by omega.
    apply Ht; auto.
Qed.

Fixpoint is_value (e : term) : bool :=
  match e with
  | t_abs _ _ => true
  | t_unit => true
  | t_pair v1 v2 => is_value v1 && is_value v2
  | _ => false
  end.

Lemma is_value_iff_value : forall e, reflect (value e) (is_value e).
Proof.
  induction e.
  - apply ReflectF.
    intros contra.
    inversion contra.
  - apply ReflectF.
    intros contra.
    inversion contra.
  - apply ReflectT.
    constructor.
  - case_eq (is_value e1); case_eq (is_value e2).
    + intros He2 He1. simpl. rewrite He2, He1. apply ReflectT.
      apply reflect_iff in IHe1. apply reflect_iff in IHe2.
      apply IHe1 in He1. apply IHe2 in He2. constructor; auto.
    + intros He2 He1. simpl. rewrite He2, He1. apply ReflectF.
      intros contra. inversion contra; subst; clear contra.
      rewrite He2 in IHe2. inversion IHe2; subst; clear IHe2.
      apply H; auto.
    + intros He2 He1. simpl. rewrite He2, He1. apply ReflectF.
      intros contra. inversion contra; subst; clear contra.
      rewrite He1 in IHe1. inversion IHe1; subst; clear IHe1.
      apply H; auto.
    + intros He2 He1. simpl. rewrite He2, He1. apply ReflectF.
      intros contra. inversion contra; subst; clear contra.
      rewrite He1 in IHe1. inversion IHe1; subst; clear IHe1.
      apply H; auto.
  - simpl. apply ReflectT; auto.
Qed.

Hint Resolve is_value_iff_value.

Inductive multistep : term -> nat -> term -> Prop :=
| multistep_refl : forall e, multistep e 0 e
| multistep_step : forall e e' e'' k, step e e' -> multistep e' k e'' -> multistep e (S k) e''.

Hint Constructors multistep.

Definition irred (e : term) : Prop :=
  forall e', step e e' -> False.

Hint Unfold irred.

Definition is_t_abs (e : term) : bool :=
  match e with
  | t_abs _ _ => true
  | _ => false
  end.

Fixpoint is_normal_form (e : term) : bool :=
  match e with
  | t_var _ => true
  | t_app (t_abs x e) t =>
    (negb (is_value t)) && is_normal_form t
  (* In this branch we already know t1 is not an abstraction *)
  | t_app t1 t2 => is_normal_form t1
  | t_pair t1 t2 => if is_value t1 then is_normal_form t2 else is_normal_form t1
  | t_unit => true
  | t_abs _ _ => true
  end.

Lemma value_implies_normal_form : forall e, value e -> is_normal_form e = true.
Proof.
  intros e Hv.
  induction Hv.
  - reflexivity.
  - assert (value v1 <-> is_value v1 = true) by (apply reflect_iff; auto).
    rewrite H in Hv1.
    simpl. rewrite Hv1.
    auto.
  - reflexivity.
Qed.

Ltac contradict_value_nf :=
  match goal with
  | [ H1 : is_value ?x = true, H2 : is_normal_form ?x = false |- _ ] =>
    assert (Hvx: value x <-> is_value x = true) by (apply reflect_iff; auto);
    rewrite <- Hvx in H1;
    apply value_implies_normal_form in H1;
    rewrite H1 in H2;
    discriminate H2
  end.

Lemma not_nf_implies_step :
  forall e, is_normal_form e = false -> exists e', step e e'.
Proof.
  induction e.
  - simpl. discriminate.
  - case_eq (is_value e2);
      case_eq (is_normal_form e2);
      case_eq (is_normal_form e1);
      intros Hnf1 Hnf2 Hv2;
      simpl;
      rewrite Hnf1, Hnf2, Hv2;
      case_eq e1;
      try discriminate;
      try (intros; subst; simpl in *;
           try match goal with
                 [ H : true = false |- _ ] => discriminate H
               end;
           try match goal with
                 [ H : false = true |- _ ] => discriminate H
               end;
           try contradict_value_nf;
           repeat match goal with
                 [ H : ?x = ?x |- _ ] => clear H
                  end;
           try match goal with
                 [ IH1 : ?P -> exists e1', step ?e1 e1',
                   H1 : ?P
                   |- exists e', step (?e1 @ ?e2) e'
                 ] => apply IH1 in H1; destruct H1 as [e1' Hstep1]; exists (e1' @ e2); constructor; auto
               end;
           try match goal with
                 [ IH2 : ?P -> exists e2', step ?e2 e2',
                   H2 : ?P
                   |- exists e', step (?e1 @ ?e2) e'
                 ] => apply IH2 in H2; destruct H2 as [e2' Hstep2]; exists (e1 @ e2'); constructor; auto
               end

          ).
    + assert (Hv2' : value e2 <-> is_value e2 = true) by (apply reflect_iff; auto).
      rewrite <- Hv2' in Hv2.
      exists ([e2 ~> a] t); constructor; auto.
  - simpl. discriminate.
  - simpl. intro Hnf.
    case_eq (is_value e1); intros Hv1; rewrite Hv1 in Hnf.
    + assert (Hv1' : value e1 <-> is_value e1 = true) by (apply reflect_iff; auto).
      rewrite <- Hv1' in Hv1.
      apply IHe2 in Hnf.
      destruct Hnf as [e2' Hstep2].
      exists (t_pair e1 e2'); constructor; auto.
    + apply IHe1 in Hnf.
      destruct Hnf as [e1' Hstep1].
      exists (t_pair e1' e2); constructor; auto.
  - simpl. discriminate.
Qed.

Lemma step_implies_not_nf :
  forall e e', step e e' -> is_normal_form e = false.
Proof.
  intros e e' Hstep.
  induction Hstep.
  - simpl; assert (Hv: value v <-> is_value v = true) by (apply reflect_iff; auto).
    rewrite Hv in H. rewrite H. simpl. reflexivity.
  - case_eq (is_normal_form e2);
      case_eq (is_value e2);
      intros Hv2 Hnf2;
      simpl;
      rewrite IHHstep, Hv2, Hnf2;
      case_eq e11;
      try discriminate;
      try (intros; subst; simpl in *;
           try match goal with
                 [ H : true = false |- _ ] => discriminate H
               end;
           try match goal with
                 [ H : false = true |- _ ] => discriminate H
               end;
           try reflexivity;
           repeat match goal with
                 [ H : ?x = ?x |- _ ] => clear H
                  end).
  - simpl. rewrite IHHstep. Search (_ && _ = false). apply andb_false_r.
  - simpl. rewrite IHHstep.
    case_eq (is_value e11); intros Hv11; auto.
    assert (Hv11' : value e11 <-> is_value e11 = true) by (apply reflect_iff; auto).
    rewrite <- Hv11' in Hv11.
    apply value_implies_normal_form in Hv11.
    rewrite IHHstep in Hv11.
    discriminate Hv11.
  - simpl.
    case_eq (is_value v1); intros Hv1; auto.
    assert (Hv1' : value v1 <-> is_value v1 = true) by (apply reflect_iff; auto).
    rewrite Hv1' in H.
    rewrite H in Hv1.
    discriminate Hv1.
Qed.

Lemma nf_iff_irred : forall e, reflect (irred e) (is_normal_form e).
Proof.
  intros e.
  case_eq (is_normal_form e); intros Hnf.
  - apply ReflectT.
    intros e' contra.
    apply step_implies_not_nf in contra.
    rewrite Hnf in contra.
    discriminate contra.
  - apply ReflectF.
    unfold irred; intros contra.
    apply not_nf_implies_step in Hnf.
    destruct Hnf as [e' Hstep].
    apply (contra e'); auto.
Qed.

Hint Resolve nf_iff_irred.

Fixpoint ty_denote (tn : ty_name) : type :=
  match tn with
  | tn_unit => ty_unit
  | tn_top => ty_top
  | tn_bottom => ty_bottom
  | tn_pair t1 t2 => ty_pair (ty_denote t1) (ty_denote t2)
  | tn_arrow t1 t2 => ty_arrow (ty_denote t1) (ty_denote t2)
  end.

Definition has_type (e : term) (k : nat) tn `{ValidType (ty_denote tn) tn} :=
  forall j e', j < k -> multistep e j e' -> irred e' -> (ty_denote tn) (k - j) e'.

Definition safe e k :=
  forall j e', j < k -> multistep e j e' -> value e' \/ exists t, step e' t.

Theorem safety e k t `{ValidType (ty_denote t) t}:
  has_type e k t -> safe e k.
Proof.
  intros Ht.
  inversion H as [Hvalue Hdec].
  unfold safe.
  intros j e' Hlt Hsteps.
  case_eq (is_normal_form e'); intros Hnfe'.
  - assert (Hirrede' : irred e' <-> is_normal_form e' = true) by (apply reflect_iff; auto).
    rewrite <- Hirrede' in Hnfe'.
    left.
    unfold has_type in Ht.
    eapply Hvalue.
    eapply Ht; eauto.
  - right.
    apply not_nf_implies_step in Hnfe'; auto.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Meta_theory.Parallel_postulates.tarski_s_euclid_remove_degenerated_cases.
Require Import GeoCoq.Tarski_dev.Annexes.perp_bisect.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section TCP_tarski.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma impossible_case_1 :
  forall A B C x y,
  Bet A B x ->
  Bet C y A ->
  Par_strict B C x y ->
  False.
Proof.
intros A B C x y.
intros HABx HACy HPar.
apply between_symmetry in HABx.
assert (HI := inner_pasch x C A B y HABx HACy); destruct HI as [I [HBCI HIxy]].
apply HPar; exists I; split; Col.
Qed.

Lemma impossible_case_2 :
  forall A B C D T x y,
  A <> D ->
  B <> D ->
  C <> D ->
  D <> T ->
  ~ Col A B C ->
  Col A B x ->
  Bet A D T ->
  ~ Col B C T ->
  Bet B D C ->
  Bet y A C ->
  Bet x T y ->
  False.
Proof.
intros A B C D T x y.
intros HAD HBD HCD HDT.
intros HABC HABx HADT HBCT HBDC HACy HxTy.
assert (HAy : A <> y) by (intro; apply HBCT; ColR).
revert HABx.
apply one_side_not_col124 with T.
apply bet_ts__os with y; Between.
apply l9_2, l9_8_2 with C.
  apply bet__ts; Between.
assert (HOS : OS A B C D) by (apply invert_one_side, out_one_side; [Col|Out]).
apply one_side_transitivity with D; Side.
apply one_side_not_col124 in HOS.
apply out_one_side; Out.
Qed.

Lemma impossible_case_3 :
  forall A B C D T x y,
  A <> D ->
  B <> D ->
  C <> D ->
  D <> T ->
  ~ Col A B C ->
  Bet A D T ->
  ~ Col B C T ->
  Bet B D C ->
  Bet B x A ->
  Bet x T y ->
  Par_strict B C x y ->
  False.
Proof.
intros A B C D T x y.
intros HAD HBD HCD HDT.
intros HABC HADT HBCT HBDC HABx HxTy HPar.
apply l12_6 in HPar.
absurd (TS B C x y); Side.
apply bet_ts__ts with T; trivial.
apply l9_8_2 with A.
  repeat split; Col; exists D; split; Col.
assert_diffs; apply out_one_side; [Col|Out].
Qed.

Lemma impossible_case_4_1 :
  forall A B C D T x y,
  A <> D ->
  C <> D ->
  ~ Col A B C ->
  Col A C y ->
  Bet A D T ->
  ~ Col B C T ->
  Bet B D C ->
  Out A B x ->
  Bet T y x ->
  False.
Proof.
intros A B C D T x y.
intros HAD HCD.
intros HABC HACy HADT HBCT HBDC HABx HTyx.
revert HACy.
apply one_side_not_col124 with T.
apply l9_17 with x; trivial.
assert (HOS : OS A C B D) by (apply invert_one_side, out_one_side; [Col|Out]).
apply one_side_transitivity with D.
  apply one_side_not_col124 in HOS; apply out_one_side; Out.
apply one_side_transitivity with B; [Side|].
assert (HACA : Col A C A) by Col.
assert (HABx' : Col B x A) by Col.
assert (H := l9_19 A C B x A HACA HABx'); rewrite H.
split; Col.
Qed.

Lemma impossible_case_4_2 :
  forall A B C D T x y,
  ~ Col A B C ->
  Col A C y ->
  Bet A D T ->
  ~ Col B C T ->
  Bet B D C ->
  Bet B A x ->
  Bet T y x ->
  Par_strict B C x y ->
  False.
Proof.
intros A B C D T x y.
intros HABC HACy HADT HBCT HBDC HABx HTyx HPar.
assert (HTS : TS B C A T) by (repeat split; [..|exists D; split]; Col).
assert (HOS : OS B C A x).
{
  assert (HBCB : Col B C B) by Col.
  assert (HABx' : Col A x B) by Col.
  assert (H := l9_19 B C A x B HBCB HABx'); rewrite H.
  apply not_col_distincts in HABC; spliter.
  split; [Out|Col].
}
assert (HTS' : TS B C x T) by (apply l9_8_2 with A; assumption);
clear HTS; clear HOS; destruct HTS' as [_ [_ [I [HBCI HITx]]]].
assert (HTx : T <> x) by (intro; treat_equalities; apply HBCT; Col).
assert (HPar' : Par_strict B C x T) by (apply par_strict_col_par_strict with y; Col).
apply HPar'; exists I; split; Col.
Qed.

Lemma impossible_case_4 :
  forall A B C D T x y,
  A <> D ->
  B <> D ->
  C <> D ->
  D <> T ->
  ~ Col A B C ->
  Col A C y ->
  Bet A D T ->
  ~ Col B C T ->
  Bet B D C ->
  Col A B x ->
  Bet T y x ->
  Par_strict B C x y ->
  False.
Proof.
intros A B C D T x y.
intros HAD HBD HCD HDT.
intros HABC HACy HADT HBCT HBDC HABx HTyx HPar.
revert HABx.
destruct (or_bet_out B A x) as [HABx|[HABx|HABx]]; [intro..|Col].

  apply (impossible_case_4_2 A B C D T x y); auto.

  apply (impossible_case_4_1 A B C D T x y); auto.
Qed.

Lemma impossible_two_sides_not_col : forall A B C D T Y,
  A <> D ->
  B <> D ->
  C <> D ->
  D <> T ->
  ~ Col A B C ->
  Bet A D T ->
  ~ Col B C T ->
  Bet B D C ->
  Bet B Y T ->
  ~ Col A C Y.
Proof.
intros A B C D T Y HAD HBD HCD HDT.
intros HABC HADT HBCT HBDC HBYT.
apply one_side_not_col124 with B.
apply l9_17 with T; trivial.
assert (HOS : OS A C B D).
  apply invert_one_side, out_one_side; [Col|Out].
apply one_side_transitivity with D; trivial.
apply one_side_not_col124 in HOS.
apply out_one_side; Out.
Qed.

(*
Lemma triangle_circumscription_aux : forall A B C P,
  Cong A P B P -> Cong A P C P -> exists CC, Cong A CC B CC /\ Cong A CC C CC /\ Coplanar A B C CC.
Proof.
  intros A B C D HCong1 HCong2.
  destruct (cop_dec A B C D).
    exists D; repeat split; assumption.
  destruct (l11_62_existence A B C D) as [CC [HCop HCC]].
  exists CC.
  assert (CC <> D) by (intro; subst; Cop).
  assert (Per B CC D) by Cop.
  assert (A <> CC).
  { intro; subst CC.
    destruct (l11_46 B A D) as [_ []]; auto.
    assert_diffs; apply per_not_col; auto.
  }
  assert (Per A CC D) by Cop.
  repeat split; trivial.
  - destruct (cong2_per2__cong_conga2 A CC D B CC D); Cong.
    intro; subst CC.
    destruct (l11_46 A B D) as [_ []]; Cong.
    assert_diffs; apply per_not_col; auto.
  - assert (Per C CC D) by Cop.
    destruct (cong2_per2__cong_conga2 A CC D C CC D); Cong.
    intro; subst CC.
    destruct (l11_46 A C D) as [_ []]; Cong.
    apply per_not_col; auto.
Qed.
*)

Lemma triangle_circumscription_implies_tarski_s_euclid_aux1 :
  forall A B C D T X Y Z M1 Z1,
  triangle_circumscription_principle ->
  B <> D ->
  C <> D ->
  D <> T ->
  T <> X ->
  ~ Col A B C ->
  Col A B M1 ->
  Bet A D T ->
  ~ Col B C T ->
  Bet B D C ->
  Col T Y Z ->
  Bet Y T X ->
  Bet Y M1 Z1 ->
  Cong Y T T X ->
  Cong Y M1 M1 Z1 ->
  Perp B C T Z ->
  Perp A B Y Z1 ->
  exists x, Col A B x /\ Par_strict B C x T /\ Cong X x Y x.
Proof.
intros A B C D T X Y Z M1 Z1; intro HTC.
intros HBD HCD HDT HTX.
intros HABC HABM1 HADT HBCT HBDC HTYZ HYTX HYM1Z1.
intros HCong1 HCong2 HPerp1 HPerp2.
assert (A <> D) by (intro; subst; apply HABC; Col).
assert_diffs.
assert (HCopA : Coplanar B C T A) by (exists D; left; split; Col).
assert (HCopB : Coplanar B C T B) by Cop.
assert (HCopC : Coplanar B C T C) by Cop.
assert (HCopT : Coplanar B C T T) by Cop.
assert (HCopZ : Coplanar B C T Z) by Cop.
assert (HCopY : Coplanar B C T Y) by (apply col_cop__cop with Z; Col).
assert (HCopX : Coplanar B C T X) by (apply col_cop__cop with Y; Col).
assert (HXYZ1 : ~ Col X Y Z1).
  {
  intro; apply HABC, col_permutation_4, par_id.
  assert (Col T Z Z1) by ColR.
  assert (Coplanar B C Y Z1) by (apply col2_cop__cop with T Z; Col).
  apply l12_9 with Y Z1; [Cop..| |Perp|].
    apply coplanar_pseudo_trans with B C T; auto; apply col_cop__cop with Z; auto.
  apply perp_sym, perp_col2 with T Z; Perp; Col.
  }
destruct (HTC X Y Z1 HXYZ1) as [x [HCong3 [HCong4 HCop1]]]; exists x.
assert (HYM1 : Y <> M1) by (intro; treat_equalities; auto).
assert (HCopZ1 : Coplanar B C T Z1).
  {
  assert (~ Col A B Y)
    by (intro; destruct (perp_not_col2 A B Y Z1) as [|HNCol]; Perp; apply HNCol; ColR).
  apply coplanar_pseudo_trans with A B Y; [| |apply coplanar_pseudo_trans with B C T..|]; Cop.
  }
assert (HCopx : Coplanar B C T x).
  apply coplanar_pseudo_trans with X Y Z1; trivial; apply coplanar_pseudo_trans with B C T; assumption.
assert (Col A B x).
  {
  apply cong_cop2_perp_bisect_col with Y Z1; trivial.
    apply coplanar_pseudo_trans with B C T; assumption.
    apply coplanar_pseudo_trans with B C T; assumption.
    apply cong_transitivity with X x; Cong.
  repeat split; Perp.
  exists M1; repeat split; Between; Cong.
  }
do 2 (split; trivial).
apply par_not_col_strict with T; Col.
apply l12_9 with X Y; [apply coplanar_pseudo_trans with B C T; assumption..| |].
  apply perp_sym, perp_col2 with T Z; Perp; ColR.
apply perp_bisect_perp; apply cong_cop_perp_bisect; Cong; [|Cop].
intro; subst; apply HABC; ColR.
Qed.

Lemma triangle_circumscription_implies_tarski_s_euclid_aux :
  forall A B C D T X Y Z M1 Z1 M2 Z2,
  triangle_circumscription_principle ->
  B <> D ->
  C <> D ->
  D <> T ->
  T <> X ->
  ~ Col A B C ->
  Col A B M1 ->
  Col A C M2 ->
  Bet A D T ->
  ~ Col B C T ->
  Bet B D C ->
  Col T Y Z ->
  Bet Y T X ->
  Bet Y M1 Z1 ->
  Bet Y M2 Z2 ->
  Cong Y T T X ->
  Cong Y M1 M1 Z1 ->
  Cong Y M2 M2 Z2 ->
  Perp B C T Z ->
  Perp A B Y Z1 ->
  Perp A C Y Z2 ->
  exists x, exists y, Bet A B x /\ Bet A C y /\ Bet x T y.
Proof.
intros A B C D T X Y Z M1 Z1 M2 Z2; intro HTC.
intros HBD HCD HDT HTX.
intros HABC HABM1 HACM2 HADT HBCT HBDC HTYZ HYTX HYM1Z1.
intros HYM2Z2 HCong5 HCong6 HCong7 HPerp1 HPerp2 HPerp3.
assert (Hx := triangle_circumscription_implies_tarski_s_euclid_aux1 A B C D T X Y Z M1 Z1).
destruct Hx as [x [HABx [Hx1 Hx2]]]; [assumption..|]; exists x.
assert (Hy := triangle_circumscription_implies_tarski_s_euclid_aux1 A C B D T X Y Z M2 Z2).
destruct Hy as [y [HACy [Hy1 Hy2]]]; [Between; Col; Perp..|]; exists y.
assert (HxTy : Col x T y).
  {
  elim (eq_dec_points T x); intro; [|elim (eq_dec_points T y); intro]; [subst; Col..|].
  assert_diffs.
  apply col_permutation_4, cop_perp2__col with X Y;
    [|apply perp_bisect_perp, cong_cop_perp_bisect; Cong; Cop..].
  assert (Coplanar B C T Y) by (apply col_cop__cop with Z; Col; Cop).
  assert (Coplanar B C T X) by (apply col_cop__cop with Y; Col).
  apply coplanar_pseudo_trans with B C T; Cop.
  }
assert (HPar : Par_strict B C x y).
  {
  apply par_strict_col_par_strict with T; Col.
  intro; subst y.
  destruct HPerp3 as [_ [HAC _]].
  assert (A = x) by (apply (l6_21 A B C A); Col).
  subst; apply Hx1; exists D; split; Col.
  }
assert (A <> D) by (intro; subst; apply HABC; Col).

elim HxTy; clear HxTy; intro HxTy.

  elim HABx; clear HABx; intro HABx.

    elim HACy; clear HACy; intro HACy; auto.
    exfalso; elim HACy; clear HACy; intro HACy.

      apply (impossible_case_1 A B C x y); assumption.

      apply (impossible_case_2 A B C D T x y); Col.

    exfalso; elim HABx; clear HABx; intro HABx.

      apply (impossible_case_3 A B C D T x y); assumption.

      apply (impossible_case_2 A C B D T y x); Col; Between.

  exfalso; elim HxTy; clear HxTy; intro HxTy.

    apply (impossible_case_4 A B C D T x y); assumption.

    apply (impossible_case_4 A C B D T y x); Between; Col; Par.
Qed.

Lemma triangle_circumscription_implies_tarski_s_euclid :
  triangle_circumscription_principle ->
  tarski_s_parallel_postulate.
Proof.
unfold tarski_s_parallel_postulate.
intro HTC; apply tarski_s_euclid_remove_degenerated_cases.
intros A B C D T HAB HAC HAD HAT HBC HBD HBT HCD HCT HDT HABC HADT HBDC HBCT.
clear HAT HBT HCT.
assert (HY := l8_18_existence B C T HBCT); destruct HY as [Y [HBCY HPerp]].
revert B C HAB HAC HBC HBD HCD HABC HBDC HBCT HBCY HPerp.
cut (forall B C, A <> B -> A <> C -> B <> C -> B <> D -> C <> D -> ~ Col A B C ->
                 Bet B D C -> ~ Col B C T -> Col B C Y -> Perp B C T Y -> B <> Y ->
                 exists x y : Tpoint, Bet A B x /\ Bet A C y /\ Bet x T y).
  {
  intros Haux B C HAB HAC HBC HBD HCD HABC HBDC HBCT HBCY HPerp.
  elim (eq_dec_points B Y); auto.
  intro HBY.
  elim (eq_dec_points C Y); intro HCY.
    subst; exfalso; apply HBC; reflexivity.
  apply between_symmetry in HBDC.
  apply perp_left_comm in HPerp.
  destruct (Haux C B) as [y [x [HACy [HABx HxTy]]]]; Col.
  exists x, y; repeat split; Between.
  }
intros B C HAB HAC HBC HBD HCD HABC HBDC HBCT HBCY HPerp HBY.
elim (eq_dec_points C Y); intro HCY.

  {
  treat_equalities.
  assert (HCT : C <> T) by (apply not_col_distincts in HBCT; spliter; auto).
  assert (HY := midpoint_existence C T); destruct HY as [Y HY].
  assert (HAY : A <> Y) by (intro; treat_equalities; apply HABC; ColR).
  assert (H := midpoint_distinct_1 Y C T HCT HY); destruct H as [HCY HTY];
  apply not_eq_sym in HCY; apply not_eq_sym in HTY.
  assert (HBY : B <> Y) by (intro; subst; apply HBCT; Col).
  destruct HY as [HCTY HCYTY].
  assert (HACY : ~ Col A B Y) by (apply impossible_two_sides_not_col with C D T; Between; Col).
  assert (HX := symmetric_point_construction Y T); destruct HX as [X HX].
  assert (H := midpoint_distinct_2 T Y X HTY HX); destruct H as [HTX HXY]; apply not_eq_sym in HTX.
  destruct HX as [HXTY HXTYT].
  assert (HZ1 := l10_2_existence A B Y); destruct HZ1 as [Z1 HZ1].
  elim HZ1; clear HZ1; intro HZ1; destruct HZ1 as [Hclear HZ1]; [|contradiction]; clear Hclear.
  destruct HZ1 as [[M1 [[HXM1Z1 HM1XM1Z1] HABM1]] HZ1].
  assert (HZ2 := l10_2_existence A C Y); destruct HZ2 as [Z2 HZ2].
  elim HZ2; clear HZ2; intro HZ2; destruct HZ2 as [Hclear HZ2]; [|contradiction]; clear Hclear.
  destruct HZ2 as [[M2 [[HXM2Z2 HM2XM2Z2] HACM2]] HZ2].
  elim HZ2; clear HZ2; intro HZ2; [|treat_equalities; exfalso; apply HABC; ColR].
  elim HZ1; clear HZ1; intro HZ1; [|treat_equalities; contradiction].
  apply triangle_circumscription_implies_tarski_s_euclid_aux with D X Y C M1 Z1 M2 Z2; Col.
  }

  {
  assert (HX := symmetric_point_construction Y T); destruct HX as [X HX].
  assert (H := perp_distinct B C T Y HPerp); destruct H as [Hclear HTY]; clear Hclear.
  assert (H := midpoint_distinct_2 T Y X HTY HX); destruct H as [HTX HXY]; apply not_eq_sym in HTX.
  destruct HX as [HXTY HXTYT].
  assert (HZ1 := l10_2_existence A B Y); destruct HZ1 as [Z1 HZ1].
  elim HZ1; clear HZ1; intro HZ1; destruct HZ1 as [Hclear HZ1]; [|contradiction]; clear Hclear.
  destruct HZ1 as [[M1 [[HXM1Z1 HM1XM1Z1] HABM1]] HZ1].
  assert (HZ2 := l10_2_existence A C Y); destruct HZ2 as [Z2 HZ2].
  elim HZ2; clear HZ2; intro HZ2; destruct HZ2 as [Hclear HZ2]; [|contradiction]; clear Hclear.
  destruct HZ2 as [[M2 [[HXM2Z2 HM2XM2Z2] HACM2]] HZ2].
  assert (HABY : ~ Col A B Y) . (intro; apply HBY; apply l6_21 with A B C B; Col).
  assert (HACY : ~ Col A C Y) by (intro; apply HCY; apply l6_21 with A C B C; Col).
  elim HZ1; clear HZ1; intro HZ1; [|treat_equalities; contradiction].
  elim HZ2; clear HZ2; intro HZ2; [|treat_equalities; contradiction].
  apply triangle_circumscription_implies_tarski_s_euclid_aux with D X Y Y M1 Z1 M2 Z2; Col.
  }
Qed.

End TCP_tarski.


Require Import Utf8.
From Coq Require Import ssreflect ssrnat ssrbool ssrfun seq.

Require Import core.

Generalizable All Variables.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

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

Notation "∄  x .. y , P" := (¬ (∃ x, .. (∃ y, P) ..))
  (at level 200, x binder, y binder, right associativity) : type_scope.

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

Instance Num_nat__ : Num nat := {| core.__op_zp__ := addn
                                 ; core.__op_zm__ := subn
                                 ; core.__op_zt__ := muln
                                 ; abs            := id
                                 ; fromInteger    := BinInt.Z.to_nat
                                 ; negate         := fun _ => 0
                                 ; signum         := fun n => match n with
                                                       | O   => 0
                                                       | S _ => 1
                                                     end |}.
Instance Num_Int__ : Num Int. Admitted.

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

Infix "∈" := List.In (at level 40).

Fixpoint indices_from {A} {B} `{Num A} (z : A) (s : list B) : list A :=
  match s with
    | [::]    => [::]
    | x :: s' => z :: indices_from (z + #1) s'
  end.

Definition indices {A} {B} `{Num B} : list A → list B := indices_from #0.

Theorem indices_from_is_iota {A} (z : nat) (s : list A) :
  indices_from z s = iota z (length s).
Proof. by elim: s z => [|a s IH] z //=; rewrite /BinPos.Pos.to_nat /= addn1 IH. Qed.

Theorem indices_is_iota {A} (s : list A) :
  indices s = iota 0 (length s).
Proof. by rewrite -indices_from_is_iota. Qed.

Fixpoint zip_with {A} {B} {C} (f : A → B → C) (s : list A) (t : list B) : list C :=
  match s , t with
    | a :: s' , b :: t' => f a b :: zip_with f s' t'
    | _       , _       => [::]
  end.

Theorem zip_with_is_zip {A} {B} :
  zip_with (@pair A B) =2 zip.
Proof. by elim => [|a s IH] [|b t] //=; rewrite IH. Qed.

Theorem map_zip_is_zip_with {A} {B} {C} (f : A → B → C) s t :
  zip_with f s t = map (prod_curry f) (zip s t).
Proof. by elim: s t => [|a s IH] [|b t] //=; rewrite IH. Qed.

Theorem map_zip_is_zip_with' {A} {B} {C} (f : A * B → C) s t :
  zip_with (prod_uncurry f) s t = map f (zip s t).
Proof. by elim: s t => [|a s IH] [|b t] //=; rewrite IH. Qed.

Fixpoint zip_with_index_from {A} {B} {C} `{Num B} (z : B) (f : A → B → C) (s : list A) : list C :=
  match s with
    | [::]    => [::]
    | a :: s' => f a z :: zip_with_index_from (z + #1) f s'
  end.

Definition zip_with_index {A} {B} {C} `{Num B} : (A → B → C) → list A → list C :=
  zip_with_index_from #0.

Theorem zip_with_index_from_is_zip_with {A} {B} (z : nat) (f : A → nat → B) (s : list A) :
  zip_with_index_from z f s = zip_with f s (indices_from z s).
Proof. by elim: s z => [|a s IH] z //=; rewrite /BinPos.Pos.to_nat /= addn1 IH. Qed.

Theorem zip_with_index_is_zip_with {A} {B} (f : A → nat → B) (s : list A) :
  zip_with_index f s = zip_with f s (indices s).
Proof. by rewrite -zip_with_index_from_is_zip_with. Qed.

Notation "[ 'seq' E | i ← s | j ← t ]"     := (zip_with       (fun i j => E) s t)
  (at level 0, E at level 99, i ident, j ident,
   format "[ '[hv' 'seq'  E '/ '  |  i  ←  s '/ '  |  j  ←  t ] ']'").
Notation "[ 'seq' E | i ← s | j 'index' ]" := (zip_with_index (fun i j => E) s)
  (at level 0, E at level 99, i ident, j ident,
   format "[ '[hv' 'seq'  E '/ '  |  i  ←  s '/ '  |  j  'index' ] ']'").

Notation "[ 'seq' E | i <- s | j <- t ]"    := [seq E | i ← s | j ← t]
  (at level 0, E at level 99, i ident, j ident, only parsing).
Notation "[ 'seq' E | i <- s | j 'index' ]" := [seq E | i ← s | j index]
  (at level 0, E at level 99, i ident, j ident, only parsing).

Notation "[ 'seq' E | i ← s ]" := [seq E | i <- s]
  (at level 0, E at level 99, i ident,
   format "[ '[hv' 'seq'  E '/ '  |  i  ←  s ] ']'").
Notation "[ 'seq' E | i : T ← s ]" := [seq E | i : T <- s]
  (at level 0, E at level 99, i ident, only parsing).

Fixpoint unzip {A} {B} (s : list (A * B)) : list A * list B :=
  match s with
    | [::]        => ([::], [::])
    | (a,b) :: s' => let: (sa,sb) := unzip s'
                     in (a::sa, b::sb)
  end.

Theorem unzip_is_unzips {A} {B} (s : list (A * B)) :
  unzip s = (unzip1 s, unzip2 s).
Proof. by elim: s => [|[a b] s IH] //=; rewrite IH. Qed.

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

Inductive Context := EmptyCtx
                   | AddCtx : ∀ (Σ : Context) (n : Var) (e : CoreExpr), Context.

Notation "·" := EmptyCtx.
Notation "Σ &[ n ↦ e ]" := (AddCtx Σ n e) (at level 50, format "Σ  &[ n  ↦  e ]").

Definition addManyCtx (Σ : Context) (ns : list Var) (es : list CoreExpr) : Context :=
  foldl (fun Σ' ne => Σ' &[ne.1 ↦ ne.2]) Σ (zip ns es).

Notation "Σ &*[ ns ↦* es ]" := (addManyCtx Σ ns es)
  (at level 50, format "Σ  &*[ ns  ↦*  es ]").

Axiom lookup : Context → Var → option CoreExpr. (* Requires some sort of comparison *)

Axiom subst       : CoreExpr → Var      → CoreExpr      → CoreExpr. (* Presumably convertable *)
Axiom multisubst  : CoreExpr → list Var → list CoreExpr → CoreExpr. (* Presumably convertable *)
Axiom multisubst' : CoreExpr → list (Var * CoreExpr)    → CoreExpr. (* Presumably convertable *)
Notation "e₁ $[ n ↦ e₂ ]" := (subst e₁ n e₂)
  (at level 50, format "e₁ $[ n ↦ e₂ ]", left associativity).
Notation "e $*[ ns ↦* es' ]" := (multisubst e ns es')
  (at level 50, format "e $*[ ns ↦* es' ]", left associativity).
Notation "e' $*[*↦*] nes" := (multisubst' e' nes)
  (at level 50, left associativity).

Axiom fv : CoreExpr → VarSet. (* Convertable, but maybe not at this type. *)

Axiom mkVarSet : list Var → VarSet. (* Convertable *)
Axiom isEmptyVarSet : VarSet → bool. (* Convertable *)
Axiom intersectVarSet : VarSet → VarSet → VarSet. (* Convertable *)
Infix "∩ᵥ" := intersectVarSet (at level 40).

Axiom isDataConId_maybe : Id → option DataCon. (* Convertable *)

Axiom coercionKind     : Coercion → Pair Type_. (* Converted *)
Axiom dataConRepType   : DataCon → Type_.       (* Converted *)
Axiom mkForAllTys      : list TyBinder -> Type_ -> Type_. (* Convertable *)
Axiom partitionBinders : list TyBinder -> (list TyVar * list Type_). (* Convertable *)

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

Notation "e ▷ γ" := (Mk_Cast e γ) (at level 40, left associativity).

Notation "'ƛ' n ',' e" := (Mk_Lam n e) (at level 200, left associativity, format "ƛ n ,  e").

Infix "@@" := Mk_App (at level 20, left associativity).

(* From the converter, prettified *)
Arguments Mk_App {_} _ _.
Definition mkApps {b} (f : Expr b) (args : list (Arg b)) : Expr b :=
  foldl Mk_App f args.
Infix "@@*" := mkApps (at level 20, left associativity).

Notation "⟨ τ ⟩ᴺ" := (Mk_Refl Mk_Nominal          τ) (format "⟨ τ ⟩ᴺ").
Notation "⟨ τ ⟩ᴿ" := (Mk_Refl Mk_Representational τ) (format "⟨ τ ⟩ᴿ").
Notation "⟨ τ ⟩ᴾ" := (Mk_Refl Mk_Phantom          τ) (format "⟨ τ ⟩ᴾ").

(* (do-add-in-font ?\⨾ (font-spec :name "Apple Symbols" :size 14)) *)
Infix "⨾" := Mk_TransCo (at level 40).

Infix "@!" := Mk_AppCo (at level 20, left associativity).

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

Reserved Notation "Σ '[op]⊢' e ⟶ e'" (at level 99).
Inductive SingleStep (Σ : Context) : CoreExpr → CoreExpr → Type :=

  | S_Var : ∀ n e,
      lookup Σ n = Some e
      →
      Σ [op]⊢ Mk_Var n ⟶ e

  | S_App : ∀ e₁ e₁' e₂,
      Σ [op]⊢ e₁ ⟶ e₁'
      →
      Σ [op]⊢ e₁ @@ e₂ ⟶ e₁' @@ e₂

  | S_Beta : ∀ n e₁ e₂,
      Σ [op]⊢ (ƛ n, e₁) @@ e₂ ⟶ e₁$[n ↦ e₂]
  (* TODO: Evaluate under *type* lambdas *)

  | S_Push : ∀ n e₁ γ e₂,
      let γ₀ := Mk_SymCo (Mk_NthCo #0 γ) in
      let γ₁ := Mk_NthCo #1 γ in
      (∄ τ, e₂ = Mk_Type τ) →
      (∄ γ, e₂ = Mk_Coercion γ)
      →
      Σ [op]⊢ ((ƛ n, e₁) ▷ γ) @@ e₂ ⟶ (ƛ n, e₁ ▷ γ₁) @@ (e₂ ▷ γ₀)

  | S_TPush : ∀ n e γ τ,
      Σ [op]⊢ ((ƛ n, e) ▷ γ) @@ Mk_Type τ ⟶ (ƛ n, e ▷ (γ @! Mk_CoVarCo n)) @@ Mk_Type τ

  | S_CPush : ∀ n e γ γ',
      let γ₀ := Mk_NthCo #1 (Mk_NthCo #0 γ) in
      let γ₁ := Mk_SymCo (Mk_NthCo #2 (Mk_NthCo #0 γ)) in
      let γ₂ := Mk_NthCo #1 γ
      in
      Σ [op]⊢ ((ƛ n, e) ▷ γ) @@ Mk_Coercion γ' ⟶ (ƛ n, e ▷ γ₂) @@ Mk_Coercion (γ₀ ⨾ γ' ⨾ γ₁)

  (* For determinism, may want to require `e` to be a value *)
  | S_Trans : ∀ e γ₁ γ₂,
      Σ [op]⊢ (e ▷ γ₁) ▷ γ₂ ⟶ e ▷ (γ₁ ⨾ γ₂)

  | S_Cast : ∀ e γ e',
      Σ [op]⊢ e ⟶ e'
      →
      Σ [op]⊢ e ▷ γ ⟶ e' ▷ γ

  (* Or: `Mk_Tick tick e ⟶ e` *)
  | S_Tick : ∀ tick e e',
      Σ [op]⊢ e ⟶ e'
      →
      Σ [op]⊢ Mk_Tick tick e ⟶ Mk_Tick tick e'

  | S_Case : ∀ e n τ alts e',
      Σ [op]⊢ e ⟶ e'
      →
      Σ [op]⊢ Mk_Case e n τ alts ⟶ Mk_Case e' n τ alts

  (* In the source, we have "u' := u[n ↦ e]…"; I believe "e" should actually be
     the matched term. *)
  | S_MatchData : ∀ K K_con τs' σs es n τ alts αs xs u,
      isDataConId_maybe K = Some K_con →
      length αs = length σs →
      length xs = length es →
      (Mk_DataAlt K_con, αs ++ xs, u) ∈ alts →
      let u' := u$[n ↦ Mk_Var K @@* τs' @@* σs @@* es]$*[αs ↦* σs]$*[xs ↦* es]
      in
      Σ [op]⊢ Mk_Case (Mk_Var K @@* τs' @@* σs @@* es) n τ alts ⟶ u'

  | S_MatchLit : ∀ lit n τ alts u,
      (Mk_LitAlt lit, [::], u) ∈ alts
      →
      Σ [op]⊢ Mk_Case (Mk_Lit lit) n τ alts ⟶ u$[n ↦ Mk_Lit lit]

  | S_MatchDefault : ∀ e n τ alts u,
      (Mk_DEFAULT, [::], u) ∈ alts →
      (* Factor out from S_MatchData? *)
      [\/ ∃ K K_con τs' σs es,
            isDataConId_maybe K = Some K_con ∧
            e = (Mk_Var K @@* τs' @@* σs @@* es) ∧
            ∄ αs xs u,
              length αs = length σs ∧
              length xs = length es ∧
              (Mk_DataAlt K_con, αs ++ xs, u) ∈ alts
      (* Factor out from S_MatchLit? *)
      |   ∃ lit,
            e = Mk_Lit lit ∧
            ∄ u,
              (Mk_LitAlt lit, [::], u) ∈ alts ]
      →
      Σ [op]⊢ Mk_Case e n τ alts ⟶ u$[n ↦ e]

(* Just use `Mk_InstCo`! *)
(* Can't do the tricky `liftCoSubst` case – the `$*[*↦*]`s below are lies. *)
(*
  | S_CasePush : ∀ K τs σs es γ n τ₂ alts T τs' αs αs_vars βs βs_vars τs₁,
      partitionBinders αs = (αs_vars, [::]) →
      partitionBinders βs = (βs_vars, [::]) →
      length τs  = length τs' →
      length τs  = length αs  →
      length σs  = length βs  →
      length τs₁ = length es  →
      Mk_Pair (Mk_TyConApp T τs) (Mk_TyConApp T τs') = coercionKind γ →
      mkForAllTys αs (mkForAllTys βs
        (mkForAllTys (map Mk_Anon τs₁) (Mk_TyConApp T (map Mk_TyVarTy αs_vars))))
          = dataConRepType K →
      let es' := [seq
                    e ▷ (τ₁ $*[*↦*] [seq (α, Mk_NthCo a γ) | α ← αs_vars | a index]
                            $*[*↦*] [seq (β, ⟨σ⟩ᴺ)         | β ← βs_vars | σ ← σs])
                 | e ← es | τ₁ ← τs₁]
      in
      Σ [op]⊢ Mk_Case (K @@* τs @@* σs @@* es ▷ γ) n τ₂ alts ⟶
                Mk_Case (K @@* τs' @@* σs @@* es') n τ₂ alts
*)

  | S_LetNonRec : ∀ n e₁ e₂,
      Σ [op]⊢ Mk_Let (Mk_NonRec n e₁) e₂ ⟶ e₂$[n ↦ e₁]

  | S_LetRec : ∀ ns es u u',
      length ns = length es →
      Σ &*[ns ↦* es] [op]⊢ u ⟶ u'
      →
      Σ [op]⊢ Mk_Let (Mk_Rec (zip ns es)) u ⟶ Mk_Let (Mk_Rec (zip ns es)) u'

  | S_LetRecApp : ∀ ns es u e',
      length ns = length es
      →
      Σ [op]⊢ Mk_Let (Mk_Rec (zip ns es)) u @@ e' ⟶ Mk_Let (Mk_Rec (zip ns es)) (u @@ e')

  | S_LetRecCast : ∀ ns es u γ,
      length ns = length es
      →
      Σ [op]⊢ Mk_Let (Mk_Rec (zip ns es)) u ▷ γ ⟶ Mk_Let (Mk_Rec (zip ns es)) (u ▷ γ)

  | S_LetRecCase : ∀ ns es u n₀ τ alts,
      length ns = length es
      →
      Σ [op]⊢ Mk_Case (Mk_Let (Mk_Rec (zip ns es)) u) n₀ τ alts ⟶
                Mk_Let (Mk_Rec (zip ns es)) (Mk_Case u n₀ τ alts)

  | S_LetRecFlat : ∀ ns es ns' es' u,
      length ns  = length es →
      length ns' = length es'
      →
      Σ [op]⊢ Mk_Let (Mk_Rec (zip ns es)) (Mk_Let (Mk_Rec (zip ns' es')) u) ⟶
                Mk_Let (Mk_Rec (zip (ns ++ ns') (es ++ es'))) u

  | S_LetRecReturn : ∀ ns es u,
      length ns = length es →
      isEmptyVarSet (fv u ∩ᵥ mkVarSet ns)
      →
      Σ [op]⊢ Mk_Let (Mk_Rec (zip ns es)) u ⟶ u

where "Σ '[op]⊢' e ⟶ e'" := (SingleStep Σ e e').