(*===================================================
=====================================================
              TOPOLOGICAL FMAPS, HMAPS -

              WITH TAGS AND EMBEDDINGS

                        PART 5:

              EQUIVALENCES (eqc, expf),
                  CHARACTERISTICS,

            GENUS THEOREM, EULER_POINCARE FORMULA,
                   PLANARITY CRITERIA

=====================================================
===================================================*)

Require Export Del04.

(*===================================================
            CONNECTIVITY IN HMAPS : eqc
===================================================*)

(* Connectivity: Definition in Prop "a la" Warshall *)

Fixpoint eqc(m:fmap)(x y:dart){struct m}:Prop:=
 match m with
     V => False
  |  I m0 x0 _ _ => x=x0 /\ y=x0 \/ eqc m0 x y
  |  L m0 _ x0 y0 =>
      eqc m0 x y
     \/ eqc m0 x x0 /\ eqc m0 y0 y
     \/ eqc m0 x y0 /\ eqc m0 x0 y
 end.

(* Decidability of eqc: *)

Lemma eqc_exd_exd : forall (m:fmap)(x y:dart),
  eqc m x y -> (exd m x /\ exd m y).
Proof.
induction m.
 simpl in |- *.
   tauto.
 simpl in |- *.
   intros.
   elim H.
  intro.
    decompose [and] H0.
    rewrite H1.
    rewrite H2.
    tauto.
  generalize (IHm x y).
    tauto.
 simpl in |- *.
   intros.
   generalize (IHm x y).
   generalize (IHm x d0).
   generalize (IHm x d1).
   generalize (IHm d1 y).
   generalize (IHm d0 y).
   tauto.
Qed.

Lemma eqc_dec: forall (m:fmap)(x y:dart),
   {eqc m x y} + {~eqc m x y}.
Proof.
induction m.
 simpl in |- *.
   tauto.
 simpl in |- *.
   intros.
   elim (IHm x y).
  tauto.
  elim (eq_dart_dec x d).
   elim (eq_dart_dec y d).
    tauto.
    tauto.
   tauto.
 simpl in |- *.
   intros x y.
   elim (IHm x y).
  tauto.
  elim (IHm x d0).
   elim (IHm d1 y).
    tauto.
    elim (IHm x d1).
     elim (IHm d0 y).
      tauto.
      tauto.
     tauto.
   elim (IHm d1 y).
    elim (IHm x d1).
     elim (IHm d0 y).
      tauto.
      tauto.
     tauto.
    elim (IHm x d1).
     elim (IHm d0 y).
      tauto.
      tauto.
     elim (IHm d0 y).
      tauto.
      tauto.
Qed.

(* Reflexivity of eqc: *)

Lemma eqc_refl: forall(m:fmap)(x:dart),
   exd m x -> eqc m x x.
Proof.
induction m.
 simpl in |- *.
   tauto.
 simpl in |- *.
   intros.
   generalize (IHm x).
   intro.
   assert (d = x -> x = d).
  intro.
    symmetry  in |- *.
    tauto.
  tauto.
 simpl in |- *.
   intros.
   generalize (IHm x).
   tauto.
Qed.

(* Symmetry of eqc: *)

Lemma eqc_symm: forall(m:fmap)(x y:dart),
   eqc m x y -> eqc m y x.
Proof.
induction m.
 simpl in |- *.
   tauto.
 simpl in |- *.
   intros.
   elim H.
  tauto.
  intro.
    generalize (IHm x y).
    tauto.
 simpl in |- *.
   intros.
   elim H.
  left.
    apply IHm.
    tauto.
  clear H.
    intro.
    elim H.
   clear H.
     intro.
     right.
     right.
     split.
    apply IHm.
      tauto.
    apply IHm.
      tauto.
   intros.
     right.
     left.
     split.
    apply IHm; tauto.
    apply IHm; tauto.
Qed.

(* Transitivity of eqc: *)

Lemma eqc_trans: forall(m:fmap)(x y z:dart),
   eqc m x y -> eqc m y z -> eqc m x z.
Proof.
induction m.
 simpl in |- *.
   tauto.
 simpl in |- *.
   intros.
   elim H.
  elim H0.
   tauto.
   intro.
     intros.
     elim H2.
     intros.
     rewrite H3.
     rewrite H4 in H1.
     tauto.
  intros.
    elim H0.
   intro.
     elim H2.
     intros.
     rewrite H4.
     rewrite H3 in H1.
     tauto.
   right.
     eapply IHm.
    apply H1.
      tauto.
 simpl in |- *.
   intros.
   elim H.
  clear H.
    elim H0.
   clear H0.
     left.
     eapply IHm.
    apply H0.
      tauto.
   clear H0.
     intros.
     elim H.
    clear H.
      intro.
      right.
      left.
      split.
     apply (IHm x y d0).
      tauto.
      tauto.
     tauto.
    intro.
      right.
      right.
      split.
     apply (IHm x y d1).
      tauto.
      tauto.
     tauto.
  clear H.
    intro.
    elim H.
   clear H.
     intro.
     elim H0.
    clear H0.
      intro.
      right.
      left.
      split.
     tauto.
     apply (IHm d1 y z).
      tauto.
      tauto.
    intros.
      elim H1.
     intros.
       clear H1.
       right.
       left.
       tauto.
     intro.
       clear H1.
       left.
       apply (IHm x d0 z).
      tauto.
      tauto.
   intro.
     clear H.
     elim H0.
    clear H0.
      intro.
      right.
      right.
      split.
     tauto.
     apply (IHm d0 y z).
      tauto.
      tauto.
    clear H0.
      intro.
      elim H.
     clear H.
       intro.
       left.
       apply (IHm x d1 z).
      tauto.
      tauto.
     intro.
       clear H.
       right.
       right.
       tauto.
Qed.

(* OK: *)

Lemma eqc_cA_r :
 forall (m:fmap)(k:dim)(x:dart),
    inv_hmap m -> exd m x -> eqc m x (cA m k x).
Proof.
induction m.
 simpl in |- *.
   tauto.
 simpl in |- *.
   intros.
   elim (eq_dart_dec d x).
  generalize (eqc_refl m x).
    intros.
    symmetry  in a.
    tauto.
  intro.
    generalize (IHm k x).
    tauto.
 simpl in |- *.
   unfold prec_L in |- *.
   intros.
   decompose [and] H.
   clear H.
   elim (eq_dim_dec d k).
  intro.
    elim (eq_dart_dec d0 x).
   intro.
     rewrite <- a0.
     right.
     left.
     split.
    apply eqc_refl.
      rewrite a0.
      tauto.
    apply eqc_refl.
      tauto.
   intro.
     elim (eq_dart_dec (cA_1 m k d1) x).
    intro.
      assert (d1 = cA m k x).
     rewrite <- a0.
       rewrite cA_cA_1.
      tauto.
      tauto.
      tauto.
     right.
       right.
       rewrite H.
       generalize (IHm k d0 H1 H3).
       generalize (IHm k x H1 H0).
       tauto.
    intro.
      generalize (IHm k x).
      tauto.
  generalize (IHm k x).
    tauto.
Qed.

(* OK: *)

Lemma eqc_cA_1_r :
 forall (m:fmap)(k:dim)(x:dart),
    inv_hmap m -> exd m x -> eqc m x (cA_1 m k x).
Proof.
induction m.
 simpl in |- *.
   tauto.
 simpl in |- *.
   intros.
   elim (eq_dart_dec d x).
  generalize (eqc_refl m x).
    intros.
    symmetry  in a.
    tauto.
  intro.
    generalize (IHm k x).
    tauto.
 simpl in |- *.
   unfold prec_L in |- *.
   intros.
   decompose [and] H.
   clear H.
   elim (eq_dim_dec d k).
  intro.
    elim (eq_dart_dec d1 x).
   intro.
     rewrite <- a0.
     right.
     right.
     split.
    apply eqc_refl.
      tauto.
    apply eqc_refl.
      tauto.
   intro.
     elim (eq_dart_dec (cA m k d0) x).
    intro.
      assert (d0 = cA_1 m k x).
     rewrite <- a0.
       rewrite cA_1_cA.
      tauto.
      tauto.
      tauto.
     right.
       left.
       rewrite H.
       generalize (IHm k x).
       generalize (IHm k d1).
       tauto.
    intro.
      generalize (IHm k x).
      tauto.
  generalize (IHm k x).
    tauto.
Qed.

(* OK: *)

Lemma eqc_eqc_cA :
 forall (m:fmap)(k:dim)(x y:dart),
   inv_hmap m ->
     eqc m x y -> eqc m x (cA m k y).
Proof.
intros.
apply eqc_trans with y.
 tauto.
 apply eqc_cA_r.
  tauto.
  generalize (eqc_exd_exd m x y).
    tauto.
Qed.

(* OK: *)

Lemma eqc_eqc_cA_1 :
 forall (m:fmap)(k:dim)(x y:dart),
   inv_hmap m ->
     eqc m x y -> eqc m x (cA_1 m k y).
Proof.
intros.
apply eqc_trans with y.
 tauto.
 apply eqc_cA_1_r.
  tauto.
  generalize (eqc_exd_exd m x y).
    tauto.
Qed.

(* OK: *)

Lemma eqc_cA_1_eqc :
 forall (m:fmap)(k:dim)(x y:dart),
   inv_hmap m ->
     eqc m (cA_1 m k x) y -> eqc m x y.
Proof.
intros.
generalize (eqc_cA_1_r m k x).
intros.
apply eqc_trans with (cA_1 m k x).
 apply H1.
  tauto.
  generalize (eqc_exd_exd m (cA_1 m k x) y).
    intros.
    generalize (exd_cA_1 m k x).
    tauto.
 tauto.
Qed.

(* OK: *)

Lemma eqc_cA_eqc :
 forall (m:fmap)(k:dim)(x y:dart),
   inv_hmap m ->
     eqc m x (cA m k y) -> eqc m x y.
Proof.
intros.
generalize (eqc_cA_r m k y H).
intros.
apply eqc_trans with (cA m k y).
 tauto.
 apply eqc_symm.
   apply H1.
   generalize (eqc_exd_exd m x (cA m k y)).
   intros.
   generalize (exd_cA m k y).
   tauto.
Qed.

Lemma eqc_eqc_cF :
 forall (m:fmap)(x y:dart),
   inv_hmap m ->
     eqc m x y -> eqc m x (cF m y).
Proof.
unfold cF in |- *.
intros.
assert (eqc m x (cA_1 m zero y)).
 apply eqc_eqc_cA_1.
  tauto.
  tauto.
 eapply eqc_eqc_cA_1.
  tauto.
  tauto.
Qed.

(* OK: *)

Lemma exd_Iter_cF :
 forall (m:fmap)(n:nat)(z:dart),
   inv_hmap m -> exd m z ->
     exd m (Iter (cF m) n z).
Proof.
intros.
induction n.
 simpl in |- *.
   tauto.
 simpl in |- *.
   generalize (exd_cF m (Iter (cF m) n z)).
   tauto.
Qed.

Lemma eqc_Iter_cF :
 forall (m:fmap)(n:nat)(z:dart),
   inv_hmap m -> exd m z ->
     eqc m z (Iter (cF m) n z).
Proof.
intros.
induction n.
 simpl in |- *.
   apply eqc_refl.
   tauto.
 simpl in |- *.
   eapply eqc_trans.
  apply IHn.
    apply eqc_eqc_cF.
   tauto.
   apply eqc_refl.
  apply exd_Iter_cF.
    tauto.
    tauto.
Qed.

(*===================================================
      	      NUMBERING AND CHARACTERISTICS:
===================================================*)

Require Import ZArith.
Open Scope Z_scope.

Fixpoint nd(m:fmap):Z :=
 match m with
    V => 0
  | I m0 x _ _ => nd m0 + 1
  | L m0 _ _ _ => nd m0
 end.

(* Number of vertices: *)

Fixpoint nv(m:fmap):Z :=
 match m with
    V => 0
  | I m0 x _ _ => nv m0 + 1
  | L m0 zero x y => nv m0
  | L m0 one x y => nv m0 - 1
 end.

(* Number of edges: *)

Fixpoint ne(m:fmap):Z :=
 match m with
    V => 0
  | I m0 x _ _ => ne m0 + 1
  | L m0 zero x y => ne m0 - 1
  | L m0 one x y => ne m0
 end.

(* TECHNICAL CHOICE:
HIDDING (inv_hmap m) in expf *)

Definition expf(m:fmap)(x y:dart):Prop:=
  inv_hmap m /\ MF.expo m x y.

Lemma expf_dec : forall(m:fmap)(x y:dart),
  {expf m x y} + {~expf m x y}.
Proof.
unfold expf in |- *.
intros.
generalize (MF.expo_dec m x y).
generalize (inv_hmap_dec m).
tauto.
Qed.

Lemma expf_eqc : forall(m:fmap)(x y:dart),
 inv_hmap m ->
   MF.expo m x y -> eqc m x y.
Proof.
intros.
assert (exd m x).
 unfold MF.expo in H0.
   tauto.
 assert (MF.f = cF).
  tauto.
  unfold MF.expo in H0.
    rewrite H2 in H0.
    intuition.
    elim H4.
    intros n In.
    rewrite <- In.
    apply eqc_Iter_cF.
   tauto.
   tauto.
Qed.

(* expf IS AN EQUIVALENCE: *)

Lemma expf_refl: forall(m:fmap)(z:dart),
    inv_hmap m -> exd m z -> expf m z z.
Proof.
unfold expf in |- *.
split.
 tauto.
 apply MF.expo_refl.
   tauto.
Qed.

Lemma expf_symm:forall(m:fmap)(z t:dart),
   expf m z t -> expf m t z.
Proof.
unfold expf in |- *.
split.
 tauto.
 apply MF.expo_symm.
  tauto.
  tauto.
Qed.

Lemma expf_trans:forall (m : fmap) (z t u : dart),
   expf m z t -> expf m t u -> expf m z u.
Proof.
unfold expf in |- *.
split.
 tauto.
 apply MF.expo_trans with t.
  tauto.
  tauto.
Qed.

(* EQUIVALENCE WITH expf: *)

Lemma expf_expof:forall (m:fmap)(z t:dart),
  inv_hmap m ->
     (expf m z t <-> expof m z t).
Proof.
intros.
unfold expf in |- *.
unfold expof in |- *.
 tauto.
Qed.

Fixpoint nf(m:fmap):Z :=
 match m with
    V => 0
  | I m0 x _ _ => nf m0 + 1
  | L m0 zero x y =>
      let x_1:= cA_1 m0 one x in nf m0 +
       if expf_dec m0 x_1 y then 1 else -1
  | L m0 one x y =>
      let y0 := cA m0 zero y in nf m0 +
       if expf_dec m0 x y0 then 1 else -1
 end.

(* Number of connected components: *)

Fixpoint nc(m:fmap):Z :=
 match m with
    V => 0
  | I m0 x _ _ => nc m0 + 1
  | L m0 _ x y => nc m0 -
       if eqc_dec m0 x y then 0 else 1
 end.

(* Euler-Poincare characteristic: *)

Definition ec(m:fmap): Z:=
  nv m + ne m + nf m - nd m.

(* The Euler-Poincare characteristic is even: *)

Theorem even_ec :
   forall m:fmap, inv_hmap m -> Zeven (ec m).
Proof.
unfold ec in |- *.
induction m.
 simpl in |- *.
   tauto.
 simpl in |- *.
   cut
    (nv m + 1 + (ne m + 1) + (nf m + 1) - (nd m + 1) =
     Z.succ (Z.succ (nv m + ne m + nf m - nd m))).
  intros.
    rewrite H.
    apply Zeven_Sn.
    apply Zodd_Sn.
    tauto.
  lia.
 induction d.
  simpl in |- *.
    unfold prec_L in |- *.
    elim (expf_dec m (cA_1 m one d0) d1).
   intro.
     assert
      (nv m + ne m + nf m - nd m =
   nv m + (ne m - 1) + (nf m + 1) - nd m).
    lia.
    rewrite <- H.
      tauto.
   intro.
     assert
      (nv m + (ne m - 1) + (nf m + -1) - nd m =
       Z.pred (Z.pred (nv m + ne m + nf m - nd m))).
    unfold Z.pred in |- *.
      lia.
    rewrite H.
      intros.
      apply Zeven_pred.
      apply Zodd_pred.
      tauto.
  simpl in |- *.
    unfold prec_L in |- *.
    elim (eq_dart_dec d1 (cA m one d0)).
   intro.
     symmetry  in a.
     tauto.
   intros.
     elim (expf_dec m d0 (cA m zero d1)).
    intro.
      assert
       (nv m - 1 + ne m + (nf m + 1) - nd m =
         nv m + ne m + nf m - nd m).
     lia.
     rewrite H0.
       tauto.
    intro.
      assert
       (nv m - 1 + ne m + (nf m + -1) - nd m =
        Z.pred (Z.pred (nv m + ne m + nf m - nd m))).
     unfold Z.pred in |- *.
       lia.
     rewrite H0.
       apply Zeven_pred.
       apply Zodd_pred.
       tauto.
Qed.

(* GENUS THEOREM: OK *)

Theorem genus_theorem : forall m:fmap,
  inv_hmap m -> 2 * (nc m) >= (ec m).
Proof.
intros.
rename H into Invm.
unfold ec.
induction m.
 simpl in |- *.
   lia.
 unfold nc in |- *.
   fold nc in |- *.
   unfold nv in |- *; fold nv in |- *.
   unfold ne in |- *; fold ne in |- *.
   unfold nf in |- *; fold nf in |- *.
   unfold nd in |- *; fold nd in |- *.
   unfold inv_hmap in Invm.
   fold inv_hmap in Invm.
   assert (2 * nc m >= nv m + ne m + nf m - nd m).
  tauto.
  lia.
 unfold inv_hmap in Invm; fold inv_hmap in Invm.
   induction d.
  unfold nc in |- *; fold nc in |- *.
    unfold nv in |- *; fold nv in |- *.
    unfold ne in |- *; fold ne in |- *.
    unfold nf in |- *; fold nf in |- *.
    unfold nd in |- *; fold nd in |- *.
    elim (expf_dec m (cA_1 m one d0) d1).
   intro.
     elim (eqc_dec m d0 d1).
    intro.
      assert (2 * nc m >= nv m + ne m + nf m - nd m).
     tauto.
     lia.
    intro.
      assert (eqc m (cA_1 m one d0) d1).
     apply expf_eqc.
      tauto.
      unfold expf in a.
        tauto.
     absurd (eqc m d0 d1).
      tauto.
      apply (eqc_cA_1_eqc m one d0 d1).
       tauto.
       tauto.
   intro.
     elim (eqc_dec m d0 d1).
    intro.
      assert (2 * nc m >= nv m + ne m + nf m - nd m).
     tauto.
     lia.
    intro.
      assert (2 * nc m >= nv m + ne m + nf m - nd m).
     tauto.
     lia.
  assert (2 * nc m >= nv m + ne m + nf m - nd m).
   tauto.
   clear IHm.
     unfold nc in |- *.
     fold nc in |- *.
     unfold nv in |- *; fold nv in |- *.
     unfold ne in |- *; fold ne in |- *.
     unfold nf in |- *; fold nf in |- *.
     unfold nd in |- *; fold nd in |- *.
     unfold prec_L in Invm.
     elim (eqc_dec m d0 d1).
    intro.
      elim (expf_dec m d0 (cA m zero d1)).
     intro.
       lia.
     intro.
       lia.
    elim (expf_dec m d0 (cA m zero d1)).
     intros.
       assert (eqc m d0 (cA m zero d1)).
      apply expf_eqc.
       tauto.
       unfold expf in a.
         tauto.
      assert (eqc m d0 d1).
       eapply eqc_cA_eqc.
        tauto.
        apply H0.
       tauto.
     intro.
       intro.
       lia.
Qed.

Definition genus(m:fmap):= (nc m) - (ec m)/2.

(* OK: *)

Theorem genus_corollary : forall m:fmap,
  inv_hmap m -> genus m >= 0.
Proof.
intros.
unfold genus in |- *.
generalize (genus_theorem m H).
generalize (even_ec m).
generalize (ec m).
generalize (nc m).
intros a b.
intros.
cut (a >= b / 2).
intro.
   lia.
 assert (b = 2 * Z.div2 b).
  apply Zeven_div2.
    tauto.
  rewrite H2 in H1.
    assert (a >= Z.div2 b).
   lia.
   rewrite H2.
 rewrite Zmult_comm.
     assert (Z.div2 b * 2 / 2 = Z.div2 b).
  apply Z_div_mult.
      lia.
    rewrite H4.
      tauto.
Qed.

Definition planar(m:fmap):= genus m = 0.

(* Rewriting of g = 0 : *)

Lemma Euler_Poincare: forall m:fmap,
  inv_hmap m -> planar m ->
    ec m / 2 = nc m.
Proof.
unfold planar in |- *.
unfold genus in |- *.
intros.
lia.
Qed.

(* ======================================================
         PLANARITY CRITERIA (SUFFICIENT CONDITIONS)
=====================================================*)

Lemma planar_dec:forall m:fmap,
  {planar m} + {~planar m}.
Proof.
unfold planar in |- *.
intro.
apply Z.eq_dec.
Qed.

Lemma planar_V: planar V.
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
tauto.
Qed.

Lemma planar_I: forall (m:fmap)(x:dart)(t:tag)(p:point),
   inv_hmap m -> planar m -> prec_I m x ->
      planar (I m x t p).
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
unfold prec_I in |- *.
simpl in |- *.
intros.
assert
 (nv m + 1 + (ne m + 1) + (nf m + 1) - (nd m + 1) =
  nv m + ne m + nf m - nd m + 1 * 2).
 lia.
 rewrite H2.
   rewrite Z_div_plus.
  lia.
  lia.
Qed.

Lemma expf_planar_0: forall (m:fmap)(x y:dart),
  inv_hmap m -> planar m ->
   prec_L m zero x y ->
    expf m (cA_1 m one x) y ->
      planar (L m zero x y).
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
unfold prec_L in |- *.
intros.
elim (expf_dec m (cA_1 m one x) y).
 intro.
   elim (eqc_dec m x y).
  intro.
    assert
     (nv m + (ne m - 1) + (nf m + 1) - nd m
        = nv m + ne m + nf m - nd m).
   lia.
   rewrite H3.
     lia.
  intro.
    elim b.
    eapply eqc_cA_1_eqc.
   tauto.
   apply expf_eqc.
    tauto.
    unfold expf in a.
      decompose [and] a.
      apply H4.
 tauto.
Qed.

(* OK: *)

Lemma expf_planar_1: forall (m:fmap)(x y:dart),
  inv_hmap m -> planar m ->
    prec_L m one x y ->
      expf m x (cA m zero y) ->
        planar (L m one x y).
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
intros m x y Inv E Pr Exp.
   elim (eqc_dec m x y).
  intro.
    elim (expf_dec m x (cA m zero y)).
   intro.
     assert
      (nv m - 1 + ne m + (nf m + 1) - nd m
          = nv m + ne m + nf m - nd m).
    lia.
    rewrite H.
      lia.
   tauto.
  intro.
    elim b.
    eapply eqc_cA_eqc.
   tauto.
   apply expf_eqc.
    tauto.
    unfold expf in Exp.
      decompose [and] Exp.
      apply H0.
Qed.

(* OK: *)

Lemma not_eqc_planar: forall (m:fmap)(k:dim)(x y:dart),
  inv_hmap m -> planar m ->
   prec_L m k x y ->
     ~eqc m x y -> planar (L m k x y).
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
unfold prec_L in |- *.
intros.
induction k.
 simpl in |- *.
   elim (eqc_dec m x y).
   tauto.
 intro.
   elim (expf_dec m (cA_1 m one x) y).
  intro.
    elim b.
     eapply eqc_cA_1_eqc.
      tauto.
    apply expf_eqc.
    tauto.
  unfold expf in a.
    decompose [and] a.
    apply H4.
   intro.
   assert
    (nv m + (ne m - 1) + (nf m + -1) - nd m =
     nv m + ne m + nf m - nd m + -1 * 2).
   lia.
 rewrite H3 in |- *.
   clear H3.
   rewrite Z_div_plus in |- *.
   lia.
  lia.
  simpl in |- *.
  elim (eqc_dec m x y).
  tauto.
intro.
  elim (expf_dec m x (cA m zero y)).
 intro.
   elim b.
    eapply eqc_cA_eqc.
     tauto.
   apply expf_eqc.
   tauto.
 unfold expf in a.
   decompose [and] a.
   apply H4.
  intro.
  assert
   (nv m - 1 + ne m + (nf m + -1) - nd m =
     nv m + ne m + nf m - nd m + -1 * 2).
  lia.
rewrite H3 in |- *.
  clear H3.
  rewrite Z_div_plus in |- *.
  lia.
 lia.
Qed.

(* Definition of "Planarly formed" hypermap: *)

Fixpoint plf(m:fmap):Prop:=
  match m with
     V => True
   | I m0 x _ _ => plf m0
   | L m0 zero x y => plf m0 /\
        (~eqc m0 x y \/ expf m0 (cA_1 m0 one x) y)
   | L m0 one x y => plf m0 /\
        (~eqc m0 x y \/ expf m0 x (cA m0 zero y))
  end.

(* Constructive Sufficient Condition of planarity: *)

Theorem plf_planar:forall (m:fmap),
  inv_hmap m -> plf m -> planar m.
Proof.
induction m.
 simpl in |- *.
   intros.
   apply planar_V.
simpl in |- *.
  intros.
  apply planar_I.
  tauto.
 tauto.
 tauto.
induction d.
 simpl in |- *.
   intros.
   decompose [and] H0.
   elim H2.
  intro.
    apply not_eqc_planar.
    tauto.
   tauto.
   tauto.
   tauto.
 intro.
   apply expf_planar_0.
   tauto.
  tauto.
  tauto.
  tauto.
simpl in |- *.
   intros.
   decompose [and] H0.
   elim H2.
  intro.
    apply not_eqc_planar.
    tauto.
   tauto.
   tauto.
   tauto.
 intro.
   apply expf_planar_1.
   tauto.
  tauto.
  tauto.
  tauto.
Qed.

(* plf_EULER-POINCARE FORMULA: *)

Theorem plf_Euler_Poincare: forall m:fmap,
  inv_hmap m -> plf m ->
     ec m / 2 = nc m.
Proof.
intros.
apply Euler_Poincare.
  tauto.
apply plf_planar.
  tauto.
 tauto.
Qed.

(*==================================================
              NECESSARY CONDITIONS
          AND FULL PLANARITY CRITERIA
===================================================*)

(* OK!:*)

Lemma expf_planar_rcp_0: forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m zero x y ->
    planar (L m zero x y) ->
      expf m (cA_1 m one x) y ->
         planar m.
Proof.
unfold planar.
unfold genus in |- *.
unfold ec in |- *.
unfold prec_L in |- *.
simpl in |- *.
intros m x y Pr Inv.
elim (expf_dec m (cA_1 m one x) y).
 intro.
   elim (eqc_dec m x y).
  intros.
    assert
     (nv m + (ne m - 1) + (nf m + 1) - nd m
         = nv m + ne m + nf m - nd m).
   lia.
   rewrite <- H1.
     lia.
  intro.
    elim b.
    eapply eqc_cA_1_eqc.
   tauto.
   apply expf_eqc.
    tauto.
    unfold expf in a.
      decompose [and] a.
      apply H0.
 tauto.
Qed.

(* OK: weak rcp *)

Lemma expf_planar_rcp_1: forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m one x y ->
    planar (L m one x y) ->
      expf m x (cA m zero y) -> planar m.
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
unfold prec_L in |- *.
simpl in |- *.
intros m x y Pr Inv.
 elim (expf_dec m x (cA m zero y)).
  elim (eqc_dec m x y).
   intros.
     assert
      (nv m - 1 + ne m + (nf m + 1) - nd m
        = nv m + ne m + nf m - nd m).
    lia.
    rewrite <- H1.
      lia.
   intros.
     elim b.
     eapply eqc_cA_eqc.
    tauto.
    apply expf_eqc.
     tauto.
     unfold expf in a.
       decompose [and] a.
       apply H2.
  tauto.
Qed.

Theorem weak_planarity_criterion_0: forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m zero x y ->
    expf m (cA_1 m one x) y ->
      (planar m <-> planar (L m zero x y)).
Proof.
intros m x y Inv Pr Exp.
split.
 intro.
   eapply expf_planar_0.
  tauto.
  tauto.
  tauto.
  tauto.
 intro.
   eapply expf_planar_rcp_0.
  tauto.
  apply Pr.
    tauto.
    tauto.
Qed.

Theorem weak_planarity_criterion_1: forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m one x y ->
    expf m x (cA m zero y) ->
       (planar m <-> planar (L m one x y)).
Proof.
intros m x y Inv Pr Exp.
split.
 intro.
   eapply expf_planar_1.
  tauto.
  tauto.
  tauto.
  tauto.
 intro.
   eapply expf_planar_rcp_1.
  tauto.
  apply Pr.
    tauto.
    tauto.
Qed.

(* OK: *)

Lemma planarity_criterion_RCP_0: forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m zero x y ->
    planar m -> planar (L m zero x y) ->
    (~ eqc m x y \/ expf m (cA_1 m one x) y).
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
intros m x y Inv Pr E.
unfold prec_L in Pr.
 elim (expf_dec m (cA_1 m one x) y).
  tauto.
  elim (eqc_dec m x y).
   intros.
     assert
      (nv m + (ne m - 1) + (nf m + -1) - nd m =
       nv m + ne m + nf m - nd m - 2).
    lia.
    rewrite H0 in H.
      generalize E H.
      generalize (nv m + ne m + nf m - nd m).
      intros.
      assert (z + -1 * 2 = z - 2).
     lia.
     rewrite <- H2 in H1.
       rewrite Z_div_plus in H1.
      absurd (nc m - z / 2 = 0).
       lia.
       tauto.
      lia.
   tauto.
Qed.

(* OK: *)

Lemma planarity_criterion_RCP_1: forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m one x y ->
   planar m -> planar (L m one x y) ->
      (~ eqc m x y \/ expf m x (cA m zero y)).
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
intros m x y Inv Pr E.
unfold prec_L in Pr.
 elim (expf_dec m x (cA m zero y)).
  tauto.
  elim (eqc_dec m x y).
   intros.
     assert
      (nv m - 1 + ne m + (nf m + -1) - nd m
       = nv m + ne m + nf m - nd m - 2).
    lia.
    rewrite H0 in H.
      generalize E H.
      generalize (nv m + ne m + nf m - nd m).
      intros.
      assert ((z + -1 * 2) / 2 = z / 2 + -1).
     apply Z_div_plus.
       auto with zarith.
     assert (z + -1 * 2 = z - 2).
      lia.
      rewrite H3 in H2.
        assert (z / 2 = (z - 2) / 2).
       lia.
       rewrite <- H4 in H2.
         absurd (z / 2 = z / 2 + -1).
        lia.
        tauto.
   tauto.
Qed.

(* OK: *)

Lemma not_eqc_planar_0:forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m zero x y ->
    planar m -> ~eqc m x y -> planar (L m zero x y).
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
intros m x y Inv Pr E.
unfold prec_L in Pr.
 elim (eqc_dec m x y).
  tauto.
  elim (expf_dec m (cA_1 m one x) y).
   intros.
     elim H.
     eapply eqc_cA_1_eqc.
    tauto.
    apply expf_eqc.
     tauto.
     unfold expf in a.
       decompose [and] a.
       apply H1.
   intros.
     assert
      (nv m + (ne m - 1) + (nf m + -1) - nd m =
       nv m + ne m + nf m - nd m + -1 * 2).
    lia.
    rewrite H0.
      rewrite Z_div_plus.
     generalize E.
       generalize (nv m + ne m + nf m - nd m).
       intros.
       lia.
     lia.
Qed.

Lemma not_eqc_planar_1:forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m one x y ->
    planar m -> ~eqc m x y -> planar (L m one x y).
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
intros m x y Inv Pr E.
unfold prec_L in Pr.
 elim (eqc_dec m x y).
  tauto.
  elim (expf_dec m x (cA m zero y)).
   intros.
     elim H.
     eapply eqc_cA_eqc.
    tauto.
    apply expf_eqc.
     tauto.
     unfold expf in a.
       decompose [and] a.
       apply H1.
   intros.
     assert
      (nv m - 1 + ne m + (nf m + -1) - nd m =
       nv m + ne m + nf m - nd m + -1 * 2).
    lia.
    rewrite H0.
      rewrite Z_div_plus.
     generalize E.
       generalize (nv m + ne m + nf m - nd m).
       intros.
       lia.
     lia.
Qed.

(* FINALLY: FULL PLANARITY CRITERION: *)

Theorem planarity_criterion_0:
 forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m zero x y -> planar m ->
    (planar (L m zero x y) <->
      (~ eqc m x y \/ expf m (cA_1 m one x) y)).
Proof.
intros.
split.
 intro.
   simpl in |- *.
   apply planarity_criterion_RCP_0.
  tauto.
  tauto.
  tauto.
  tauto.
 simpl in |- *.
   intro.
   elim H2.
  apply not_eqc_planar_0.
   tauto.
   tauto.
   tauto.
  apply expf_planar_0.
   tauto.
   tauto.
   tauto.
Qed.

Theorem planarity_criterion_1:
 forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m one x y -> planar m ->
   (planar (L m one x y) <->
      (~ eqc m x y \/ expf m x (cA m zero y))).
Proof.
intros.
split.
 intro.
   simpl in |- *.
   apply planarity_criterion_RCP_1.
  tauto.
  tauto.
  tauto.
  tauto.
 simpl in |- *.
   intro.
   elim H2.
  apply not_eqc_planar_1.
   tauto.
   tauto.
   tauto.
  apply expf_planar_1.
   tauto.
   tauto.
   tauto.
Qed.

(* OK: *)

Lemma incr_genus_0:forall(m:fmap)(x y:dart),
  inv_hmap m -> prec_L m zero x y ->
     genus m <= genus (L m zero x y).
Proof.
unfold planar in |- *.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
unfold prec_L in |- *.
intros m x y Inv Pr.
 elim (expf_dec m (cA_1 m one x) y).
  elim (eqc_dec m x y).
   intros.
     assert
      (nv m + (ne m - 1) + (nf m + 1) - nd m
         = nv m + ne m + nf m - nd m).
    lia.
    rewrite H.
      lia.
   intros.
     elim b.
     eapply eqc_cA_1_eqc.
    tauto.
    apply expf_eqc.
     tauto.
     unfold expf in a.
       decompose [and] a.
       apply H0.
  elim (eqc_dec m x y).
   intros.
     assert
      (nv m + (ne m - 1) + (nf m + -1) - nd m =
       nv m + ne m + nf m - nd m + -1 * 2).
    lia.
    rewrite H.
      rewrite Z_div_plus.
     generalize (nv m + ne m + nf m - nd m).
       intros.
       lia.
     lia.
   intros.
     assert
      (nv m + (ne m - 1) + (nf m + -1) - nd m =
       nv m + ne m + nf m - nd m + -1 * 2).
    lia.
    rewrite H.
      rewrite Z_div_plus.
     generalize (nv m + ne m + nf m - nd m).
       intros.
       lia.
     lia.
Qed.

Lemma incr_genus_1:forall(m:fmap)(x y:dart),
  inv_hmap m -> prec_L m one x y ->
     genus m <= genus (L m one x y).
Proof.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
unfold prec_L in |- *.
intros m x y Inv Pr.
 elim (expf_dec m x (cA m zero y)).
  elim (eqc_dec m x y).
   intros.
     assert
      (nv m - 1 + ne m + (nf m + 1) - nd m
         = nv m + ne m + nf m - nd m).
    lia.
    rewrite H.
      lia.
   intros.
     elim b.
     eapply eqc_cA_eqc.
    tauto.
    apply expf_eqc.
     tauto.
     unfold expf in a.
       decompose [and] a.
       apply H0.
  intros.
    elim (eqc_dec m x y).
   intros.
     assert
      (nv m - 1 + ne m + (nf m + -1) - nd m =
       nv m + ne m + nf m - nd m + -1 * 2).
    lia.
    rewrite H.
      rewrite Z_div_plus.
     lia.
     lia.
   intro.
     assert
      (nv m - 1 + ne m + (nf m + -1) - nd m =
       nv m + ne m + nf m - nd m + -1 * 2).
    lia.
    rewrite H.
      rewrite Z_div_plus.
     lia.
     lia.
Qed.

(* FINALLY: *)

Theorem incr_genus:forall(m:fmap)(k:dim)(x y:dart),
  inv_hmap m -> prec_L m k x y ->
     genus m <= genus (L m k x y).
Proof.
induction k.
 apply incr_genus_0.
 apply incr_genus_1.
Qed.

Theorem inversion_planarity:forall(m:fmap)(k:dim)(x y:dart),
  inv_hmap m -> prec_L m k x y ->
    planar (L m k x y) -> planar m.
Proof.
unfold planar in |- *.
intros.
assert (genus m <= genus (L m k x y)).
 apply incr_genus.
  tauto.
  tauto.
 generalize (genus_corollary m H).
   lia.
Qed.

Theorem planarity_crit_0: forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m zero x y ->
    (planar (L m zero x y) <->
 (planar m /\
     (~ eqc m x y \/ expf m (cA_1 m one x) y))).
Proof.
intros.
split.
 intro.
   assert (planar m).
  eapply inversion_planarity.
   tauto.
   apply H0.
     tauto.
  split.
   tauto.
   generalize (planarity_criterion_0 m x y H H0 H2).
     tauto.
 generalize (planarity_criterion_0 m x y H H0).
   tauto.
Qed.

Theorem planarity_crit_1: forall (m:fmap)(x y:dart),
  inv_hmap m -> prec_L m one x y ->
     (planar (L m one x y) <->
  (planar m /\
      (~ eqc m x y \/ expf m x (cA m zero y)))).
Proof.
intros.
split.
 intro.
   assert (planar m).
  eapply inversion_planarity.
   tauto.
   apply H0.
     tauto.
  split.
   tauto.
   generalize (planarity_criterion_1 m x y H H0 H2).
     tauto.
 generalize (planarity_criterion_1 m x y H H0).
   tauto.
Qed.

(* OK:*)

Lemma eq_genus_I : forall(m:fmap)(x:dart)(t:tag)(p:point),
   inv_hmap (I m x t p) -> genus (I m x t p) = genus m.
Proof.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
intros.
assert
 (nv m + 1 + (ne m + 1) + (nf m + 1) - (nd m + 1) =
  nv m + ne m + nf m - nd m + 1 * 2).
  lia.
rewrite H0 in |- *.
  rewrite Z_div_plus in |- *.
  lia.
 lia.
Qed.

(* Necessary condition for a planar formation: *)

Theorem planar_plf: forall m:fmap,
  inv_hmap m -> genus m = 0 -> plf m.
Proof.
intros.
induction m.
 simpl in |- *.
    tauto.
simpl in |- *.
  simpl in H.
  apply IHm.
  tauto.
rewrite eq_genus_I in H0.
  tauto.
simpl in |- *.
   tauto.
induction d.
 simpl in |- *.
   simpl in H.
   generalize (planarity_crit_0 m d0 d1).
    tauto.
simpl in |- *.
  simpl in H.
  generalize (planarity_crit_1 m d0 d1).
   tauto.
Qed.

(* RECIPROCAL OF EULER FORMULA PROOF: *)

Theorem Euler_Poincare_plf: forall m:fmap,
  inv_hmap m -> ec m / 2 = nc m -> plf m.
Proof.
intros.
apply planar_plf.
  tauto.
unfold genus in |- *.
   lia.
Qed.

(* CHARACTERIZATION OF THE PLANAR POLYHEDRA: *)

Theorem Euler_Poincare_criterion: forall m:fmap,
  inv_hmap m -> (plf m <-> ec m / 2 = nc m).
Proof.
intros.
split.
 apply plf_Euler_Poincare.
    tauto.
apply Euler_Poincare_plf.
   tauto.
Qed.

(* IN FACT, WE EARLY HAVE THE SYNTHESIS: *)

Theorem genus_variation_0: forall(m:fmap)(x y:dart),
  let m1:= L m zero x y in
   inv_hmap m1 ->
    genus m1 = genus m +
       if eqc_dec m x y
       then
           if expf_dec m (cA_1 m one x) y
           then 0
           else 1
       else 0.
Proof.
intros.
unfold m1 in |- *.
unfold m1 in H.
simpl in H.
unfold prec_L in H.
decompose [and] H.
clear H.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
elim (eqc_dec m x y).
 elim (expf_dec m (cA_1 m one x) y).
  intros.
    assert
     (nv m + (ne m - 1) + (nf m + 1) - nd m =
  nv m + ne m + nf m - nd m).
    lia.
  rewrite H in |- *.
     lia.
 intros.
   assert
    (nv m + (ne m - 1) + (nf m + -1) - nd m =
     nv m + ne m + nf m - nd m + -1 * 2).
   lia.
 rewrite H in |- *.
   rewrite Z_div_plus in |- *.
  generalize (nv m + ne m + nf m - nd m).
    intros.
     lia.
  lia.
elim (expf_dec m (cA_1 m one x) y).
 intros.
   elim b.
   clear b.
   apply eqc_trans with (cA_1 m one x).
  apply (eqc_cA_1_r m one x H0 H2).
 apply expf_eqc.
   tauto.
 unfold expf in a.
    tauto.
intros.
  assert
   (nv m + (ne m - 1) + (nf m + -1) - nd m =
    nv m + ne m + nf m - nd m + -1 * 2).
  lia.
rewrite H in |- *.
  rewrite Z_div_plus in |- *.
 generalize (nv m + ne m + nf m - nd m).
   intros.
    lia.
 lia.
Qed.

(* AND: *)

Theorem genus_variation_1: forall(m:fmap)(x y:dart),
  let m1:= L m one x y in
   inv_hmap m1 ->
    genus m1 = genus m +
       if eqc_dec m x y
       then
           if expf_dec m x (cA m zero y)
           then 0
           else 1
       else 0.
Proof.
intros.
unfold m1 in |- *.
unfold m1 in H.
simpl in H.
unfold prec_L in H.
decompose [and] H.
clear H.
unfold genus in |- *.
unfold ec in |- *.
simpl in |- *.
elim (eqc_dec m x y).
 elim (expf_dec m x (cA m zero y)).
  assert (nv m - 1 + ne m + (nf m + 1) - nd m = nv m + ne m + nf m - nd m).
    lia.
  rewrite H in |- *.
    intros.
     lia.
 intros.
   assert
    (nv m - 1 + ne m + (nf m + -1) - nd m =
     nv m + ne m + nf m - nd m + -1 * 2).
   lia.
 rewrite H in |- *.
   rewrite Z_div_plus in |- *.
   lia.
  lia.
elim (expf_dec m x (cA m zero y)).
 intros.
   elim b.
    eapply eqc_cA_eqc.
     tauto.
   apply expf_eqc.
   tauto.
 unfold expf in a.
   decompose [and] a.
   apply H5.
  intros.
  assert
   (nv m - 1 + ne m + (nf m + -1) - nd m =
  nv m + ne m + nf m - nd m + -1 * 2).
  lia.
rewrite H in |- *.
  rewrite Z_div_plus in |- *.
  lia.
 lia.
Qed.

(*=====================================================
=======================================================
		      END OF PART3
=======================================================
=====================================================*)


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Limits.Limit Limits.GenProd_GenSum.
From Categories Require Import Archetypal.Discr.Discr.
From Categories Require Import Basic_Cons.Terminal.

(** In category of types, generalized products are simply dependent prdoducts. *)
Section Type_Cat_GenProd.
  Context (A : Type) (map : A → Type_Cat).

  Local Notation Fm := (Discr_Func Type_Cat map) (only parsing).

  Program Definition Type_Cat_GenProd_Cone : Cone Fm :=
    {|
      cone_apex := {|FO := fun _ => ∀ x : A, (Fm _o x)%object; FA := fun _ _ _ h => h|};
      cone_edge := {|Trans := fun x y => y x |}
    |}.

  Program Definition Type_Cat_GenProd : (Π map)%object :=
    {|
      LRKE := Type_Cat_GenProd_Cone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|Trans :=
                  fun c X x  =>
                    match c as u return ((Cn _o)%object u → map x) with
                    | tt => fun X : (Cn _o)%object tt => Trans Cn x X
                    end X
              |}
          |}
    |}.

  Next Obligation.
  Proof.
    destruct c; destruct c'; destruct h.
    extensionality x; extensionality y.
    apply (equal_f ((@Trans_com _ _ _ _ Cn) y y eq_refl) x).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Type_Cat_GenProd_obligation_1.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y; extensionality z.
    destruct x.
    set (hc := (cone_morph_com h')).
    rewrite (cone_morph_com h) in hc.
    set (hc' := (f_equal (fun w :
                  ((Cn ∘ (Functor_To_1_Cat (Discr_Cat A))) –≻ Fm)%nattrans =>
           Trans w z y) hc)); clearbody hc'; clear hc.
    trivial.
  Qed.

End Type_Cat_GenProd.


From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import QArith.QArith_base.
From Coq Require Import QArith.Qabs.
From Coq Require Import QArith.Qminmax.
From Coq Require Import QArith.Qround.
From Coq Require Import Logic.Classical.
From Coq Require Import Classes.Equivalence.
From Coq Require Import Classes.Morphisms.
From Coq Require Export Field.
From CReal Require Import QArith_ext.QArith_base_ext.
From CReal Require Import QArith_ext.Inject_lemmas.
From CReal.Cauchy Require Import RBase.
From CReal.Cauchy Require Import RArith.
From CReal.Cauchy Require Import RSign.
From CReal.Cauchy Require Import ROrder.
From CReal.Cauchy Require Import RAbs.
From CReal.Cauchy Require Import RFloor.
From CReal.Cauchy Require Import RFunc.

(* Helping Lemmas *)

Lemma  inject_Q_minus : forall q1 q2,
(inject_Q (q1 - q2) == inject_Q q1 - inject_Q q2)%R.
Proof. intros. unfold Rminus. unfold Qminus.
  rewrite inject_Q_plus. rewrite inject_Q_opp. reflexivity.
Qed.

(* Definition of R_seq*)
Class R_seq (RS: nat -> Real -> Prop) : Prop := {
  Rseq_exists : forall (n:nat), exists A1, RS n A1;
  Rseq_unique : forall (n:nat)  A1 A2,
      RS n A1 -> RS n A2 -> (A1 == A2)%R;
  Rseq_proper: forall n, Proper (Real_equiv ==> iff) (RS n);
}.

Inductive Real_seq : Type :=
| Rseq_intro (RS : nat -> Real -> Prop) (H: R_seq RS).
Lemma eps_divide_4_positive: forall (eps:Q), 0 < eps -> eps * (1 # 4) > 0.
Proof. intros. unfold Qmult. unfold Qlt. simpl.
    rewrite <- Zmult_assoc. simpl. apply H.
Qed.

Theorem take_max_N_0604: forall N1 N2 N3 (P Q R:nat->Prop),
 (forall n, (n>=N1)%nat -> P n) ->
 (forall m,(m>=N2)%nat -> Q m) ->
 (forall m,(m>=N3)%nat -> R m) ->
  exists N, ((forall n, (n>=N)%nat -> P n )/\
              (forall n, (n>=N)%nat -> Q n )/\
            (forall n, (n>=N)%nat -> R n)).
Proof. intros.
  exists (max (max N1 N2) N3).
  remember (max (max N1 N2) N3) as N.
  assert (E3: (N>=N3)%nat). { rewrite HeqN. apply Nat.le_max_r. }
  assert (E0: (N>=(max N1 N2))%nat). { rewrite HeqN. apply Nat.le_max_l. }
  pose proof (Nat.max_lub_r _ _ _ E0) as E2.
  pose proof (Nat.max_lub_l _ _ _ E0) as E1.
  split.
  - intros. apply H. omega.
  - split.
  + intros. apply H0. omega.
  + intros. apply H1. omega.
Qed.

Theorem Real_density_of_Q:
forall A B, (B<A)%R -> exists q, ((B<inject_Q q) /\ (inject_Q q< A))%R.
Proof.
intros. hnf in H. destruct A as [A HA], B as [B HB].
destruct H as [dlt [Hdlt [N1 HN1]]].
destruct (Cauchy_Q_limit (Real_intro A HA) _ (eps_divide_4_positive _ Hdlt)) as [N2 HN2].
destruct (Cauchy_Q_limit (Real_intro B HB) _ (eps_divide_4_positive _ Hdlt)) as [N3 HN3].
destruct (take_max_N_0604 _ _ _ _ _ _ HN1 HN2 HN3) as [N [H1 [H2 H3]]].
clear HN1. clear HN2. clear HN3.
clear N1. clear N2. clear N3.

destruct (Cauchy_exists _ HA N) as [qNA HqNA].
destruct (Cauchy_exists _ HB N) as [qNB HqNB].
exists (qNA - dlt*(1#2)).

split.
- apply (Rlt_trans _ ((inject_Q (qNB + dlt*(1#4))))).
  + apply (Rlt_plus_compat_r _ _ (- inject_Q qNB)).
    rewrite <- inject_Q_opp. rewrite <- inject_Q_plus.
    assert (qNB + dlt * (1 # 4) + - qNB == dlt * (1 # 4)) by ring.
    rewrite H. rewrite inject_Q_opp.
    pose proof (H3 N (le_refl _) qNB HqNB).
    apply Rabs_lt_iff in H0. apply (proj2 H0).
    apply Qlt_Rlt. auto using eps_divide_4_positive.
  + apply (Rle_lt_trans _ ((inject_Q (qNA - dlt*(3#4))))).
  * apply (Rle_plus_compat_r _ _ (inject_Q (dlt * (3 # 4)))).
    repeat rewrite <- inject_Q_plus. apply Qle_Rle.
    unfold Qminus. repeat rewrite <- Qplus_assoc.
    repeat rewrite <- Qmult_plus_distr_r.
    assert ((1 # 4) + (3 # 4) == 1) by ring. rewrite H.
    assert ((- (dlt * (3 # 4)) + dlt * (3 # 4)) == 0) by ring. rewrite H0.
    rewrite Qplus_0_r. rewrite Qmult_1_r.
    apply (Qplus_le_l _ _ (-qNB)). assert ( qNB + dlt + - qNB  == dlt) by ring.
    rewrite H4.
    pose proof (H1 N (le_refl _) (qNA-qNB)). apply H5.
    hnf. intros. hnf in H7. rewrite (Cauchy_unique _ HA _ _ _ HqNA H6).
    rewrite (H7 qNB HqNB). ring.
  * apply Qlt_Rlt. unfold Qminus. apply Qlt_minus_iff.
    assert (qNA + - (dlt * (1 # 2)) + - (qNA + - (dlt * (3 # 4))) == dlt*(3#4)+dlt*(-(1#2))) by ring.
    rewrite H. rewrite  <- Qmult_plus_distr_r.
    assert (((3 # 4) + - (1 # 2)) == 1#4) by ring.
    rewrite H0. apply eps_divide_4_positive. auto.
- apply (Rlt_trans _ ((inject_Q (qNA - dlt*(1#4))))).
  + apply Qlt_Rlt. unfold Qminus. apply Qlt_minus_iff.
    assert (qNA + - (dlt * (1 # 4)) + - (qNA + - (dlt * (1 # 2))) == dlt*(1#2)+dlt*(-(1#4))) by ring.
    rewrite H. rewrite  <- Qmult_plus_distr_r.
    assert (((1 # 2) + - (1 # 4)) == 1#4) by ring.
    rewrite H0. apply eps_divide_4_positive. auto.
  + apply (Rlt_plus_compat_r _ _ (- inject_Q qNA)).
    rewrite <- inject_Q_opp. rewrite <- inject_Q_plus.
    assert (qNA - dlt * (1 # 4) + - qNA == - (dlt * (1 # 4))) by ring.
    rewrite H. repeat rewrite inject_Q_opp.
    pose proof (H2 N (le_refl _) qNA HqNA).
    apply Rabs_lt_iff in H0. apply (proj1 H0).
    apply Qlt_Rlt. auto using eps_divide_4_positive.
Qed.

Definition Rlimit (Rseq:Real_seq) (Lim:Real):Prop:=
forall Eps:Real, (0 < Eps)%R -> exists N, forall n,
(n>=N)%nat -> forall A,
(match Rseq with Rseq_intro RS _ => RS end) n A -> (Rabs (A - Lim) < Eps)%R.

Definition Cauchy_of_R (Rseq:Real_seq):Prop:=
forall Eps:Real, (0 < Eps)%R -> exists N, forall n m,
(n>=N)%nat -> (m>=N)%nat -> forall A B,
(match Rseq with Rseq_intro RS _ => RS end) n A ->
(match Rseq with Rseq_intro RS _ => RS end) m B ->
 (Rabs (A - B) < Eps)%R.

Theorem CC_necessity: forall (Rseq:Real_seq), (exists Lim:Real, Rlimit Rseq Lim)
 -> Cauchy_of_R Rseq.
Proof. intros. destruct H as [Lim H]. hnf in H. hnf.
  intros. assert (0< Eps*(inject_Q (1#2)))%R.
  { rewrite <- (Rmult_0_l (inject_Q (1 # 2))%R).
  apply Rlt_mult_r. { hnf. exists (1#4). split. reflexivity. exists O. intros.
   unfold inject_Q in H2. rewrite H2. intros C. discriminate C. } auto. }
  apply H in H1. clear H. destruct H1 as [N HN].
  exists N. intros.
  pose proof (HN _ H _ H2).
  pose proof (HN _ H1 _ H3).
  pose proof (Rlt_plus_compat _ _ _ _ H4 H5).
  apply (Rle_lt_trans _ ((Rabs (A - Lim) + Rabs (B - Lim))%R)).
  rewrite (Rabs_Rminus B Lim).
  assert (Et:(A-B==(A-Lim) +(Lim-B))%R) by ring.
  rewrite Et. apply Rabs_triangle.
  assert (Et: (Eps == Eps * inject_Q (1 # 2) + Eps * inject_Q (1 # 2))%R).
    { rewrite <- Rmult_plus_distr_r. rewrite <- inject_Q_plus.
      assert ((1 # 2) + (1 # 2) == 1) by ring. rewrite H7.
      rewrite Rmult_1_r. reflexivity. }
  rewrite Et. auto.
Qed.

Lemma CCfunlemma1: forall (RS : nat -> Real -> Prop),
R_seq RS-> forall n : nat, exists q : Q,   forall A : Real,  RS n A ->
  forall z : Z, Rfloor (A * inject_Q (inject_Z (Z.of_nat n))) z -> q == z # Pos.of_nat n.
Proof.
intros. destruct H. destruct (Rseq_exists0 n).
  destruct (Rfloor_exists  (x * inject_Q (inject_Z (Z.of_nat n)))) as [z Hz].
  exists (z # Pos.of_nat (n)). intros.
  rewrite (Rseq_unique0 _ _ _ H H0) in Hz.
  rewrite (Rfloor_unique _ _ _ Hz H1). reflexivity.
Qed.

Lemma CCfunlemma2: forall (RS : nat -> Real -> Prop),
R_seq RS->forall (n : nat) (q1 q2 : Q), (forall A : Real,  RS n A ->
 forall z : Z, Rfloor (A * inject_Q (inject_Z (Z.of_nat n))) z -> q1 == z # Pos.of_nat n) ->
(forall A : Real,  RS n A ->
 forall z : Z, Rfloor (A * inject_Q (inject_Z (Z.of_nat n))) z -> q2 == z # Pos.of_nat n) ->
q1 == q2.
Proof.
  intros. destruct H. destruct (Rseq_exists0 n).
  destruct (Rfloor_exists (x * inject_Q (inject_Z (Z.of_nat n)))) as [z Hz].
  assert (q1 == z # Pos.of_nat n). { apply (H0 x). auto. auto. }
  assert (q2 == z # Pos.of_nat n). { apply (H1 x). auto. auto. }
  rewrite H2,H3. reflexivity.
Qed.

Lemma CCfunlemma3: forall (RS : nat -> Real -> Prop),
R_seq RS -> forall (p q : Q) (n : nat),
p == q -> (forall A : Real,  RS n A ->
 forall z : Z, Rfloor (A * inject_Q (inject_Z (Z.of_nat n))) z -> p == z # Pos.of_nat n) ->
forall A : Real, RS n A ->
forall z : Z, Rfloor (A * inject_Q (inject_Z (Z.of_nat n))) z -> q == z # Pos.of_nat n.
Proof.
  intros.
  rewrite <- (H1 A H2). rewrite H0. ring. auto.
Qed.

(* We prove that the sequence construted is a cauchy sequence of rational*)

Lemma Real_constr_help1: forall A z m q, (m<>0)%nat ->
     Rfloor (A * inject_Q (inject_Z (Z.of_nat m))) z -> q == z # Pos.of_nat m
    -> (inject_Q q <= A)%R.
Proof. intros A z m q E. intros.
  apply Rfloor_iff in H. destruct H.
  apply (Rle_mult_l_compat _ _ (inject_Q (inject_Z (Z.of_nat m)))).
  apply Rpositive_gt_0. apply Qlt_Rlt. assert (0==inject_Z 0) by ring.
  rewrite H2. rewrite <- Zlt_Qlt. omega.
  rewrite H0. rewrite Qmake_Qdiv. rewrite <- inject_Q_mult.
  assert (Et: ((Z.of_nat m)) = (Z.pos (Pos.of_nat m))).
    { symmetry. apply Inject_2.  omega. }
  rewrite <- Et.
  assert (Et1: (inject_Z (Z.of_nat m) * (inject_Z z / inject_Z (Z.of_nat m))) == inject_Z z).
    { field. intros C.
      apply inject_Z_nonzero in E. contradiction. }
  rewrite Et1. rewrite Rmult_comm. auto.
Qed.
Lemma Real_constr_help2: forall A z m q, (m<>0)%nat ->
     Rfloor (A * inject_Q (inject_Z (Z.of_nat m))) z -> q == z # Pos.of_nat m
    -> (inject_Q q > A - inject_Q (1# Pos.of_nat m))%R.
Proof. intros A z m q E. intros.
  apply Rfloor_iff in H. destruct H.
  apply (Rlt_mult_compat_r _ _ (inject_Q (inject_Z (Z.of_nat m)))).
  apply Rpositive_gt_0. apply Qlt_Rlt. assert (0==inject_Z 0) by ring.
  rewrite H2. rewrite <- Zlt_Qlt. omega.
  rewrite H0. repeat rewrite Qmake_Qdiv. unfold Rminus. repeat unfold Qdiv.
  rewrite Rmult_plus_distr_l. rewrite <- Ropp_mult_distr.
  repeat rewrite <- inject_Q_mult.
  assert (Et: ((Z.of_nat m)) = (Z.pos (Pos.of_nat m))).
    { symmetry. apply Inject_2.  omega. }
  rewrite <- Et.
  assert (Et1: inject_Z 1 * / inject_Z (Z.of_nat m) * inject_Z (Z.of_nat m) == inject_Z 1).
    { field. intros C.
      apply inject_Z_nonzero in E. contradiction. }
  assert (Et2: inject_Z z * / inject_Z (Z.of_nat m) * inject_Z (Z.of_nat m) == inject_Z z).
    { field. intros C.
      apply inject_Z_nonzero in E. contradiction. }
  rewrite Et1. rewrite Et2.
  assert (Et3:  (- inject_Q (inject_Z 1) == - (1))%R). { reflexivity. }
  rewrite Et3. auto.
Qed.
Lemma CCfun_is_Cauchy: forall (RS : nat -> Real -> Prop)
  (H: R_seq RS) , Cauchy_of_R (Rseq_intro RS H) ->
  forall eps : Q, 0< eps -> exists n : nat,   forall m1 m2 : nat,  (m1 > n)%nat ->  (m2 > n)%nat ->  forall q1 q2 : Q,
  (forall A : Real, RS m1 A -> forall z : Z, Rfloor (A * inject_Q (inject_Z (Z.of_nat m1))) z -> q1 == z # Pos.of_nat m1) ->
  (forall A : Real, RS m2 A -> forall z : Z, Rfloor (A * inject_Q (inject_Z (Z.of_nat m2))) z -> q2 == z # Pos.of_nat m2) ->
  Qabs (q1 - q2) < eps.
Proof.
  intros RS. intros [Rseq_exists Rseq_unique Rseq_proper] HS eps Heps.

  remember (Z.to_nat (2*(Qceiling (/eps)%Q)+1)) as N.

  assert (T1:0 == inject_Z 0) by ring.
  destruct (HS (inject_Q (1#(Pos.of_nat N)))) as [M HM].
  { apply Qlt_Rlt. rewrite (Qmake_Qdiv 1). unfold Qdiv. rewrite Qmult_1_l. apply Qlt_shift_inv_l.
    rewrite T1. rewrite <- Zlt_Qlt.
    assert (T0:((Z.pos (Pos.of_nat N))>0)%Z). { apply Zgt_pos_0. }
    omega. rewrite Qmult_0_l. reflexivity. }
  clear HS.
  exists (max (N) (M)).
  intros.
  assert (Eeps': /eps>0). { apply Qinv_lt_0_compat. auto. }
  assert (Em1: (m1 <> 0)%nat). { intros C. rewrite C in H. omega. }
  assert (Em2: (m2 <> 0)%nat). { intros C. rewrite C in H0. omega. }
  assert (Eepsceil: ((2 * Qceiling (/ eps) + 1)>0)%Z).
    { apply Z.lt_gt. apply (Z.lt_le_trans _ (1)).
      omega. assert (0<= Qceiling (/ eps) )%Z.
      { assert (0 = Qceiling 0)%Z by reflexivity. rewrite H3.
        apply Qceiling_resp_le. apply Qlt_le_weak. apply Qinv_lt_0_compat. auto. }
      omega. }
  assert (EN: (N<>0)%nat). { intros C. rewrite C in HeqN.
    apply Z.gt_lt in Eepsceil. assert (0<=0)%Z by omega.
    apply (Z2Nat.inj_lt 0 (2 * Qceiling (/ eps) + 1) H3 (Zlt_le_weak _ _ Eepsceil)) in Eepsceil.
    assert (Z.to_nat 0 = 0)%nat by omega. rewrite H4 in Eepsceil. omega. }

  assert (EN0:(0 < Z.pos (Pos.of_nat N))%Z).
  { apply Z.gt_lt. apply Zgt_pos_0. }
  apply Nat.max_lub_lt_iff in H.
  apply Nat.max_lub_lt_iff in H0.

  assert (Em3:(Z.pos (Pos.of_nat m1) > Z.pos (Pos.of_nat N))%Z).
  { rewrite (Inject_2 _ Em1).  rewrite (Inject_2 _ EN). omega. }
  assert (Em4:(Z.pos (Pos.of_nat m2) > Z.pos (Pos.of_nat N))%Z).
  { rewrite (Inject_2 _ Em2).  rewrite (Inject_2 _ EN). omega. }

  assert (EN1: / inject_Z (Z.pos (Pos.of_nat N)) * (2 # 1) < eps).

  { rewrite Qmult_comm. apply Qlt_shift_div_r. rewrite T1. rewrite <- Zlt_Qlt. omega.
    apply (Qmult_lt_r _ _ (/eps));auto.
    assert (Et1: eps * inject_Z (Z.pos (Pos.of_nat N)) * / eps ==inject_Z (Z.pos (Pos.of_nat N)) ).
      { field. intros C. rewrite C in Heps. apply Qlt_irrefl in Heps. auto. }
    rewrite Et1. rewrite Inject_2;auto. rewrite HeqN.
    rewrite Z2Nat.id. pose proof (Qle_ceiling (/eps)).
    assert (inject_Z 2 >0) by auto.
    apply (proj2 (Qmult_le_l _ _ _ H4)) in H3.
    apply (Qle_lt_trans _ _ _ H3). rewrite (inject_Z_plus _ 1).
    rewrite <- Qplus_0_r.  rewrite (inject_Z_mult). apply Qplus_lt_r. reflexivity.
    omega. }
  apply Qabs_Qlt_condition.
  destruct (Rseq_exists m1) as [Am1 HAm1],(Rseq_exists m2) as [Am2 HAm2].
  split.

{ rewrite <- (Qopp_involutive (q1 - q2)). apply Qopp_lt_compat.
  assert (T:- (q1 - q2) == q2-q1) by ring. rewrite T.
  assert (E1: (inject_Q (q2- q1) < Am2 - (Am1 - inject_Q (1#Pos.of_nat m1)))%R).
    { rewrite inject_Q_minus. apply Rle_lt_plus_compat.
      - destruct (Rfloor_exists (Am2 * inject_Q (inject_Z (Z.of_nat m2)))) as [z Hz].
        pose proof (Real_constr_help1 Am2 z m2 q2 Em2 Hz).
        apply H3. apply (H2 Am2). auto. auto.
     - apply Ropp_lt_compat.
       destruct (Rfloor_exists (Am1 * inject_Q (inject_Z (Z.of_nat m1)))) as [z Hz].
       apply (Real_constr_help2 Am1 z m1 q1).
       auto. auto. auto. apply (H1 Am1). auto. auto.
    }
  assert (E2: (Rabs (Am2 - Am1) < inject_Q (1 # Pos.of_nat N))%R).
    { apply (HM m2 m1). omega. omega. auto. auto. }
  apply Qlt_Rlt. apply (Rlt_trans _ (inject_Q (1 # Pos.of_nat N) + inject_Q (1 # Pos.of_nat m1))%R).
  - apply (Rlt_trans _ (Am2 - (Am1 - inject_Q (1 # Pos.of_nat m1)))%R).
    auto. assert ((Am2 - (Am1 - inject_Q (1 # Pos.of_nat m1)) == Am2 - Am1 + inject_Q (1 # Pos.of_nat m1)))%R by ring.
    rewrite H3. apply Rlt_plus_r. apply Rabs_lt_iff in E2. destruct E2. apply H5.
    apply Qlt_Rlt. rewrite (Qmake_Qdiv 1). apply Qinv_lt_0_compat.
    assert (0==inject_Z 0)%Q by ring. rewrite H5. rewrite <- Zlt_Qlt.
    rewrite Inject_2. omega. auto.
  - rewrite <- inject_Q_plus. apply Qlt_Rlt.
    { repeat rewrite Qmake_Qdiv. repeat unfold Qdiv.
      repeat rewrite Qmult_1_l.
      apply (Qlt_trans _ (/ inject_Z (Z.pos (Pos.of_nat N))+ / inject_Z (Z.pos (Pos.of_nat N)))).
      { apply Qplus_lt_r. apply Qlt_shift_inv_r.
        rewrite T1. rewrite <- Zlt_Qlt. omega.
        rewrite Qmult_comm. apply Qlt_shift_div_l.
        rewrite T1. rewrite <- Zlt_Qlt. omega. rewrite Qmult_1_l.
        rewrite <- Zlt_Qlt. repeat rewrite Inject_2. omega. omega. omega. }
      { rewrite <- (Qmult_1_r (/ inject_Z (Z.pos (Pos.of_nat N)))).
        rewrite <- Qmult_plus_distr_r. assert ((1 + 1==(2#1))%Q) by ring.
        rewrite H3. auto. }
     }
}

{ (*q1 - q2 < Sm1 - Sm2 + 1/m2 < 1/m2 + eps < 2eps*)
  assert (E1: (inject_Q (q1 - q2) < Am1 - (Am2 - inject_Q (1#Pos.of_nat m2)))%R).
  { rewrite inject_Q_minus. apply Rle_lt_plus_compat.
    - destruct (Rfloor_exists (Am1 * inject_Q (inject_Z (Z.of_nat m1)))) as [z Hz].
      pose proof (Real_constr_help1 Am1 z m1 q1 Em1 Hz).
      apply H3. apply (H1 Am1). auto. auto.
   - apply Ropp_lt_compat.
     destruct (Rfloor_exists (Am2 * inject_Q (inject_Z (Z.of_nat m2)))) as [z Hz].
     apply (Real_constr_help2 Am2 z m2 q2).
     auto. auto. auto. apply (H2 Am2). auto. auto.
  }
  assert (E2: (Rabs (Am1 - Am2) < inject_Q (1 # Pos.of_nat N))%R).
    { apply (HM m1 m2). omega. omega. auto. auto. }
  apply Qlt_Rlt. apply (Rlt_trans _ (inject_Q (1 # Pos.of_nat N) + inject_Q (1 # Pos.of_nat m2))%R).
  - apply (Rlt_trans _ (Am1 - (Am2 - inject_Q (1 # Pos.of_nat m2)))%R).
    auto. assert ((Am1 - (Am2 - inject_Q (1 # Pos.of_nat m2)) == Am1 - Am2 + inject_Q (1 # Pos.of_nat m2)))%R by ring.
    rewrite H3. apply Rlt_plus_r. apply Rabs_lt_iff in E2. destruct E2. apply H5.
    apply Qlt_Rlt. rewrite (Qmake_Qdiv 1). apply Qinv_lt_0_compat.
    assert (0==inject_Z 0)%Q by ring. rewrite H5. rewrite <- Zlt_Qlt.
    rewrite Inject_2. omega. auto.
  - rewrite <- inject_Q_plus. apply Qlt_Rlt.
    { repeat rewrite Qmake_Qdiv. repeat unfold Qdiv.
      repeat rewrite Qmult_1_l.
      apply (Qlt_trans _ (/ inject_Z (Z.pos (Pos.of_nat N))+ / inject_Z (Z.pos (Pos.of_nat N)))).
      { apply Qplus_lt_r. apply Qlt_shift_inv_r.
        rewrite T1. rewrite <- Zlt_Qlt. omega.
        rewrite Qmult_comm. apply Qlt_shift_div_l.
        rewrite T1. rewrite <- Zlt_Qlt. omega. rewrite Qmult_1_l.
        rewrite <- Zlt_Qlt. repeat rewrite Inject_2. omega. omega. omega. }
      { rewrite <- (Qmult_1_r (/ inject_Z (Z.pos (Pos.of_nat N)))).
        rewrite <- Qmult_plus_distr_r. assert ((1 + 1==(2#1))%Q) by ring.
        rewrite H3. auto. }
     } }
Qed.

Definition RCCFun: {X: Real_seq| (Cauchy_of_R X)}%R -> Real.
intros. destruct X as [Rseq HS]. destruct Rseq.
  apply (Real_intro (fun n q => forall A, RS n A -> forall z,
          (Rfloor (A * (inject_Q (inject_Z (Z.of_nat (n)%nat)))) z) ->
        q == z # (Pos.of_nat (n)%nat))).
split.
- apply CCfunlemma1. auto.
- apply CCfunlemma2. auto.
- apply CCfunlemma3. auto.
- apply (CCfun_is_Cauchy RS H HS).
Defined.

(* We prove that the constructed real is the limit *)

Theorem CC_sufficiency: forall (Rseq:Real_seq),
 Cauchy_of_R Rseq -> (exists Lim:Real, Rlimit Rseq Lim).
Proof. intros.
  exists (RCCFun (exist _ Rseq H)). hnf.
  remember (RCCFun (exist Cauchy_of_R Rseq H)) as RC.
  destruct Rseq as [RS HRS].
  intros.
  pose proof (Real_density_of_Q _ _ H0). destruct H1 as [epsq [Hepsq Hepsq2]].
  apply Qlt_Rlt in Hepsq.
  destruct (Cauchy_Q_limit RC (epsq*(1#2))) as [M HM]. apply eps_divide_2_positive. auto.
  assert (T1:0 == inject_Z 0) by ring.
  assert (Eepsq': /epsq>0). { apply Qinv_lt_0_compat. auto. }
  assert (Eepsceil: ((2 * Qceiling (/ epsq) + 1)>0)%Z).
    { apply Z.lt_gt. apply (Z.lt_le_trans _ (1)).
      omega. assert (0<= Qceiling (/ epsq) )%Z.
      { assert (0 = Qceiling 0)%Z by reflexivity. rewrite H1.
        apply Qceiling_resp_le. apply Qlt_le_weak. apply Qinv_lt_0_compat. auto. }
      omega. }

  assert ( exists N, forall n : nat,
     (n >= N)%nat -> forall A : Real, RS n A ->
     forall q : Q,
     match RC with
     | Real_intro A0 _ => A0
     end n q -> (Rabs (A - inject_Q q) < inject_Q (epsq * (1 # 2)))%R).
    { exists (2*Z.to_nat((Qceiling (/epsq)%Q)+1))%nat. intros. rewrite HeqRC in H3. hnf in H3.
      pose proof (H3 _ H2). clear H3.
      assert (E0:(n<>0)%nat). { intros C.
      rewrite C in H1.
      destruct (classic (2 * Z.to_nat (Qceiling (/ epsq) + 1) = 0)%nat).
      { apply mult_is_O in H3. destruct H3. omega.
        assert (Et4: (0 <= Qceiling (/ epsq))%Z).
      { assert (0 = Qceiling 0)%Z by reflexivity. rewrite H5.
        apply Qceiling_resp_le. apply Qlt_le_weak. apply Qinv_lt_0_compat. auto. }
        assert (Et5: (0<=1)%Z) by omega.
        rewrite (Z2Nat.inj_add _ _ Et4 Et5) in H3.
        assert (Et8: (Z.to_nat 1 = 1)%nat) by reflexivity.
        rewrite Et8 in H3. omega. }
        omega. }

      apply Rabs_lt_iff. { apply Qlt_Rlt. apply eps_divide_2_positive. auto. } split.
      - apply (Rlt_le_trans _ 0)%R. { rewrite (Ropp_involutive 0). apply Ropp_lt_compat.
           assert (-0 == (0))%R by ring. assert (0==inject_Q 0)%R by reflexivity.
          rewrite H3,H5. apply Qlt_Rlt. apply eps_divide_2_positive. auto. }
        apply (Rle_plus_compat_r 0 _ (inject_Q q)).
        rewrite Rplus_0_l. assert (Et: (A - inject_Q q + inject_Q q == A)%R) by ring.
        rewrite Et. destruct (Rfloor_exists (A * inject_Q (inject_Z (Z.of_nat n)))) as [z Hz].
        apply (Real_constr_help1 A z n). omega. auto. apply H4. auto.
      - apply (Rlt_plus_compat_r _ _ (inject_Q q - inject_Q (epsq * (1 # 2)))).
        assert (Et1: (A - inject_Q q + (inject_Q q - inject_Q (epsq * (1 # 2)))
                      == A - inject_Q (epsq *(1#2)))%R) by ring.
        assert (Et2:  (inject_Q (epsq * (1 # 2)) + (inject_Q q - inject_Q (epsq * (1 # 2))) == inject_Q q)%R) by ring.
        rewrite Et2,Et1.
        assert (Et3:  (inject_Q q > A - inject_Q (1# Pos.of_nat n))%R).
          { destruct (Rfloor_exists (A * inject_Q (inject_Z (Z.of_nat n)))) as [z Hz].
            apply (Real_constr_help2 _ z). auto. auto. auto. }
        assert (Et4: (A - inject_Q (1 # Pos.of_nat n) > A - inject_Q (epsq * (1 # 2)))%R).
          { unfold Rminus. apply Rlt_plus_l. apply Ropp_lt_compat. apply Qlt_Rlt.
            rewrite Qmake_Qdiv. unfold Qdiv. rewrite Qmult_1_l.
            apply Qlt_shift_inv_r. rewrite Inject_2. rewrite T1. rewrite <- Zlt_Qlt. omega. omega.
            apply (Qmult_lt_r _ _ (inject_Z 2 * (/epsq))).
                apply Qlt_shift_div_l. auto. rewrite Qmult_0_l. reflexivity.
                assert (Te1: epsq * (1 # 2) * inject_Z (Z.pos (Pos.of_nat n)) * (inject_Z 2 * / epsq) ==inject_Z (Z.pos (Pos.of_nat n)) ).
                  { field. intros C. rewrite C in Hepsq. apply Qlt_irrefl in Hepsq. auto. }
                rewrite Te1. rewrite Inject_2;auto. apply (Qlt_le_trans _ (inject_Z (Z.of_nat (2 * Z.to_nat (Qceiling (/ epsq) + 1))))).
                  { apply (Qle_lt_trans _ (inject_Z (Z.of_nat (2 * Z.to_nat (Qceiling (/ epsq)))))).
                    { rewrite Qmult_1_l. rewrite Nat2Z.inj_mul. rewrite inject_Z_mult.
                      apply Qmult_le_l. reflexivity. rewrite Z2Nat.id. apply (Qle_ceiling (/epsq)).
                      pose proof (Qlt_le_weak _ _ Eepsq'). apply (Qceiling_resp_le _ _ H3). }
                    { rewrite <- Zlt_Qlt. apply inj_lt. apply mult_lt_compat_l.
                      apply Z2Nat.inj_lt. pose proof (Qlt_le_weak _ _ Eepsq'). apply (Qceiling_resp_le _ _ H3).
                      pose proof (Qlt_le_weak _ _ Eepsq'). pose proof (Qceiling_resp_le _ _ H3). omega. omega. omega.
                      }
                  }
            rewrite <- Zle_Qle. apply inj_le. auto.
          }
      apply (Rlt_trans _ _ _ Et4 Et3). }
    destruct H1 as [N HN].

  exists (max (S N) (S M)). intros.
  apply Nat.max_lub_lt_iff in H1.
  destruct A as [A HA].
  destruct RC as [RC HRC].
  destruct (Cauchy_exists _ HRC n) as [q Hq].
  apply (Rle_lt_trans _ (Rabs ((Real_intro A HA) - inject_Q q) + Rabs ((Real_intro RC HRC) - inject_Q q)))%R.
  { rewrite (Rabs_Rminus (Real_intro RC HRC)).
    assert (Real_intro A HA - (Real_intro RC HRC) == (Real_intro A HA - inject_Q q) + (inject_Q q - (Real_intro RC HRC)))%R by ring.
    rewrite H3. apply Rabs_triangle. }
  apply (Rlt_trans _ (inject_Q epsq)).
  - assert (Et: (inject_Q epsq == inject_Q (epsq * (1 # 2)) +inject_Q (epsq * (1 # 2)))%R).
     { rewrite <- inject_Q_plus. assert (epsq == (epsq * (1 # 2) + epsq * (1 # 2))) by ring.
      rewrite <- H3. reflexivity. }
    rewrite Et.
    apply Rle_lt_plus_compat.
    + apply Rlt_le_weak. apply (HN n). omega. auto. auto.
    + apply (HM n). omega. auto.
  - auto.
Qed.


Require Import Coq.Bool.Bvector.
Require Export CatSem.CAT.cat_TYPE.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Ltac app_any := match goal with [H:_|-_]=>apply H end.

(** this should be in std lib -- wtf *)

Section Vmap.

Variables A B : Type.
Variable f : A -> B.

Fixpoint Vmap n (X : vector A n) : vector B n :=
  match X in vector _ n return vector B n with
  | Vnil => Vnil _
  | Vcons a _ al => Vcons _ (f a) _ (Vmap al) end.

End Vmap.

Ltac simpind x := induction x; simpl; auto; rew_all; auto.

Lemma Vmap_id A l x: Vmap (A:=A) (fun x => x) (n:=l) x = x.
Proof.
  simpind x.
Qed.

Lemma Vmap_comp A B C (f : A -> B) (g : B -> C) l (x : vector A l):
     Vmap (fun x => g (f x)) x = Vmap g (Vmap f x).
Proof.
  simpind x.
Qed.

Hint Rewrite Vmap_id : vec.
Hint Resolve Vmap_id : vec.

Ltac vec := simpl; intros; autorewrite with vec;
               auto with vec.

Record type_sig : Type := {
  ts_ind : Type ;
  ts_dom : ts_ind -> nat }.

Section type_arity_reps.

Variable T : type_sig.

Class ts_rep_struct (X : Type) := {
  ts_rep_s : forall a : ts_ind T, vector X (ts_dom a) -> X  }.

Record ts_rep := {
  ta_c :> Type ;
  ta_rep_s :> ts_rep_struct ta_c }.

Existing Instance ta_rep_s.

Section homs.

Variable A B : ts_rep.

Class ts_rep_hom_s (f : A -> B) : Prop := {
   ts_rep_hom_com :
       forall (a : ts_ind T) (x : vector A (ts_dom a)),
                   f (ts_rep_s x) = ts_rep_s (Vmap f x) }.

Record ts_rep_hom : Type := {
  ts_rep_hom_c :> A -> B ;
  ts_rep_hom_struct :> ts_rep_hom_s ts_rep_hom_c }.

End homs.

Existing Instance ts_rep_hom_struct.

Obligation Tactic := vec.

Program Instance ts_rep_id_s A : ts_rep_hom_s (fun x : _ A => x).
Definition ts_rep_id A := Build_ts_rep_hom (ts_rep_id_s A).

Obligation Tactic := simpl; intros; auto;
          repeat (rewrite Vmap_comp || rewrite ts_rep_hom_com ; app_any || auto).

Program Instance ts_rep_comp_s A B C (f : ts_rep_hom A B) (g : ts_rep_hom B C) :
                 ts_rep_hom_s (fun x : _ A => g (f x)).
Definition ts_rep_comp A B C f g := Build_ts_rep_hom (ts_rep_comp_s A B C f g).

Obligation Tactic := vec ; unfold Transitive; simpl; intros; etransitivity; auto.

Program Instance ts_eq A B : Equivalence (fun f g : ts_rep_hom A B => forall x, f x = g x).
Definition ts_oid A B := Build_Setoid (ts_eq A B).

Obligation Tactic := unfold Proper, respectful; simpl; intros;
        repeat rew_all; auto.

Program Instance TS_rep_s : Cat_struct ts_rep_hom := {
  mor_oid a b := ts_oid a b ;
  id := ts_rep_id ;
  comp := ts_rep_comp }.

Definition TS_rep := Build_Cat TS_rep_s.

Inductive ts_in : Type :=
  ts_build : forall i : ts_ind T, ts_in_list (ts_dom i) -> ts_in
with
  ts_in_list : nat -> Type :=
   | vnil : ts_in_list 0
   | vcons : forall n, ts_in -> ts_in_list n -> ts_in_list (S n).

Scheme ts_induct := Induction for ts_in Sort Prop with
      ts_list_induct := Induction for ts_in_list Sort Prop.

Fixpoint vec_f_ts_list n (x : ts_in_list n) : vector ts_in n :=
    match x in ts_in_list n return vector ts_in n with
        | vnil => Vnil
        | vcons _ a l => Vcons a (vec_f_ts_list l) end.

Fixpoint ts_list_f_vec n (x : vector ts_in n) : ts_in_list n :=
    match x in vector _ n return ts_in_list n with
        | Vnil => vnil
        | Vcons a _ l => vcons a (ts_list_f_vec l) end.

Lemma one_way n (x : ts_in_list n) :
         ts_list_f_vec (vec_f_ts_list x) = x.
Proof.
  simpind x.
Qed.

Lemma or_another n (x : vector ts_in n) :
         vec_f_ts_list (ts_list_f_vec x) = x.
Proof.
  simpind x.
Qed.

Program Instance ts_init_rep_s : ts_rep_struct ts_in := {
   ts_rep_s := fun a x => ts_build (ts_list_f_vec x) }.
Definition ts_init : TS_rep := Build_ts_rep ts_init_rep_s.

Section init.

Variable R : TS_rep.

Fixpoint init (x : ts_in) : R :=
  match x with ts_build i l => ts_rep_s (init_list l) end
with
  init_list i (x : ts_in_list i) : vector R i :=
  match x in ts_in_list i return vector R i with
    vnil => Vnil
    | vcons _ a al => Vcons (init a) (init_list al) end.

Lemma init_list_vmap (a : ts_ind T) (x : vector ts_in (ts_dom (t:=T) a)) :
    init_list (ts_list_f_vec x) = Vmap init x.
Proof.
  induction x; simpl;
  repeat (reflexivity || rew_all).
Qed.

Hint Rewrite init_list_vmap : vec.

Obligation Tactic := vec.

Program Instance init_hom_s : ts_rep_hom_s (A:=ts_init) (B:=R) init.

Definition init_hom := Build_ts_rep_hom init_hom_s.

Lemma unique : forall f : ts_init ---> R, f == init_hom.
Proof.
  simpl.
  intro f.
  apply (@ts_induct
              (fun t => f t = init t)
              (fun n lk => Vmap f (vec_f_ts_list lk) = init_list lk));
  simpl; intros; auto.
  assert (H2:= @ts_rep_hom_com _ _ f).
  simpl in H2.
  rewrite <- H.
  rewrite <- (H2 f).
  apply f_equal.
  apply f_equal.
  rew one_way.
  repeat rew_all.
  auto.
Qed.

End init.

Program Instance ts_INIT : Initial TS_rep := {
  Init := ts_init ;
  InitMor := init_hom ;
  InitMorUnique := unique
}.

End type_arity_reps.