Set Implicit Arguments.
Require Import Prelude.
Require Import InfrastructureFV.
Require Import TLC.LibLogic.
Require Import TLC.LibLN.
(* large portions of this are based on the TLC formalisation of FSub *)

(** ** Preserving size *)
Lemma open_ee_var_preserves_size : forall e x n vk,
    trm_size e = trm_size (open_ee_rec n (trm_fvar vk x) e).
  induction e using trm_ind'; introv; try solve [cbn; try case_if; cbn; eauto].
  cbn.
  - rewrite <- IHe.
    f_equal.
    f_equal.
    unfold map_clause_trms.
    rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* Heq: H cl clin.
    destruct cl.
    unfold clauseTerm.
    apply* Heq.
Qed.

Lemma open_te_var_preserves_size : forall e x n,
    trm_size e = trm_size (open_te_rec n (typ_fvar x) e).
  induction e using trm_ind'; introv; try solve [cbn; try case_if; cbn; eauto].
  - cbn.
    rewrite <- IHe.
    f_equal.
    f_equal.
    unfold map_clause_trms.
    rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* Heq: H cl clin.
    destruct cl.
    unfold clauseTerm.
    apply* Heq.
Qed.

Lemma open_tt_var_preserves_size : forall T X n,
    typ_size T = typ_size (open_tt_rec n (typ_fvar X) T).
  induction T using typ_ind' ; introv; try solve [cbn; try case_if; cbn; eauto].
  - cbn. crush_compare.
  - cbn.
    rewrite List.map_map.
    assert ((List.map typ_size ls) = (List.map (fun x : typ => typ_size (open_tt_rec n0 (typ_fvar X) x)) ls)) as Hmapeq.
    + apply List.map_ext_in.
      rewrite List.Forall_forall in H.
      intros. apply* H.
    + rewrite Hmapeq. auto.
Qed.

(** ** Properties of type substitution in type *)

(** Substitution on indices is identity on well-formed terms. *)

Inductive typ_closed_in_surroundings : nat -> typ -> Prop :=
| closed_typ_bvar : forall J k, J < k -> typ_closed_in_surroundings k (typ_bvar J)
| closed_typ_fvar : forall X k, typ_closed_in_surroundings k (typ_fvar X)
| closed_typ_unit : forall k, typ_closed_in_surroundings k (typ_unit)
| closed_typ_tuple : forall T1 T2 k,
    typ_closed_in_surroundings k T1 ->
    typ_closed_in_surroundings k T2 ->
    typ_closed_in_surroundings k (T1 ** T2)
| closed_typ_arrow : forall T1 T2 k,
    typ_closed_in_surroundings k T1 ->
    typ_closed_in_surroundings k T2 ->
    typ_closed_in_surroundings k (T1 ==> T2)
| closed_typ_all : forall T k,
    typ_closed_in_surroundings (S k) T ->
    typ_closed_in_surroundings k (typ_all T)
| closed_typ_gadt : forall Ts N k,
    List.Forall (typ_closed_in_surroundings k) Ts ->
    typ_closed_in_surroundings k (typ_gadt Ts N).

Lemma opening_adds_one : forall T X k n,
    (* for example, typ_closed_in_surroundings 0 (open_tt_rec 42 (typ_fvar X) (typ_bvar 42))
       which evaluates to typ_fvar X, so it is open in 0
       but
     *)
    typ_closed_in_surroundings n (open_tt_rec k (typ_fvar X) T) ->
    (*
      the original term (typ_bvar 42), is not open in 1, so that's why we need k+1 too
      - this is the case where the maximum binder disappeared in open
      case n+1 is the case where it was some smaller binder and so the other binders get incremented
    *)
    typ_closed_in_surroundings (max (S n) (S k)) T.
  induction T using typ_ind'; introv Hc; try solve [inversions Hc; constructor*].
  - cbn in Hc.
    crush_compare; cbn in *; econstructor; try lia.
    inversions Hc. lia.
  - constructor*.
    inversions Hc.
    rewrite List.Forall_forall in *.
    intros T Hin.
    lets* IH: H T Hin X k n0.
    apply* IH.
    apply* H2.
    apply* List.in_map.
Qed.

Lemma type_closed : forall T,
    type T -> typ_closed_in_surroundings 0 T.
  induction 1; constructor*.
  - pick_fresh X.
    lets* Hoao: opening_adds_one T2 X 0 0.
  - rewrite List.Forall_forall.
    auto.
Qed.

Lemma closed_id : forall T U n k,
    typ_closed_in_surroundings n T ->
    k >= n ->
    T = open_tt_rec k U T.
  induction T using typ_ind'; introv Hc Hk; eauto;
    try solve [
          cbn; crush_compare; inversions Hc; lia
        | cbn; inversions Hc;
          lets* IH1: IHT1 U n k;
          lets* IH2: IHT2 U n k;
          rewrite* <- IH1;
          rewrite* <- IH2
          ].
  - lets* IH: IHT U (S n) (S k).
    cbn. inversions Hc.
    rewrite* <- IH. lia.
  - cbn.
    f_equal.
    inversions Hc.
    rewrite List.Forall_forall in *.
    rewrite <- List.map_id at 1.
    apply List.map_ext_in.
    intros T Hin.
    lets* IH: H Hin.
Qed.

Lemma open_tt_rec_type : forall T U,
  type T -> forall k, T = open_tt_rec k U T.
Proof.
  introv Htype. intros.
  lets* Hc: closed_id T U 0 k.
  apply Hc.
  - apply* type_closed.
  - lia.
Qed.

(* this one describes terms being closed in relation to type-variables, not term-varaibles*)
Inductive te_closed_in_surroundings : nat -> trm -> Prop :=
| closed_trm_bvar : forall i k, te_closed_in_surroundings k (trm_bvar i)
| closed_trm_fvar : forall x vk k, te_closed_in_surroundings k (trm_fvar vk x)
| closed_trm_unit : forall k, te_closed_in_surroundings k (trm_unit)
| closed_trm_fst : forall e k, te_closed_in_surroundings k e -> te_closed_in_surroundings k (trm_fst e)
| closed_trm_snd : forall e k, te_closed_in_surroundings k e -> te_closed_in_surroundings k (trm_snd e)
| closed_trm_tuple : forall e1 e2 k, te_closed_in_surroundings k e1 ->
                                te_closed_in_surroundings k e2 ->
                                te_closed_in_surroundings k (trm_tuple e1 e2)
| closed_trm_abs : forall e T k, te_closed_in_surroundings k e ->
                            typ_closed_in_surroundings k T ->
                            te_closed_in_surroundings k (trm_abs T e)
| closed_trm_app : forall e1 e2 k, te_closed_in_surroundings k e1 ->
                              te_closed_in_surroundings k e2 ->
                              te_closed_in_surroundings k (trm_app e1 e2)
| closed_trm_tabs : forall e k, te_closed_in_surroundings (S k) e ->
                           te_closed_in_surroundings k (trm_tabs e)
| closed_trm_tapp : forall e T k, te_closed_in_surroundings k e ->
                            typ_closed_in_surroundings k T ->
                            te_closed_in_surroundings k (trm_tapp e T)
| closed_trm_fix : forall e T k, te_closed_in_surroundings k e ->
                            typ_closed_in_surroundings k T ->
                            te_closed_in_surroundings k (trm_fix T e)
| closed_trm_let : forall e1 e2 k, te_closed_in_surroundings k e1 ->
                              te_closed_in_surroundings k e2 ->
                              te_closed_in_surroundings k (trm_let e1 e2)
| closed_term_constructor : forall Ts N e k,
    List.Forall (typ_closed_in_surroundings k) Ts ->
    te_closed_in_surroundings k e ->
    te_closed_in_surroundings k (trm_constructor Ts N e)
| closed_term_match : forall G e ms k,
    te_closed_in_surroundings k e ->
    (forall cl, List.In cl ms -> te_closed_in_surroundings (k + clauseArity cl) (clauseTerm cl)) ->
    te_closed_in_surroundings k (trm_matchgadt e G ms)
.

Lemma te_opening_te_adds_one : forall e X k n,
    te_closed_in_surroundings n (open_te_rec k (typ_fvar X) e) ->
    te_closed_in_surroundings (max (S n) (S k)) e.
Proof.
  induction e using trm_ind'; introv Hc; inversions Hc;
    try solve [
          constructor*
        | constructor*; apply* opening_adds_one
        ].
  - constructor*.
    rewrite List.Forall_forall in *.
    intros T Hin.
    apply* opening_adds_one.
    apply* H2.
    unfold open_typlist_rec.
    apply* List.in_map.
  - constructor*.
    introv clin.
    rewrite List.Forall_forall in *.
    lets* IHcl: H clin.
    destruct cl as [clArity clTerm].
    cbn.
    cbn in IHcl.
    assert (Harit: Nat.max n k + clArity = Nat.max (n + clArity) (k + clArity)); try lia.
    rewrite Harit.
    apply IHcl with X.
    lets* IHcl2: H5 (clause clArity (open_te_rec (k + clArity) (typ_fvar X) clTerm)).
    cbn in IHcl2.
    apply* IHcl2.
    apply* List.in_map_iff.
    exists (clause clArity clTerm). eauto.
Qed.

Lemma te_opening_ee_preserves : forall e x vk k n,
    te_closed_in_surroundings n (open_ee_rec k (trm_fvar vk x) e) ->
    te_closed_in_surroundings n e.
  induction e using trm_ind'; introv Hc; try solve [inversions Hc; constructor*].
  - inversions Hc.
    rewrite List.Forall_forall in *.
    constructor*.
    introv clin.
    apply H with x vk (S k); eauto.
    destruct cl as [clA clT].
    lets* Hcl: H5 (clause clA (open_ee_rec (S k) (trm_fvar vk x) clT)).
    cbn in Hcl.
    cbn.
    apply Hcl.
    apply* List.in_map_iff.
    exists (clause clA clT). eauto.
Qed.

Lemma te_opening_te_many_adds : forall As N n e,
    te_closed_in_surroundings n (open_te_many_var As e) ->
    length As = N ->
    te_closed_in_surroundings (N + n) e.
  induction As as [| Ah Ats]; destruct N; introv Hcl Hlen; inversion Hlen.
  - cbn in *. eauto.
  - cbn in Hcl.
    fold (open_te_many_var Ats (e open_te_var Ah)) in Hcl.

    lets IH: IHAts (length Ats) n (e open_te_var Ah).
    assert (Harit2: Nat.max (S (length Ats + n)) (S 0) = (S (length Ats) + n)); try lia.
    rewrite <- Harit2.
    apply te_opening_te_adds_one with Ah.
    fold (e open_te_var Ah).
    apply* IH.
Qed.

Lemma term_te_closed : forall e,
    term e -> te_closed_in_surroundings 0 e.
Proof.
  induction 1; try solve [
                     constructor*
                   | match goal with
                     | H: forall x : var, x \notin ?L ->
                                     te_closed_in_surroundings 0 (open_ee ?e1 (trm_fvar ?vk x))
                                     |- _ =>
                       constructor*; try solve [
                                           pick_fresh X; apply* te_opening_ee_preserves; lets* He: H X
                                         | apply* type_closed]
                     end
                   ].
  - constructor*.
    rewrite List.Forall_forall. intros T Hin.
    apply* type_closed.
  - constructor*.
    pick_fresh X.
    lets* Hopen: te_opening_te_adds_one e1 X 0 0.
  - constructor*. apply* type_closed.
  - constructor*.
    introv clin.
    cbn.
    lets* fresh_alphas: exist_alphas L (clauseArity cl).
    inversion fresh_alphas as [Alphas [Hlen [Hdist Hnotin]]].
    pick_fresh x.
    assert (xfresh: x \notin L); eauto.
    assert (xfreshA: x \notin from_list Alphas); eauto.
    lets hmm: H1 clin Alphas x Hlen Hdist.
    lets hmm2: hmm Hnotin xfresh xfreshA.
    unfold open_ee in hmm2.
    lets hmm3: te_opening_ee_preserves hmm2.
    lets hmm4: te_opening_te_many_adds (clauseArity cl) hmm3.
    assert (Hneutral: forall n, n + 0 = n); try (intro; lia).
    rewrite Hneutral in hmm4.
    apply* hmm4.
Qed.

Lemma te_closed_id : forall e T n k,
    te_closed_in_surroundings n e ->
    k >= n ->
    e = open_te_rec k T e.
Proof.
  induction e using trm_ind'; introv Hc Hk; eauto; inversions Hc; cbn; f_equal;
    try (match goal with
         | IH: forall T n k, ?P1 -> ?P2 -> ?e1 = open_te_rec k T ?e1 |- _ => apply* IH
         end);
    try apply* closed_id;
    try lia.
  - unfold open_typlist_rec.
    rewrite <- List.map_id at 1.
    apply* List.map_ext_in.
    intro U.
    rewrite List.Forall_forall in *.
    lets* HC: H2 U.
    lets*: closed_id U T n k.
  - rewrite <- List.map_id at 1.
    apply* List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    destruct cl as [clA clT].
    f_equal.
    lets* IH: H (clause clA clT) T (n + clA) (k + clA).
    cbn in IH.
    apply* IH.
    + lets* Hcl: H5 (clause clA clT).
    + lia.
Qed.

Lemma open_te_rec_term : forall e U,
  term e -> forall k, e = open_te_rec k U e.
Proof.
  introv Hterm. intros.
  lets* Hc: te_closed_id e U 0 k.
  apply Hc.
  - apply* term_te_closed.
  - lia.
Qed.

Lemma open_ee_rec_term_core : forall e j v u i, i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof.
  induction e using trm_ind'; introv Neq Hopen; simpl in *; inversion Hopen; f_equal*.
  - crush_eq. crush_eq. subst. intuition.
  - rewrite List.Forall_forall in *.
    rewrite List.map_map in H2.
    rewrite <- List.map_id at 1.
    apply* List.map_ext_in.
    intros cl clin.
    lets* Hcleq: ext_in_map H2 clin.
    destruct cl.
    inversion* Hcleq.
    f_equal.
    lets* IH: H clin (S j) (S i).
Qed.

Lemma open_ee_rec_type_core : forall e j V u i,
  open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
  e = open_ee_rec i u e.
Proof.
  induction e using trm_ind'; introv Ho; simpls; inversion Ho; f_equal*.
  - rewrite List.Forall_forall in *.
    rewrite List.map_map in H2.
    rewrite <- List.map_id at 1.
    apply* List.map_ext_in.
    intros cl clin.
    lets* Hcleq: ext_in_map H2 clin.
    destruct cl.
    inversion* Hcleq.
    f_equal.
    lets* IH: H clin (j + clArity) (S i).
Qed.

Lemma open_ee_rec_type_many : forall As k u e,
  open_te_many_var As e =
  open_ee_rec k u (open_te_many_var As e) ->
  e = open_ee_rec k u e.
  induction As as [| Ah Ats]; introv Heq.
  - cbn in Heq. eauto.
  - cbn in Heq.
    fold (open_te_many_var Ats (e open_te_var Ah)) in Heq.
    lets* IH: IHAts k u (e open_te_var Ah) Heq.
    apply* open_ee_rec_type_core.
Qed.

Lemma open_ee_rec_term : forall u e,
  term e -> forall k, e = open_ee_rec k u e.
Proof.
  induction 1; intro k;
    simpl; f_equal*.
  - unfolds open_ee. pick_fresh x.
    apply* (@open_ee_rec_term_core e1 0 (trm_fvar lam_var x)).

  - unfolds open_te.
    pick_fresh X.
    apply* (@open_ee_rec_type_core e1 0 (typ_fvar X)).

  - unfolds open_ee. pick_fresh x.
    apply* (@open_ee_rec_term_core v1 0 (trm_fvar fix_var x)).

  - unfolds open_ee. pick_fresh x.
    apply* (@open_ee_rec_term_core e2 0 (trm_fvar lam_var x)).
  - rewrite <- List.map_id at 1.
    apply List.map_ext_in.
    intros cl clin.
    destruct cl as [clA clT].
    f_equal.

    lets* fresh_alphas: exist_alphas L clA.
    inversion fresh_alphas as [Alphas [Hlen [Hdist Hnotin]]].
    pick_fresh x.
    assert (xfresh: x \notin L); eauto.

    lets* IHcl: H1 clin Alphas x.
    cbn in IHcl.
    lets* IHcl2: IHcl Hlen Hdist Hnotin xfresh.

    assert (Hpart: open_te_many_var Alphas clT =
                   open_ee_rec (S k) u (open_te_many_var Alphas clT)).
    + unfolds open_ee.
      eapply open_ee_rec_term_core.
      2: {
        apply* IHcl2.
      }
      lia.
    + apply* open_ee_rec_type_many.
Qed.

Lemma rewrite_open_tt_many_gadt : forall OTs GTs N,
    open_tt_many OTs (typ_gadt GTs N) =
    typ_gadt (List.map (open_tt_many OTs) GTs) N.
  induction OTs as [| OTh OTt]; introv.
  - cbn. rewrite* List.map_id.
  - cbn.
    assert (List.map (fun T : typ => open_tt_many OTt (open_tt T OTh)) GTs = List.map (open_tt_many OTt) (List.map (open_tt_rec 0 OTh) GTs)).
    + rewrite List.map_map.
      apply* List.map_ext.
    + rewrite H.
      apply IHOTt.
Qed.

Lemma open_tt_many_closed : forall As T,
    type T ->
    open_tt_many As T = T.
  induction As; introv Hcl.
  - cbn. trivial.
  - cbn. unfold open_tt.
    rewrite* <- open_tt_rec_type.
Qed.


(** printing \2/ $\cup$ #∪# *)
(** printing <2= $\subseteq$ #⊆# *)
(** printing forall $\forall$ #∀# *)
(** printing -> $\rightarrow$ #→# *)
(** printing /\ $\land$ #∧# *)

Require Import Setoid Program.
Require Import VST.concurrency.paco.src.paco.

Section safety_equivalence.

  Context
  ( X Y:Type)
  ( halted: X -> Y -> Prop)
  ( int_step: X -> Y -> Y -> Prop)
  ( ext_step: X -> Y -> X -> Y -> Prop)
  ( valid: X -> Y -> Prop).

  Axiom determinism:
    forall x y y',
      valid x y  -> int_step x y y' ->
      forall x',
        valid x' y -> int_step x' y y'.

  Axiom valid_step:
    forall x y y',
      valid x y  -> int_step x y y' ->
      valid x y'.

  Section explicit_safety.

    (** *Normal explicit safety *)
    CoInductive exp_safety (x:X) (y:Y): Prop:=
    | halted_safety : halted x y -> exp_safety x y
    | internal_safety y': int_step x y y'  ->
                          (forall x',  valid x' y' -> exp_safety x' y') ->
                          exp_safety x y
    | external_safety x' y': ext_step x y x' y' ->
                             (forall x',  valid x' y' -> exp_safety x' y') ->
                             exp_safety x y.

    (*Parametrized version*)
    Inductive exp_safety_gen {_exp_safety} (x:X) (y:Y): Prop:=
    | paco_halted_safety : halted x y -> exp_safety_gen x y
    | paco_internal_safety y': int_step x y y'  ->
                               (forall x',  valid x' y' -> _exp_safety x' y') ->
                               exp_safety_gen x y
    | paco_external_safety x' y': ext_step x y x' y' ->
                                  (forall x',  valid x' y' -> _exp_safety x' y') ->
                                  exp_safety_gen x y.
    Definition paco_exp_safety := paco2 (@exp_safety_gen).

    (*Show that the paco representation is correct. *)
    Lemma exp_safety_paco_correct:
      forall x y, exp_safety x y <-> paco_exp_safety bot2 x y.
    Proof.
      intros x y; split; generalize x y; clear x y.
      - pcofix CO; intros x y HH.
        pfold. inversion HH;
          [ econstructor 1; eauto |
            econstructor 2; eauto |
            econstructor 3; eauto ]; intros x'' VAL'.
      - cofix CO; intros x y HH.
        inversion HH. inversion SIM;
          [ econstructor 1; eauto |
            econstructor 2; eauto |
            econstructor 3; eauto ]; intros x'' VAL'; eapply CO.
        + specialize (LE _ _ (H0 _ VAL')).
          destruct LE. 2: compute in *; tauto.
          apply H1.
        + specialize (LE _ _ (H0 _ VAL')).
          destruct LE. 2: compute in *; tauto.
          apply H1.
    Qed.

  End explicit_safety.

  Section explicit_safetyN.
    Inductive stepN x y y': nat -> Prop :=
    | trivial_step: y = y' -> stepN x y y' 0
    | _stepN n _y: int_step x y _y -> stepN x _y y' n -> stepN x y y' (S n).

    (** *Safety with stepN *)
    Inductive exp_safetyN_gen {_exp_safety} (x:X) (y:Y): Prop:=
    | paco_halted_safetyN : halted x y -> exp_safetyN_gen x y
    | paco_internal_safetyN y' n: stepN x y y' (S n)  ->
                                  (forall x',  valid x' y' -> _exp_safety x' y') ->
                                  exp_safetyN_gen x y
    | paco_external_safetyN x' y': ext_step x y x' y' ->
                                   (forall x',  valid x' y' -> _exp_safety x' y') ->
                                   exp_safetyN_gen x y.
    Definition paco_exp_safetyN := paco2 (@exp_safetyN_gen).

    Lemma determinismN:
      forall n,
      forall x y y',
        valid x y  -> stepN x y y' n ->
        forall x',
          valid x' y -> stepN x' y y' n.
    Proof. induction n.
           - intros; econstructor.
             inversion H0; assumption.
           - intros.
             inversion H0; subst.
             econstructor.
             eapply (determinism x y _y); eauto.
             eapply IHn; eauto.
             eapply valid_step; eauto.
             eapply valid_step; eauto.
             eapply (determinism x y _y); eauto.
    Qed.

    Lemma valid_stepN:
      forall n,
      forall x y y',
        valid x y  -> stepN x y y' n ->
        valid x y'.
    Proof. induction n; intros ? ? ? VAL HH; inversion HH; subst.
           - exact VAL.
           - apply (IHn _ _y); try assumption.
             apply (valid_step x y _y VAL H0).
    Qed.

    Lemma safetyN_equivalence:
      forall x y,
        valid x y ->
        paco_exp_safety bot2 x y <-> paco_exp_safetyN bot2 x y.
    Proof.
      intros x y VAL.
      split; generalize x y VAL; clear VAL x y.
      - pcofix CO.
        intros x y VAL HH.
        inversion HH.
        inversion SIM; subst; clear SIM.
        + pfold.
          econstructor 1; eassumption.
        + pfold.
          econstructor 2. apply (_stepN x y y' 0 y'); auto.
          constructor; reflexivity.
          intros x' AA.
          right.
          eapply CO; try assumption.
          specialize (LE _ _ (H0 _ AA)).
          destruct LE. 2: compute in *; tauto.
          unfold paco_exp_safety.
          apply H1.
        + pfold.
          econstructor 3. eauto.
          intros x'0 AA.
          right.
          eapply CO; try assumption.
          specialize (LE _ _ (H0 _ AA)).
          destruct LE. 2: compute in *; tauto.
          unfold paco_exp_safety.
          apply H1.
      - pcofix CO.
        intros x y VAL HH; inversion HH; clear HH.
        inversion SIM; subst; clear SIM.
        + pfold.
          econstructor 1; eassumption.
        + cut (valid x y').
          { intros VAL'.
            assert (LE':= LE).
            specialize (LE _ _ (H0 _ VAL')).
            destruct LE. 2: compute in *; tauto.
            generalize dependent y; generalize x.
            induction n.
            * (*base case*)
              intros ? ? VAL H; inversion H; inversion H4; subst; clear H H4.
              pfold. econstructor 2. eassumption.
              intros x' AA.
              right.
              eapply CO; try assumption.
              specialize (LE' _ _ (H0 _ AA)).
              destruct LE'; [ | compute in *; tauto].
              unfold paco_exp_safetyN.
              apply H.
            * (*inductive step*)
              intros. inversion H; subst; clear H.
              pfold; econstructor 2; eauto.
              intros.
              unfold upaco2.
              left; eapply IHn; eauto.
              eapply (determinismN _ x0 _y y' ) with (x'0:= x'); eauto.
              eapply valid_step; eauto.
          }
          { (*Prove the cut*)
            eapply valid_stepN; eauto.
          }
        + pfold.
          econstructor 3. eauto.
          intros x'0 AA.
          right.
          eapply CO; try assumption.
          specialize (LE _ _ (H0 _ AA)).
          destruct LE. 2: compute in *; tauto.
          unfold paco_exp_safety.
          apply H1.
    Qed.

  End explicit_safetyN.

  Section explicit_safetyN_stutter.

  Context {core_data: Type}
          {core_ord : core_data -> core_data -> Prop}
          (core_ord_wf: well_founded core_ord).

  (** *Safety with Stutter and stepN*)
  CoInductive exp_safetyN_stutter (cd:core_data) (x:X) (y:Y): Prop:=
  | halted_safetyN_stut : halted x y -> exp_safetyN_stutter cd x y
  | internal_safetyN_stut cd' y' n: stepN x y y' (S n)  ->
                            (forall x',  valid x' y' -> exp_safetyN_stutter cd' x' y') ->
                            exp_safetyN_stutter cd x y
  | external_safetyN_stut cd' x' y': ext_step x y x' y' ->
                            (forall x',  valid x' y' -> exp_safetyN_stutter cd' x' y') ->
                            exp_safetyN_stutter cd x y
  | stutter cd': core_ord cd' cd ->
                 exp_safetyN_stutter cd' x y ->
                 exp_safetyN_stutter cd x y.

  (*Paco version*)
  Inductive exp_safetyN_stutter_gen {_exp_safety} (cd:core_data) (x:X) (y:Y): Prop:=
  | paco_halted_safetyN_stut : halted x y -> exp_safetyN_stutter_gen cd x y
  | paco_internal_safetyN_stut cd' y' n: stepN x y y' (S n)  ->
                            (forall x',  valid x' y' -> _exp_safety cd' x' y') ->
                            exp_safetyN_stutter_gen cd x y
  | paco_external_safetyN_stut cd' x' y': ext_step x y x' y' ->
                            (forall x',  valid x' y' -> _exp_safety cd' x' y') ->
                            exp_safetyN_stutter_gen cd x y
  | paco_stutter cd': core_ord cd' cd ->
                 _exp_safety cd' x y ->
                 exp_safetyN_stutter_gen cd x y.
  Definition paco_exp_safetyN_stutter := paco3 (@exp_safetyN_stutter_gen).

  (*Show that the paco representation is correct. *)
  Lemma exp_safetyN_stutter_paco_correct:
    forall cd x y, exp_safetyN_stutter cd x y <-> paco_exp_safetyN_stutter bot3 cd x y.
  Proof.
    intros cd x y; split; generalize cd x y; clear cd x y.
    - pcofix CO; intros cd x y HH.
      pfold. inversion HH;
        [ econstructor 1; eauto |
            econstructor 2; eauto |
            econstructor 3; eauto |
            econstructor 4; eauto ]; intros x'' VAL'.
    - cofix CO; intros cd x y HH.
      inversion HH. inversion SIM;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto |
          econstructor 4; eauto ].
      + intros x'' VAL'; eapply CO.
        specialize (LE _ _ _ (H0 _ VAL')).
        destruct LE. 2: compute in *; tauto.
        apply H1.
      + intros x'' VAL'; eapply CO.
        specialize (LE _ _ _ (H0 _ VAL')).
          destruct LE. 2: compute in *; tauto.
          apply H1.
      + eapply CO .
        specialize (LE _ _ _ (H0)).
        destruct LE. 2: compute in *; tauto.
        apply H1.
  Qed.

  (*The stutter doesn't matter*)
  Lemma speach_therapy:
    forall cd x y,
      paco_exp_safetyN bot2 x y <->
      paco_exp_safetyN_stutter bot3 cd x y.
  Proof.
    intros cd x y.
    split; generalize cd x y; clear cd x y.
    - pcofix CO.
      intros cd x y HH; inversion HH; subst; clear HH.
      pfold.
      inversion SIM;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto ]; intros x0 VAL'.
      + specialize (LE _ _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. apply CO. eapply H1.

      + specialize (LE _ _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. apply CO. eapply H1.
    - pcofix CO.
      intros cd x y HH; pfold.
      generalize cd x y HH; clear HH y x cd.
      (*set up the well formed induction*)
      apply (@well_founded_ind _ core_ord core_ord_wf
                               (fun cd => forall (x : X) (y : Y),
                                      paco_exp_safetyN_stutter bot3 cd x y ->
                                      exp_safetyN_gen x y)); auto.

      (*now do teh cofixpoint induction*)

      intros x wf_ind x' y HH; inversion HH; subst; clear HH.
      inversion SIM; clear SIM;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto |].
      + intros x0 VAL'. specialize (LE _ _ _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. eapply CO. eapply H1.
      + intros x0 VAL'. specialize (LE _ _ _ (H0 _ VAL')).
        destruct LE; [| compute in *; tauto].
        unfold upaco3. right. eapply CO. eapply H1.
      + eapply wf_ind in H; [ exact H|].
        pfold. specialize (LE _ _ _ (H0)).
        destruct LE; [| compute in *; tauto].
        simpl. punfold H1.
        {
          clear.
          unfold monotone3.
          intros.
          inversion IN;
        [ econstructor 1; eauto |
          econstructor 2; eauto |
          econstructor 3; eauto |
          econstructor 4; eauto ]. }
        Grab Existential Variables.
        assumption.
        assumption.
  Qed.
  End explicit_safetyN_stutter.

  Section The_Equivalence.

  Context (core_data: Type)
          (core_ord : core_data -> core_data -> Prop)
          (core_ord_wf: well_founded core_ord)
          (default: core_data).

  Theorem safety_stutter_stepN_equiv:
    forall x y,
      valid x y ->
      exp_safety x y <-> exists cd, @exp_safetyN_stutter _ core_ord cd x y.
  Proof.
    intros x y VAL; split; intros HH.
    - exists default.
      apply exp_safetyN_stutter_paco_correct.
      apply speach_therapy; [assumption|].
      apply safetyN_equivalence; [assumption|].
      apply exp_safety_paco_correct; assumption.
    - destruct HH as [cd HH].
      apply exp_safety_paco_correct.
      apply safetyN_equivalence; [assumption|].
      eapply speach_therapy with (cd0:=cd); [eassumption|].
      apply exp_safetyN_stutter_paco_correct; assumption.
  Qed.

  End The_Equivalence.

End safety_equivalence.


(** * Maps: Total and Partial Maps *)

(* Adapted from the Software Foundations series:
   https://softwarefoundations.cis.upenn.edu/ *)

Require Import
        Coq.Strings.String
        Coq.Lists.List
        Coq.Logic.FunctionalExtensionality.

(* ################################################################# *)
(** * Total Maps *)

Definition total_map (A : Type) := string -> A.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if string_dec x x' then v else m x'.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Definition build_total_map {A} (xs : list string) (l : list A) (a : A) : total_map A :=
  fold_left (fun m xa => t_update m (fst xa) (snd xa)) (combine xs l) (t_empty a).

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  auto.
Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  intros. unfold t_update. now destruct string_dec.
Qed.

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
  intros. unfold t_update. now destruct string_dec.
Qed.

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros. extensionality x'.
  unfold t_update. now destruct string_dec.
Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  intros. extensionality x'.
  unfold t_update. destruct string_dec. congruence. easy.
Qed.

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  intros. extensionality x'.
  unfold t_update. destruct string_dec; destruct string_dec; auto. congruence.
Qed.

Create HintDb maps discriminated.

Hint Resolve
     t_apply_empty t_update_eq t_update_neq
     t_update_shadow t_update_same t_update_permute : maps.

Hint Rewrite
     t_apply_empty t_update_eq t_update_neq
     t_update_shadow t_update_same : maps.

(* ################################################################# *)
(** * Partial maps *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

Notation "x '|->' v" := (update empty x v)
  (at level 100).

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.

Lemma update_inv
  : forall (A : Type) (m : partial_map A) x1 x2 v1 v2,
    (update m x1 v1) x2 = Some v2 ->
    (x1 = x2 /\ v1 = v2) \/ (x1 <> x2 /\ m x2 = Some v2).
Proof.
  unfold update, t_update; intros.
  destruct (string_dec x1 x2);
    try injection H; intros; subst; intuition.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************
    Proof of Bertrand's conjecture: Check128.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)

From Coq Require Import Arith.
From Bertrand Require Export Prime Misc.

(** Check if there is a prime between n and n+m *)

Fixpoint prime_between (n m : nat) {struct m} : bool :=
  if primeb n
  then true
  else match m with
       | O => false
       | S m1 => prime_between (S n) m1
       end.

Theorem prime_between_correct :
 forall n m : nat,
 if prime_between n m
 then exists p : nat, prime p /\ n <= p /\ p <= n + m
 else forall p : nat, n <= p -> p <= n + m -> ~ prime p.
Proof.
intros n m; generalize n; clear n; elim m; clear m; simpl in |- *; auto.
intros n; generalize (primeb_correct n); case (primeb n); auto.
intros H; exists n; repeat (split; auto with arith).
rewrite <- plus_n_O; auto with arith.
intros H p H0 H1; replace p with n; auto with arith.
intros m Rec n; generalize (primeb_correct n); case (primeb n); auto.
intros H; exists n; repeat (split; auto with arith).
intros H; generalize (Rec (S n)); case (prime_between (S n) m);
 auto with arith.
simpl in |- *; rewrite <- plus_n_Sm; intros (p, (H1, (H2, H3))); exists p;
 repeat (split; auto with arith).
simpl in |- *; rewrite <- plus_n_Sm; intros H1 p H2; inversion H2;
 auto with arith.
rewrite <- H0; auto.
Qed.

(** Bertrand's postulate is decidable *)

Theorem postulate_dec :
 forall n : nat,
 {(exists p : nat, prime p /\ n < p /\ p < 2 * n)} +
 {(forall p : nat, n < p -> p < 2 * n -> ~ prime p)}.
Proof.
intros n; case n.
right; simpl in |- *; intros p H1 H2; inversion H2.
intros n1; case n1.
right; simpl in |- *; intros p H1; inversion H1; auto with arith.
intros H2; Contradict H2; auto with arith.
intros H2; inversion H2; auto with arith.
inversion H4; auto.
inversion H6.
intros n2; generalize (prime_between_correct (S (S (S n2))) n2);
 case (prime_between (S (S (S n2))) n2).
intros H0; left; case H0; intros p (H1, (H2, H3)); exists p;
 repeat (split; auto with arith).
simpl in |- *; repeat rewrite <- plus_n_Sm || rewrite <- plus_n_O;
 auto with arith.
intros H0; right; intros p H1 H2; apply H0; auto with arith.
generalize H2; simpl in |- *;
 repeat rewrite <- plus_n_Sm || rewrite <- plus_n_O;
 auto with arith.
Qed.

(** Check the postulate from 2 to n *)

Fixpoint check_postulate (n : nat) : bool :=
  match n with
  | O => true
  | S n1 =>
      match n1 with
      | O => true
      | S n2 =>
          match prime_between (S n) n2 with
          | true => check_postulate n1
          | false => false
          end
      end
  end.

Theorem check_postulate_correct :
 forall m : nat,
 check_postulate m = true ->
 forall n : nat,
 2 <= n -> n <= m -> exists p : nat, prime p /\ n < p /\ p < 2 * n.
Proof.
intros m; elim m; simpl in |- *; auto.
intros H n H0 H1; generalize H0; inversion H1; auto.
intros H3; inversion H3.
clear m; intros m; case m; clear m.
intros H H0 n; case n; auto with arith.
intros n1; case n1; auto with arith.
intros n0 H1 H2; inversion H2.
inversion H4.
intros n H;
 (generalize (prime_between_correct (S (S (S n))) n);
   case (prime_between (S (S (S n))) n)).
intros H0 H1 n0 H2 H3; inversion H3; auto with arith.
case H0; auto; intros p1 (H5, (H6, H7));
 (exists p1; repeat (split; auto with arith)).
repeat rewrite <- plus_n_Sm || rewrite <- plus_n_O; auto with arith.
intros; discriminate.
Qed.

(** Check the postulate from 1 to 128 *)

Theorem postulate_correct_128 :
 forall n : nat,
 2 <= n -> n <= power 2 7 -> exists p : nat, prime p /\ n < p /\ p < 2 * n.
Proof.
apply check_postulate_correct.
vm_compute;reflexivity.
Qed.


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

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

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo.
Require Import R_sqrt.
Open Local Scope R_scope.

Lemma tan_PI : tan PI = 0.
Proof.
  unfold tan in |- *; rewrite sin_PI; rewrite cos_PI; unfold Rdiv in |- *;
    apply Rmult_0_l.
Qed.

Lemma sin_3PI2 : sin (3 * (PI / 2)) = -1.
Proof.
  replace (3 * (PI / 2)) with (PI + PI / 2).
  rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; rewrite sin_PI2; ring.
  pattern PI at 1 in |- *; rewrite (double_var PI); ring.
Qed.

Lemma tan_2PI : tan (2 * PI) = 0.
Proof.
  unfold tan in |- *; rewrite sin_2PI; unfold Rdiv in |- *; apply Rmult_0_l.
Qed.

Lemma sin_cos_PI4 : sin (PI / 4) = cos (PI / 4).
Proof with trivial.
  rewrite cos_sin...
  replace (PI / 2 + PI / 4) with (- (PI / 4) + PI)...
  rewrite neg_sin; rewrite sin_neg; ring...
  cut (PI = PI / 2 + PI / 2); [ intro | apply double_var ]...
  pattern PI at 2 3 in |- *; rewrite H; pattern PI at 2 3 in |- *; rewrite H...
  assert (H0 : 2 <> 0);
    [ discrR | unfold Rdiv in |- *; rewrite Rinv_mult_distr; try ring ]...
Qed.

Lemma sin_PI3_cos_PI6 : sin (PI / 3) = cos (PI / 6).
Proof with trivial.
  replace (PI / 6) with (PI / 2 - PI / 3)...
  rewrite cos_shift...
  assert (H0 : 6 <> 0); [ discrR | idtac ]...
  assert (H1 : 3 <> 0); [ discrR | idtac ]...
  assert (H2 : 2 <> 0); [ discrR | idtac ]...
  apply Rmult_eq_reg_l with 6...
  rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
  unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
  rewrite <- Rinv_l_sym...
  rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
  pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
  ring...
Qed.

Lemma sin_PI6_cos_PI3 : cos (PI / 3) = sin (PI / 6).
Proof with trivial.
  replace (PI / 6) with (PI / 2 - PI / 3)...
  rewrite sin_shift...
  assert (H0 : 6 <> 0); [ discrR | idtac ]...
  assert (H1 : 3 <> 0); [ discrR | idtac ]...
  assert (H2 : 2 <> 0); [ discrR | idtac ]...
  apply Rmult_eq_reg_l with 6...
  rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
  unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
  rewrite <- Rinv_l_sym...
  rewrite (Rmult_comm (/ 3)); repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym...
  pattern PI at 2 in |- *; rewrite (Rmult_comm PI); repeat rewrite Rmult_1_r;
    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
  ring...
Qed.

Lemma PI6_RGT_0 : 0 < PI / 6.
Proof.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
Qed.

Lemma PI6_RLT_PI2 : PI / 6 < PI / 2.
Proof.
  unfold Rdiv in |- *; apply Rmult_lt_compat_l.
  apply PI_RGT_0.
  apply Rinv_lt_contravar; prove_sup.
Qed.

Lemma sin_PI6 : sin (PI / 6) = 1 / 2.
Proof with trivial.
  assert (H : 2 <> 0); [ discrR | idtac ]...
  apply Rmult_eq_reg_l with (2 * cos (PI / 6))...
  replace (2 * cos (PI / 6) * sin (PI / 6)) with
  (2 * sin (PI / 6) * cos (PI / 6))...
  rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3)...
  rewrite sin_PI3_cos_PI6...
  unfold Rdiv in |- *; rewrite Rmult_1_l; rewrite Rmult_assoc;
    pattern 2 at 2 in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
      rewrite <- Rinv_l_sym...
  rewrite Rmult_1_r...
  unfold Rdiv in |- *; rewrite Rinv_mult_distr...
  rewrite (Rmult_comm (/ 2)); rewrite (Rmult_comm 2);
    repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
  rewrite Rmult_1_r...
  discrR...
  ring...
  apply prod_neq_R0...
  cut (0 < cos (PI / 6));
    [ intro H1; auto with real
      | apply cos_gt_0;
        [ apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)
          | apply PI6_RLT_PI2 ] ]...
Qed.

Lemma sqrt2_neq_0 : sqrt 2 <> 0.
Proof.
  assert (Hyp : 0 < 2);
    [ prove_sup0
      | generalize (Rlt_le 0 2 Hyp); intro H1; red in |- *; intro H2;
        generalize (sqrt_eq_0 2 H1 H2); intro H; absurd (2 = 0);
          [ discrR | assumption ] ].
Qed.

Lemma R1_sqrt2_neq_0 : 1 / sqrt 2 <> 0.
Proof.
  generalize (Rinv_neq_0_compat (sqrt 2) sqrt2_neq_0); intro H;
    generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H);
      intro H0; assumption.
Qed.

Lemma sqrt3_2_neq_0 : 2 * sqrt 3 <> 0.
Proof.
  apply prod_neq_R0;
    [ discrR
      | assert (Hyp : 0 < 3);
        [ prove_sup0
          | generalize (Rlt_le 0 3 Hyp); intro H1; red in |- *; intro H2;
            generalize (sqrt_eq_0 3 H1 H2); intro H; absurd (3 = 0);
              [ discrR | assumption ] ] ].
Qed.

Lemma Rlt_sqrt2_0 : 0 < sqrt 2.
Proof.
  assert (Hyp : 0 < 2);
    [ prove_sup0
      | generalize (sqrt_positivity 2 (Rlt_le 0 2 Hyp)); intro H1; elim H1;
        intro H2;
          [ assumption
            | absurd (0 = sqrt 2);
              [ apply (sym_not_eq (A:=R)); apply sqrt2_neq_0 | assumption ] ] ].
Qed.

Lemma Rlt_sqrt3_0 : 0 < sqrt 3.
Proof.
  cut (0%nat <> 1%nat);
    [ intro H0; assert (Hyp : 0 < 2);
      [ prove_sup0
        | generalize (Rlt_le 0 2 Hyp); intro H1; assert (Hyp2 : 0 < 3);
          [ prove_sup0
            | generalize (Rlt_le 0 3 Hyp2); intro H2;
              generalize (lt_INR_0 1 (neq_O_lt 1 H0));
                unfold INR in |- *; intro H3;
                  generalize (Rplus_lt_compat_l 2 0 1 H3);
                    rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3;
                      [ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3;
                        apply (Rlt_trans 0 (sqrt 2) (sqrt 3) Rlt_sqrt2_0 H3)
                        | ring ] ] ]
      | discriminate ].
Qed.

Lemma PI4_RGT_0 : 0 < PI / 4.
Proof.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
Qed.

Lemma cos_PI4 : cos (PI / 4) = 1 / sqrt 2.
Proof with trivial.
  apply Rsqr_inj...
  apply cos_ge_0...
  left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 4) _PI2_RLT_0 PI4_RGT_0)...
  left; apply PI4_RLT_PI2...
  left; apply (Rmult_lt_0_compat 1 (/ sqrt 2))...
  prove_sup...
  apply Rinv_0_lt_compat; apply Rlt_sqrt2_0...
  rewrite Rsqr_div...
  rewrite Rsqr_1; rewrite Rsqr_sqrt...
  assert (H : 2 <> 0); [ discrR | idtac ]...
  unfold Rsqr in |- *; pattern (cos (PI / 4)) at 1 in |- *;
    rewrite <- sin_cos_PI4;
      replace (sin (PI / 4) * cos (PI / 4)) with
      (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4)))...
  rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2)...
  rewrite sin_PI2...
  apply Rmult_1_r...
  unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr...
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
  rewrite Rmult_1_r...
  unfold Rdiv in |- *; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc...
  rewrite <- Rinv_l_sym...
  rewrite Rmult_1_l...
  left; prove_sup...
  apply sqrt2_neq_0...
Qed.

Lemma sin_PI4 : sin (PI / 4) = 1 / sqrt 2.
Proof.
  rewrite sin_cos_PI4; apply cos_PI4.
Qed.

Lemma tan_PI4 : tan (PI / 4) = 1.
Proof.
  unfold tan in |- *; rewrite sin_cos_PI4.
  unfold Rdiv in |- *; apply Rinv_r.
  change (cos (PI / 4) <> 0) in |- *; rewrite cos_PI4; apply R1_sqrt2_neq_0.
Qed.

Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2.
Proof with trivial.
  replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
  rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4...
  unfold Rdiv in |- *; rewrite Ropp_mult_distr_l_reverse...
  unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
    rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
      repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
        [ ring | discrR | discrR ]...
Qed.

Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2.
Proof with trivial.
  replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
  rewrite sin_shift; rewrite cos_neg; rewrite cos_PI4...
  unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
    rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
      repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
        [ ring | discrR | discrR ]...
Qed.

Lemma cos_PI6 : cos (PI / 6) = sqrt 3 / 2.
Proof with trivial.
  apply Rsqr_inj...
  apply cos_ge_0...
  left; apply (Rlt_trans (- (PI / 2)) 0 (PI / 6) _PI2_RLT_0 PI6_RGT_0)...
  left; apply PI6_RLT_PI2...
  left; apply (Rmult_lt_0_compat (sqrt 3) (/ 2))...
  apply Rlt_sqrt3_0...
  apply Rinv_0_lt_compat; prove_sup0...
  assert (H : 2 <> 0); [ discrR | idtac ]...
  assert (H1 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
  rewrite Rsqr_div...
  rewrite cos2; unfold Rsqr in |- *; rewrite sin_PI6; rewrite sqrt_def...
  unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
  rewrite Rmult_minus_distr_l; rewrite (Rmult_comm 3);
    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
  rewrite Rmult_1_l; rewrite Rmult_1_r...
  rewrite <- (Rmult_comm (/ 2)); repeat rewrite <- Rmult_assoc...
  rewrite <- Rinv_l_sym...
  rewrite Rmult_1_l; rewrite <- Rinv_r_sym...
  ring...
  left; prove_sup0...
Qed.

Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3.
Proof.
  unfold tan in |- *; rewrite sin_PI6; rewrite cos_PI6; unfold Rdiv in |- *;
    repeat rewrite Rmult_1_l; rewrite Rinv_mult_distr.
  rewrite Rinv_involutive.
  rewrite (Rmult_comm (/ 2)); rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  apply Rmult_1_r.
  discrR.
  discrR.
  red in |- *; intro; assert (H1 := Rlt_sqrt3_0); rewrite H in H1;
    elim (Rlt_irrefl 0 H1).
  apply Rinv_neq_0_compat; discrR.
Qed.

Lemma sin_PI3 : sin (PI / 3) = sqrt 3 / 2.
Proof.
  rewrite sin_PI3_cos_PI6; apply cos_PI6.
Qed.

Lemma cos_PI3 : cos (PI / 3) = 1 / 2.
Proof.
  rewrite sin_PI6_cos_PI3; apply sin_PI6.
Qed.

Lemma tan_PI3 : tan (PI / 3) = sqrt 3.
Proof.
  unfold tan in |- *; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv in |- *;
    rewrite Rmult_1_l; rewrite Rinv_involutive.
  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  apply Rmult_1_r.
  discrR.
  discrR.
Qed.

Lemma sin_2PI3 : sin (2 * (PI / 3)) = sqrt 3 / 2.
Proof.
  rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3;
    unfold Rdiv in |- *; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2));
      repeat rewrite <- Rmult_assoc; rewrite double_var;
        reflexivity.
Qed.

Lemma cos_2PI3 : cos (2 * (PI / 3)) = -1 / 2.
Proof with trivial.
  assert (H : 2 <> 0); [ discrR | idtac ]...
  assert (H0 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
  rewrite double; rewrite cos_plus; rewrite sin_PI3; rewrite cos_PI3;
    unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
  rewrite Rmult_minus_distr_l; repeat rewrite Rmult_assoc;
    rewrite (Rmult_comm 2)...
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
  rewrite Rmult_1_r; rewrite <- Rinv_r_sym...
  pattern 2 at 4 in |- *; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym...
  rewrite Rmult_1_r; rewrite Ropp_mult_distr_r_reverse; rewrite Rmult_1_r...
  rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
  rewrite Rmult_1_r; rewrite (Rmult_comm 2); rewrite (Rmult_comm (/ 2))...
  repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
  rewrite Rmult_1_r; rewrite sqrt_def...
  ring...
  left; prove_sup...
Qed.

Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3.
Proof with trivial.
  assert (H : 2 <> 0); [ discrR | idtac ]...
  unfold tan in |- *; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv in |- *;
    rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
      rewrite <- Ropp_inv_permute...
  rewrite Rinv_involutive...
  rewrite Rmult_assoc; rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_l_sym...
  ring...
  apply Rinv_neq_0_compat...
Qed.

Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2.
Proof with trivial.
  replace (5 * (PI / 4)) with (PI / 4 + PI)...
  rewrite neg_cos; rewrite cos_PI4; unfold Rdiv in |- *;
    rewrite Ropp_mult_distr_l_reverse...
  pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
    rewrite double_var; assert (H : 2 <> 0);
      [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
Qed.

Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2.
Proof with trivial.
  replace (5 * (PI / 4)) with (PI / 4 + PI)...
  rewrite neg_sin; rewrite sin_PI4; unfold Rdiv in |- *;
    rewrite Ropp_mult_distr_l_reverse...
  pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
    rewrite double_var; assert (H : 2 <> 0);
      [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
Qed.

Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)).
Proof.
  rewrite cos_5PI4; rewrite sin_5PI4; reflexivity.
Qed.

Lemma Rgt_3PI2_0 : 0 < 3 * (PI / 2).
Proof.
  apply Rmult_lt_0_compat;
    [ prove_sup0
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ] ].
Qed.

Lemma Rgt_2PI_0 : 0 < 2 * PI.
Proof.
  apply Rmult_lt_0_compat; [ prove_sup0 | apply PI_RGT_0 ].
Qed.

Lemma Rlt_PI_3PI2 : PI < 3 * (PI / 2).
Proof.
  generalize PI2_RGT_0; intro H1;
    generalize (Rplus_lt_compat_l PI 0 (PI / 2) H1);
      replace (PI + PI / 2) with (3 * (PI / 2)).
  rewrite Rplus_0_r; intro H2; assumption.
  pattern PI at 2 in |- *; rewrite double_var; ring.
Qed.

Lemma Rlt_3PI2_2PI : 3 * (PI / 2) < 2 * PI.
Proof.
  generalize PI2_RGT_0; intro H1;
    generalize (Rplus_lt_compat_l (3 * (PI / 2)) 0 (PI / 2) H1);
      replace (3 * (PI / 2) + PI / 2) with (2 * PI).
  rewrite Rplus_0_r; intro H2; assumption.
  rewrite double; pattern PI at 1 2 in |- *; rewrite double_var; ring.
Qed.

(***************************************************************)
(** Radian -> Degree | Degree -> Radian                        *)
(***************************************************************)

Definition plat : R := 180.
Definition toRad (x:R) : R := x * PI * / plat.
Definition toDeg (x:R) : R := x * plat * / PI.

Lemma rad_deg : forall x:R, toRad (toDeg x) = x.
Proof.
  intro; unfold toRad, toDeg in |- *;
    replace (x * plat * / PI * PI * / plat) with
    (x * (plat * / plat) * (PI * / PI)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym.
  ring.
  apply PI_neq0.
  unfold plat in |- *; discrR.
Qed.

Lemma toRad_inj : forall x y:R, toRad x = toRad y -> x = y.
Proof.
  intros; unfold toRad in H; apply Rmult_eq_reg_l with PI.
  rewrite <- (Rmult_comm x); rewrite <- (Rmult_comm y).
  apply Rmult_eq_reg_l with (/ plat).
  rewrite <- (Rmult_comm (x * PI)); rewrite <- (Rmult_comm (y * PI));
    assumption.
  apply Rinv_neq_0_compat; unfold plat in |- *; discrR.
  apply PI_neq0.
Qed.

Lemma deg_rad : forall x:R, toDeg (toRad x) = x.
Proof.
  intro x; apply toRad_inj; rewrite (rad_deg (toRad x)); reflexivity.
Qed.

Definition sind (x:R) : R := sin (toRad x).
Definition cosd (x:R) : R := cos (toRad x).
Definition tand (x:R) : R := tan (toRad x).

Lemma Rsqr_sin_cos_d_one : forall x:R, Rsqr (sind x) + Rsqr (cosd x) = 1.
Proof.
  intro x; unfold sind in |- *; unfold cosd in |- *; apply sin2_cos2.
Qed.

(***************************************************)
(**               Other properties                 *)
(***************************************************)

Lemma sin_lb_ge_0 : forall a:R, 0 <= a -> a <= PI / 2 -> 0 <= sin_lb a.
Proof.
  intros; case (Rtotal_order 0 a); intro.
  left; apply sin_lb_gt_0; assumption.
  elim H1; intro.
  rewrite <- H2; unfold sin_lb in |- *; unfold sin_approx in |- *;
    unfold sum_f_R0 in |- *; unfold sin_term in |- *;
      repeat rewrite pow_ne_zero.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
    repeat rewrite Rplus_0_r; right; reflexivity.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  elim (Rlt_irrefl 0 (Rle_lt_trans 0 a 0 H H2)).
Qed.


Require Import util stability.
Require Export CRsign.
Require Export CRln.
Require Import CRexp.
Require Import QMinMax.
Require Import Morphisms.

Set Implicit Arguments.
Open Local Scope CR_scope.

Definition deci: Qpos := (1#10)%Qpos.
Definition centi: Qpos := (1#100)%Qpos.
Definition milli: Qpos := (1#1000)%Qpos.

Program Definition overestimate_CRnonNeg eps r: overestimation (CRnonNeg r) :=
  if Qle_total (- (2) * QposAsQ eps) (approximate r (Qpos2QposInf eps)) then true else false.
Next Obligation.
  intro.
  pose proof (H1 eps).
  set (ax := approximate r eps) in *.
  clear H0. clear H1.
  apply (Qlt_not_le (-(2)*eps) (-eps)).
    change (-eps)%Q with (- (1)%positive * eps)%Q.
    apply Qmult_lt_compat_r.
      destruct eps.
      assumption.
    compute; trivial.
  apply Qle_trans with ax; trivial.
Defined.

Definition overestimate_CRle eps x y: overestimation (CRle x y) := overestimate_CRnonNeg eps (y - x).

Lemma CRadd_0_r x: x + 0 == x.
  intros.
  rewrite (Radd_comm CR_ring_theory).
  apply (Radd_0_l CR_ring_theory).
Qed. (* todo: generalize to arbitrary ring. *)

Lemma add_both_sides x y: x == y -> forall z, x+z == y+z.
Proof. intros. rewrite H. reflexivity. Qed.

Lemma diff_zero_eq x y: x - y == 0 -> x == y.
Proof.
  intros.
  set (add_both_sides H y).
  rewrite (Radd_0_l CR_ring_theory) in s.
  rewrite <- (Radd_assoc CR_ring_theory) in s.
  rewrite (Radd_comm CR_ring_theory (-y)) in s.
  rewrite (Ropp_def CR_ring_theory) in s.
  rewrite (Radd_comm CR_ring_theory) in s.
  rewrite (Radd_0_l CR_ring_theory) in s.
  assumption.
Qed.

Lemma CRminus_zero x: x - 0 == x.
Proof with auto.
  intros.
  rewrite CRopp_Qopp.
  replace ((-0)%Q) with 0%Q...
  rewrite (Radd_comm CR_ring_theory).
  apply (Radd_0_l CR_ring_theory).
Qed.

Lemma inject_Q_le x y: (x <= y)%Q -> 'x <= 'y.
Proof. intros. apply (CRle_Qle x y). assumption. Qed.

Lemma CRlt_trans x y z: x < y -> y < z -> x < z.
Proof. apply (cof_proof CRasCOrdField). Qed.

Lemma positive_CRpos (q: positive): CRpos ('q).
Proof.
  unfold CRpos.
  exists (QposMake q 1).
  apply CRle_refl.
Defined.

Lemma Qpos_CRpos (q: Qpos): CRpos ('q).
  unfold CRpos.
  exists q. apply CRle_refl.
Defined.

Lemma CRnonNeg_nonPos x: CRnonNeg x -> CRnonPos (-x).
  unfold CRnonNeg.
  unfold CRnonPos.
  intros.
  simpl.
  rewrite <- (Qopp_opp e).
  apply Qopp_le_compat.
  apply H.
Qed.

Lemma CRnonNeg_le_zero x: CRnonNeg x <-> 0 <= x.
Proof with auto.
  unfold CRle.
  split; intro; apply (CRnonNeg_wd (CRminus_zero x))...
Qed.

Lemma CRnonNeg_zero: CRnonNeg 0.
Proof. apply (CRnonNeg_le_zero 0). apply CRle_refl. Qed.
  (* a much more direct proof should be possible, but we don't care,
   because this is in Prop, anyway. *)

Lemma t3: Setoid_Theory CR (@st_eq _).
  unfold Setoid_Theory.
  apply (CSetoid_eq_Setoid (csg_crr CRasCField)).
Qed.

Lemma diff_opp x y: x - y == -(y - x).
Proof.
  rewrite (@Ropp_add _ _ _ _ _ _ _ _ t3 CR_ring_eq_ext CR_ring_theory ).
  rewrite (@Ropp_opp _ _ _ _ _ _ _ _ t3 CR_ring_eq_ext CR_ring_theory).
  apply (Radd_comm CR_ring_theory).
Qed.

Lemma Qmult_inv (x: Q) (y: positive): (x == y -> x * (1 # y) == 1)%Q.
Proof with auto.
  intros. rewrite H.
  unfold Qeq. simpl. repeat rewrite Pmult_1_r. ref.
Qed.

Lemma QposAsQ_Qpos_plus x y: QposAsQ (Qpos_plus x y) = (QposAsQ x + QposAsQ y)%Q.
  reflexivity.
Qed.

Lemma CRle_le_eq x y: x <= y -> y <= x -> x == y.
Proof with auto.
  unfold CRle.
  intros.
  set (CRnonNeg_nonPos H0).
  clearbody c.
  assert (CRnonPos (y - x)).
    rewrite diff_opp.
    assumption.
  clear c. clear H0.
  symmetry.
  apply diff_zero_eq.
  unfold st_eq.
  simpl.
  apply regFunEq_e.
  unfold CRnonNeg in H. unfold CRnonPos in H1.
  intros.
  simpl approximate at 2.
  unfold ball.
  unfold Qmetric.Q_as_MetricSpace at 1.
  unfold Qmetric.Qball.
  unfold Qminus.
  replace ((-0)%Q) with 0%Q...
  rewrite (Radd_comm Qsrt).
  rewrite (Radd_0_l Qsrt).
  set (H e). set (H1 e). clearbody q q0. clear H H1.
  unfold AbsSmall.
  set (@approximate Qmetric.Q_as_MetricSpace (y - x)%CR e) in *.
  clearbody s.
  simpl.
  assert ((e <= (e + e)%Qpos)%Q).
    rewrite QposAsQ_Qpos_plus.
    apply Qle_trans with ((e + 0)%Q).
      rewrite (Radd_comm Qsrt).
      rewrite (Radd_0_l Qsrt).
      apply Qle_refl.
    apply Qplus_le_compat.
      apply Qle_refl.
    apply Qpos_nonneg.
  split.
    apply Qle_trans with ((-e)%Q)...
    apply Qopp_le_compat.
    assumption.
  apply Qle_trans with e...
Qed.

Lemma CRlt_le x y: x < y -> x <= y.
Proof.
  intros.
  destruct (def_leEq _ _ _ _ _ CRisCOrdField x y).
  apply H1.
  intro.
  destruct (ax_less_strorder _ _  _ _ _ CRisCOrdField).
  apply (so_asym x y); assumption.
Qed.

Lemma t1 (x y z: CR): x < y -> x+z < y+z.
Proof.
  set (ax_plus_resp_less _ _ _ _ _ CRisCOrdField).
  simpl in c.
  intros.
  apply c.
  assumption.
Qed.

Lemma CRlt_wd (x y: CR): x < y ->
  forall x' y', x==x'->y==y'->x'<y'.
Proof.
  intros [q H] x' y' A B.
  exists q.
  rewrite <- A, <- B.
  assumption.
Qed.

Lemma t1_rev (x y z: CR): x < y -> z+x < z+y.
Proof with auto.
  intros.
  cut (x + z < y + z).
   intro A.
   apply (CRlt_wd A); apply CRplus_comm.
  apply t1...
Qed.

Lemma t4 (q: Qpos): 0 <= 'q.
Proof.
  intros.
  destruct (CRle_Qle 0 q).
  apply H0.
  apply Qpos_nonneg.
Qed.

Lemma Qadd_both_sides x y: (x == y -> forall z, x+z == y+z)%Q.
Proof. intros. rewrite H. reflexivity. Qed.

Lemma Qbla (x y: Q): (-(x * y) == -x * y)%Q.
  intros.
  symmetry.
  rewrite <- (Qplus_0_l (-(x * y))).
  rewrite <- (Qplus_0_l (-x * y)).
  rewrite <- (Qplus_opp_r (x * y)) at 1.
  rewrite <- Qplus_assoc.
  rewrite (Qplus_comm (-(x*y))).
  rewrite Qplus_assoc.
  apply Qadd_both_sides.
  rewrite <- Qmult_plus_distr_l.
  rewrite Qplus_opp_r.
  apply Qmult_0_l.
Qed.

Lemma Qpositive_ne_0 (x: positive): ~(x == 0)%Q.
Proof.
  intro A.
  inversion A.
Qed.

Lemma Qbla4 (x: positive): (x # x == 1)%Q.
  intros.
  rewrite Qmake_Qdiv.
  apply Qmult_inv_r.
  apply Qpositive_ne_0.
Qed.

Lemma Qhalves_add_to_1: ((1#2) + (1#2) == 1)%Q.
Proof. compute. reflexivity. Qed.

Lemma t10 (x y: CR): CRnonNeg x -> CRnonNeg y -> CRnonNeg (x + y).
Proof with auto.
  unfold CRnonNeg.
  intros.
  simpl.
  unfold Cap_raw.
  simpl.
  apply Qle_trans with ((-((1#2)*e)%Qpos + -((1#2)*e)%Qpos)%Q).
    rewrite Q_Qpos_mult.
    rewrite Qbla.
    rewrite <- Qmult_plus_distr_l.
    rewrite <- Qopp_plus.
    rewrite Qhalves_add_to_1.
    rewrite <- Qbla.
    rewrite Qmult_1_l.
    apply Qle_refl.
  apply Qplus_le_compat...
Qed.

Lemma Zero_CRasIR: [0] [=] CRasIR 0.
  cut ([0] [=] CRasIR (IRasCR [0])).
    intro.
    rewrite H.
    apply CRasIR_wd, IR_Zero_as_CR.
  symmetry. apply IRasCRasIR_id.
Qed.

Lemma CRnonNeg_mult x y: CRnonNeg x -> CRnonNeg y -> CRnonNeg (x * y).
Proof with auto.
  intros.
  apply <- CRnonNeg_le_zero.
  rewrite <- IR_Zero_as_CR.
  rewrite <- (CRasIRasCR_id x).
  rewrite <- (CRasIRasCR_id y).
  rewrite <- IR_mult_as_CR.
  apply -> IR_leEq_as_CR.
  apply mult_resp_nonneg.
    rewrite Zero_CRasIR.
    apply <- IR_leEq_as_CR.
    do 2 rewrite CRasIRasCR_id.
    apply -> CRnonNeg_le_zero...
  rewrite Zero_CRasIR.
  apply <- IR_leEq_as_CR.
  do 2 rewrite CRasIRasCR_id.
  apply -> CRnonNeg_le_zero...
Qed.

Lemma t11 x y: y == x + (y - x).
  intros.
  rewrite (Radd_comm CR_ring_theory y).
  rewrite (Radd_assoc CR_ring_theory).
  rewrite (Ropp_def CR_ring_theory).
  symmetry.
  apply (Radd_0_l CR_ring_theory).
Qed.

Lemma CRmult_0_l x: 0 * x == 0.
Proof @Rmul_0_l _ _ _ _ _ _ _ _ t3 CR_ring_eq_ext CR_ring_theory x.

Lemma CRmult_comm x y: x * y == y * x.
Proof Rmul_comm CR_ring_theory x y.

Lemma CRmult_0_r x: x * 0 == 0.
Proof. rewrite CRmult_comm. apply CRmult_0_l. Qed.

Lemma t9 (x y x' y': CR): x <= x' -> y <= y' -> x+y <= x'+y'.
Proof with auto.
  unfold CRle.
  intros.
  rewrite <- (Radd_assoc CR_ring_theory x').
  rewrite (@Ropp_add _ _ _ _ _ _ _ _ t3
    CR_ring_eq_ext CR_ring_theory ).
  rewrite (Radd_assoc CR_ring_theory y').
  rewrite (Radd_comm CR_ring_theory y').
  rewrite <- (Radd_assoc CR_ring_theory (-x)).
  rewrite (Radd_assoc CR_ring_theory x').
  apply t10...
Qed.

Lemma t2 (x y z: CR): x <= y -> x+z <= y+z.
Proof.
  unfold CRle.
  intros.
  set (@Ropp_add CR 0 1 CRplus CRmult
    (fun x y : CR => x - y) CRopp (@st_eq CR) t3
    CR_ring_eq_ext CR_ring_theory).
  rewrite <- (Radd_assoc CR_ring_theory y).
  rewrite (Radd_comm CR_ring_theory x).
  rewrite s.
  rewrite (Radd_assoc CR_ring_theory z).
  rewrite (Ropp_def CR_ring_theory).
  rewrite (Radd_0_l CR_ring_theory).
  assumption.
Qed.

Lemma t8 x y: x <= y -> -y <= -x.
Proof.
  unfold CRle.
  intros.
  set (s := @Ropp_opp _ _ _ _ _ _ _ _ t3 CR_ring_eq_ext CR_ring_theory).
  rewrite s.
  rewrite (Radd_comm CR_ring_theory).
  assumption.
Qed.

Lemma CRlt_opp_compat x y: x < y -> -y < -x.
  unfold CRlt.
  unfold CRpos.
  intros.
  destruct H.
  exists x0.
  rewrite (@Ropp_opp _ _ _ _ _ _ _ _ t3 CR_ring_eq_ext CR_ring_theory).
  rewrite (Radd_comm CR_ring_theory).
  assumption.
Qed.

Lemma CRopp_mult_l x y: -(x * y) == -x * y.
Proof Ropp_mul_l t3 CR_ring_eq_ext CR_ring_theory x y.

Lemma CRmult_lt_0 x y: 0 < x -> 0 < y -> 0 < x * y.
Proof ax_mult_resp_pos _ _ _ _ _ (cof_proof CRasCOrdField) x y.

Lemma CRopp_0: -0 == 0.
  rewrite CRopp_Qopp.
  reflexivity.
Qed.

Lemma CRpos_lt_0 x: 0 < x -> CRpos x.
  unfold CRlt.
  intros.
  apply CRpos_wd with (x - 0).
    rewrite CRopp_0.
    apply CRadd_0_r.
  assumption.
Qed.

Lemma CRneg_opp x: CRpos (-x) -> CRneg x.
Proof.
  intros.
  destruct H.
  exists x0.
  unfold CRle in *.
  apply (@CRnonNeg_wd _ (-x - 'x0)).
    rewrite CRopp_Qopp.
    apply (Radd_comm CR_ring_theory).
  assumption.
Defined.

Lemma CRpos_le_trans: forall x, CRpos x -> forall y, x <= y -> CRpos y.
Proof. intros x [e H] y E. exists e. apply (CRle_trans H E). Defined.

Lemma CRneg_le_trans: forall x, CRneg x -> forall y, y <= x -> CRneg y.
Proof. intros x [e H] y E. exists e. apply (CRle_trans E H). Defined.

Lemma CRpos_lt_0_rev x: CRpos x -> 0 < x.
Proof with auto.
  unfold CRlt.
  intros.
  apply CRpos_wd with x.
    rewrite CRopp_0.
    symmetry. apply CRadd_0_r.
  assumption.
Defined.

Lemma CRpos_mult x y: CRpos x -> CRpos y -> CRpos (x * y).
Proof.
  intros.
  apply CRpos_lt_0.
  apply CRmult_lt_0; apply CRpos_lt_0_rev; assumption.
Qed.

Lemma CRmult_lt_pos_r x y: x < y -> forall z, CRpos z -> z * x < z * y.
Proof.
  intros.
  unfold CRlt in *.
  apply CRpos_wd with (z * y + z * -x).
    rewrite (Rmul_comm CR_ring_theory z (-x)).
    rewrite <- (CRopp_mult_l x z).
    rewrite (Rmul_comm CR_ring_theory x z).
    reflexivity.
  apply CRpos_wd with (z * (y + - x)).
    rewrite (Rmul_comm CR_ring_theory z).
    rewrite (Rdistr_l CR_ring_theory).
    rewrite (Rmul_comm CR_ring_theory y).
    rewrite (Rmul_comm CR_ring_theory (-x)).
    reflexivity.
  apply CRpos_mult; assumption.
Qed.

Lemma t12 x y: -x <= y -> -y <= x.
Proof.
  intros.
  set (s := @Ropp_opp _ _ _ _ _ _ _ _ t3 CR_ring_eq_ext CR_ring_theory x).
  rewrite <- s.
  apply t8.
  assumption.
Qed.

Lemma CRpos_opp x: CRneg x -> CRpos (-x).
Proof with auto.
  unfold CRpos, CRneg, CRle.
  intros.
  destruct H.
  exists x0.
  rewrite CRopp_Qopp.
  rewrite (Radd_comm CR_ring_theory)...
Qed.

Lemma CRpos_opp' x: CRneg (-x) -> CRpos x.
Proof with auto.
   intros.
   apply (@CRpos_wd (--x)).
   apply (Ropp_opp t3 CR_ring_eq_ext CR_ring_theory).
   apply CRpos_opp...
Qed.

Lemma t6 x y: CRneg (x - y) -> CRpos (y - x).
Proof with auto.
  intros.
  apply CRpos_opp'.
  apply CRneg_wd with (x - y)...
  apply diff_opp.
Qed.

Import PowerSeries.
Import Exponential.

Lemma exp_sum a b: exp (a + b) == exp a * exp b.
  intros.
  rewrite <- (CRasIRasCR_id a).
  rewrite <- (CRasIRasCR_id b).
  rewrite <- IR_plus_as_CR.
  do 3 rewrite <- exp_correct.
  rewrite <- IR_mult_as_CR.
  apply IRasCR_wd.
  apply Exp_plus.
Qed.

Lemma blo x y: x < y -> x < IRasCR (CRasIR y).
  intros.
  apply CRlt_wd with x y.
      assumption.
    reflexivity.
  symmetry.
  apply CRasIRasCR_id.
Qed.

Lemma CRln_expand a p: CRln a p == CRln (IRasCR (CRasIR a)) (blo p).
Proof. intros. apply CRln_wd. symmetry. apply CRasIRasCR_id. Qed.

Lemma CR_mult_as_IR (x y: CR): CRasIR (x * y) [=] CRasIR x [*] CRasIR y.
Proof with auto.
  intros.
  transitivity (CRasIR (IRasCR (CRasIR x) * IRasCR (CRasIR y))).
    apply CRasIR_wd.
    repeat rewrite CRasIRasCR_id.
    reflexivity.
  transitivity (CRasIR (IRasCR (CRasIR x [*] CRasIR y))).
    apply CRasIR_wd.
    rewrite <- IR_mult_as_CR.
    reflexivity.
  apply IRasCRasIR_id.
Qed. (* this is an extra-awful proof *)

Lemma CRln_mult a b p q r: CRln (a * b) r == CRln a p + CRln b q.
Proof with auto.
  intros.
  assert ([0] [<] CRasIR a).
    apply CR_less_as_IR.
    apply CRlt_wd with 0 a...
      symmetry. apply IR_Zero_as_CR.
    symmetry. apply CRasIRasCR_id.
  assert ([0] [<] CRasIR b).
    apply CR_less_as_IR.
    apply CRlt_wd with 0 b...
      symmetry. apply IR_Zero_as_CR.
    symmetry. apply CRasIRasCR_id.
  assert ([0] [<] CRasIR (a * b)).
    apply CR_less_as_IR.
    apply CRlt_wd with 0 (a * b)...
      symmetry. apply IR_Zero_as_CR.
    symmetry. apply CRasIRasCR_id.
  rewrite (CRln_expand p).
  rewrite (CRln_expand q).
  rewrite CRln_expand at 1.
  rewrite <- (CRln_correct (CRasIR (a * b)) X1).
  rewrite <- (CRln_correct (CRasIR a) X).
  rewrite <- (CRln_correct (CRasIR b) X0).
  rewrite <- IR_plus_as_CR.
  apply IRasCR_wd.
  assert ([0] [<] CRasIR a [*] CRasIR b).
    apply CR_less_as_IR.
    apply CRlt_wd with 0 (a * b)...
      symmetry. apply IR_Zero_as_CR.
    transitivity (IRasCR (CRasIR (a * b))).
      symmetry. apply CRasIRasCR_id.
    apply IRasCR_wd.
    apply CR_mult_as_IR.
  rewrite <- (Log_mult (CRasIR a) (CRasIR b) X X0 X2).
  apply Log_wd.
  apply CR_mult_as_IR.
Qed.

Lemma exp_0: exp 0 == 1.
  rewrite <- IR_One_as_CR.
  rewrite <- IR_Zero_as_CR.
  rewrite <- exp_correct.
  apply IRasCR_wd.
  apply Exp_zero.
Qed.

Lemma exp_le_inv x y: exp x <= exp y -> x <= y.
  rewrite <- (CRasIRasCR_id x).
  rewrite <- (CRasIRasCR_id y).
  do 2 rewrite <- exp_correct.
  intros.
  apply (IR_leEq_as_CR (CRasIR x) (CRasIR y)).
  apply Exp_cancel_leEq.
  apply <- IR_leEq_as_CR.
  assumption.
Qed.

Lemma CRln_exp x p: CRln (exp x) p == x.
Proof with auto.
  intros.
  assert (0 < exp (IRasCR (CRasIR x))).
    apply CRlt_wd with 0 (exp x)...
      reflexivity.
    rewrite (CRasIRasCR_id x).
    reflexivity.
  assert (exp x == IRasCR (Exp (CRasIR x))).
    rewrite exp_correct.
    apply exp_wd.
    symmetry.
    apply CRasIRasCR_id.
  assert (0 < IRasCR (Exp (CRasIR x))).
    apply CRlt_wd with 0 (exp x)...
    reflexivity.
  rewrite (CRln_wd p H).
    rewrite (CRln_wd H H1).
      assert ([0] [<] Exp (CRasIR x)).
        apply CR_less_as_IR.
        apply CRlt_wd with 0 (exp x)...
        rewrite IR_Zero_as_CR. reflexivity.
      rewrite <- (CRln_correct (Exp (CRasIR x)) X).
      rewrite <- (CRasIRasCR_id x) at 2.
      apply IRasCR_wd.
      apply Log_Exp.
    rewrite <- exp_correct.
    reflexivity.
  apply exp_wd.
  symmetry.
  apply CRasIRasCR_id.
Qed.

Lemma exp_ln x p: exp (CRln x p) == x.
Proof with auto.
  intros.
  assert (0 < IRasCR (CRasIR x)).
    apply CRlt_wd with 0 x...
      reflexivity.
    symmetry. apply CRasIRasCR_id.
  assert (CRln x p == CRln _ H).
    apply CRln_wd. symmetry. apply CRasIRasCR_id.
  rewrite (exp_wd H0).
  assert ([0] [<] CRasIR x).
    apply CR_less_as_IR.
    apply CRlt_wd with 0 x...
      rewrite IR_Zero_as_CR. reflexivity.
    symmetry. apply CRasIRasCR_id.
  rewrite <- (CRln_correct (CRasIR x) X).
  rewrite <- exp_correct.
  rewrite <- (CRasIRasCR_id x) at 2.
  apply IRasCR_wd.
  apply Exp_Log.
Qed.

Lemma CRpos_plus x y: CRpos x -> CRnonNeg y -> CRpos (x + y).
Proof with auto.
  intros.
  unfold CRpos.
  destruct H.
  exists x0.
  unfold CRle in *.
  rewrite (Radd_comm CR_ring_theory x).
  rewrite <- (Radd_assoc CR_ring_theory).
  apply t10...
Qed.

Lemma CRlt_le_trans: forall x y, x < y -> forall z, y <= z -> x < z.
Proof with auto.
  intros x y A z B.
  unfold CRltT in *.
  unfold CRle in *.
  apply CRpos_wd with (y - x + (z - y)).
    rewrite <- (Radd_assoc CR_ring_theory).
    rewrite (Radd_assoc CR_ring_theory (-x)).
    rewrite <- t11.
    apply (Radd_comm CR_ring_theory).
  apply CRpos_plus...
Qed.

(*
Definition Qpos_div (a b: Qpos): Qpos :=
  match a, b with
  | QposMake aNum aDen, QposMake bNum bDen =>
    QposMake (aNum * bDen) (aDen * bNum)
  end.
*)

Lemma CRln_le x y p q: x <= y -> CRln x p <= CRln y q.
Proof with auto.
  intros.
  set (CRasIRasCR_id x). symmetry in s.
  set (CRasIRasCR_id y). symmetry in s0.
  assert (0 < IRasCR (CRasIR x)).
    apply CRlt_wd with (0) x... reflexivity.
  assert (0 < IRasCR (CRasIR y)).
    apply CRlt_wd with (0) y... reflexivity.
  rewrite (CRln_wd p H0 s).
  rewrite (CRln_wd q H1 s0).
  assert ([0] [<] CRasIR x).
    apply CR_less_as_IR.
    apply CRlt_wd with (0) x...
    symmetry. apply IR_Zero_as_CR.
  assert ([0] [<] CRasIR y).
    apply CR_less_as_IR.
    apply CRlt_wd with (0) y...
    symmetry. apply IR_Zero_as_CR.
  rewrite <- (CRln_correct _ X H0).
  rewrite <- (CRln_correct _ X0 H1).
  apply -> IR_leEq_as_CR.
  apply Log_resp_leEq.
  apply <- IR_leEq_as_CR.
  do 2 rewrite CRasIRasCR_id.
  assumption.
Qed.

Lemma CRle_mult x: 0 <= x -> forall a b, a <= b -> x * a <= x * b.
Proof with auto.
  intros.
  unfold CRle in *.
  rewrite (Rmul_comm CR_ring_theory x a).
  rewrite CRopp_mult_l.
  rewrite (Rmul_comm CR_ring_theory x b).
  rewrite <- (Rdistr_l CR_ring_theory).
  apply CRnonNeg_mult...
  rewrite <- (CRminus_zero x)...
Qed.

Lemma CRle_mult_both_sides x y: 0 <= x -> x <= y ->
  forall a b, 0 <= a -> a <= b -> x * a <= y * b.
Proof with auto.
  intros.
  apply CRle_trans with (x * b).
    apply CRle_mult...
  rewrite (Rmul_comm CR_ring_theory x b).
  rewrite (Rmul_comm CR_ring_theory y b).
  apply CRle_mult...
  apply CRle_trans with a...
Qed.

(*
Lemma bah: forall x y, 0 < x * y -> 0 < x -> 0 < y.
Proof with auto.
  intros.
  apply (mult_cancel_less CRasCOrdField (0) y x).
    assumption.
  simpl.
  apply CRlt_wd with ('0) (x * y)...
    apply (@Rmul_0_l _ _ _ _ _ _ _ _ t3 CR_ring_eq_ext CR_ring_theory x).
  apply (Rmul_comm CR_ring_theory).
Defined.
*)

Lemma CRle_opp_inv: forall x y, -x <= -y -> y <= x.
  unfold CRle.
  intros.
  rewrite (@Ropp_opp _ _ _ _ _ _ _ _ t3 CR_ring_eq_ext CR_ring_theory) in H.
  rewrite (Radd_comm CR_ring_theory).
  assumption.
Defined.

Lemma CRlt_irrefl: forall x: CR, Not (x < x).
Proof less_irreflexive_unfolded CRasCOrdField.

Lemma CRlt_asym: forall x y: CR, x < y -> Not (y < x).
Proof less_antisymmetric_unfolded CRasCOrdField.

Definition st_eq_refl X x: @st_eq X x x. reflexivity. Qed.
Hint Immediate st_eq_refl.

Hint Resolve CRlt_le.

Lemma CRlt_le_asym x y: x < y -> y <= x -> False.
Proof with auto.
  repeat intro.
  apply CRlt_irrefl with y, CRlt_wd with x y...
  apply <- CRle_def...
Qed.

Lemma CRln_opp_mult x y P Q R (S: 0 < -x * y):
  CRln (- (x * y)) P == CRln (-x) Q + CRln y R.
Proof.
  intros.
  rewrite <- (@CRln_mult (-x) y Q R S).
  apply CRln_wd, CRopp_mult_l.
Qed.

Definition CR_sign_dec (e: Qpos) (x: CR): option (CRpos x + CRneg x) :=
  let a := approximate x e in
  match Qle_total a (2 * e), Qle_total (- (2) * e) a with
  | right q, _ => Some (inl (CRpos_char e x q))
  | _, right q => Some (inr (CRneg_char e x q ))
  | left _, left _ => None
  end.

Lemma CRdiv_Qdiv (a b: Qpos):
  '(a / b)%Qpos == 'a * CRinvT (' b) (inr (CRpos_lt_0_rev (Qpos_CRpos b))).
Proof with auto.
  intros.
  rewrite <- (CRmult_Qmult a (Qpos_inv b)).
  apply CRmult_wd...
  symmetry.
  apply CRinv_Qinv.
Qed.

Lemma CRinvT_le (x y: CR) xH yH: CRpos x -> x <= y -> CRinvT y yH <= CRinvT x xH.
Proof with auto.
  simpl.
  intros.
  assert (IRasCR (CRasIR x) >< 0).
    apply CRapartT_wd with x (0)...
    symmetry. apply CRasIRasCR_id.
  assert (IRasCR (CRasIR y) >< 0).
    apply CRapartT_wd with y (0)...
    symmetry. apply CRasIRasCR_id.
  rewrite (@CRinvT_wd x (IRasCR (CRasIR x)) _ H1).
    rewrite (@CRinvT_wd y (IRasCR (CRasIR y)) _ H2).
      do 2 rewrite <- IR_recip_as_CR_2.
      apply -> IR_leEq_as_CR.
      apply recip_resp_leEq.
        apply CR_less_as_IR.
        apply CRlt_wd with (0) (IRasCR (CRasIR x))...
          apply CRlt_wd with (0) x...
            apply CRpos_lt_0_rev...
          symmetry. apply CRasIRasCR_id.
        symmetry. apply IR_Zero_as_CR.
      apply <- IR_leEq_as_CR...
      apply <- (CRle_wd (CRasIRasCR_id x) (CRasIRasCR_id y))...
    symmetry. apply CRasIRasCR_id.
  symmetry. apply CRasIRasCR_id.
Qed.

Lemma CRinv_le: forall (x y: canonical_names.ApartZero CR), CRpos (` x) -> `x <= `y -> CRinv y <= CRinv x.
Proof with auto.
  intros [x xH] [y yH].
  unfold CRinv.
  apply CRinvT_le.
Qed.

Lemma CRinvT_mult x xH: x * CRinvT x xH == 1.
Proof with auto.
  assert (IRasCR (CRasIR x) >< 0).
    apply CRapartT_wd with x 0...
      symmetry. apply CRasIRasCR_id.
  rewrite <- (@CRinvT_wd (IRasCR (CRasIR x)) x H).
    rewrite <- IR_recip_as_CR_2.
    rewrite <- (CRasIRasCR_id x) at 1.
    rewrite <- IR_mult_as_CR.
    rewrite <- IR_One_as_CR.
    apply -> IR_eq_as_CR.
    unfold cf_div.
    rewrite (ax_mult_assoc  _ _ _ (cr_proof IR)).
    rewrite (runit _ _ (ax_mult_mon _ _ _ (cr_proof IR)) (CRasIR x)).
    apply x_div_x.
  apply CRasIRasCR_id.
Qed.

Lemma CRinv_mult (x: canonical_names.ApartZero CR): `x * CRinv x == 1.
Proof. apply CRinvT_mult. Qed.

Instance: Proper (@canonical_names.sig_equiv _ _ _ ==> @st_eq _) CRinv.
Proof.
  intros [??] [??] ?.
  unfold CRinv.
  apply CRinvT_wd.
  assumption.
Qed.

Lemma fold_CRinvT (x: CR) (p: x >< 0): CRinvT x p == CRinv (exist _ x (snd (CR_apart_apartT x 0) p)).
Proof.
  unfold CRinv.
  simpl proj1_sig.
  apply CRinvT_wd.
  reflexivity.
Qed.

Lemma CRinvT_pos: forall x p, CRpos x -> CRpos (CRinvT x p).
Proof with auto.
  intros.
  exists (Qpos_inv (CR_b (1#1) x)).
  rewrite Q_Qpos_inv.
  assert ('(CR_b (1#1) x) >< 0).
    right. apply CRpos_lt_0_rev. apply Qpos_CRpos.
  rewrite <- (CRinv_Qinv _ H0).
  rewrite fold_CRinvT.
  unfold CRinv.
  apply CRinvT_le...
  apply CR_b_upperBound.
Qed.

Lemma CRinv_pos: forall x, CRpos (`x) -> CRpos (CRinv x).
Proof with auto.
  intros.
  unfold CRinv.
  apply CRinvT_pos...
Qed.

  (* todo: *)
Axiom exp_pos: forall x: CR, 0 < exp x.
Axiom exp_opp_ln: forall x xp, x * exp (- CRln x xp) == 1.
Axiom CRmult_le_compat_r: forall x y, x <= y -> forall z, CRnonNeg z -> z * x <= z * y.
Axiom CRmult_le_inv: forall x, CRnonNeg x -> forall a b, x * a <= x * b -> a <= b.

Lemma CRpos_mult_inv: forall y, CRpos y -> forall x, CRpos (x * y) -> CRpos x.
Proof with try assumption.
  intros.
  set (yu := CR_b ((1#1)%Qpos) y).
  destruct H0 as [mq H0].
  exists ((mq / yu)%Qpos).
  rewrite CRdiv_Qdiv.
  apply CRle_trans with (x * y * CRinvT y (inr (CRpos_lt_0_rev H))).
    apply CRle_mult_both_sides...
        apply t4.
      rewrite CRinv_Qinv.
      apply <- CRle_Qle.
      apply Qinv_le_0_compat.
      apply Qpos_nonneg.
    apply CRinvT_le...
    apply CR_b_upperBound.
  rewrite <- (Rmul_assoc CR_ring_theory).
  rewrite CRinvT_mult.
  rewrite (Rmul_comm CR_ring_theory).
  rewrite (Rmul_1_l CR_ring_theory).
  apply CRle_refl.
Qed.

Lemma exp_pos' x: CRpos (exp x).
  intros. apply CRpos_lt_0, exp_pos.
Defined.

Definition weak_CRlt_decision (f: (CR -> CR -> Set) -> Set): Set :=
  option (sum (f CRlt) (f (fun x y => y < x))).

Definition weak_CRle_decision (f: (CR -> CR -> Prop) -> Prop): Set :=
  option ({f CRle}+{f (fun x y => y <= x)}).

Definition NonNegCR: Type := sig CRnonNeg.

Program Definition NonNegCR_plus (n n': NonNegCR): NonNegCR := n + n'.

Next Obligation.
  destruct n. destruct n'.
  simpl. apply t10; assumption.
Qed.

Definition NonNegCR_zero: NonNegCR := exist _ _ CRnonNeg_zero.

Lemma CRnonPos_nonNeg x: CRnonPos x -> CRnonNeg (-x).
  unfold CRnonPos, CRnonNeg.
  intros. simpl. apply Qopp_le_compat. auto.
Qed.

Lemma CRnonNeg_nonPos_mult_inv: forall x (p: CRnonNeg x) y,
  CRnonPos (x * y) -> CRnonPos y.
Proof with auto.
Admitted.

Lemma CRnonPos_le_0 x: CRnonPos x -> x <= 0.
Proof with auto.
  intros.
  apply (@CRnonNeg_wd (0 - x) (-x)).
    apply (Radd_0_l CR_ring_theory).
  apply CRnonPos_nonNeg...
Qed.

Lemma CRnonPos_not_pos x: CRnonPos x -> CRpos x -> False.
Proof with auto.
  intros.
  apply CRlt_le_asym with (0) x.
    apply CRpos_lt_0_rev...
  apply CRnonPos_le_0...
Qed.

Lemma CRnonNeg_not_neg x: CRnonNeg x -> CRneg x -> False.
Proof with auto.
  intros.
  apply CRnonPos_not_pos with (-x).
    apply CRnonNeg_nonPos...
  apply CRpos_opp...
Qed.

Lemma CRneg_pos_excl x: CRpos x -> CRneg x -> False.
Proof with auto.
  intros.
  apply CRnonPos_not_pos with x...
  apply CRneg_nonPos...
Qed.

Lemma CRneg_lt_0 x: x < 0 -> CRneg x.
  unfold CRlt.
  intros.
  apply CRneg_opp.
  apply CRpos_wd with (0 - x).
    rewrite (Radd_comm CR_ring_theory).
    apply CRadd_0_r.
  assumption.
Qed.

Definition CRle_lt_dec: forall x y, DN ((x <= y) + (y < x)).
Proof with auto.
  intros.
  apply (DN_fmap (@DN_decisionT (y < x))).
  intros [A | B]...
  left.
  apply (leEq_def CRasCOrdField x y)...
Qed.

Implicit Arguments CRle_lt_dec [].

Definition CRnonNeg_or_pos: forall x, DN (CRnonNeg x + CRneg x).
Proof with auto.
  intros.
  apply (DN_fmap (CRle_lt_dec 0 x)).
  intro.
  destruct H; [left | right].
    apply <- CRnonNeg_le_zero...
  apply CRneg_lt_0...
Qed.

Definition CRle_cases: forall x y: CR, x <= y -> DN ((x < y) + (x == y))
  := leEq_less_or_equal CRasCOrdField.

Definition CRle_dec: forall (x y: CR), DN ((x<=y) + (y<=x)).
Proof. intros. apply (DN_fmap (CRle_lt_dec x y)). intros [A | B]; auto. Qed.

Implicit Arguments CRle_dec [].

Lemma CR_trichotomy x y: DN ((x == y) + ((x < y) + (y < x))).
Proof with intuition.
  intros.
  apply (DN_bind (@CRle_lt_dec x y)). intros [A | A]...
  apply (DN_fmap (CRle_cases A))...
Qed.

Implicit Arguments CR_trichotomy [].

Section function_properties.

  Variable f: CR -> CR.
  Variable f_wd: forall x x', x == x' -> f x == f x'.

  Definition strongly_increasing: CProp :=
    forall x x', x < x' -> f x < f x'.
  Definition strongly_decreasing: CProp :=
    forall x x', x < x' -> f x' < f x.

  Definition increasing: CProp :=
    forall x x', x <= x' -> f x <= f x'.
  Definition decreasing: CProp :=
    forall x x', x <= x' -> f x' <= f x.

  Lemma strongly_increasing_inv_mild:
    strongly_increasing -> forall x x', f x <= f x' -> x <= x'.
  Proof with auto.
    unfold strongly_increasing.
    intros.
    apply (CRle_stable x x').
    apply (DN_fmap (CR_trichotomy x x')); intro.
    destruct H0.
      rewrite s.
      apply CRle_refl.
    destruct s.
      apply CRlt_le...
    elimtype False.
    destruct (def_leEq _ _ _ _ _ CRisCOrdField (f x) (f x')).
    apply H0...
    apply X...
  Qed.

  Lemma strongly_decreasing_inv_mild:
    strongly_decreasing -> forall x x', f x <= f x' -> x' <= x.
  Proof with auto.
    unfold strongly_increasing.
    intros.
    apply (CRle_stable x' x).
    apply (DN_fmap (CR_trichotomy x x')). intro.
    destruct H0.
      rewrite s.
      apply CRle_refl.
    destruct s.
      elimtype False.
      destruct (def_leEq _ _ _ _ _ CRisCOrdField (f x) (f x')).
      apply H0...
      apply X...
    apply CRlt_le...
  Qed.

  Lemma mildly_increasing:
    strongly_increasing -> forall x x', x <= x' -> f x <= f x'.
  Proof with auto.
    intros.
    apply (CRle_stable (f x) (f x')).
    apply (DN_fmap (CR_trichotomy x x')). intro.
    destruct H0.
      rewrite (f_wd s).
      apply CRle_refl.
    destruct s.
      apply CRlt_le...
    elimtype False.
    destruct (def_leEq _ _ _ _ _ CRisCOrdField x x').
    apply H0...
  Qed.

  Lemma mildly_decreasing:
    strongly_decreasing -> forall x x', x <= x' -> f x' <= f x.
  Proof with auto.
    intros.
    apply (CRle_stable (f x') (f x)).
    apply (DN_fmap (CR_trichotomy x x')). intro.
    destruct H0.
      rewrite (f_wd s).
      apply CRle_refl.
    destruct s.
      apply CRlt_le...
    elimtype False.
    destruct (def_leEq _ _ _ _ _ CRisCOrdField x x').
    apply H0...
  Qed.

  Definition monotonic: Type := sum strongly_increasing strongly_decreasing.

  Add Morphism f with signature (@cs_eq _) ==> (@cs_eq _) as f_mor.
  Proof. exact f_wd. Qed.

  Lemma mono_eq: monotonic -> forall x x', f x == f x' <-> x == x'.
  Proof with auto.
    intros.
    split.
      intros.
      apply (CReq_stable x x').
      apply (DN_fmap (CR_trichotomy x x')). intro.
      destruct H0...
      elimtype False.
      destruct s; destruct X.
            set (s _ _ c).
            destruct (def_leEq _ _ _ _ _ CRisCOrdField (f x') (f x)).
            apply H0... rewrite H. apply CRle_refl.
          set (s _ _ c).
          destruct (def_leEq _ _ _ _ _ CRisCOrdField (f x) (f x')).
          apply H0... rewrite H. apply CRle_refl.
        set (s _ _ c).
        destruct (def_leEq _ _ _ _ _ CRisCOrdField (f x) (f x')).
        apply H0... rewrite H. apply CRle_refl.
      set (s _ _ c).
      destruct (def_leEq _ _ _ _ _ CRisCOrdField (f x') (f x)).
      apply H0... rewrite H. apply CRle_refl.
    intros.
    apply f_wd...
  Qed.

End function_properties.

Program Definition fst_mor {A B}:
  morpher (@cs_eq (ProdCSetoid A B) ==> @cs_eq A)%signature := fst.
Next Obligation. intros [x x'] [y y'] [e e']. assumption. Qed.

Program Definition snd_mor {A B}:
  morpher (@cs_eq (ProdCSetoid A B) ==> @cs_eq B)%signature := snd.
Next Obligation. intros [x x'] [y y'] [e e']. assumption. Qed.

Ltac Qle_constants := vm_compute; repeat intro; discriminate.
  (* Solves goals of the form [x <= y] where x and y are constants in Q. *)
Ltac CRle_constants := apply inject_Q_le; Qle_constants.
  (* Solves goals of the form ['x <= 'y]. *)


(** ** Constructions related to ltowers opver an object

by Vladimir Voevodsky, started on Feb. 3, 2015.

*)

Unset Automatic Introduction.

Require Export lBsystems.ltowers.

(** ltowers of objects over an object *)

Definition ltower_over_carrier { T : ltower } ( A : T ) :=
  total2 ( fun X : T => isover X A ) .

Definition obj_over_constr { T : ltower } { A : T } { X : T } ( isov : isover X A ) :
  ltower_over_carrier A := tpair ( fun X : T => isover X A ) _ isov .

Definition isov_isov { T : ltower } { A : T } ( X : ltower_over_carrier A ) :
  isover ( pr1 X ) A := pr2 X .

Definition ltower_over_ll { T : ltower } { A : T } ( X : ltower_over_carrier A ) : nat :=
  ll ( pr1 X ) - ll A .

Definition ltower_over_ft { T : ltower } { A : T } ( X : ltower_over_carrier A ) :
  ltower_over_carrier A .
Proof .
  intros .
  destruct ( isover_choice ( isov_isov X ) ) as [ isov | eq ] .
  exact ( tpair _ ( ft ( pr1 X ) )  isov ) .

  exact ( tpair ( fun X : T => isover X A ) A ( isover_XX A ) ) .

Defined.

Lemma ltower_over_ll_ft_eq { T : ltower } { A : T } ( X : ltower_over_carrier A ) :
  ltower_over_ll ( ltower_over_ft X ) = ltower_over_ll X - 1 .
Proof .
  intros .
  unfold ltower_over_ft .
  destruct ( isover_choice ( isov_isov X ) ) as [ isov | eq ] .
  unfold ltower_over_ll .
  simpl .
  rewrite ll_ft .
  rewrite natminusassoc .
  rewrite natpluscomm .
  rewrite <- natminusassoc .
  apply idpath .

  unfold ltower_over_ll .
  simpl .
  rewrite natminusnn .
  rewrite <- eq .
  rewrite natminusnn .
  apply idpath .

Defined.

Lemma ispointed_ltower_over_int { T : ltower } ( A : T ) :
  iscontr ( total2 ( fun X : ltower_over_carrier A =>
                       ltower_over_ll X = 0 ) ) .
Proof.
  intros .
  assert ( weq1 : weq ( total2 ( fun X : ltower_over_carrier A =>
                                   ltower_over_ll X = 0 ) )
                      ( total2 ( fun X : T => dirprod
                                                ( isover X A ) ( ll X - ll A = 0 ) ) ) ) .
  apply weqtotal2asstor .

  assert ( weq2 : weq ( total2 ( fun X : T => dirprod
                                                ( isover X A ) ( ll X - ll A = 0 ) ) )
                      ( total2 ( fun X : T => A = X ) ) ) .
  refine ( weqfibtototal _ _ _ ) .
  intro X .
  assert ( weq3 : weq (dirprod (isover X A) (ll X - ll A = 0))
                      (dirprod (ll X - ll A = 0) (isover X A)) ) .
  apply weqdirprodcomm .

  assert ( weq4 : weq (dirprod (ll X - ll A = 0) (isover X A))
                      (dirprod (ll X - ll A = 0) ( A = X ) ) ) .
  refine ( weqfibtototal _ _ _ ) .
  intro eq .
  unfold isover .
  rewrite eq .
  apply idweq.

  assert ( weq5 : weq (dirprod (ll X - ll A = 0) (A = X))
                      (dirprod (A = X)(ll X - ll A = 0))).
  apply weqdirprodcomm .

  assert ( weq6 : weq (dirprod (A = X) (ll X - ll A = 0))
                      ( A = X ) ) .
  apply weqpr1 .
  intro eq .
  rewrite eq .
  rewrite natminusnn .
  apply iscontraprop1 .
  apply isasetnat .

  apply idpath .

  apply ( weqcomp weq3 ( weqcomp weq4 ( weqcomp weq5 weq6 ) ) ) .

  assert ( weq := weqcomp weq1 weq2 ) .
  apply ( iscontrweqb weq ) .

  apply iscontrpathsfrom .

Defined.

Lemma ltower_over_ll0_eq { T : ltower } { A : T }
      ( X : ltower_over_carrier A ) ( eq0 : ltower_over_ll X = 0 ) :
  ltower_over_ft X = X .
Proof .
  intros .
  assert ( eq0' : ltower_over_ll ( ltower_over_ft X ) = 0 ) .
  rewrite ltower_over_ll_ft_eq .
  rewrite eq0 .
  apply idpath .

  assert ( int : tpair ( fun X' => ltower_over_ll X' = 0 ) _ eq0' =
                 tpair ( fun X' => ltower_over_ll X' = 0 ) X eq0 ) .
  apply ( proofirrelevancecontr ( ispointed_ltower_over_int _ ) _ _ ) .

  apply ( maponpaths ( @pr1 _ ( fun X' => ltower_over_ll X' = 0 ) ) int ) .

Defined.

Definition ltower_over { T : ltower } ( A : T ) : ltower :=
  ltower_constr ( @ltower_over_ll _ A ) ( @ltower_over_ft _ A )
                ( @ltower_over_ll_ft_eq _ A ) ( @ltower_over_ll0_eq _ A ) .

(** The name of the following function comes from the word octothrope that is the official name for the
"pound sign". This symbol, as a subscript, is used sometimes to denote the left adjoint to the pull-back
functor that takes a presheaf represneted by p : X -> B over B to the presheaf represented by X. *)

Definition pocto { T : ltower } { A : T } ( X : ltower_over A ) : T := pr1 X .

Definition ll_pocto { T : ltower } { A : T } ( X : ltower_over A ) :
  ll ( pocto X ) = ll X + ll A .
Proof.
  intros .
  change ( ll X ) with ( ltower_over_ll X ) .
  unfold ltower_over_ll .
  rewrite minusplusnmm .
  apply idpath .

  apply ( isover_geh ( pr2 X ) ) .

Defined.

Definition ispointed_ltower_over { T : ltower } ( A : T ) : ispointed_type ( ltower_over A ) :=
  ispointed_ltower_over_int A .

Definition pltower_over { T : ltower } ( A : T ) : pltower := pltower_constr ( ispointed_ltower_over A ) .

Definition ltower_over_to_pltower_over { T : ltower } ( A : T ) ( X : ltower_over A ) :
  pltower_over A := X .

Lemma ltower_over_ftn { T : ltower } { A : T } ( n : nat )
      ( X : ltower_over A ) ( ge : ll X >= n ) : pr1 ( ftn n X ) = ftn n ( pr1 X ) .
Proof .
  intros T A n .
  induction n .
  intros .
  apply idpath .

  intros.
  rewrite <- ftn_ft .
  rewrite <- ftn_ft .
  assert ( int : ft ( pr1 X ) = pr1 ( ft X ) ) .
  change ( ft X ) with ( ltower_over_ft X ) .
  unfold ltower_over_ft .
  destruct ( isover_choice (isov_isov X) ) as [ isov | eq ] .
  simpl .
  apply idpath .

  assert ( absd : empty ) .
  change ( ll X ) with ( ll ( pr1 X ) - ll A ) in ge .
  rewrite <- eq in ge .
  rewrite natminusnn in ge .
  apply ( ge ( natgthsn0 _ ) ) .

  destruct absd .
  rewrite int .
  refine ( IHn ( ft X ) _ ) .
  apply ( ll_ft_gtn ge ) .

Defined.

(** **** Standard constructions of over-objects *)

Definition X_over_X { T : ltower } ( X : T ) : ltower_over X :=
  obj_over_constr ( isover_XX X ) .

Lemma ll_X_over_X { T : ltower } ( X : T ) : ll ( X_over_X X ) = 0 .
Proof.
  intros .
  change _ with ( ll X - ll X = 0 ) .
  apply natminusnn .

Defined.

Definition X_over_ftX { T : ltower } ( X : T ) : ltower_over ( ft X ) :=
  obj_over_constr ( isover_X_ftX X ) .

Lemma ll_X_over_ftX { T : ltower } { X : T } ( gt0 : ll X > 0 ) :
  ll ( X_over_ftX X ) = 1 .
Proof.
  intros.
  change _ with ( ltower_over_ll (X_over_ftX X) = 1 ) .
  unfold ltower_over_ll .
  rewrite ll_ft .
  change _ with ( ll X - ( ll X - 1 ) = 1 ) .
  apply natminusmmk .
  apply ( @natgthminus1togeh 1 _ gt0 ) .

Defined.

(** The projection pocto from the over-tower to the tower is over-monotone *)

Lemma ll_over_minus_ll_over { T : ltower } { A : T } ( X1 X2 : ltower_over A ) :
  ll X1 - ll X2 = ll ( pocto X1 ) - ll ( pocto X2 ) .
Proof .
  intros .
  destruct X1 as [ X1 isov1 ] . destruct X2 as [ X2 isov2 ] .
  unfold ll .
  simpl .
  unfold ltower_over_ll .  simpl .
  change _ with ( ( ll X1 - ll A ) - ( ll X2 - ll A ) = ( ll X1 - ll X2 ) ) .
  rewrite natminusassoc .
  rewrite natpluscomm .
  rewrite ( minusplusnmm _ _ ( isover_geh isov2 ) ) .
  apply idpath .

Defined.

Definition isovmonot_pocto { T : ltower } ( A : T ) { X Y : ltower_over A } ( isov : isover X Y ) :
isover ( pocto X ) ( pocto Y ) .
Proof .
  intros .
  destruct X as [ X isovX ] .
  destruct Y as [ Y isovY ] .
  simpl .
  assert ( int := maponpaths pr1 isov ) .
  simpl in int .
  rewrite ltower_over_ftn in int .
  simpl in int .
  rewrite ll_over_minus_ll_over in int .
  simpl in int .
  exact int .

  exact ( natminuslehn _ _ ) .

Defined.

Lemma isllmonot_pocto { T : ltower } { A : T } : isllmonot ( @pocto T A ) .
Proof .
  intros .
  unfold isllmonot .
  intros X Y .
  apply ( ! ( ll_over_minus_ll_over X Y ) ) .

Defined.

(** **** The projection pocto and ft *)

Lemma ft_pocto { T : ltower } { A : T } { X : ltower_over A } ( gt0 : ll X > 0 ) :
  ft ( pocto X ) = pocto ( ft X ) .
Proof.
  intros .
  change ( ft X ) with ( ltower_over_ft X ) .
  unfold ltower_over_ft .
  destruct (isover_choice (isov_isov X)) as [ isov | eq ] .
  simpl .
  apply idpath .

  assert ( absd : empty ) .
  assert ( eq0 : ll X = 0 ) .  change _ with ( ll ( pr1 X ) - ll A = 0 ) .
  rewrite <- eq .
  apply natminusnn .

  rewrite eq0 in gt0 . apply ( negnatgthnn _ gt0 ) .

  destruct absd .

Defined.

(** **** Some functions between over-towers *)

Definition to_ltower_over { T : pltower } ( X : T ) : ltower_over ( cntr T ) .
Proof .
  intros .
  exact ( obj_over_constr ( isoverll0 ( ll_cntr T ) X ) ) .

Defined.

Lemma ll_to_ltower_over { T : pltower } ( X : T ) :
  ll ( to_ltower_over X ) = ll X .
Proof .
  intros.
  unfold ll .
  simpl .
  unfold ltower_over_ll .
  rewrite ll_cntr .
  rewrite natminuseqn .
  apply idpath .

Defined.

Lemma isllmonot_to_ltower_over ( T : pltower )  :
  isllmonot ( @to_ltower_over T ) .
Proof .
  unfold isllmonot . intros .
  repeat rewrite ll_to_ltower_over . apply idpath .

Defined.

Lemma isbased_to_ltower_over ( T : pltower ) :
  isbased ( @to_ltower_over T ) .
Proof .
  intros .
  unfold isbased. intros X eq0 .
  rewrite ll_to_ltower_over .
  exact eq0 .

Defined.

(** The following constructions probably work for all ltowers
but we only give a proof for ltowers of sets in the file hSet_ltowers.v .

Definition ovmonot_to_over_pocto  { T : ltower } { X : T } { X' : ltower_over X } :
  ovmonot_fun ( ltower_over X' ) ( ltower_over ( pocto X' ) ) .

Definition ovmonot_over { T1 T2 : ltower } ( f : ovmonot_fun T1 T2 )
           ( X : T1 ) : ovmonot_fun ( ltower_over X ) ( ltower_over ( f X ) ) .

Definition lft { T : hSet_ltower }
           { X : T } { X' : ltower_over X } ( X'' : ltower_over ( pocto X' ) ) : ltower_over X' .

Definition ovmonot_second { T : ltower }
           { X Y : T } ( f : ovmonot_fun ( ltower_over X ) ( ltower_over Y ) )
           ( X' : ltower_over X ) :
  ovmonot_fun ( ltower_over ( pocto X' ) ) ( ltower_over ( pocto ( f X' ) ) ) .

Lemma isovmonot_to_ltower_over { T : ltower } ( is : ispointed T ) : isovmonot ( to_ltower_over is ) .

*)

(* End of the file ltowers_over.v *)