(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.algebra.COrdCauchy.
Require Export CoRN.tactics.RingReflection.

(**
* The Field of Cauchy Sequences

In this chapter we will prove that whenever we start from an ordered
field [F], we can define a new ordered field of Cauchy sequences over [F].

%\begin{convention}% Let [F] be an ordered field.
%\end{convention}%
*)

Section Structure.

Variable F : COrdField.

(**
** Setoid Structure

[R_Set] is the setoid of Cauchy sequences over [F]; given two sequences
[x,y] over [F], we say that [x] is smaller than [y] if from some point
onwards [(y n) [-] (x n)] is greater than some fixed, positive
[e].  Apartness of two sequences means that one of them is smaller
than the other, equality is the negation of the apartness.
*)

Definition R_Set := CauchySeq F.

Section CSetoid_Structure.

Definition R_lt (x y : R_Set) := {N : nat |
  {e : F | [0] [<] e | forall n, N <= n -> e [<=] CS_seq _ y n[-]CS_seq _ x n}}.

Definition R_ap (x y : R_Set) := R_lt x y or R_lt y x.

Definition R_eq (x y : R_Set) := Not (R_ap x y).

Lemma R_lt_cotrans : cotransitive R_lt.
Proof.
 red in |- *.
 intros x y.
 elim x; intros x_ px.
 elim y; intros y_ py.
 intros Hxy z.
 elim z; intros z_ pz.
 elim Hxy; intros N H.
 elim H; clear Hxy H; intros e He HN.
 simpl in HN.
 set (e3 := e [/]ThreeNZ) in *.
 cut ([0] [<] e3); [ intro He3 | unfold e3 in |- *; apply pos_div_three; auto ].
 set (e6 := e [/]SixNZ) in *.
 cut ([0] [<] e6); [ intro He6 | unfold e6 in |- *; apply pos_div_six; auto ].
 set (e12 := e [/]TwelveNZ) in *.
 cut ([0] [<] e12); [ intro He12 | unfold e12 in |- *; apply pos_div_twelve; auto ].
 set (e24 := e [/]TwentyFourNZ) in *.
 cut ([0] [<] e24); [ intro He24 | unfold e24 in |- *; apply pos_div_twentyfour; auto ].
 elim (px e24 He24); intros Nx HNx.
 elim (py e24 He24); intros Ny HNy.
 elim (pz e24 He24); intros Nz HNz.
 set (NN := max N (max Nx (max Ny Nz))) in *.
 set (x0 := x_ NN) in *.
 set (y0 := y_ NN) in *.
 set (z0 := z_ NN) in *.
 elim (less_cotransitive_unfolded _ (x0[+]e3) (y0[-]e3)) with z0.
   intro Hyz.
   left.
   exists NN; exists e6; auto.
   intros n Hn; simpl in |- *.
   apply leEq_wdl with (e3[-] (e24[+]e24[+]e24[+]e24)).
    2: unfold e3, e6, e12, e24 in |- *; rational.
   apply leEq_transitive
     with (e3[-] (z0[-]z_ Nz[+] (z_ Nz[-]z_ n) [+] (x_ n[-]x_ Nx) [+] (x_ Nx[-]x0))).
    apply minus_resp_leEq_rht.
    repeat apply plus_resp_leEq_both.
       unfold z0 in |- *; elim (HNz NN); auto; unfold NN in |- *; eauto with arith.
      apply shift_minus_leEq; apply shift_leEq_plus'.
      unfold cg_minus in |- *; apply shift_plus_leEq'.
      elim (HNz n); auto; apply le_trans with NN; auto; unfold NN in |- *; eauto with arith.
     elim (HNx n); auto; apply le_trans with NN; auto; unfold NN in |- *; eauto with arith.
    apply shift_minus_leEq; apply shift_leEq_plus'.
    unfold cg_minus in |- *; apply shift_plus_leEq'.
    unfold x0 in |- *; elim (HNx NN); auto; unfold NN in |- *; eauto with arith.
   apply shift_minus_leEq.
   rstepr (z0[-]x0).
   apply shift_leEq_minus; astepl (x0[+]e3); apply less_leEq; auto.
  intro Hzx.
  right.
  exists NN; exists e6; auto.
  intros n Hn; simpl in |- *.
  apply leEq_wdl with (e3[-] (e24[+]e24[+]e24[+]e24)).
   2: unfold e3, e6, e12, e24 in |- *; rational.
  apply leEq_transitive
    with (e3[-] (z_ Nz[-]z0[+] (z_ n[-]z_ Nz) [+] (y_ Ny[-]y_ n) [+] (y0[-]y_ Ny))).
   apply minus_resp_leEq_rht.
   repeat apply plus_resp_leEq_both.
      apply shift_minus_leEq; apply shift_leEq_plus'.
      unfold cg_minus in |- *; apply shift_plus_leEq'.
      unfold z0 in |- *; elim (HNz NN); auto; unfold NN in |- *; eauto with arith.
     elim (HNz n); auto; apply le_trans with NN; auto; unfold NN in |- *; eauto with arith.
    apply shift_minus_leEq; apply shift_leEq_plus'.
    unfold cg_minus in |- *; apply shift_plus_leEq'.
    elim (HNy n); auto; apply le_trans with NN; auto; unfold NN in |- *; eauto with arith.
   unfold y0 in |- *; elim (HNy NN); auto; unfold NN in |- *; eauto with arith.
  apply shift_minus_leEq.
  rstepr (y0[-]z0).
  apply shift_leEq_minus; apply shift_plus_leEq'; apply less_leEq; auto.
 apply shift_less_minus.
 astepl (x0[+] (e3[+]e3)); apply shift_plus_less'.
 apply less_leEq_trans with e.
  apply shift_plus_less.
  apply less_wdl with ((e[-]e3) [/]TwoNZ).
   2: unfold e3 in |- *; rational.
  apply pos_div_two'.
  apply shift_less_minus; astepl e3; unfold e3 in |- *; apply pos_div_three'; auto.
 unfold x0, y0, NN in |- *; apply HN; eauto with arith.
Qed.

Lemma R_ap_cotrans : cotransitive R_ap.
Proof.
 red in |- *; intros x y Hxy z.
 elim Hxy; intro H; elim (R_lt_cotrans _ _ H z); unfold R_ap in |- *; auto.
Qed.

Lemma R_ap_symmetric : Csymmetric R_ap.
Proof.
 red in |- *; intros x y Hxy.
 elim Hxy; unfold R_ap in |- *; auto.
Qed.

Lemma R_lt_irreflexive : irreflexive R_lt.
Proof.
 red in |- *; intros x Hx.
 elim Hx; intros N HN.
 elim HN; clear Hx HN; intros e He HN.
 apply (ap_irreflexive_unfolded _ (x N)).
 apply less_imp_ap.
 apply less_leEq_trans with (x N[+]e).
  astepl (x N[+][0]); apply plus_resp_less_lft; auto.
 apply shift_plus_leEq'; auto with arith.
Qed.

Lemma R_ap_irreflexive : irreflexive R_ap.
Proof.
 red in |- *; intros x Hx.
 elim (R_lt_irreflexive x).
 elim Hx; auto.
Qed.

Lemma R_ap_eq_tight : tight_apart R_eq R_ap.
Proof.
 split; auto.
Qed.

Definition R_CSetoid : CSetoid.
Proof.
 apply Build_CSetoid with R_Set R_eq R_ap.
 split.
    exact R_ap_irreflexive.
   exact R_ap_symmetric.
  exact R_ap_cotrans.
 exact R_ap_eq_tight.
Defined.

End CSetoid_Structure.

Section Group_Structure.

(**
** Group Structure
The group structure is just the expected one; the lemmas which
are specifically proved are just the necessary ones to get the group axioms.
*)

Definition R_plus (x y : R_CSetoid) : R_CSetoid :=
  Build_CauchySeq _ _ (CS_seq_plus F _ _ (CS_proof _ x) (CS_proof _ y)).

Definition R_zero := Build_CauchySeq _ _ (CS_seq_const F [0]).

Lemma R_plus_lft_ext : forall x y z, R_plus x z [#] R_plus y z -> x [#] y.
Proof.
 intros x y z Hxy.
 elim Hxy; clear Hxy; intro H; [ left | right ]; elim H; intros N HN; elim HN;
   clear H HN; intros e He HN; exists N; exists e; auto; intros n Hn; simpl in HN.
  rstepr (CS_seq _ y n[+]CS_seq _ z n[-] (CS_seq _ x n[+]CS_seq _ z n)); auto.
 rstepr (CS_seq _ x n[+]CS_seq _ z n[-] (CS_seq _ y n[+]CS_seq _ z n)); auto.
Qed.

Lemma R_plus_assoc : associative R_plus.
Proof.
 intros x y z Hap.
 elim Hap; clear Hap; intro H; elim H; intros N HN; elim HN; clear H HN;
   intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e).
  apply leEq_less_trans with (CS_seq _ x N[+]CS_seq _ y N[+]CS_seq _ z N[-]
    (CS_seq _ x N[+] (CS_seq _ y N[+]CS_seq _ z N))); auto.
  rstepl ([0]:F); auto.
 apply leEq_less_trans with (CS_seq _ x N[+] (CS_seq _ y N[+]CS_seq _ z N) [-]
   (CS_seq _ x N[+]CS_seq _ y N[+]CS_seq _ z N)); auto.
 rstepl ([0]:F); auto.
Qed.

Lemma R_zero_lft_unit : forall x, R_plus R_zero x [=] x.
Proof.
 intro x; intro x_ap.
 apply (R_lt_irreflexive x).
 elim x_ap; clear x_ap; intro x_lt; elim x_lt; intros N H; elim H;
   clear x_lt H; intros e He HN; exists N; exists e; auto; simpl in HN; intros n Hn.
  astepr (CS_seq _ x n[-] ([0][+]CS_seq _ x n)); auto.
 astepr ([0][+]CS_seq _ x n[-]CS_seq _ x n); auto.
Qed.

Lemma R_plus_comm : forall x y, R_plus x y [=] R_plus y x.
Proof.
 intros x y Hxy.
 elim Hxy; clear Hxy; intro H; elim H; intros N HN; elim HN; clear H HN;
   intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e).
  apply leEq_less_trans with (CS_seq _ y N[+]CS_seq _ x N[-] (CS_seq _ x N[+]CS_seq _ y N)); auto.
  rstepl ([0]:F); auto.
 apply leEq_less_trans with (CS_seq _ x N[+]CS_seq _ y N[-] (CS_seq _ y N[+]CS_seq _ x N)); auto.
 rstepl ([0]:F); auto.
Qed.

Definition R_inv (x : R_CSetoid) : R_CSetoid :=
  Build_CauchySeq _ _ (CS_seq_inv F _ (CS_proof _ x)).

Lemma R_inv_is_inv : forall x, R_plus x (R_inv x) [=] R_zero.
Proof.
 intro x; intro x_ap.
 apply (R_lt_irreflexive R_zero).
 elim x_ap; clear x_ap; intro x_lt; elim x_lt; intros N H; elim H;
   clear x_lt H; intros e He HN; exists N; exists e; auto; simpl in HN; intros n Hn.
  simpl in |- *; astepr ([0][-] (CS_seq _ x n[+][--] (CS_seq _ x n))); auto.
 simpl in |- *; astepr (CS_seq _ x n[+][--] (CS_seq _ x n) [-][0]); auto.
Qed.

Lemma R_inv_ext : un_op_strext _ R_inv.
Proof.
 intros x y Hxy.
 elim Hxy; clear Hxy; intro x_lt; [ right | left ]; elim x_lt; intros N H;
   elim H; clear x_lt H; intros e He HN; exists N; exists e; auto; simpl in HN; intros n Hn.
  rstepr ([--] (CS_seq _ y n) [-][--] (CS_seq _ x n)); auto.
 rstepr ([--] (CS_seq _ x n) [-][--] (CS_seq _ y n)); auto.
Qed.

Definition Rinv : CSetoid_un_op R_CSetoid.
Proof.
 red in |- *.
 apply Build_CSetoid_un_op with R_inv.
 exact R_inv_ext.
Defined.

Definition R_CAbGroup : CAbGroup.
Proof.
 apply Build_CAbGroup' with R_CSetoid R_zero R_plus Rinv.
     exact R_plus_lft_ext.
    exact R_zero_lft_unit.
   exact R_plus_comm.
  exact R_plus_assoc.
 exact R_inv_is_inv.
Defined.

End Group_Structure.

Section Ring_Structure.

(**
** Ring Structure
Same comments as previously.
*)

Definition R_mult (x y : R_CAbGroup) : R_CAbGroup :=
  Build_CauchySeq _ _ (CS_seq_mult F _ _ (CS_proof _ x) (CS_proof _ y)).
Definition R_one : R_CAbGroup := Build_CauchySeq _ _ (CS_seq_const F [1]).

Lemma R_one_ap_zero : R_one [#] [0].
Proof.
 right; exists 0; exists ([1]:F).
  apply pos_one.
 intros; simpl in |- *; astepr ([1]:F); apply leEq_reflexive.
Qed.

Lemma R_mult_dist_plus : forall x y z, R_mult x (y[+]z) [=] R_mult x y[+]R_mult x z.
Proof.
 intros x y z H.
 elim H; intro Hlt; elim Hlt; intros N HN; elim HN; clear H Hlt HN;
   intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e).
  eapply leEq_less_trans.
   apply (HN N (le_n _)).
  rstepl ([0]:F); auto.
 eapply leEq_less_trans.
  apply (HN N (le_n _)).
 rstepl ([0]:F); auto.
Qed.

Lemma R_mult_dist_minus : forall x y z, R_mult x (y[-]z) [=] R_mult x y[-]R_mult x z.
Proof.
 intros x y z H.
 elim H; intro Hlt; elim Hlt; intros N HN; elim HN; clear H Hlt HN;
   intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e).
  eapply leEq_less_trans.
   apply (HN N (le_n _)).
  rstepl ([0]:F); auto.
 eapply leEq_less_trans.
  apply (HN N (le_n _)).
 rstepl ([0]:F); auto.
Qed.

Lemma R_one_rht_unit : forall x, R_mult x R_one [=] x.
Proof.
 intro x; intro x_ap.
 apply (R_lt_irreflexive x).
 elim x_ap; clear x_ap; intro x_lt; elim x_lt; intros N H; elim H;
   clear x_lt H; intros e He HN; exists N; exists e; auto; simpl in HN; intros n Hn.
  astepr (CS_seq _ x n[-]CS_seq _ x n[*][1]); auto.
 astepr (CS_seq _ x n[*][1][-]CS_seq _ x n); auto.
Qed.

Lemma R_mult_comm : forall x y, R_mult x y [=] R_mult y x.
Proof.
 intros x y Hxy.
 elim Hxy; clear Hxy; intro H; elim H; intros N HN; elim HN; clear H HN;
   intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e).
  apply leEq_less_trans with (CS_seq _ y N[*]CS_seq _ x N[-]CS_seq _ x N[*]CS_seq _ y N); auto.
  rstepl ([0]:F); auto.
 apply leEq_less_trans with (CS_seq _ x N[*]CS_seq _ y N[-]CS_seq _ y N[*]CS_seq _ x N); auto.
 rstepl ([0]:F); auto.
Qed.

Lemma R_mult_ap_zero' : forall x y, R_mult x y [#] [0] -> x [#] [0].
Proof.
 intros x y Hxy.
 elim (CS_seq_bounded _ (CS_seq _ y) (CS_proof _ y)); intros K HK Hy; elim Hy;
   clear Hy; intros Ny HNY.
 set (z := Build_CauchySeq _ _ (CS_seq_mult _ _ _ (CS_seq_const _ (Two[*]K)) (CS_proof _ x))
   :R_CAbGroup) in *.
 elim (ap_cotransitive_unfolded _ _ _ Hxy z); intro Hap; elim Hap; intro Hlt;
   elim Hlt; intros N HN; elim HN; clear Hap Hlt HN; intros e He HN.
    right.
    cut (forall n : nat, Ny <= n -> [0] [<] Two[*]K[-]CS_seq _ y n); [ intro Hy' | intros n Hn ].
     set (KK := e[/] _[//]mult_resp_ap_zero _ _ _ (three_ap_zero _) (pos_ap_zero _ _ HK)) in *.
     exists (max N Ny); exists KK.
      unfold KK in |- *; apply div_resp_pos; auto.
      apply mult_resp_pos; auto; apply pos_three.
     intros; simpl in |- *; unfold KK in |- *.
     cut (N <= n); [ intro Hn | apply le_trans with (max N Ny); auto with arith ].
     cut (Ny <= n); [ intro Hn' | apply le_trans with (max N Ny); auto with arith ].
     apply leEq_transitive with (e[/] _[//]pos_ap_zero _ _ (Hy' n Hn')).
      apply mult_cancel_leEq with ([1][/] _[//]pos_ap_zero _ _ He).
       apply recip_resp_pos; auto.
      rstepl ([1][/] _[//]mult_resp_ap_zero _ _ _ (three_ap_zero _) (pos_ap_zero _ _ HK)).
      rstepr ([1][/] _[//]pos_ap_zero _ _ (Hy' n Hn')).
      apply recip_resp_leEq; auto.
      unfold cg_minus in |- *; apply shift_plus_leEq'; rstepr ([--][--]K).
      apply inv_resp_leEq; elim (HNY n); auto.
     apply shift_div_leEq; auto.
     eapply leEq_wdr.
      apply (HN n); auto.
     simpl in |- *; rational.
    apply shift_zero_less_minus; apply leEq_less_trans with K.
     elim (HNY n); auto.
    astepl ([0][+]K); astepr (K[+]K); apply plus_resp_less_rht; auto.
   left.
   cut (forall n : nat, Ny <= n -> [0] [<] Two[*]K[-]CS_seq _ y n); [ intro Hy' | intros n Hn ].
    set (KK := e[/] _[//]mult_resp_ap_zero _ _ _ (three_ap_zero _) (pos_ap_zero _ _ HK)) in *.
    exists (max N Ny); exists KK.
     unfold KK in |- *; apply div_resp_pos; auto.
     apply mult_resp_pos; auto; apply pos_three.
    intros; simpl in |- *; unfold KK in |- *.
    cut (N <= n); [ intro Hn | apply le_trans with (max N Ny); auto with arith ].
    cut (Ny <= n); [ intro Hn' | apply le_trans with (max N Ny); auto with arith ].
    apply leEq_transitive with (e[/] _[//]pos_ap_zero _ _ (Hy' n Hn')).
     apply mult_cancel_leEq with ([1][/] _[//]pos_ap_zero _ _ He).
      apply recip_resp_pos; auto.
     rstepl ([1][/] _[//]mult_resp_ap_zero _ _ _ (three_ap_zero _) (pos_ap_zero _ _ HK)).
     rstepr ([1][/] _[//]pos_ap_zero _ _ (Hy' n Hn')).
     apply recip_resp_leEq; auto.
     unfold cg_minus in |- *; apply shift_plus_leEq'; rstepr ([--][--]K).
     apply inv_resp_leEq; elim (HNY n); auto.
    apply shift_div_leEq; auto.
    eapply leEq_wdr.
     apply (HN n); auto.
    simpl in |- *; rational.
   apply shift_zero_less_minus; apply leEq_less_trans with K.
    elim (HNY n); auto.
   astepl ([0][+]K); astepr (K[+]K); apply plus_resp_less_rht; auto.
  left.
  set (KK := e[/] _[//]mult_resp_ap_zero _ _ _ (two_ap_zero _) (pos_ap_zero _ _ HK)) in *.
  exists N; exists KK.
   unfold KK in |- *; apply div_resp_pos; auto.
   apply mult_resp_pos; auto; apply pos_two.
  intros; simpl in |- *; unfold KK in |- *.
  apply shift_div_leEq.
   apply mult_resp_pos; auto; apply pos_two.
  eapply leEq_wdr.
   apply (HN n H).
  simpl in |- *; rational.
 right.
 set (KK := e[/] _[//]mult_resp_ap_zero _ _ _ (two_ap_zero _) (pos_ap_zero _ _ HK)) in *.
 exists N; exists KK.
  unfold KK in |- *; apply div_resp_pos; auto.
  apply mult_resp_pos; auto; apply pos_two.
 intros; simpl in |- *; unfold KK in |- *.
 apply shift_div_leEq.
  apply mult_resp_pos; auto; apply pos_two.
 eapply leEq_wdr.
  apply (HN n H).
 simpl in |- *; rational.
Qed.

Lemma R_mult_lft_ext : forall x y z, R_mult x z [#] R_mult y z -> x [#] y.
Proof.
 intros x y z Hxy.
 apply zero_minus_apart.
 apply R_mult_ap_zero' with z.
 apply ap_wdl_unfolded with (R_mult x z[-]R_mult y z).
  apply minus_ap_zero; auto.
 apply eq_symmetric_unfolded.
 eapply eq_transitive_unfolded.
  apply R_mult_comm.
 eapply eq_transitive_unfolded.
  apply R_mult_dist_minus.
 apply cg_minus_wd; apply R_mult_comm.
Qed.

Lemma R_mult_rht_ext : forall x y z, R_mult x y [#] R_mult x z -> y [#] z.
Proof.
 intros x y z Hxy.
 apply R_mult_lft_ext with x.
 eapply ap_wdl_unfolded.
  eapply ap_wdr_unfolded.
   apply Hxy.
  apply R_mult_comm.
 apply R_mult_comm.
Qed.

Lemma R_mult_strext : bin_op_strext _ R_mult.
Proof.
 red in |- *; red in |- *.
 intros x y a b Hap.
 elim (ap_cotransitive_unfolded _ _ _ Hap (R_mult x b)); intro H.
  right; apply R_mult_rht_ext with x; auto.
 left; apply R_mult_lft_ext with b; auto.
Qed.

Definition Rmult : CSetoid_bin_op R_CAbGroup.
Proof.
 red in |- *.
 apply Build_CSetoid_bin_fun with R_mult.
 apply R_mult_strext.
Defined.

Lemma R_mult_assoc : associative Rmult.
Proof.
 intros x y z Hap.
 elim Hap; clear Hap; intro H; elim H; intros N HN; elim HN; clear H HN;
   intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e).
  apply leEq_less_trans with (CS_seq _ x N[*]CS_seq _ y N[*]CS_seq _ z N[-]
    CS_seq _ x N[*] (CS_seq _ y N[*]CS_seq _ z N)); auto.
  rstepl ([0]:F); auto.
 apply leEq_less_trans with (CS_seq _ x N[*] (CS_seq _ y N[*]CS_seq _ z N) [-]
   CS_seq _ x N[*]CS_seq _ y N[*]CS_seq _ z N); auto.
 rstepl ([0]:F); auto.
Qed.

Lemma R_one_lft_unit : forall x, R_mult R_one x [=] x.
Proof.
 intro.
 eapply eq_transitive_unfolded.
  apply R_mult_comm.
 apply R_one_rht_unit.
Qed.

Definition R_CRing : CRing.
Proof.
 apply Build_CRing with R_CAbGroup R_one Rmult.
 apply Build_is_CRing with R_mult_assoc.
    apply Build_is_CMonoid.
     exact R_one_rht_unit.
    exact R_one_lft_unit.
   exact R_mult_comm.
  exact R_mult_dist_plus.
 exact R_one_ap_zero.
Defined.

End Ring_Structure.

Add Ring R_CRing: (CRing_Ring R_CRing).

Section Field_Structure.

(**
** Field Structure
For the field structure, it is technically easier to first prove
that our ring is actually an integral domain.  The rest then follows
quite straightforwardly.
*)

Lemma R_integral_domain :
 forall x y : R_CRing, x [#] [0] -> y [#] [0] -> x[*]y [#] [0].
Proof.
 intros x y Hx Hy.
 elim Hx; intro Hlt; elim Hlt; intros Nx HN; elim HN; clear Hx Hlt HN;
   intros ex Hex HNx; simpl in HNx; elim Hy; intro Hlt;
     elim Hlt; intros Ny HN; elim HN; clear Hy Hlt HN; intros ey Hey HNy; simpl in HNy.
    right.
    exists (max Nx Ny); exists (ex[*]ey).
     apply mult_resp_pos; auto.
    intros; simpl in |- *; rstepr ([--] (CS_seq _ x n) [*][--] (CS_seq _ y n)).
    apply mult_resp_leEq_both; try (apply less_leEq; assumption).
     astepr ([0][-]CS_seq _ x n); eauto with arith.
    astepr ([0][-]CS_seq _ y n); eauto with arith.
   left.
   exists (max Nx Ny); exists (ex[*]ey).
    apply mult_resp_pos; auto.
   intros; simpl in |- *; rstepr ([--] (CS_seq _ x n) [*]CS_seq _ y n).
   apply mult_resp_leEq_both; try (apply less_leEq; assumption).
    astepr ([0][-]CS_seq _ x n); eauto with arith.
   astepr (CS_seq _ y n[-][0]); eauto with arith.
  left.
  exists (max Nx Ny); exists (ex[*]ey).
   apply mult_resp_pos; auto.
  intros; simpl in |- *; rstepr (CS_seq _ x n[*][--] (CS_seq _ y n)).
  apply mult_resp_leEq_both; try (apply less_leEq; assumption).
   astepr (CS_seq _ x n[-][0]); eauto with arith.
  astepr ([0][-]CS_seq _ y n); eauto with arith.
 right.
 exists (max Nx Ny); exists (ex[*]ey).
  apply mult_resp_pos; auto.
 intros; simpl in |- *; astepr (CS_seq _ x n[*]CS_seq _ y n).
 apply mult_resp_leEq_both; try (apply less_leEq; assumption).
  astepr (CS_seq _ x n[-][0]); eauto with arith.
 astepr (CS_seq _ y n[-][0]); eauto with arith.
Qed.

Definition R_recip : forall x : R_CRing, x [#] [0] -> R_CRing.
 intros x Hx; elim Hx; intro Hlt; elim Hlt; intros N HN; elim HN; clear Hx Hlt HN; intros e He HN.
Proof.
  cut (forall n : nat, N <= n -> e [<=] [--] (CS_seq _ x n)); intros.
   apply (Build_CauchySeq _ _ (CS_seq_inv _ _
     (CS_seq_recip _ _ (CS_seq_inv _ _ (CS_proof _ x)) e He N H))).
  astepr ([0][-]CS_seq _ x n); simpl in HN; auto.
 cut (forall n : nat, N <= n -> e [<=] CS_seq _ x n); intros.
  apply (Build_CauchySeq _ _ (CS_seq_recip _ _ (CS_proof _ x) e He N H)).
 astepr (CS_seq _ x n[-][0]); simpl in HN; auto.
Defined.

Lemma R_recip_inverse : forall x x_, x[*]R_recip x x_ [=] [1].
Proof.
 intros x Hx; elim Hx; intro Hlt; elim Hlt; intros N HN; elim HN;
   clear Hx Hlt HN; simpl in |- *; intros e He HN Hap;
     elim Hap; intro Hlt; elim Hlt; intros K HK; elim HK;
       clear Hap Hlt HK; intros d Hd HM; simpl in HM.
    apply (less_irreflexive_unfolded _ d).
    apply leEq_less_trans with ([0]:F); auto.
    simpl in HM.
    eapply leEq_wdr.
     apply (HM (max K N)); auto with arith.
    unfold CS_seq_recip_seq in |- *; elim lt_le_dec; intro.
     exfalso; apply le_not_lt with N (max K N); auto with arith.
    simpl in |- *; rational.
   apply (less_irreflexive_unfolded _ d).
   apply leEq_less_trans with ([0]:F); auto.
   simpl in HM.
   eapply leEq_wdr.
    apply (HM (max K N)); auto with arith.
   unfold CS_seq_recip_seq in |- *; elim lt_le_dec; intro.
    exfalso; apply le_not_lt with N (max K N); auto with arith.
   simpl in |- *; rational.
  apply (less_irreflexive_unfolded _ d).
  apply leEq_less_trans with ([0]:F); auto.
  simpl in HM.
  eapply leEq_wdr.
   apply (HM (max K N)); auto with arith.
  unfold CS_seq_recip_seq in |- *; elim lt_le_dec; intro.
   exfalso; apply le_not_lt with N (max K N); auto with arith.
  simpl in |- *; rational.
 apply (less_irreflexive_unfolded _ d).
 apply leEq_less_trans with ([0]:F); auto.
 simpl in HM.
 eapply leEq_wdr.
  apply (HM (max K N)); auto with arith.
 unfold CS_seq_recip_seq in |- *; elim lt_le_dec; intro.
  exfalso; apply le_not_lt with N (max K N); auto with arith.
 simpl in |- *; rational.
Qed.

Lemma R_recip_strext : forall x y x_ y_, R_recip x x_ [#] R_recip y y_ -> x [#] y.
Proof.
 intros.
 apply zero_minus_apart.
 apply ap_wdl with (x[*]y[*] (R_recip y y_[-]R_recip x x_)).
  apply R_integral_domain.
   apply R_integral_domain; auto.
  apply minus_ap_zero; apply ap_symmetric_unfolded; auto.
 stepl (y[*]R_recip y y_[*]x[-]x[*]R_recip x x_[*]y). 2: unfold cg_minus; ring.
 stepr ([1][*]x[-][1][*]y). 2: unfold cg_minus; ring.
 apply cg_minus_wd; apply mult_wdl; apply R_recip_inverse.
Qed.

Lemma R_recip_inverse' : forall x x_, R_recip x x_[*]x [=] [1].
Proof.
 intros.
 astepl (x[*]R_recip x x_).
 apply R_recip_inverse.
Qed.

Definition R_CField : CField.
Proof.
 apply Build_CField with R_CRing R_recip.
  split.
   apply R_recip_inverse.
  apply R_recip_inverse'.
 exact R_recip_strext.
Defined.

End Field_Structure.

Section Order.

(**
** Order Structure
Finally, we extend the field structure with the ordering we
defined at the beginning.
*)

Lemma R_lt_strext : Crel_strext R_CSetoid R_lt.
Proof.
 intros x a y b Hxy.
 elim (R_lt_cotrans x y Hxy a); intro H.
  right; left; left; auto.
 elim (R_lt_cotrans a y H b); intro H'.
  left; auto.
 right; right; right; auto.
Qed.

Definition Rlt : CCSetoid_relation R_CField.
Proof.
 apply Build_CCSetoid_relation with R_lt.
 exact R_lt_strext.
Defined.

Lemma Rlt_transitive : Ctransitive Rlt.
Proof.
 intros x y z H H'.
 simpl in H, H'.
 elim H; intros N1 HN1; elim HN1; clear H HN1; intros e1 He1 HN1.
 elim H'; intros N2 HN2; elim HN2; clear H' HN2; intros e2 He2 HN2.
 exists (max N1 N2); exists (e1[+]e2).
  apply plus_resp_pos; auto.
 intros; rstepr (CS_seq _ y n[-]CS_seq _ x n[+] (CS_seq _ z n[-]CS_seq _ y n)).
 apply plus_resp_leEq_both; eauto with arith.
Qed.

Lemma Rlt_strict : strictorder Rlt.
Proof.
 apply Build_strictorder.
  exact Rlt_transitive.
 intros x y H H'.
 apply R_lt_irreflexive with x.
 apply Rlt_transitive with y; auto.
Qed.

Lemma R_plus_resp_lt : forall x y, Rlt x y -> forall z, Rlt (x[+]z) (y[+]z).
Proof.
 intros x y Hxy z.
 elim Hxy; intros N HN; elim HN; clear Hxy HN; intros e He HN; exists N; exists e; auto; intros n Hn.
 simpl in |- *; rstepr (CS_seq _ y n[-]CS_seq _ x n); auto.
Qed.

Lemma R_mult_resp_lt : forall x y, Rlt [0] x -> Rlt [0] y -> Rlt [0] (x[*]y).
Proof.
 intros x y Hx Hy.
 elim Hx; intros Nx HN; elim HN; clear Hx HN; intros ex Hex HNx; simpl in HNx;
   elim Hy; intros Ny HN; elim HN; clear Hy HN; intros ey Hey HNy; simpl in HNy.
 exists (max Nx Ny); exists (ex[*]ey).
  apply mult_resp_pos; auto.
 intros; simpl in |- *; astepr (CS_seq _ x n[*]CS_seq _ y n).
 apply mult_resp_leEq_both; try (apply less_leEq; assumption).
  astepr (CS_seq _ x n[-][0]); eauto with arith.
 astepr (CS_seq _ y n[-][0]); eauto with arith.
Qed.

Definition R_COrdField : COrdField.
Proof.
 apply Build_COrdField with R_CField Rlt (default_leEq _ Rlt) (default_greater _ Rlt) (default_grEq _ (default_leEq _ Rlt)).
 apply Build_is_COrdField; try solve [unfold Iff; tauto].
    exact Rlt_strict.
   exact R_plus_resp_lt.
  exact R_mult_resp_lt.
 split; auto.
Defined.

End Order.

(**
** Other Results
Auxiliary characterizations of the main relations on [R_Set].
*)

Section Auxiliary.

Lemma Rlt_alt_1 : forall x y : R_Set, {e : F | [0] [<] e |
 {N : nat | forall m, N <= m -> e [<=] CS_seq F y m[-]CS_seq F x m}} -> Rlt x y.
Proof.
 intros x y H.
 case H.
 intro e1.
 intros H1 H2.
 case H2.
 intro N1.
 intros H3.
 unfold Rlt in |- *.
 exists N1.
 exists (e1 [/]TwoNZ).
  apply pos_div_two.
  assumption.
 intros.
 apply leEq_transitive with e1.
  apply mult_cancel_leEq with (Two:F).
   apply pos_two.
  rstepl (e1[+] ([0]:F)).
  rstepr (e1[+]e1).
  apply plus_resp_leEq_lft.
  apply less_leEq; assumption.
 apply H3.
 assumption.
Qed.

Lemma Rlt_alt_2 : forall x y : R_Set, Rlt x y -> {e : F | [0] [<] e |
 {N : nat | forall m, N <= m -> e [<=] CS_seq F y m[-]CS_seq F x m}}.
Proof.
 intros x y H.
 unfold Rlt in H.
 case H.
 intros N H2.
 case H2.
 intros e H1 H0.
 exists e.
  assumption.
 exists N.
 auto.
Qed.

Lemma R_ap_alt_1 : forall x y : R_CSetoid, x [#] y -> {e : F | [0] [<] e |
 {N : nat | forall m, N <= m -> AbsBig e (CS_seq F x m[-]CS_seq F y m)}}.
Proof.
 intros x y H.
 case H; intros H0.
  case H0; intros N1 HN1.
  case HN1; intros e1 H2 H31.
  exists e1.
   assumption.
  exists N1.
  split.
   assumption.
  right.
  apply inv_cancel_leEq.
  rstepl e1.
  rstepr (CS_seq F y m[-]CS_seq F x m).
  apply H31.
  assumption.
 case H0; intros N1 HN1.
 case HN1; intros e1 H2 H31.
 exists e1.
  assumption.
 exists N1.
 split; try left; auto.
Qed.

Lemma Eq_alt_1 : forall (x y : R_Set) (e : F), [0] [<] e ->
 Not {N : nat | forall m,   N <= m -> AbsBig (e [/]FourNZ) (CS_seq F x m[-]CS_seq F y m)} ->
 {N : nat | forall m, N <= m -> AbsSmall e (CS_seq F x m[-]CS_seq F y m)}.
Proof.
 intros x y e H.
 set (e2 := e [/]TwoNZ) in *.
 set (e4 := e [/]FourNZ) in *.
 set (e8 := e [/]EightNZ) in *.
 set (e16 := e [/]SixteenNZ) in *.
 assert (He2 : [0] [<] e2).
  unfold e2 in |- *; apply pos_div_two; assumption.
 assert (He4 : [0] [<] e4).
  unfold e4 in |- *; apply pos_div_four; assumption.
 assert (He8 : [0] [<] e8).
  unfold e8 in |- *; apply pos_div_eight; assumption.
 assert (He16 : [0] [<] e16).
  unfold e16 in |- *; apply pos_div_sixteen; assumption.
 case x; intros x_ px.
 case y; intros y_ py.
 unfold CS_seq in |- *; intro.
 case (px e16 He16); intros N1 px2.
 case (py e16 He16); intros N2 py2.
 set (NN := max N1 N2) in *.
 assert (N1_NN : N1 <= NN).
  unfold NN in |- *; auto with arith.
 assert (N2_NN : N2 <= NN).
  unfold NN in |- *; auto with arith.
 exists NN.
 cut (forall m : nat, Not (NN <= m and AbsBig e2 (x_ m[-]y_ m))).
  intros.
  unfold AbsSmall in |- *.
  assert (H3 : Not (AbsBig e2 (x_ m[-]y_ m))).
   intro; elim (H1 m); split; assumption.
  assert (H4 : ~ e2 [<=] x_ m[-]y_ m).
   intro; apply H3; split; try left; assumption.
  assert (H5 : ~ x_ m[-]y_ m [<=] [--]e2).
   intro; apply H3; split; try right; assumption.
  split; rewrite -> leEq_def; intro.
   apply H5.
   apply leEq_transitive with ([--]e).
    apply less_leEq; assumption.
   apply less_leEq; apply inv_resp_less.
   unfold e2 in |- *; apply pos_div_two'; assumption.
  apply H4.
  apply leEq_transitive with e.
   apply less_leEq; unfold e2 in |- *; apply pos_div_two'; auto.
  apply less_leEq; assumption.
 intro.
 intro H1.
 elim H1; intros X Y.
 elim H0.
 exists NN.
 intros.
 apply AbsBig_wdl with (e2[-]e8[-]e8).
  2: unfold e2, e4, e8 in |- *; rational.
 apply AbsBig_wdr with (x_ m[-]y_ m[-] (x_ m[-]x_ m0) [-] (y_ m0[-]y_ m)).
  2: rational.
 assert (e8 [<] e2).
  unfold e2, e8 in |- *.
  rstepl ((e [/]TwoNZ) [/]FourNZ).
  rstepr (e [/]TwoNZ).
  apply pos_div_four'.
  assumption.
 assert ([0] [<] e2[-]e8).
  apply plus_cancel_less with e8.
  rstepl e8.
  rstepr e2.
  assumption.
 assert (e8 [<] e2[-]e8).
  apply plus_cancel_less with e8.
  rstepr e2.
  unfold e2, e8 in |- *; rstepl (e [/]FourNZ).
  rstepl ((e [/]TwoNZ) [/]TwoNZ).
  apply pos_div_two'.
  assumption.
 apply AbsBigSmall_minus; auto.
  apply AbsBigSmall_minus; auto.
  unfold e8 in |- *.
  rstepl (e [/]SixteenNZ[+]e [/]SixteenNZ).
  rstepr (x_ m[-]x_ N1[+] (x_ N1[-]x_ m0)).
  apply AbsSmall_plus.
   apply px2.
   apply le_trans with NN; assumption.
  apply AbsSmall_minus.
  apply px2.
  apply le_trans with NN; assumption.
 unfold e8 in |- *.
 rstepl (e [/]SixteenNZ[+]e [/]SixteenNZ).
 rstepr (y_ m0[-]y_ N2[+] (y_ N2[-]y_ m)).
 apply AbsSmall_plus.
  apply py2.
  apply le_trans with NN; assumption.
 apply AbsSmall_minus.
 apply py2.
 apply le_trans with NN; assumption.
Qed.

Lemma R_ap_alt_2 : forall x y : R_CSetoid, {e : F | [0] [<] e |
 {N : nat | forall m, N <= m -> AbsBig e (CS_seq F x m[-]CS_seq F y m)}} -> x [#] y.
Proof.
 intros x y H.
 case H.
 intros e H0.
 set (e2 := e [/]TwoNZ) in *.
 set (e4 := e [/]FourNZ) in *.
 set (e8 := e [/]EightNZ) in *.
 set (e16 := e [/]SixteenNZ) in *.
 assert (He2 : [0] [<] e2).
  unfold e2 in |- *; apply pos_div_two; assumption.
 assert (He4 : [0] [<] e4).
  unfold e4 in |- *; apply pos_div_four; assumption.
 assert (He8 : [0] [<] e8).
  unfold e8 in |- *; apply pos_div_eight; assumption.
 assert (He16 : [0] [<] e16).
  unfold e16 in |- *; apply pos_div_sixteen; assumption.
 case x; intros x_ px.
 case y; intros y_ py.
 case (px e16 He16); intros N1 H31.
 case (py e16 He16); intros N2 H41.
 simpl in |- *; intro H2; case H2; intros N H21.
 set (NN := max N (max N1 N2)) in *.
 assert (N_NN : N <= NN).
  unfold NN in |- *; auto with arith.
 assert (N1_NN : N1 <= NN).
  unfold NN in |- *; apply le_trans with (max N1 N2); auto with arith.
 assert (N2_NN : N2 <= NN).
  unfold NN in |- *; apply le_trans with (max N1 N2); auto with arith.
 set (x0 := x_ NN) in *.
 set (y0 := y_ NN) in *.
 simpl in |- *.
 unfold R_ap in |- *.
 unfold R_lt in |- *.
 simpl in |- *.
 assert (H5 : AbsBig e2 (x0[-]y0)).
  assert (e2 [<=] e).
   unfold e2 in |- *; apply less_leEq; apply pos_div_two'; auto.
  split; auto.
  elim (H21 NN).
   intros H' Haux; elim Haux; intros; [ left | right ].
    apply leEq_transitive with e; auto.
   apply leEq_transitive with ([--]e); auto; apply inv_resp_leEq; auto.
  unfold NN in |- *; auto with arith.
 case H5; intros Hx s; case s; intro H6.
  right.
  exists NN.
  exists e4.
   assumption.
  intro m; intros.
  astepl ([--]e8[+]e2[+][--]e8).
   2: unfold e2, e8, e4 in |- *; rational.
  rstepr (x_ m[-]x0[+] (x0[-]y0) [+] (y0[-]y_ m)).
  apply plus_resp_leEq_both.
   apply plus_resp_leEq_both.
    astepl ([--]e16[+][--]e16).
     2: unfold e16, e8 in |- *; rational.
    rstepr (x_ m[-]x_ N1[+] (x_ N1[-]x0)).
    apply plus_resp_leEq_both.
     assert (H7 : AbsSmall e16 (x_ m[-]x_ N1)).
      apply H31; apply le_trans with NN; auto.
     elim H7; intros.
     rstepl ([--]e16).
     assumption.
    assert (H7 : AbsSmall e16 (x_ N1[-]x0)).
     apply AbsSmall_minus.
     unfold x0 in |- *; auto.
    elim H7; intros.
    rstepl ([--]e16).
    assumption.
   (* e *)
   assumption.
  (* e *)
  astepl ([--]e16[+][--]e16).
   2: unfold e16, e8 in |- *; rational.
  rstepr (y0[-]y_ N2[+] (y_ N2[-]y_ m)).
  apply plus_resp_leEq_both.
   assert (H7 : AbsSmall e16 (y0[-]y_ N2)).
    unfold y0 in |- *; auto.
   elim H7; intros.
   rstepl ([--]e16).
   assumption.
  assert (H7 : AbsSmall e16 (y_ N2[-]y_ m)).
   apply AbsSmall_minus.
   apply H41.
   apply le_trans with NN; auto.
  elim H7; intros.
  rstepl ([--]e16).
  assumption.
 left.
 exists NN.
 exists e4.
  assumption.
 intro m; intros.
 astepl ([--]e8[+]e2[+][--]e8).
  2: unfold e8, e2, e4 in |- *; rational.
 rstepr (y_ m[-]y0[+] (y0[-]x0) [+] (x0[-]x_ m)).
 apply plus_resp_leEq_both.
  apply plus_resp_leEq_both.
   astepl ([--]e16[+][--]e16).
    2: unfold e16, e8 in |- *; rational.
   rstepr (y_ m[-]y_ N2[+] (y_ N2[-]y0)).
   apply plus_resp_leEq_both.
    assert (H8 : AbsSmall e16 (y_ m[-]y_ N2)).
     apply H41.
     apply le_trans with NN; auto.
    elim H8; intros.
    rstepl ([--]e16).
    assumption.
   assert (H8 : AbsSmall e16 (y_ N2[-]y0)).
    apply AbsSmall_minus.
    unfold y0 in |- *; auto.
   elim H8; intros.
   rstepl ([--]e16).
   assumption.
  (* e *)
  apply inv_cancel_leEq.
  rstepl (x0[-]y0).
  assumption.
 (* e *)
 astepl ([--]e16[+][--]e16).
  2: unfold e16, e8 in |- *; rational.
 rstepr (x0[-]x_ N1[+] (x_ N1[-]x_ m)).
 apply plus_resp_leEq_both.
  assert (H8 : AbsSmall e16 (x0[-]x_ N1)).
   unfold x0 in |- *; auto.
  elim H8; intros.
  rstepl ([--]e16).
  assumption.
 assert (H8 : AbsSmall e16 (x_ N1[-]x_ m)).
  apply AbsSmall_minus.
  apply H31.
  apply le_trans with NN; auto.
 elim H8; intros.
 rstepl ([--]e16).
 assumption.
Qed.

Lemma Eq_alt_2_1 : forall x y : R_Set, Not (R_ap x y) -> forall e : F, [0] [<] e ->
 {N : nat | forall m, N <= m -> AbsSmall e (CS_seq F x m[-]CS_seq F y m)}.
Proof.
 intros.
 apply Eq_alt_1.
  assumption.
 intro.
 apply H.
 apply R_ap_alt_2.
 exists (e [/]FourNZ).
  apply pos_div_four; auto.
 assumption.
Qed.

Lemma Eq_alt_2_2 : forall x y : R_Set, (forall e : F, [0] [<] e ->
 {N : nat | forall m, N <= m -> AbsSmall e (CS_seq F x m[-]CS_seq F y m)}) -> Not (R_ap x y).
Proof.
 intros x y.
 case x; intros x_ px.
 case y; intros y_ py.
 simpl in |- *.
 intros H. intro H0.
 assert (H1 : {e : F | [0] [<] e |
   {N : nat | forall m : nat, N <= m -> AbsBig (Two[*]e) (x_ m[-]y_ m)}}).
  elim (R_ap_alt_1 _ _ H0).
  intros e H1 H2.
  exists (e [/]TwoNZ).
   apply pos_div_two; assumption.
  elim H2; intros N HN.
  exists N. intros.
  apply AbsBig_wdl with e; [ auto | rational ].
 case H1.
 intros e H2 H3.
 case H3; intros N1 A.
 case (H e H2); intros N2 B.
 set (NN := max N1 N2) in *.
 assert (N1_NN : N1 <= NN).
  unfold NN in |- *; auto with arith.
 assert (N2_NN : N2 <= NN).
  unfold NN in |- *; auto with arith.
 assert (H4 := A NN N1_NN).
 assert (H5 := B NN N2_NN).
 unfold AbsSmall in H5.
 rewrite -> leEq_def in H5.
 elim H5; intros.
 elim H4; intros.
 elim b; intros.
  rewrite ->  leEq_def in H7; apply H7.
  apply less_leEq_trans with (Two[*]e).
   astepl ([0][+]e).  rstepr (e[+]e).
   apply plus_resp_less_rht; auto.
  assumption.
 apply H6.
 apply leEq_less_trans with ([--] (Two[*]e)).
  auto.
 apply inv_resp_less.
 astepl ([0][+]e); rstepr (e[+]e).
 apply plus_resp_less_rht; auto.
Qed.

End Auxiliary.

End Structure.


(*
Inductive TreeFamItrp (G:Ctx) : treeFam->(G->Typ)->Type :=
	tfItrpUv : TreeFamItrp G Uv (fun g=>typUv) |
	tfItrpEl p p' : TreeParamItrp G p (fun g=>typUv) p'->
		TreeFamItrp G (El p) (fun g=>typEl (p' g)) |
	tfItrpPi A B A' B' : TreeFamItrp G A A'->TreeFamItrp (extCtx G A') B B'->
		TreeFamItrp G (Pi A B) (fun g=>typPi (A' g) (fun a=>B' (existT A' g a)))
with TreeParamItrp (G:Ctx) : treeParam->forall T:G->Typ,(forall g,T g)->Type :=
	tpItrpVar i T (i':AtCtx G i T) : TreeParamItrp G (var i) T (ctxProj i') |
	tpItrpApl f a B P (a':AtCtx G a P) B' f' :
		TreeFamItrp (extCtx G P) B B'->
		TreeParamItrp G f (fun g=>typPi (P g) (fun p=>B' (existT P g p))) f'->
		TreeParamItrp G (apl f a B) (fun g=>B' (existT P g (ctxProj a' g))) (fun g=>f' g (ctxProj a' g)).
*)

Inductive TFItrpEl (G:Ctx) (R:forall G (T:_->Typ),(forall g,T g)->Type) : (G->Typ)->Type :=
	tfItrpEl p' : R G (fun g=>typUv) p'->
		TFItrpEl G R (fun g=>typEl (p' g)).
Implicit Arguments tfItrpEl [G R p'].

Inductive TFItrpPi (G:Ctx) (RA RB:forall G:Ctx,(G->Typ)->Type) : (G->Typ)->Type :=
	tfItrpPi A' B' : RA G A'->RB (extCtx G A') B'->
		TFItrpPi G RA RB (fun g=>typPi (A' g) (fun a=>B' (existT A' g a))).
Implicit Arguments tfItrpPi [G RA RB A' B'].

Inductive TPItrpVar (G:Ctx) i : forall T:G->Typ,(forall g,T g)->Type :=
	tpItrpVar T (i':AtCtx G i T) : TPItrpVar G i T (ctxProj i').
Implicit Arguments tpItrpVar [G i T].

Inductive TPItrpApl (G:Ctx) (Rf:forall G (T:_->Typ),(forall g,T g)->Type) a (RB:forall G:Ctx,(G->Typ)->Type) :
forall T:G->Typ,(forall g,T g)->Type :=
	tpItrpApl P (a':AtCtx G a P) B' f' :
		RB (extCtx G P) B'->
		Rf G (fun g=>typPi (P g) (fun p=>B' (existT P g p))) f'->
		TPItrpApl G Rf a RB (fun g=>B' (existT P g (ctxProj a' g))) (fun g=>f' g (ctxProj a' g)).
Implicit Arguments tpItrpApl [Rf a RB P B' f'].

Fixpoint TreeFamItrp (G:Ctx) F : (G->Typ)->Type := match F with
	Uv => eq (fun g=>typUv) |
	El p => TFItrpEl G (fun G=>TreeParamItrp G p) |
	Pi A B => TFItrpPi G (fun G=>TreeFamItrp G A) (fun G=>TreeFamItrp G B)
end
with TreeParamItrp G p : forall T,_->Type := match p with
	var i => TPItrpVar G i |
	apl f a B => TPItrpApl G (fun G=>TreeParamItrp G f) a (fun G=>TreeFamItrp G B)
end.

----------

Lemma tpItrpBump G n l p GL P (xg:ExtCtx GL l G) : forall T p',TreeParamItrp G (pBump n l p) T p'->
TreeParamItrp (ctxBump P xg) (pBump (S n) l p) (elBump P xg T) (elBump P xg p').
	(*induction la;simpl.

	intros.
	apply spItrpNilInv with (1 := X).
	apply spItrpNil.

	intros ? ?.
	destruct (lt_dec a l) as [Ho | Ho].
		rewrite (proj1 (nat_compare_lt _ _) Ho).
		intro.
		apply spItrpConsInv with (1 := X).
		clear T la' X.
		intros.
		pose proof (spItrpCons _ _ _ _ _ _ (atBumpGLo P xg a' Ho)
			(fun d g=>B d (existT _ (xc_f' (xgBumpG P xg) d (projT1 g)) (projT2 g)))
			_ (IHla _ _ X)).
		simpl in X0.
		rewrite ctxProj_BumpGLo in X0.
		exact X0.

		assert (nolt : forall k,k = match nat_compare a l with
			Lt => a |
			_ => k
		end).
			intro.
			destruct (nat_compare_spec a l);try reflexivity.
			destruct (Ho H).
		rewrite <- nolt.
		rewrite <- nolt.
		clear nolt.
		intro.
		apply spItrpConsInv with (1 := X).
		clear T la' X.
		intros.
		assert (l <= n + a).
			rewrite <- plus_comm.
			apply le_plus_trans.
			exact (not_lt _ _ Ho).
		pose proof (spItrpCons _ _ _ _ _ _ (atBumpGHi P xg a' H)
			(fun d g=>B d (existT _ (xc_f' (xgBumpG P xg) d (projT1 g)) (projT2 g)))
			_ (IHla _ _ X)).
		simpl in X0.
		rewrite ctxProj_BumpGHi in X0.
		exact X0.
Qed.*)
Admitted.

Lemma tpItrpBump_O G n p T p' P : TreeParamItrp G (pBump n O p) T p'->
TreeParamItrp (extCtx G P) (pBump (S n) O p) (fun g=>T (projT1 g)) (fun g=>p' (projT1 g)).
	apply tpItrpBump with (P := P) (xg := extOCtx G).
Qed.

Lemma tfItrpBump n F GL P : forall G l F' (xg:ExtCtx GL l G),TreeFamItrp G (fBump n l F) F'->
TreeFamItrp (ctxBump P xg) (fBump (S n) l F) (elBump P xg F').
	(*induction F as [| p];[| destruct p as (f,la)];simpl;intros.

	rewrite sfItrpNilInv with (1 := X).
	apply sfItrpNil.

	apply sfItrpConsInv with (1 := X).
	clear F' X.
	intros B ? ? F'.
	pose (A d g := la' d g (tctxProj f' d)).
	change (forall d,extCtx G A d->Type) in F'.
	pose (F_ d g := forall p,F' d (existT _ g p)).
	change (SimpParamItrp G B (laBumpG n l la) (fun d g=>Type) la'->
		SimpFamItrp D (extCtx G A) (fBumpG n (S l) F) F'->
		SimpFamItrp D (ctxBumpG P xg) ((f,laBumpG (S n) l la) :: fBumpG (S n) (S l) F) (elBumpG P xg F_)).
	intros Xp Xf.
	apply sfItrpCons with (la' := elBumpG P xg la') (2 := IHF _ _ _ (extSCtx xg _) Xf).
	apply spItrpBumpG with (1 := Xp) (xg := xg).
Qed.*)
Admitted.

Lemma tfItrpBump_O G n F F' P : TreeFamItrp G (fBump n O F) F'->
TreeFamItrp (extCtx G P) (fBump (S n) O F) (fun g=>F' (projT1 g)).
	apply tfItrpBump with (P := P) (xg := extOCtx G).
Qed.

Lemma tpItrpSubst G p l b GL P (xg:ExtCtx (extCtx GL P) l G) (b':AtCtx GL b P) : forall T p',
	TreeParamItrp G p T p'->
TreeParamItrp (ctxSubst xg (ctxProj b')) (pSubst l b p)
(elSubst xg T (ctxProj b')) (elSubst xg p' (ctxProj b')).
	(*induction la;intros ? ?;simpl.

	intro.
	apply spItrpNilInv with (1 := X).
	apply spItrpNil.

	destruct (lt_eq_lt_dec a l) as [s | Ho];[destruct s as [Ho | Ho] |].
		intro.
		rewrite (proj1 (nat_compare_lt _ _) Ho).
		apply spItrpConsInv with (1 := X).
		clear T la' X.
		intros.
		pose proof (spItrpCons _ _ _ _ _ _ (atSubstLt xg a' Ho (ctxProj b'))
			(fun d g=>B d (existT _ (xc_f' (xgSubst xg (ctxProj b')) d (projT1 g)) (projT2 g)))
			_ (IHla _ _ X)).
		simpl in X0.
		rewrite ctxProj_SubstLt in X0.
		exact X0.

		intro.
		rewrite (proj2 (nat_compare_eq_iff _ _) Ho).
		revert xg IHla.
		apply (tr (fun _=>_) Ho).
		clear l Ho.
		intros.
		apply spItrpConsInv with (1 := X).
		clear T la' X.
		intros.
		pose (b0 := tr (AtCtx G _) (atCtxExtTEq b' xg a') (ax_a (atCtxExt xg (popCtx b' P)))).
		assert (Ha : a + S b = S (a + b)).
			rewrite <- plus_n_Sm.
			reflexivity.
		pose (b1 := tr (fun n=>AtCtx G n P0) Ha b0).
		simpl in b1.
		assert (Hb : a <= a + b).
			apply le_plus_l.
		pose proof (spItrpCons _ _ _ _ _ _ (atSubstGt xg b1 Hb (ctxProj b'))
			(fun d g=>B d (existT _ (xc_f' (xgSubst xg (ctxProj b')) d (projT1 g)) (projT2 g)))
			_ (IHla _ _ X)).
		simpl in X0.
		rewrite ctxProj_SubstGt in X0.
		subst b1.
		rewrite <- Ha in X0.
		simpl in X0.
		clear Ha Hb.
		subst b0.
		rewrite ctxProj_Ext in X0.
		rewrite ctxProj_SubstEq in X0.
		exact X0.

		rewrite (proj1 (nat_compare_gt _ _) Ho).
		destruct a.
			exact (match lt_n_O _ Ho with end).
		unfold lt in Ho.
		intro.
		simpl.
		apply spItrpConsInv with (1 := X).
		clear T la' X.
		intros.
		pose proof (le_S_n _ _ Ho).
		pose proof (spItrpCons _ _ _ _ _ _ (atSubstGt xg a' H (ctxProj b'))
			(fun d g=>B d (existT _ (xc_f' (xgSubst xg (ctxProj b')) d (projT1 g)) (projT2 g)))
			_ (IHla _ _ X)).
		simpl in X0.
		rewrite ctxProj_SubstGt in X0.
		exact X0.
Qed.*)
Admitted.

Lemma tpItrpSubst_O G P p b T p' (b':AtCtx G b P) : TreeParamItrp (extCtx G P) p T p'->
TreeParamItrp G (pSubst O b p) _ (fun g=>p' (existT _ g (ctxProj b' g))).
	apply tpItrpSubst with (xg := extOCtx (extCtx G P)) (b' := b').
Qed.

Lemma tfItrpSubst F b GL P (b':AtCtx GL b P) : forall G l F' (xg:ExtCtx (extCtx GL P) l G),TreeFamItrp G F F'->
TreeFamItrp (ctxSubst xg (ctxProj b')) (fSubst l b F) (elSubst xg F' (ctxProj b')).
	(*induction F as [| p];[| destruct p as (f,la)];simpl;intros.

	rewrite sfItrpNilInv with (1 := X).
	apply sfItrpNil.

	apply sfItrpConsInv with (1 := X).
	clear F' X.
	intros B ? ? F'.
	pose (A d g := la' d g (tctxProj f' d)).
	change (forall d,extCtx G A d->Type) in F'.
	pose (F_ d g := forall p,F' d (existT _ g p)).
	change (SimpParamItrp G B la (fun d g=>Type) la'->
		SimpFamItrp D (extCtx G A) F F'->
		SimpFamItrp D (ctxSubst xg (ctxProj b')) ((f,laSubstG la l b) :: fSubstG F (S l) b)
			(elSubst xg F_ (ctxProj b'))).
	intros Xp Xf.
	apply sfItrpCons with (la' := elSubst xg la' (ctxProj b')) (2 := IHF _ _ _ (extSCtx xg _) Xf).
	apply spItrpSubst with (1 := Xp) (xg := xg).
Qed.*)
Admitted.

Lemma tfItrpSubst_O G P F b F' (b':AtCtx G b P) : TreeFamItrp (extCtx G P) F F'->
TreeFamItrp G (fSubst O b F) (fun g=>F' (existT _ g (ctxProj b' g))).
	apply tfItrpSubst with (xg := extOCtx (extCtx G P)) (b' := b').
Qed.

Lemma tcItrpProj i C : forall G G',(ltd i (length G))->TreeCtxItrp G G'->
	(forall F,AtCtx G' i F->TreeFamItrp G' (fBump (S i) O (nth i G Uv)) F->C)->
C.
	induction i;intros ? ?;(destruct G as [| F];intro;[destruct H |]);simpl;intro;
	destruct X;intro rtn.

	apply (rtn _ (topCtx G' F')).
	apply tfItrpBump_O.
	rewrite fBump_O.
	exact t0.

	apply (IHi _ _ H t).
	intros.
	apply (rtn _ (popCtx X F')).
	apply tfItrpBump_O.
	exact X0.
Qed.

Inductive ExTreeParamItrp G p T : Type :=
	exTreeParamItrp T' p' : TreeParamItrp G p T' p'->TreeFamItrp G T T'->ExTreeParamItrp G p T.
Implicit Arguments exTreeParamItrp [G p T].

Lemma tfItrpTotalNest G F C : TreeFamGood
	(fun G p T=>forall G',TreeCtxItrp G G'->ExTreeParamItrp G' p T) G F->
forall G',TreeCtxItrp G G'->
	(forall F',TreeFamItrp G' F F'->C)->
C.
	intro.
	induction X;intros ? XG rtn.

	apply (rtn (fun g=>typUv)).
	reflexivity.

	destruct (p0 _ XG) as (?,?,Xp,XU).
	simpl in XU.
	revert p' Xp.
	rewrite <- XU.
	clear T' XU.
	intros.
	apply (rtn (fun g=>typEl (p' g))).
	simpl.
	exact (tfItrpEl Xp).

	clear X1 X2.
	apply (IHX1 _ XG).
	intros A' XA.
	apply (IHX2 (extCtx G' A')).
		simpl.
		exact (tcItrpCons XG XA).
	intros B' XB.
	apply (rtn (fun g=>typPi (A' g) (fun a=>B' (existT _ g a)))).
	simpl.
	exact (tfItrpPi XA XB).
Qed.

Lemma tpItrpTotal G p T : TreeParamGood G p T->forall G',TreeCtxItrp G G'->ExTreeParamItrp G' p T.
	intro.
	induction H;intros ? XG.

	apply tcItrpProj with (i := i) (2 := XG).
		unfold ltd.
		rewrite (proj1 (nat_compare_lt _ _) H).
		exact I.
	intros T i' XT.
	apply (exTreeParamItrp T (ctxProj i')).
		apply tpItrpVar.

		exact XT.

	apply tcItrpProj with (i := a) (2 := XG).
		unfold ltd.
		rewrite (proj1 (nat_compare_lt _ _) H).
		exact I.
	intros P a' XP.
	destruct (IHTreeParamGood _ XG) as (T,f',Xf,XT).
	simpl in XT.
	revert f' Xf.
	destruct XT as (P0,B'0,XP0,XB0).
	simpl.
	intros.
	apply tfItrpTotalNest with (1 := X) (G' := extCtx G' P).
		simpl.
		exact (tcItrpCons XG XP).
	clear X.
	intros B' XB.
	(* Aaaaaand we're screwed *)
	apply (exSimpParamItrp (fun g=>B' (existT _ g (ctxProj a' g))) (fun g f=>la'
		apply spItrpCons with (a' := a') (1 := Xp).

		apply sfItrpSubst_O with (1 := Xf).
Qed.


Require Import lib.

Class Size (A : Type) := size : A -> nat.

Ltac gen_Size :=
hnf; match goal with [ |- ?A -> nat] =>
fix size' 1; intros s;
assert(size_inst : Size A);[exact size' | idtac];
destruct s eqn:E;
let term := type of s in
match goal with
    [E : s = ?s' |- _] =>
    let rec map s :=
        (match s with
             ?s1 ?s2 =>
             let size_s1 := map s1 in
             let s2_T := type of s2 in
             let size_s2 := match s2_T with
                         | A => constr:(size' s2)
                         | _ => constr:(size s2)
                       end in
             constr:(size_s1 + size_s2)
           | _ => constr:(O) end) in
    let t' := map s' in
    let t'' := eval simpl plus in t' in
    exact (S t'')
end
end.

Require Import Omega.

Lemma size_rec {A : Type} f (x : A) : forall P : A -> Type, (forall x, (forall y, f y < f x -> P y) -> P x) -> P x.
Proof.
  intros P IS. cut (forall n x, f x <= n -> P x). { eauto. }
  intros n. induction n; intros; apply IS; intros.
  - omega.
  - apply IHn. omega.
Defined.

Tactic Notation "sinduction" ident(H) "using" open_constr(f) :=
let T := typeof H in
autorevert H; induction H using (@size_rec _ f);
match goal with [H : T |- _] => destruct H end.

Ltac sind H :=
let IH := fresh "IH" in
let x := fresh "x" in
induction H as [x IH] using (@size_rec _ size); try rename x into H.

Instance def_size (A : Type) : Size A | 100 := (fun x => O).

Instance size_list (A : Type) (size_A : Size A) : Size (list A). gen_Size. Show Proof. Defined.

Instance size_nat : Size nat := id.

Inductive foo := Foo1 | Foo2 (_ : list foo) (_ : nat).

Instance size_foo : Size foo. gen_Size. Set Printing Implicit. Show Proof. Defined.

Ltac sizesimpl := repeat(unfold size in *; unfold def_size in *; simpl in *).

Tactic Notation "somega" := sizesimpl; omega.

(*
Ltac elim_term :=
let rec elim2 x t :=
    match t with
      | ?t1 +' x => repeat rewrite pplus_assoc
      | ?t1 +' ?t2 =>
        refine(eq_ind_r (fun p : pnat => _ <=' _ +' p) _ (pplus_comm _ _));
        refine(eq_ind_r (fun p : pnat => _ <=' p) _ (pplus_assoc _ _ _));
        elim2 x t1
      | x => idtac
    end
in let elim1 x t :=
    match t with
      | ?t1 +' x => idtac
      | ?t1 +' ?t2 =>
        refine(eq_ind_r (fun p : pnat => _ <=' p) _ (pplus_comm _ _));
          elim2 x t1
      | _ => idtac
    end
in
  match goal with
    | [ |- ?s +' ?x <=' ?t ] => elim1 x t; apply pleq_plus
    | [ |- ?x <=' ?t ] => elim1 x t; apply pleq_plus_r
  end.

Ltac solve_pleq :=
  intros;
  repeat match goal with [H : ?x <=' ?y |- _] => destruct H end;
  autorew;
  autorewrite with pplus;
  repeat apply pleq_S;
  repeat apply pleq_S_r;
  try apply pleq_zero;
  repeat elim_term.
*)
(*
Inductive ord : Prop :=
C (A : Type) : (A -> ord) -> ord.
*)


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
Set Implicit Arguments.

Section PACO2.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.

(** ** Signatures *)

Record sig2T  :=
  exist2T {
      proj2T0: @T0;
      proj2T1: @T1 proj2T0;
    }.
Definition uncurry2  (R: rel2 T0 T1): rel1 sig2T :=
  fun x => R (proj2T0 x) (proj2T1 x).
Definition curry2  (R: rel1 sig2T): rel2 T0 T1 :=
  fun x0 x1 => R (@exist2T x0 x1).

Lemma uncurry_map2 r0 r1 (LE : r0 <2== r1) : uncurry2 r0 <1== uncurry2 r1.
Proof. intros [] H. apply LE. apply H. Qed.

Lemma uncurry_map_rev2 r0 r1 (LE: uncurry2 r0 <1== uncurry2 r1) : r0 <2== r1.
Proof.
  red; intros. apply (LE (@exist2T x0 x1) PR).
Qed.

Lemma curry_map2 r0 r1 (LE: r0 <1== r1) : curry2 r0 <2== curry2 r1.
Proof.
  red; intros. apply (LE (@exist2T x0 x1) PR).
Qed.

Lemma curry_map_rev2 r0 r1 (LE: curry2 r0 <2== curry2 r1) : r0 <1== r1.
Proof.
  intros [] H. apply LE. apply H.
Qed.

Lemma uncurry_bij1_2 r : curry2 (uncurry2 r) <2== r.
Proof. unfold le2. intros. apply PR. Qed.

Lemma uncurry_bij2_2 r : r <2== curry2 (uncurry2 r).
Proof. unfold le2. intros. apply PR. Qed.

Lemma curry_bij1_2 r : uncurry2 (curry2 r) <1== r.
Proof. intros [] H. apply H. Qed.

Lemma curry_bij2_2 r : r <1== uncurry2 (curry2 r).
Proof. intros [] H. apply H. Qed.

Lemma uncurry_adjoint1_2 r0 r1 (LE: uncurry2 r0 <1== r1) : r0 <2== curry2 r1.
Proof.
  apply uncurry_map_rev2. eapply le1_trans; [apply LE|]. apply curry_bij2_2.
Qed.

Lemma uncurry_adjoint2_2 r0 r1 (LE: r0 <2== curry2 r1) : uncurry2 r0 <1== r1.
Proof.
  apply curry_map_rev2. eapply le2_trans; [|apply LE]. apply uncurry_bij2_2.
Qed.

Lemma curry_adjoint1_2 r0 r1 (LE: curry2 r0 <2== r1) : r0 <1== uncurry2 r1.
Proof.
  apply curry_map_rev2. eapply le2_trans; [apply LE|]. apply uncurry_bij2_2.
Qed.

Lemma curry_adjoint2_2 r0 r1 (LE: r0 <1== uncurry2 r1) : curry2 r0 <2== r1.
Proof.
  apply uncurry_map_rev2. eapply le1_trans; [|apply LE]. apply curry_bij1_2.
Qed.

(** ** Predicates of Arity 2
*)

Definition paco2(gf : rel2 T0 T1 -> rel2 T0 T1)(r: rel2 T0 T1) : rel2 T0 T1 :=
  curry2 (paco (fun R0 => uncurry2 (gf (curry2 R0))) (uncurry2 r)).

Definition upaco2(gf : rel2 T0 T1 -> rel2 T0 T1)(r: rel2 T0 T1) := paco2 gf r \2/ r.
Arguments paco2 : clear implicits.
Arguments upaco2 : clear implicits.
Hint Unfold upaco2.

Definition monotone2 (gf: rel2 T0 T1 -> rel2 T0 T1) :=
  forall x0 x1 r r' (IN: gf r x0 x1) (LE: r <2= r'), gf r' x0 x1.

Definition _monotone2 (gf: rel2 T0 T1 -> rel2 T0 T1) :=
  forall r r'(LE: r <2= r'), gf r <2== gf r'.

Lemma monotone2_eq (gf: rel2 T0 T1 -> rel2 T0 T1) :
  monotone2 gf <-> _monotone2 gf.
Proof. unfold monotone2, _monotone2, le2. split; intros; eapply H; eassumption. Qed.

Lemma monotone2_map (gf: rel2 T0 T1 -> rel2 T0 T1)
      (MON: _monotone2 gf) :
  _monotone (fun R0 => uncurry2 (gf (curry2 R0))).
Proof.
  red; intros. apply uncurry_map2. apply MON; apply curry_map2; assumption.
Qed.

Lemma monotone2_compose (gf gf': rel2 T0 T1 -> rel2 T0 T1)
      (MON1: monotone2 gf)
      (MON2: monotone2 gf'):
  monotone2 (compose gf gf').
Proof.
  red; intros. eapply MON1. apply IN.
  intros. eapply MON2. apply PR. apply LE.
Qed.

Lemma monotone2_union (gf gf': rel2 T0 T1 -> rel2 T0 T1)
      (MON1: monotone2 gf)
      (MON2: monotone2 gf'):
  monotone2 (gf \3/ gf').
Proof.
  red; intros. destruct IN.
  - left. eapply MON1. apply H. apply LE.
  - right. eapply MON2. apply H. apply LE.
Qed.

Lemma _paco2_mon_gen (gf gf': rel2 T0 T1 -> rel2 T0 T1) r r'
    (LEgf: gf <3= gf')
    (LEr: r <2= r'):
  paco2 gf r <2== paco2 gf' r'.
Proof.
  apply curry_map2. red; intros. eapply paco_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma paco2_mon_gen (gf gf': rel2 T0 T1 -> rel2 T0 T1) r r' x0 x1
    (REL: paco2 gf r x0 x1)
    (LEgf: gf <3= gf')
    (LEr: r <2= r'):
  paco2 gf' r' x0 x1.
Proof.
  eapply _paco2_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma paco2_mon_bot (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1
    (REL: paco2 gf bot2 x0 x1)
    (LEgf: gf <3= gf'):
  paco2 gf' r' x0 x1.
Proof.
  eapply paco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upaco2_mon_gen (gf gf': rel2 T0 T1 -> rel2 T0 T1) r r' x0 x1
    (REL: upaco2 gf r x0 x1)
    (LEgf: gf <3= gf')
    (LEr: r <2= r'):
  upaco2 gf' r' x0 x1.
Proof.
  destruct REL.
  - left. eapply paco2_mon_gen; [apply H | apply LEgf | apply LEr].
  - right. apply LEr, H.
Qed.

Lemma upaco2_mon_bot (gf gf': rel2 T0 T1 -> rel2 T0 T1) r' x0 x1
    (REL: upaco2 gf bot2 x0 x1)
    (LEgf: gf <3= gf'):
  upaco2 gf' r' x0 x1.
Proof.
  eapply upaco2_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Section Arg2.

Variable gf : rel2 T0 T1 -> rel2 T0 T1.
Arguments gf : clear implicits.

Theorem _paco2_mon: _monotone2 (paco2 gf).
Proof.
  red; intros. eapply curry_map2, _paco_mon; apply uncurry_map2; assumption.
Qed.

Theorem _paco2_acc: forall
  l r (OBG: forall rr (INC: r <2== rr) (CIH: l <2== rr), l <2== paco2 gf rr),
  l <2== paco2 gf r.
Proof.
  intros. apply uncurry_adjoint1_2.
  eapply _paco_acc. intros.
  apply uncurry_adjoint1_2 in INC. apply uncurry_adjoint1_2 in CIH.
  apply uncurry_adjoint2_2.
  eapply le2_trans. eapply (OBG _ INC CIH).
  apply curry_map2.
  apply _paco_mon; try apply le1_refl; apply curry_bij1_2.
Qed.

Theorem _paco2_mult_strong: forall r,
  paco2 gf (upaco2 gf r) <2== paco2 gf r.
Proof.
  intros. apply curry_map2.
  eapply le1_trans; [| eapply _paco_mult_strong].
  apply _paco_mon; intros [] H; apply H.
Qed.

Theorem _paco2_fold: forall r,
  gf (upaco2 gf r) <2== paco2 gf r.
Proof.
  intros. apply uncurry_adjoint1_2.
  eapply le1_trans; [| apply _paco_fold]. apply le1_refl.
Qed.

Theorem _paco2_unfold: forall (MON: _monotone2 gf) r,
  paco2 gf r <2== gf (upaco2 gf r).
Proof.
  intros. apply curry_adjoint2_2.
  eapply _paco_unfold; apply monotone2_map; assumption.
Qed.

Theorem paco2_acc: forall
  l r (OBG: forall rr (INC: r <2= rr) (CIH: l <2= rr), l <2= paco2 gf rr),
  l <2= paco2 gf r.
Proof.
  apply _paco2_acc.
Qed.

Theorem paco2_mon: monotone2 (paco2 gf).
Proof.
  apply monotone2_eq.
  apply _paco2_mon.
Qed.

Theorem upaco2_mon: monotone2 (upaco2 gf).
Proof.
  red; intros.
  destruct IN.
  - left. eapply paco2_mon. apply H. apply LE.
  - right. apply LE, H.
Qed.

Theorem paco2_mult_strong: forall r,
  paco2 gf (upaco2 gf r) <2= paco2 gf r.
Proof.
  apply _paco2_mult_strong.
Qed.

Corollary paco2_mult: forall r,
  paco2 gf (paco2 gf r) <2= paco2 gf r.
Proof. intros; eapply paco2_mult_strong, paco2_mon; [apply PR|..]; intros; left; assumption. Qed.

Theorem paco2_fold: forall r,
  gf (upaco2 gf r) <2= paco2 gf r.
Proof.
  apply _paco2_fold.
Qed.

Theorem paco2_unfold: forall (MON: monotone2 gf) r,
  paco2 gf r <2= gf (upaco2 gf r).
Proof.
  intro. eapply _paco2_unfold; apply monotone2_eq; assumption.
Qed.

End Arg2.

Arguments paco2_acc : clear implicits.
Arguments paco2_mon : clear implicits.
Arguments upaco2_mon : clear implicits.
Arguments paco2_mult_strong : clear implicits.
Arguments paco2_mult : clear implicits.
Arguments paco2_fold : clear implicits.
Arguments paco2_unfold : clear implicits.

Global Instance paco2_inst  (gf : rel2 T0 T1->_) r x0 x1 : paco_class (paco2 gf r x0 x1) :=
{ pacoacc    := paco2_acc gf;
  pacomult   := paco2_mult gf;
  pacofold   := paco2_fold gf;
  pacounfold := paco2_unfold gf }.

End PACO2.

Global Opaque paco2.

Hint Unfold upaco2.
Hint Resolve paco2_fold.
Hint Unfold monotone2.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  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: Znat.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)

Require Export Arith_base.
Require Import BinPos.
Require Import BinInt.
Require Import Zcompare.
Require Import Zorder.
Require Import Decidable.
Require Import Peano_dec.
Require Import Min Max Zmin Zmax.
Require Export Compare_dec.

Open Local Scope Z_scope.

Definition neq (x y:nat) := x <> y.

(************************************************)
(** Properties of the injection from nat into Z *)

(** Injection and successor *)

Theorem inj_0 : Z_of_nat 0 = 0%Z.
Proof.
  reflexivity.
Qed.

Theorem inj_S : forall n:nat, Z_of_nat (S n) = Zsucc (Z_of_nat n).
Proof.
  intro y; induction y as [| n H];
    [ unfold Zsucc in |- *; simpl in |- *; trivial with arith
      | change (Zpos (Psucc (P_of_succ_nat n)) = Zsucc (Z_of_nat (S n))) in |- *;
	rewrite Zpos_succ_morphism; trivial with arith ].
Qed.

(** Injection and equality. *)

Theorem inj_eq : forall n m:nat, n = m -> Z_of_nat n = Z_of_nat m.
Proof.
  intros x y H; rewrite H; trivial with arith.
Qed.

Theorem inj_neq : forall n m:nat, neq n m -> Zne (Z_of_nat n) (Z_of_nat m).
Proof.
  unfold neq, Zne, not in |- *; intros x y H1 H2; apply H1; generalize H2;
    case x; case y; intros;
      [ auto with arith
	| discriminate H0
	| discriminate H0
	| simpl in H0; injection H0;
	  do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ;
	    intros E; rewrite E; auto with arith ].
Qed.

Theorem inj_eq_rev : forall n m:nat, Z_of_nat n = Z_of_nat m -> n = m.
Proof.
  intros x y H.
  destruct (eq_nat_dec x y) as [H'|H']; auto.
  exfalso.
  exact (inj_neq _ _ H' H).
Qed.

Theorem inj_eq_iff : forall n m:nat, n=m <-> Z_of_nat n = Z_of_nat m.
Proof.
 split; [apply inj_eq | apply inj_eq_rev].
Qed.

(** Injection and order relations: *)

(** One way ... *)

Theorem inj_le : forall n m:nat, (n <= m)%nat -> Z_of_nat n <= Z_of_nat m.
Proof.
  intros x y; intros H; elim H;
    [ unfold Zle in |- *; elim (Zcompare_Eq_iff_eq (Z_of_nat x) (Z_of_nat x));
      intros H1 H2; rewrite H2; [ discriminate | trivial with arith ]
      | intros m H1 H2; apply Zle_trans with (Z_of_nat m);
	[ assumption | rewrite inj_S; apply Zle_succ ] ].
Qed.

Theorem inj_lt : forall n m:nat, (n < m)%nat -> Z_of_nat n < Z_of_nat m.
Proof.
  intros x y H; apply Zgt_lt; apply Zle_succ_gt; rewrite <- inj_S; apply inj_le;
    exact H.
Qed.

Theorem inj_ge : forall n m:nat, (n >= m)%nat -> Z_of_nat n >= Z_of_nat m.
Proof.
  intros x y H; apply Zle_ge; apply inj_le; apply H.
Qed.

Theorem inj_gt : forall n m:nat, (n > m)%nat -> Z_of_nat n > Z_of_nat m.
Proof.
  intros x y H; apply Zlt_gt; apply inj_lt; exact H.
Qed.

(** The other way ... *)

Theorem inj_le_rev : forall n m:nat, Z_of_nat n <= Z_of_nat m -> (n <= m)%nat.
Proof.
  intros x y H.
  destruct (le_lt_dec x y) as [H0|H0]; auto.
  exfalso.
  assert (H1:=inj_lt _ _ H0).
  red in H; red in H1.
  rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto.
Qed.

Theorem inj_lt_rev : forall n m:nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat.
Proof.
  intros x y H.
  destruct (le_lt_dec y x) as [H0|H0]; auto.
  exfalso.
  assert (H1:=inj_le _ _ H0).
  red in H; red in H1.
  rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto.
Qed.

Theorem inj_ge_rev : forall n m:nat, Z_of_nat n >= Z_of_nat m -> (n >= m)%nat.
Proof.
  intros x y H.
  destruct (le_lt_dec y x) as [H0|H0]; auto.
  exfalso.
  assert (H1:=inj_gt _ _ H0).
  red in H; red in H1.
  rewrite <- Zcompare_antisym in H; rewrite H1 in H; auto.
Qed.

Theorem inj_gt_rev : forall n m:nat, Z_of_nat n > Z_of_nat m -> (n > m)%nat.
Proof.
  intros x y H.
  destruct (le_lt_dec x y) as [H0|H0]; auto.
  exfalso.
  assert (H1:=inj_ge _ _ H0).
  red in H; red in H1.
  rewrite <- Zcompare_antisym in H1; rewrite H in H1; auto.
Qed.

(* Both ways ... *)

Theorem inj_le_iff : forall n m:nat, (n<=m)%nat <-> Z_of_nat n <= Z_of_nat m.
Proof.
 split; [apply inj_le | apply inj_le_rev].
Qed.

Theorem inj_lt_iff : forall n m:nat, (n<m)%nat <-> Z_of_nat n < Z_of_nat m.
Proof.
 split; [apply inj_lt | apply inj_lt_rev].
Qed.

Theorem inj_ge_iff : forall n m:nat, (n>=m)%nat <-> Z_of_nat n >= Z_of_nat m.
Proof.
 split; [apply inj_ge | apply inj_ge_rev].
Qed.

Theorem inj_gt_iff : forall n m:nat, (n>m)%nat <-> Z_of_nat n > Z_of_nat m.
Proof.
 split; [apply inj_gt | apply inj_gt_rev].
Qed.

(** Injection and usual operations *)

Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m.
Proof.
  intro x; induction x as [| n H]; intro y; destruct y as [| m];
    [ simpl in |- *; trivial with arith
      | simpl in |- *; trivial with arith
      | simpl in |- *; rewrite <- plus_n_O; trivial with arith
      | change (Z_of_nat (S (n + S m)) = Z_of_nat (S n) + Z_of_nat (S m)) in |- *;
	rewrite inj_S; rewrite H; do 2 rewrite inj_S; rewrite Zplus_succ_l;
	  trivial with arith ].
Qed.

Theorem inj_mult : forall n m:nat, Z_of_nat (n * m) = Z_of_nat n * Z_of_nat m.
Proof.
  intro x; induction x as [| n H];
    [ simpl in |- *; trivial with arith
      | intro y; rewrite inj_S; rewrite <- Zmult_succ_l_reverse; rewrite <- H;
	rewrite <- inj_plus; simpl in |- *; rewrite plus_comm;
	  trivial with arith ].
Qed.

Theorem inj_minus1 :
  forall n m:nat, (m <= n)%nat -> Z_of_nat (n - m) = Z_of_nat n - Z_of_nat m.
Proof.
  intros x y H; apply (Zplus_reg_l (Z_of_nat y)); unfold Zminus in |- *;
    rewrite Zplus_permute; rewrite Zplus_opp_r; rewrite <- inj_plus;
      rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r;
        trivial with arith.
Qed.

Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0.
Proof.
  intros x y H; rewrite not_le_minus_0;
    [ trivial with arith | apply gt_not_le; assumption ].
Qed.

Theorem inj_minus : forall n m:nat,
 Z_of_nat (minus n m) = Zmax 0 (Z_of_nat n - Z_of_nat m).
Proof.
 intros.
 rewrite Zmax_comm.
 unfold Zmax.
 destruct (le_lt_dec m n) as [H|H].

 rewrite (inj_minus1 _ _ H).
 assert (H':=Zle_minus_le_0 _ _ (inj_le _ _ H)).
 unfold Zle in H'.
 rewrite <- Zcompare_antisym in H'.
 destruct Zcompare; simpl in *; intuition.

 rewrite (inj_minus2 _ _ H).
 assert (H':=Zplus_lt_compat_r _ _ (- Z_of_nat m) (inj_lt _ _ H)).
 rewrite Zplus_opp_r in H'.
 unfold Zminus; rewrite H'; auto.
Qed.

Theorem inj_min : forall n m:nat,
  Z_of_nat (min n m) = Zmin (Z_of_nat n) (Z_of_nat m).
Proof.
 induction n; destruct m; try (compute; auto; fail).
 simpl min.
 do 3 rewrite inj_S.
 rewrite <- Zsucc_min_distr; f_equal; auto.
Qed.

Theorem inj_max : forall n m:nat,
  Z_of_nat (max n m) = Zmax (Z_of_nat n) (Z_of_nat m).
Proof.
 induction n; destruct m; try (compute; auto; fail).
 simpl max.
 do 3 rewrite inj_S.
 rewrite <- Zsucc_max_distr; f_equal; auto.
Qed.

(** Composition of injections **)

Theorem Zpos_eq_Z_of_nat_o_nat_of_P :
  forall p:positive, Zpos p = Z_of_nat (nat_of_P p).
Proof.
  intros x; elim x; simpl in |- *; auto.
  intros p H; rewrite ZL6.
  apply f_equal with (f := Zpos).
  apply nat_of_P_inj.
  rewrite nat_of_P_o_P_of_succ_nat_eq_succ; unfold nat_of_P in |- *;
    simpl in |- *.
  rewrite ZL6; auto.
  intros p H; unfold nat_of_P in |- *; simpl in |- *.
  rewrite ZL6; simpl in |- *.
  rewrite inj_plus; repeat rewrite <- H.
  rewrite Zpos_xO; simpl in |- *; rewrite Pplus_diag; reflexivity.
Qed.

(** Misc *)

Theorem intro_Z :
  forall n:nat,  exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0.
Proof.
  intros x; exists (Z_of_nat x); split;
    [ trivial with arith
      | rewrite Zmult_comm; rewrite Zmult_1_l; rewrite Zplus_0_r;
	unfold Zle in |- *; elim x; intros; simpl in |- *;
          discriminate ].
Qed.

Lemma Zpos_P_of_succ_nat : forall n:nat,
 Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n).
Proof.
  intros.
  unfold Z_of_nat.
  destruct n.
  simpl; auto.
  simpl (P_of_succ_nat (S n)).
  apply Zpos_succ_morphism.
Qed.


(** * AST and translation of the monomorphic fragment of Oak to MetaCoq *)
Require Template.All.

Require Import Bool.
Require Import Template.Ast Template.AstUtils.
Require Import Template.Typing.
Require Import String List.

Require Import MyEnv.

Import ListNotations.
Open Scope string_scope.

(* TODO: we use definition of monads from Template Coq,
   but (as actually comment in the [monad_utils] says, we
   should use a real monad library) *)
Require Import Template.monad_utils.
Import MonadNotation.

(** Aliases *)
Definition name := string.
Definition inductive := string.

Inductive type : Set :=
| tyInd : inductive -> type
| tyArr : type -> type -> type.

Record pat := pConstr {pName : name; pVars : list name}.

(** ** Oak AST *)

(** We have both named variables and de Bruijn indices.  Translation to Meta Coq requires indices, while named representation is what we might get from the integration API. We can define relations on type of expressions ensuring that either names are used, or indices, but not both at the same time. *)

(** Note also that AST must be explicitly annotated with types. This is required for the translation to Meta Coq. *)
Inductive expr : Set :=
| eRel       : nat -> expr (*de Bruijn index *)
| eVar       : name -> expr (* named variables *)
| eLambda    : name -> type -> expr -> expr
| eLetIn     : name -> expr -> type -> expr -> expr
| eApp       : expr -> expr -> expr
| eConstr    : inductive -> name -> expr
| eConst     : name -> expr
| eCase      : (inductive * nat) (* name of indictive and number of parameters *) ->
               type ->
               expr (* discriminee *) ->
               list (pat * expr) (* branches *) ->
               expr
| eFix       : name (* of the fix *) -> name (* of the arg *) ->
               type (* of the arg *) -> type (* return type *) -> expr (* body *) -> expr.

(** An induction principle that takes into account nested occurrences of expressions
   in the list of branches for [eCase] *)
Definition expr_ind_case (P : expr -> Prop)
           (Hrel    : forall n : nat, P (eRel n))
           (Hvar    : forall n : name, P (eVar n))
           (Hlam    :forall (n : name) (t : type) (e : expr), P e -> P (eLambda n t e))
           (Hletin  : forall (n : name) (e : expr),
               P e -> forall (t : type) (e0 : expr), P e0 -> P (eLetIn n e t e0))
           (Happ    :forall e : expr, P e -> forall e0 : expr, P e0 -> P (eApp e e0))
           (Hconstr :forall (i : inductive) (n : name), P (eConstr i n))
           (Hconst  :forall n : name, P (eConst n))
           (Hcase   : forall (p : inductive * nat) (t : type) (e : expr),
               P e -> forall l : list (pat * expr), Forall (fun x => P (snd x)) l ->P (eCase p t e l))
           (Hfix    :forall (n n0 : name) (t t0 : type) (e : expr), P e -> P (eFix n n0 t t0 e)) :
  forall e : expr, P e.
Proof.
  refine (fix ind (e : expr) := _ ).
  destruct e.
  + apply Hrel.
  + apply Hvar.
  + apply Hlam. apply ind.
  + apply Hletin; apply ind.
  + apply Happ;apply ind.
  + apply Hconstr.
  + apply Hconst.
  + apply Hcase. apply ind.
    induction l.
    * constructor.
    * constructor. apply ind. apply IHl.
  + apply Hfix. apply ind.
Defined.

Fixpoint iclosed_n (n : nat) (e : expr) : bool :=
  match e with
  | eRel i => Nat.ltb i n
  | eVar x => false
  | eLambda nm ty b => iclosed_n (1+n) b
  | eLetIn nm e1 ty e2 => iclosed_n n e1 && iclosed_n (1+n) e2
  | eApp e1 e2 => iclosed_n n e1 && iclosed_n n e2
  | eConstr x x0 => true
  | eConst x => true
  | eCase ii ty e bs =>
    let bs'' := List.forallb
                  (fun x => iclosed_n (length ((fst x).(pVars)) + n) (snd x)) bs in
    iclosed_n n e && bs''
  | eFix fixname nm ty1 ty2 e => iclosed_n (2+n) e
  end.

Definition vars_to_apps acc vs :=
  fold_left eApp vs acc.

Definition constr := (name * list type)%type.

(** Global declarations. Will be extended to handle declaration of constant, e.g. function definitions *)
Inductive global_dec :=
| gdInd : name -> list constr -> global_dec.

Definition global_env := list global_dec.

Fixpoint lookup {A} (l : list (string * A)) key : option A :=
  match l with
  | [] => None
  | (key', v) :: xs => if eq_string key' key then Some v else lookup xs key
  end.

Fixpoint lookup_global ( Σ : global_env) key : option global_dec :=
  match Σ with
  | [] => None
  | gdInd key' v :: xs => if eq_string key' key then Some (gdInd key' v) else lookup_global xs key
  end.

(** Looks up for the given inductive by name and if succeeds, returns a list of constructors with corresponding arities *)
Definition resolve_inductive (Σ : global_env) (ind_name : ident)
  : option (list (name * list type)) :=
  match (lookup_global Σ ind_name) with
  | Some (gdInd n cs) => Some cs
  | None => None
  end.

(** Resolves the given constructor name to a corresponding position in the list of constructors along with the constructor arity *)
Definition resolve_constr (Σ : global_env) (ind_name constr_name : ident)
  : option (nat * list type)  :=
  match (resolve_inductive Σ ind_name) with
  | Some cs => lookup_with_ind cs constr_name
  | None => None
  end.

Definition from_option {A : Type} ( o : option A) (default : A) :=
  match o with
  | None => default
  | Some v => v
  end.

Definition bump_indices (l : list (name * nat)) (n : nat) :=
  map (fun '(x,y) => (x, n+y)) l.

(** For a list of vars returns a list of pairs (var,number) where the number is a position of the var counted from the end of the list.
 E.g. number_vars ["x"; "y"; "z"] = [("x", 2); ("y", 1); ("z", 0)] *)
Definition number_vars (ns : list name) : list (name * nat) :=
  combine ns (rev (seq 0 (length ns))).

Example number_vars_xyz : number_vars ["x"; "y"; "z"] = [("x", 2); ("y", 1); ("z", 0)].
Proof. reflexivity. Qed.

(** Converting variable names to De Bruijn indices *)
Fixpoint indexify (l : list (name * nat)) (e : expr) : expr :=
  match e with
  | eRel i => eRel i
  | eVar nm =>
    match (lookup l nm) with
    | None => (* NOTE: a workaround to make the function total *)
      eVar ("not a closed term")
    | Some v => eRel v
    end
  | eLambda nm ty b =>
    eLambda nm ty (indexify ((nm,0 ):: bump_indices l 1) b)
  | eLetIn nm e1 ty e2 =>
    eLetIn nm e1 ty (indexify ((nm, 0) :: bump_indices l 1) e2)
  | eApp e1 e2 => eApp (indexify l e1) (indexify l e2)
  | eConstr t i as e => e
  | eConst nm as e => e
  | eCase nm_i ty e bs =>
    eCase nm_i ty (indexify l e)
          (map (fun p => (fst p, indexify (number_vars (fst p).(pVars) ++ bump_indices l (length (fst p).(pVars))) (snd p))) bs)
  | eFix nm vn ty1 ty2 b =>
    (* name of the fixpoint becomes an index as well *)
    eFix nm vn ty1 ty2 (indexify ((nm,1) :: (vn,0) :: bump_indices l 2) b)
  end.

Fixpoint type_to_term (ty : type) : term :=
  match ty with
  | tyInd i => tInd (mkInd i 0) []
  | tyArr t1 t2 => tProd nAnon (type_to_term t1) (type_to_term t2)
  end.

Fixpoint pat_to_lam (tys : list (name * type)) (body : term) : term :=
  match tys with
    [] => body
  | (n,ty) :: tys' => tLambda (nNamed n) (type_to_term ty) (pat_to_lam tys' body)
  end.

Fixpoint pat_to_elam (tys : list (name * type)) (body : expr) : expr :=
  match tys with
    [] => body
  | (n,ty) :: tys' => eLambda n ty (pat_to_elam tys' body)
  end.

(** Resolves a pattern by looking up in the global environment and returns an index of the constructor in the list of constructors for the given inductive and a list of pairs mapping pattern variable names to the types of the constructor arguments *)
Definition resolve_pat_arity (Σ : global_env) (ind_name : name) (p : pat) : nat * list (name * type) :=
  (* NOTE: in lookup failed we return a dummy value [(0,("",[]))]
     to make the function total *)
  let o_ci := resolve_constr Σ ind_name p.(pName) in
  let (i, nm_tys) := from_option o_ci (0,[]) in
  (i, combine p.(pVars) nm_tys).

(** Translating branches of the [eCase] construct. Note that MetaCoq uses indices to represent constructors. Indices are corresponding positions in the list of constructors for a particular inductive type *)
Definition trans_branch (bs : list (pat * term))
           (c : name * list type) :=
  let dummy := (0, tVar "error") in
  let (nm, tys) := c in
  let o_pt_e := find (fun x =>(fst x).(pName) =? nm) bs in
  match o_pt_e with
    | Some pt_e => if (Nat.eqb #|(fst pt_e).(pVars)| #|tys|) then
                    let vars_tys := combine (fst pt_e).(pVars) tys in
                    (length (fst pt_e).(pVars), pat_to_lam vars_tys (snd pt_e))
                  else dummy
    | None => dummy
  end.

Definition fun_prod {A B C D} (f : A -> C) (g : B -> D) : A * B -> C * D :=
  fun x => (f (fst x), g (snd x)).

(** ** Translation of Oak to MetaCoq *)

Definition expr_to_term (Σ : global_env) : expr -> Ast.term :=
  fix expr_to_term e :=
  match e with
  | eRel i => tRel i
  | eVar nm => tVar nm
  | eLambda nm ty b => tLambda (nNamed nm) (type_to_term ty) (expr_to_term b)
  | eLetIn nm e1 ty e2 => tLetIn (nNamed nm) (expr_to_term e1) (type_to_term ty) (expr_to_term e2)
  | eApp e1 e2 => mkApps (expr_to_term e1) [expr_to_term e2]
  | eConstr t i => match (resolve_constr Σ t i) with
                  | Some c => tConstruct (mkInd t 0) (fst c) []
                  (* NOTE: a workaround to make the function total *)
                  | None => tConstruct (mkInd (t ++ ": no declaration found.") 0) 0 []
                     end
  | eConst nm => tConst nm []
  | eCase nm_i ty e bs =>
    let (nm,i) := nm_i in
    let typeInfo := tLambda nAnon (tInd (mkInd nm 0) []) (type_to_term ty) in
    let cs := from_option (resolve_inductive Σ nm) [] in
    let tbs := map (fun_prod id expr_to_term) bs in
    let branches := map (trans_branch tbs) cs in
    (* TODO: no translation for polymorphic types, the number of parameters is zero *)
    tCase (mkInd nm 0, 0) typeInfo (expr_to_term e) branches
  | eFix nm nv ty1 ty2 b =>
    let tty1 := type_to_term ty1 in
    let tty2 := type_to_term ty2 in
    let ty := tProd nAnon tty1 tty2 in
    let body := tLambda (nNamed nv) tty1 (expr_to_term b) in
    tFix [(mkdef _ (nNamed nm) ty body 0)] 0
  end.

(** A "library" of data types available by default *)

Module BaseTypes.
  Definition Nat_name := "Coq.Init.Datatypes.nat".
  Definition Nat := Nat_name.

  Definition Bool_name := "Coq.Init.Datatypes.bool".
  Definition Bool := Bool_name.
End BaseTypes.

Import BaseTypes.

(** * Notations for the deep embeding *)

(** Here we use "custom entries" - a new feature of Coq allowing to define autonomous grammars *)
Declare Custom Entry expr.
Declare Custom Entry pat.
Declare Custom Entry type.

Notation "ty" := (tyInd ty) (in custom type at level 2, ty constr at level 3).
Notation "ty1 -> ty2" := (tyArr ty1 ty2)
                          (in custom type at level 4).

Notation "[| e |]" := e (e custom expr at level 2).
Notation "^ i " := (eRel i) (in custom expr at level 3, i constr at level 4).
Notation "x" := (eVar x) (in custom expr at level 0, x constr at level 4).
Notation "\ x : ty -> b" := (eLambda x ty b)
                              (in custom expr at level 1,
                                  ty custom type at level 2,
                                  b custom expr at level 4,
                                  x constr at level 4).
Notation "'let' x : ty := e1 'in' e2" := (eLetIn x e1 ty e2)
                                           (in custom expr at level 1,
                                               ty custom type at level 2,
                                               x constr at level 4).

(** Unfortunately there are some problems with recursive notations (might go away after the next stable release - 8.10.). So,there are several variants
   of [case] for different number of cases below *)

(* Notation "'case' x : ty 'of'  b1 | .. | bn " := *)
(*   (eCase (ty,0) (tyInd "") x (cons b1 .. (cons bn nil) ..)) *)
(*     (in custom expr at level 1, *)
(*         b1 custom expr at level 4, *)
(*         bn custom expr at level 4, *)
(*         ty constr at level 4). *)

Notation "'case' x : ty1 'return' ty2 'of' | p1 -> b1 | pn -> bn" :=
  (eCase (ty1,0) ty2 x [(p1,b1);(pn,bn)])
    (in custom expr at level 1,
        p1 custom pat at level 4,
        pn custom pat at level 4,
        b1 custom expr at level 4,
        bn custom expr at level 4,
        ty1 constr at level 4,
        ty2 custom type at level 4).

Notation "'case' x : ty1 'return' ty2 'of' p1 -> b1 " :=
  (eCase (ty1,0) ty2 x [(p1,b1)])
    (in custom expr at level 1,
        p1 custom pat at level 4,
        b1 custom expr at level 4,
        ty1 constr at level 4,
        ty2 custom type at level 4).

Notation "t1 t2" := (eApp t1 t2) (in custom expr at level 4, left associativity).

Notation "'fix' fixname ( v : ty1 ) : ty2 := b" := (eFix fixname v ty1 ty2 b)
                                  (in custom expr at level 2,
                                      fixname constr at level 4,
                                      v constr at level 4,
                                      b custom expr at level 4,
                                      ty1 custom type at level 4,
                                      ty2 custom type at level 4).
Notation "( x )" := x (in custom expr, x at level 2).
Notation "{ x }" := x (in custom expr, x constr).

Module StdLib.
  Notation "a + b" := [| {eConst "Coq.Init.Nat.add"} {a} {b} |]
                        (in custom expr at level 0).
  Notation "a * b" := [| {eConst "Coq.Init.Nat.mul"} {a} {b} |]
                        (in custom expr at level 0).
  Notation "'Z'" := (eConstr Nat "Z") ( in custom expr at level 0).
  Notation "'Suc'" := (eConstr Nat "Suc") ( in custom expr at level 0).
  Notation "0" := [| Z |] ( in custom expr at level 0).
  Notation "1" := [| Suc Z |] ( in custom expr at level 0).

  Notation "'Z'" := (pConstr "Z" [])
                  (in custom pat at level 0).

  Notation "'Suc' x" := (pConstr "Suc" [x])
                    (in custom pat at level 0,
                        x constr at level 4).

  Definition true_name := "true".
  Definition false_name := "false".
  Notation "'true'" := (pConstr true_name []) (in custom pat at level 0).
  Notation "'false'" := (pConstr false_name []) ( in custom pat at level 0).

  Notation "'true'" := (eConstr Bool true_name) (in custom expr at level 0).
  Notation "'false'" := (eConstr Bool false_name) ( in custom expr at level 0).

  Definition Σ : global_env :=
    [gdInd Bool [("true", []); ("false", [])];
     gdInd Nat  [("Z", []); ("Suc", [tyInd Nat])]].
End StdLib.

Section Examples.
  Import StdLib.

  Definition x := "x".
  Definition y := "y".
  Definition z := "z".

  Check [| ^0 |].

  Check [| \x : Nat -> y |].

  Definition id_f_syn :=  [| (\x : Nat -> ^0) 1 |].

  Make Definition id_f_one := Eval compute in (expr_to_term Σ id_f_syn).
  Example id_f_eq : id_f_one = 1. Proof. reflexivity. Qed.

  (* The same as [id_f_syn], but with named vars *)
  Definition id_f_with_vars := [| (\x : Nat -> x) 1 |].

  Make Definition id_f_one' := Eval compute in (expr_to_term Σ (indexify [] id_f_with_vars)).
  Example id_f_eq' : id_f_one' = 1. Proof. reflexivity. Qed.

  Definition simple_let_syn :=
    [|
     \x : Nat ->
       let y : Nat := 1 in ^0
     |].

  Make Definition simple_let := Eval compute in (expr_to_term Σ simple_let_syn).
  Example simple_let_eq : simple_let 1 = 1. Proof. reflexivity. Qed.

  Definition simple_let_with_vars_syn :=
    [|
     \x : Nat ->
       let y : Nat := 1 in y
     |].

  Make Definition simple_let' := Eval compute in (expr_to_term Σ (indexify [] simple_let_with_vars_syn)).
  Example simple_let_eq' : simple_let' 0 = 1. Proof. reflexivity. Qed.

  Definition negb_syn :=
    [|
     \x : Bool ->
            case x : Bool return Bool of
            | true -> false
            | false -> true
    |].

  Make Definition negb' := Eval compute in (expr_to_term Σ (indexify [] negb_syn)).

  Example negb'_correct : forall b, negb' b = negb b.
  Proof.
    destruct b;easy.
  Qed.

  Definition myplus_syn :=
    [| \x : Nat -> \y : Nat -> x + y |].

  Make Definition myplus := Eval compute in (expr_to_term Σ (indexify [] myplus_syn)).

End Examples.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.reals.CPoly_Contin.

Section Nested_Intervals.
(**
* Intermediate Value Theorem

** Nested intervals

%\begin{convention}% Let [a,b:nat->IR] be sequences such that:
- [a] is increasing;
- [b] is decreasing;
- [forall (i:nat), (a i) [<] (b i)];
- for every positive real number [eps], there is an [i] such that [(b i) [<] (a i) [+]eps].

%\end{convention}%
*)

Variables a b : nat -> IR.
Hypothesis a_mon : forall i : nat, a i [<=] a (S i).
Hypothesis b_mon : forall i : nat, b (S i) [<=] b i.
Hypothesis a_b : forall i : nat, a i [<] b i.
Hypothesis b_a : forall eps : IR, [0] [<] eps -> {i : nat | b i [<=] a i[+]eps}.

Lemma a_mon' : forall i j : nat, i <= j -> a i [<=] a j.
Proof.
 intros.
 apply local_mon'_imp_mon'; auto.
Qed.

Lemma b_mon' : forall i j : nat, i <= j -> b j [<=] b i.
Proof.
 intros.
 set (b' := fun i : nat => [--] (b i)) in *.
 astepl ( [--][--] (b j)).
 astepr ( [--][--] (b i)).
 fold (b' i) (b' j) in |- *.
 apply inv_resp_leEq.
 apply local_mon'_imp_mon'.
  unfold b' in |- *; intro; apply inv_resp_leEq; auto.
 auto.
Qed.

Lemma a_b' : forall i j : nat, a i [<] b j.
Proof.
 intros.
 elim (le_lt_dec i j); intro.
  apply leEq_less_trans with (a j).
   apply a_mon'. auto.
   auto.
 apply less_leEq_trans with (b i).
  auto.
 apply b_mon'. auto with arith.
Qed.

Lemma intervals_cauchy : Cauchy_prop a.
Proof.
 unfold Cauchy_prop in |- *.
 unfold AbsSmall in |- *.
 intro eps. intros H.
 elim (b_a eps H). intro n. intros. exists n.
 intro i. intros.
 split; apply less_leEq.
  apply less_leEq_trans with ZeroR.
   astepr ( [--]ZeroR).
   apply inv_resp_less. auto.
   astepl (a n[-]a n).
  apply minus_resp_leEq.
  apply a_mon'. auto.
  apply shift_minus_less'.
 apply less_leEq_trans with (b n).
  apply a_b'.
 auto.
Qed.

(* begin hide *)
Let a' := Build_CauchySeq _ a intervals_cauchy.
(* end hide *)

Lemma Cnested_intervals_limit : {z : IR | forall i, a i [<=] z | forall i, z [<=] b i}.
Proof.
 exists (Lim a').
  intros.
  rewrite -> leEq_def in |- *. unfold Not in |- *. intros.
  elim (Lim_less_so_seq_less a' (a i)). intro n. intros H0.
   elim (le_lt_dec n i); intro H1.
    cut (Not (a i [<] a i)). intro H2.
     unfold Not in H1. elim H2. apply H0. auto.
     apply less_irreflexive_unfolded.
   cut (forall i j : nat, i <= j -> a i [<=] a j). intro a_mon''.
    pose (c:=a_mon'' i n).
    rewrite -> leEq_def in c.
    apply c.
     auto with arith.
    apply H0.
    auto.
   intros. apply a_mon'; auto.
   auto.
 intros i. rewrite -> leEq_def. unfold Not. intros H.
 elim (less_Lim_so_less_seq a' (b i) H). intro n. intros H0.
 elim (le_lt_dec n i); intro H1.
  cut (Not (a i [<] b i)). unfold Not in |- *. intro.
   elim H2. auto. apply less_antisymmetric_unfolded.
   apply H0.
  auto.
 cut (Not (a n [<] b n)). unfold Not in |- *. intro H2.
  apply H2. auto. apply less_antisymmetric_unfolded.
  apply leEq_less_trans with (b i).
  apply b_mon'. auto with arith.
  apply H0. auto.
Qed.

(** %\begin{convention}% Let [f] be a continuous real function.
%\end{convention}%
*)

Variable f : CSetoid_un_op IR.
Hypothesis f_contin : contin f.

Lemma f_contin_pos : forall z : IR, [0] [<] f z ->
 {eps : IR | [0] [<] eps | forall x, x [<=] z[+]eps -> z [<=] x[+]eps -> [0] [<] f x}.
Proof.
 intros z H.
 unfold contin in f_contin.
 unfold continAt in f_contin.
 unfold funLim in f_contin.
 unfold AbsSmall in f_contin.
 elim (f_contin z (f z [/]TwoNZ) (pos_div_two _ _ H)). intro eps. intros H1 H2.
 exists eps.
  auto. intros.
 elim (H2 x). intros H5 H6.
  astepl (f z[-]f z).
  apply shift_minus_less.
  apply shift_less_plus'.
  apply leEq_less_trans with (f z [/]TwoNZ). auto. apply pos_div_two'. auto.
   split.
  apply shift_leEq_minus.
  rstepl (x[-]eps).
  apply shift_minus_leEq. auto.
  apply shift_minus_leEq. astepr (x[+]eps). auto.
Qed.

Lemma f_contin_neg : forall z : IR, f z [<] [0] ->
 {eps : IR | [0] [<] eps | forall x, x [<=] z[+]eps -> z [<=] x[+]eps -> f x [<] [0]}.
Proof.
 intros.
 unfold contin in f_contin.
 unfold continAt in f_contin.
 unfold funLim in f_contin.
 unfold AbsSmall in f_contin.
 cut ([0] [<] [--] (f z)). intro H0.
  elim (f_contin z ( [--] (f z) [/]TwoNZ) (pos_div_two _ _ H0)). intro eps. intros H2 H3.
  exists eps.
   auto. intros.
  elim (H3 x). intros H6 H7.
   rstepr (f z[-][--][--] (f z)).
   apply shift_less_minus'.
   apply shift_plus_less.
   apply less_leEq_trans with (f z [/]TwoNZ).
    astepl (f z). apply inv_cancel_less. rstepl ( [--] (f z) [/]TwoNZ). apply pos_div_two'. auto.
    rstepl ( [--] ( [--] (f z) [/]TwoNZ)). auto.
   split.
   apply shift_leEq_minus.
   rstepl (x[-]eps).
   apply shift_minus_leEq. auto.
   apply shift_minus_leEq. astepr (x[+]eps). auto.
  astepl ( [--]ZeroR).
 apply inv_resp_less. auto.
Qed.

(** Assume also that [forall i, f (a i) [<=] [0] [<=] f (b i)]. *)

Hypothesis f_a : forall i, f (a i) [<=] [0].
Hypothesis f_b : forall i, [0] [<=] f (b i).

Lemma Cnested_intervals_zero : {z : IR | a 0 [<=] z /\ z [<=] b 0 /\ f z [=] [0]}.
Proof.
 elim Cnested_intervals_limit. intro z. intros H0 H1. exists z.
 split. auto. split. auto.
  apply not_ap_imp_eq.
 unfold Not in |- *.
 intros H2.
 elim (ap_imp_less _ _ _ H2); intros H3.
  elim (f_contin_neg z H3). intro eps. intros H5 H6.
  elim (b_a eps). intro i. intros H7.
   cut (b i [<=] z[+]eps). intro.
    cut (z [<=] b i[+]eps). intro.
     pose (c:= f_b i). rewrite -> leEq_def in c. apply c. apply H6. auto. auto.
     apply leEq_transitive with (b i). auto.
     astepl (b i[+][0]). apply plus_resp_leEq_lft. apply less_leEq. auto.
    apply leEq_transitive with (a i[+]eps). auto.
    apply plus_resp_leEq. auto. auto.
   elim (f_contin_pos z H3). intro eps. intros H5 H6.
 elim (b_a eps). intro i. intros H7.
  cut (a i [<=] z[+]eps). intro.
   cut (z [<=] a i[+]eps). intro.
    pose (c:= f_a i). rewrite -> leEq_def in c; apply c. apply H6. auto. auto.
    apply leEq_transitive with (b i). auto.
    auto. apply leEq_transitive with z. auto.
  astepl (z[+][0]). apply less_leEq. apply plus_resp_less_lft. auto.
  auto.
Qed.

End Nested_Intervals.

Section Bisection.

(**
** Bissections *)

Variable f : CSetoid_un_op IR.
Hypothesis f_apzero_interval :
  forall a b, a [<] b -> {c : IR | a [<=] c /\ c [<=] b | f c [#] [0]}.
Variables a b : IR.
Hypothesis a_b : a [<] b.
Hypothesis f_a : f a [<=] [0].
Hypothesis f_b : [0] [<=] f b.

(**
%\begin{convention}% Let [Small] denote [Two[/]ThreeNZ], [lft] be [(Two[*]a[+]b) [/]ThreeNZ] and [rht] be [(a[+]Two[*]b) [/]ThreeNZ].
%\end{convention}%
*)

(* begin hide *)
Let Small : IR := Two [/]ThreeNZ.
Let lft := (Two[*]a[+]b) [/]ThreeNZ.
Let rht := (a[+]Two[*]b) [/]ThreeNZ.
(* end hide *)

Lemma a_lft : a [<] lft.
Proof.
 unfold lft in |- *.
 apply shift_less_div.
  apply pos_three.
 rstepl (Two[*]a[+]a).
 apply plus_resp_less_lft.
 auto.
Qed.

Lemma rht_b : rht [<] b.
Proof.
 unfold rht in |- *.
 apply shift_div_less.
  apply pos_three.
 rstepr (b[+]Two[*]b).
 apply plus_resp_less_rht.
 auto.
Qed.

Lemma lft_rht : lft [<] rht.
Proof.
 unfold lft in |- *. unfold rht in |- *.
 apply div_resp_less_rht.
  rstepl (a[+]b[+]a).
  rstepr (a[+]b[+]b).
  apply plus_resp_less_lft.
  auto.
 apply pos_three.
Qed.

Lemma smaller_lft : rht[-]a [=] Small[*] (b[-]a).
Proof.
 unfold Small in |- *. unfold rht in |- *.
 rational.
Qed.

Lemma smaller_rht : b[-]lft [=] Small[*] (b[-]a).
Proof.
 unfold Small in |- *. unfold lft in |- *.
 rational.
Qed.

Hint Resolve smaller_lft smaller_rht: algebra.

Lemma Cbisect' : {a' : IR | {b' : IR |
 a' [<] b' | a [<=] a' /\ b' [<=] b /\ b'[-]a' [<=] Small[*] (b[-]a) /\ f a' [<=] [0] /\ [0] [<=] f b'}}.
Proof.
 elim (f_apzero_interval lft rht lft_rht). intro c. intro H.
 elim H. intros H0 H2 H3.
 cut ({f c [<=] [0]} + {[0] [<=] f c}).
  intro H4; inversion_clear H4.
   exists c. exists b.
   apply leEq_less_trans with rht. auto. apply rht_b.
     split. apply leEq_transitive with lft. apply less_leEq. apply a_lft. auto.
    split. apply leEq_reflexive.
    split. astepr (b[-]lft). apply minus_resp_leEq_rht. auto.
    split. auto. auto.
    exists a. exists c.
  apply less_leEq_trans with lft. apply a_lft. auto.
    split. apply leEq_reflexive.
   split. apply less_leEq. apply leEq_less_trans with rht. auto. apply rht_b.
   split.
   astepr (rht[-]a). apply minus_resp_leEq. auto.
   split. auto. auto.
   elim (ap_imp_less _ _ _ H3); intros.
  left. apply less_leEq. auto.
  right. apply less_leEq. auto.
Qed.

End Bisection.

Section Bisect_Interval.

Variable f : CSetoid_un_op IR.
Hypothesis C_f_apzero_interval :
  forall a b, a [<] b -> {c : IR | a [<=] c /\ c [<=] b | f c [#] [0]}.

(* begin hide *)
Let Small : IR := Two [/]ThreeNZ.
(* end hide *)

Record bisect_interval : Type :=
  {interval_lft     : IR;
   interval_rht     : IR;
   interval_lft_rht : interval_lft [<] interval_rht;
   interval_f_lft   : f interval_lft [<=] [0];
   interval_f_rht   : [0] [<=] f interval_rht}.

Lemma Cbisect_exists : forall I : bisect_interval, {I' : bisect_interval |
 interval_rht I'[-]interval_lft I' [<=] Small[*] (interval_rht I[-]interval_lft I) /\
 interval_lft I [<=] interval_lft I' /\ interval_rht I' [<=] interval_rht I}.
Proof.
 intros.
 elim (Cbisect' f C_f_apzero_interval _ _ (interval_lft_rht I) (
   interval_f_lft I) (interval_f_rht I)).
 intro lft. intro H.
 elim H. intro rht. intros H1 H2. elim H2. intros H3 H4. elim H4. intros H5 H6.
 elim H6. intros H7 H8.
 elim H8. intros H9 H10.
 exists (Build_bisect_interval lft rht H1 H9 H10).
 simpl in |- *.
 unfold Small in |- *.
 split. auto. split. auto. auto.
Qed.

Definition bisect I : bisect_interval := ProjT1 (Cbisect_exists I).

Lemma bisect_prop : forall I : bisect_interval,
 interval_rht (bisect I) [-]interval_lft (bisect I) [<=] Small[*] (interval_rht I[-]interval_lft I)
 /\ interval_lft I [<=] interval_lft (bisect I) /\ interval_rht (bisect I) [<=] interval_rht I.
Proof.
 intros.
 unfold bisect in |- *.
 apply proj2_sigT.
Qed.

End Bisect_Interval.

Section IVT_Op.

(**
** IVT for operations
Same conventions as before.
*)

Variable f : CSetoid_un_op IR.
Hypothesis f_contin : contin f.
Hypothesis f_apzero_interval :
  forall a b, a [<] b -> {c : IR | a [<=] c /\ c [<=] b | f c [#] [0]}.
Variables a b : IR.
Hypothesis a_b : a [<] b.
Hypothesis f_a : f a [<=] [0].
Hypothesis f_b : [0] [<=] f b.

(* begin hide *)
Let Small : IR := Two [/]ThreeNZ.
(* end hide *)

Fixpoint interval_sequence (n : nat) : bisect_interval f :=
  match n with
  | O   => Build_bisect_interval f a b a_b f_a f_b
  | S m => bisect f f_apzero_interval (interval_sequence m)
  end.

Let a_ (i : nat) := interval_lft _ (interval_sequence i).
Let b_ (i : nat) := interval_rht _ (interval_sequence i).

Lemma intervals_smaller : forall i, b_ i[-]a_ i [<=] Small[^]i[*] (b[-]a).
Proof.
 intros.
 induction  i as [| i Hreci]; intros.
  unfold a_ in |- *. unfold b_ in |- *. simpl in |- *.
  rstepr (b[-]a).
  apply leEq_reflexive.
 apply leEq_transitive with (Small[*] (b_ i[-]a_ i)).
  elim (bisect_prop f f_apzero_interval (interval_sequence i)).
  intros H H0.
  elim H0; intros H1 H2.
  auto.
 simpl in |- *.
 replace (nexp _ i Small) with (Small[^]i). 2: auto.
  rstepr (Small[*] (Small[^]i[*] (b[-]a))).
 apply mult_resp_leEq_lft.
  auto.
 apply less_leEq.
 unfold Small in |- *. apply div_resp_pos. apply pos_three. apply pos_two.
Qed.

Lemma intervals_small'' : forall i : nat, Small[^]i[*]nring i [<=] [1].
Proof.
 intros.
 apply mult_cancel_leEq with (Three[^]i:IR).
  apply nexp_resp_pos. apply pos_three.
  astepr (Three[^]i:IR).
 apply leEq_wdl with (nring i[*]Two[^]i:IR).
  2: rstepr (nring i[*] (Small[^]i[*]Three[^]i)).
  2: astepr (nring i[*] (Small[*]Three) [^]i).
  2: cut (Small[*]Three [=] Two); algebra.
  2: unfold Small in |- *; rational.
 induction  i as [| i Hreci].
  simpl in |- *. astepl ZeroR. apply less_leEq. apply pos_one.
  elim (zerop i); intro y.
  rewrite y. simpl in |- *.
  rstepl (Two:IR). rstepr (Three:IR).
  apply less_leEq. apply two_less_three.
  elim (le_lt_eq_dec _ _ (lt_le_S _ _ y)); intros H0.
  apply mult_cancel_leEq with (nring i:IR).
   astepl (nring 0:IR). apply nring_less. auto.
   apply leEq_wdl with (nring (S i) [*]Two[*] (nring i[*]Two[^]i:IR)).
   2: simpl in |- *; rational.
  apply leEq_wdr with (nring i[*]Three[*]Three[^]i:IR).
   2: simpl in |- *; rational.
  apply leEq_transitive with (nring i[*]Three[*] (nring i[*]Two[^]i:IR)).
   apply mult_resp_leEq_rht.
    simpl in |- *.
    rstepl (nring i[*]Two[+] (Two:IR)).
    rstepr (nring i[*]Two[+] (nring i:IR)).
    apply plus_resp_leEq_lft.
    elim (le_lt_eq_dec _ _ (lt_le_S _ _ H0)); intros H1.
     apply less_leEq. apply nring_less. auto.
     rewrite <- H1. apply leEq_reflexive.
    apply less_leEq. apply mult_resp_pos.
   astepl (nring 0:IR). apply nring_less. auto.
    apply nexp_resp_pos. apply pos_two.
   apply mult_resp_leEq_lft. auto.
   apply less_leEq. apply mult_resp_pos.
  astepl (nring 0:IR). apply nring_less. auto.
   apply pos_three.
 rewrite <- H0.
 rstepl (nring (R:=IR) 8).
 rstepr (nring (R:=IR) 9).
 apply nring_leEq. auto.
Qed.

Lemma intervals_small' : forall eps, [0] [<] eps -> {i : nat | Small[^]i[*] (b[-]a) [<=] eps}.
Proof.
 intros.
 cut (eps [#] [0]). intro H0.
  elim (Archimedes (b[-]a[/] eps[//]H0)). intro i. intros H1. exists i.
  astepr (eps[*][1]).
  apply shift_leEq_mult' with H0. auto.
   apply leEq_transitive with (Small[^]i[*]nring i).
   astepl (Small[^]i[*] (b[-]a[/] eps[//]H0)).
   apply mult_resp_leEq_lft.
    auto.
   apply nexp_resp_nonneg.
   apply less_leEq.
   astepl (ZeroR [/]ThreeNZ). unfold Small in |- *.
   apply div_resp_less_rht. apply pos_two. apply pos_three.
    apply intervals_small''.
 apply Greater_imp_ap. auto.
Qed.

Lemma intervals_small : forall eps, [0] [<] eps -> {i : nat | b_ i [<=] a_ i[+]eps}.
Proof.
 intros eps H.
 elim (intervals_small' eps H). intro i. intros. exists i.
 apply shift_leEq_plus'.
 apply leEq_transitive with (Small[^]i[*] (b[-]a)).
  apply intervals_smaller.
 auto.
Qed.

Lemma Civt_op : {z : IR | a [<=] z /\ z [<=] b /\ f z [=] [0]}.
Proof.
 cut (forall i : nat, a_ i [<=] a_ (S i)). intro H.
  cut (forall i : nat, b_ (S i) [<=] b_ i). intro H0.
   cut (forall i : nat, a_ i [<] b_ i). intro H1.
    cut (forall i : nat, f (a_ i) [<=] [0]). intro H2.
     cut (forall i : nat, [0] [<=] f (b_ i)). intro H3.
      elim (Cnested_intervals_zero a_ b_ H H0 H1 intervals_small f f_contin H2 H3).
      intro z. intro H4. exists z.
      exact H4.
     intros. exact (interval_f_rht _ (interval_sequence i)).
     intros. exact (interval_f_lft _ (interval_sequence i)).
    intros. exact (interval_lft_rht _ (interval_sequence i)).
   intros. elim (bisect_prop f f_apzero_interval (interval_sequence i)).
  intros H0 H1. elim H1. intros H2 H3.
  unfold b_ in |- *. simpl in |- *.
  assumption.
 intros. elim (bisect_prop f f_apzero_interval (interval_sequence i)).
 intros H H0. elim H0. intros H1 H2.
 unfold a_ in |- *. simpl in |- *. auto.
Qed.

End IVT_Op.

Section IVT_Poly.

(**
** IVT for polynomials *)

Lemma Civt_poly : forall f : cpoly_cring IR, f [#] [0] ->
 forall a b, a [<] b -> f ! a [<=] [0] -> [0] [<=] f ! b -> {x : IR | a [<=] x /\ x [<=] b /\ f ! x [=] [0]}.
Proof.
 intros.
 cut ({x : IR | a [<=] x /\ x [<=] b /\ cpoly_csetoid_op _ f x [=] [0]}).
  intro. auto.
  apply Civt_op; auto.
  apply cpoly_op_contin.
 intros.
 change {c : IR | a0 [<=] c /\ c [<=] b0 | f ! c [#] [0]} in |- *.
 apply Cpoly_apzero_interval. auto. auto.
Qed.

End IVT_Poly.