(**************************************************************************
* TLC: A library for Coq                                                  *
* Intervals as sets                                                       *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibReflect
  LibOperation LibStruct LibInt LibOrder
  LibEpsilon LibRelation LibSet.
Require Export LibBag.

Class Range_incl_excl A := { range_incl_excl : A -> A -> set A }.
Class Range_incl_incl A := { range_incl_incl : A -> A -> set A }.
Class Range_excl_excl A := { range_excl_excl : A -> A -> set A }.
Class Range_excl_incl A := { range_excl_incl : A -> A -> set A }.

Global Instance Range_incl_excl_le `{Le A} : Range_incl_excl A.
Proof. constructor. apply (fun x y => set_st (fun a => x <= a < y)). Defined.

Global Instance Range_incl_incl_le `{Le A} : Range_incl_incl A.
Proof. constructor. apply (fun x y => set_st (fun a => x <= a <= y)). Defined.

Global Instance Range_excl_excl_le `{Le A} : Range_excl_excl A.
Proof. constructor. apply (fun x y => set_st (fun a => x < a < y)). Defined.

Global Instance Range_excl_incl_le `{Le A} : Range_excl_incl A.
Proof. constructor. apply (fun x y => set_st (fun a => x < a <= y)). Defined.

Lemma Range_incl_excl_le_def :
  forall `{Le A} (x y : A),
  range_incl_excl x y = set_st (fun a => x <= a < y).
Proof. reflexivity. Qed.

Lemma Range_incl_incl_le_def :
  forall `{Le A} (x y : A),
  range_incl_incl x y = set_st (fun a => x <= a <= y).
Proof. reflexivity. Qed.

Lemma Range_excl_excl_le_def :
  forall `{Le A} (x y : A),
  range_excl_excl x y = set_st (fun a => x < a < y).
Proof. reflexivity. Qed.

Lemma Range_excl_incl_le_def :
  forall `{Le A} (x y : A),
  range_excl_incl x y = set_st (fun a => x < a <= y).
Proof. reflexivity. Qed.

Global Opaque Range_incl_excl_le Range_incl_incl_le Range_excl_excl_le Range_excl_incl_le.

Notation "'\set[' a , b )" := (range_incl_excl a b)
  (at level 0, format "'\set[' a ,  b )").
Notation "'\set[' a , b ]" := (range_incl_incl a b)
  (at level 0, format "'\set[' a ,  b ]").
Notation "'\set(' a , b )" := (range_excl_excl a b)
  (at level 0, format "'\set(' a ,  b )").
Notation "'\set(' a , b ]" := (range_excl_incl a b)
  (at level 0, format "'\set(' a ,  b ]").

Goal forall (n: Z), 0 < n -> \set[0, n) = \{0} \u \set[1, n-1].
Abort.

Goal forall (n: Z), 0 < n -> \set(0, n) = \{1} \u \set(1, n-1].
Abort.

Lemma range_incl_excl_split :
  forall `{Le A} (a b c : A),
  Le_total_order ->
  a <= b <= c ->
  \set[a, c) = \set[a, b) \u \set[b, c).
Proof using.
  introv M L.
  do 3 (rewrite Range_incl_excl_le_def).
  apply in_extens. intro x.
  rewrite in_union_eq.
  do 3 (rewrite in_set_st_eq).
  iff P.
  - destruct (case_le_gt b x) as [C|C].
    right*. left*.
  - destruct P as [P|P].
    forwards*: lt_le_trans b x c.
    forwards*: le_trans b a x. (* TODO: le_le_trans = le_trans *)
Qed.


(* Theorem is (A -> B) -> (A -> B) *)

Theorem implies_reflex : (forall A B : Prop, (A -> B) -> (A -> B)).
Proof.
  intros A.
  intros B.
  intros A_implies_B.
  exact A_implies_B.
Qed.


Require Import Base.
Require Import Monad.
Require Import ClassicalMonads.
Require Import Nabla.
Require Import Kleene.
Require Import MultivalueMonad.
Require Import RealAxioms.
Require Import RealRing.
Require Import RealOrder.
Require Export RealOrderTactic.

Require Import Psatz.

(* This file proves that Real is order complete in classical sense *)

Section RealLimit0.
  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  Lemma limit_only_if_fast_cauchy : forall f (x : Real), is_fast_limit_p x f -> is_fast_cauchy_p f.
  Proof.
    intros f x H n m.
    pose proof (H n).
    pose proof (H m).
    destruct H0, H1.
    split.
    pose proof (real_le_le_plus_le _ _ _ _ H2 H1).
    apply (real_le_plus_le (-x + f n - prec n)) in H4.
    ring_simplify in H4.
    exact H4.
    pose proof (real_le_le_plus_le _ _ _ _ H0 H3).
    apply (real_le_plus_le (f n + prec n - x)) in H4.
    ring_simplify in H4.
    exact H4.
  Qed.

  (*  *)
  Definition is_W_limit_p (x : Real) (f : nat -> Real) :=
    forall n, exists N, forall m, (N <= m)%nat ->  - prec n <= x - f m <= prec n.

  Definition is_W_cauchy_p (f : nat -> Real) :=
    forall n, exists N, forall m k, (N <= m)%nat -> (N <= k)%nat -> - prec n <= f m - f k <= prec n.

  Lemma W_limit_p_aux_1 :
    forall (f : nat -> Real),
      is_W_cauchy_p f ->
      exists h : nat -> nat,
        forall n m k,  (h n <= m)%nat -> (h n <= k)%nat -> -prec n <= f m - f k <= prec n.
  Proof.
    intros.
    apply (countable_choice nat (fun N FN => forall m k, (FN <= m)%nat -> (FN <= k)%nat -> -prec N <= f m - f k <= prec N)).
    intros.
    exact (H n).
  Defined.

  Lemma W_limit_p :
    forall (f : nat -> Real), is_W_cauchy_p f -> exists x, is_W_limit_p x f.
  Proof.
    intros.
    destruct (W_limit_p_aux_1 f H) as [g p].

    pose proof (real_limit_p (fun n => f ( g n))).

    assert ( is_fast_cauchy_p (fun n : nat => f ( g n))).
    + intros n m .
      assert True by auto.
      assert (g n < g m \/ g m <= g n)%nat by lia.
      destruct H1.
    ++
      pose proof (p n ( g n) ( g m)).
      assert  (g n <= g n)%nat by lia; assert (g n <= g m)%nat by lia.
      pose proof (H2 H3 H4).
      split.
      destruct H5.
      left.
      apply (fun a => real_lt_le_lt _ _ _ a  H5).
      apply (real_lt_add_r (prec n + prec m)).
      replace ( - prec n - prec m + (prec n + prec m)) with real_0 by ring.
      replace (- prec n + (prec n + prec m)) with (prec m) by ring.
      apply prec_pos.
      destruct H5.
      left.
      apply (real_le_lt_lt _ _ _ H6).
      apply (real_lt_add_r (-prec n)).
      replace
        (prec n + - prec n) with real_0 by ring.
      replace (prec n + prec m + - prec n) with (prec m) by ring.
      apply prec_pos.
    ++
      pose proof (p m ( g n) ( g m)).
      assert  (g m <= g n)%nat by lia; assert (g m <= g m)%nat by lia.
      pose proof (H2 H3 H4).
      split.
      destruct H5.
      left.
      apply (fun a => real_lt_le_lt _ _ _ a  H5).
      apply (real_lt_add_r (prec n + prec m)).
      replace (- prec n - prec m + (prec n + prec m)) with real_0 by ring.
      replace ( - prec m + (prec n + prec m)) with (prec n) by ring.
      apply prec_pos.
      destruct H5.
      left.
      apply (real_le_lt_lt _ _ _ H6).
      apply (real_lt_add_r (-prec m)).
      replace ( prec m + - prec m) with real_0 by ring.
      replace (prec n + prec m + - prec m) with (prec n) by ring.
      apply prec_pos.
    +
      rename H0 into H1.
      rename X into H0.
      apply H0 in H1.
      clear H0.

      destruct (H1).
      exists x.
      intros n.
      exists (g (n + 1)%nat).
      intros.
      pose proof (i (n + 1)%nat).
      simpl in H2.
      pose proof (p (n + 1)%nat (g (n + 1)%nat) m).
      assert (g (n + 1) <= g (n + 1))%nat by lia; assert (g (n + 1) <= m)%nat by lia.
      pose proof (H3 H4 H5).
      clear H3 H4 H5.
      destruct H2, H6.
      split.
      pose proof (real_le_le_plus_le _ _ _ _ H2 H4).
      replace ( - prec (n + 1) + - prec (n + 1)) with (- (prec (n + 1) + prec (n+1))) in H6 by ring.
      rewrite prec_twice in H6.
      replace (x - f (g (n + 1)%nat) + (f (g (n + 1)%nat) - f m)) with (x - f m) in H6 by ring.
      exact H6.

      pose proof (real_le_le_plus_le _ _ _ _ H3 H5).
      replace (x - f (g (n + 1)%nat) + (f (g (n + 1)%nat) - f m)) with (x - f m) in H6 by ring.
      rewrite prec_twice in H6.
      exact H6.
  Defined.

  Definition W_is_non_empty (P : Real -> Prop) := exists z, P z.
  Definition W_is_upper_bound  (P : Real -> Prop) (u : Real ) := forall z : Real, P z -> z <= u.
  Definition W_is_strict_upper_bound  (P : Real -> Prop) (u : Real ) := forall z : Real, P z -> z < u.
  Definition W_is_bounded_above (P : Real -> Prop) := exists u, W_is_upper_bound P u.
  Definition W_is_strictly_bounded_above (P : Real -> Prop) := exists u, W_is_strict_upper_bound P u.

  (* Definition W_upbd (P : Real -> Prop) := exists u, W_upb P u. *)
  Definition W_is_sup  (P : Real-> Prop) (s : Real) := W_is_upper_bound P s /\ (forall s', W_is_upper_bound P s' -> s <= s').

  Lemma W_complete_aux :
    forall P : Real -> Prop,
      W_is_non_empty P ->  W_is_strictly_bounded_above P ->
      exists w, w > real_0 /\ exists f : nat -> Real,
          (forall n, ~ W_is_strict_upper_bound P (f n) /\ W_is_strict_upper_bound P (f n + w * prec n)).
  Proof.
    intros.
    destruct H.
    destruct H0.
    exists (x0 - x).
    split.
    pose proof (H0  _ H).
    apply (real_lt_plus_lt (-x)) in H1.
    replace (-x + x) with real_0 in H1 by ring.
    replace (-x + x0) with (x0 - x) in H1 by ring.
    exact H1.
    apply (countable_choice Real (fun n y => ~ W_is_strict_upper_bound P y /\ W_is_strict_upper_bound P (y + (x0 - x) * prec n))).
    intro.
    induction n.
    exists x.
    split; auto.
    intro.
    exact (real_nlt_triv  _ (H1 _ H)).

    simpl prec.
    replace ((x + (x0 - x) * real_1)) with x0 by ring.
    exact H0.

    destruct IHn.
    destruct H1.
    pose (m := (x1 + (x0 - x) * prec (S n))).
    destruct (lem (W_is_strict_upper_bound P m)).

    exists x1.
    split; auto.

    exists m.
    split; auto.
    assert ( (m + (x0 - x) * prec (S n)) = (x1 + (x0 - x) * prec n)).
    unfold m.
    replace ( x1 + (x0 - x) * prec (S n) + (x0 - x) * prec (S n))
      with  ( x1 + (x0 - x) * (prec (S n) +  prec (S n))) by ring.
    replace (S n) with (n + 1)%nat by lia.
    rewrite (prec_twice n).
    ring.
    rewrite H4.
    exact H2.
  Defined.

  Lemma W_log : forall x : Real, x > real_0 -> exists n, x * prec n < real_1.
  Proof.
    intros.
    pose proof (real_Archimedean  (/ (dg0  H))).
    pose proof (real_pos_inv_pos2  _ H).
    apply H0 in H1.
    destruct H1.
    exists x0.
    apply (real_lt_mult_pos_lt x _ _ H) in H1.
    replace ( x * /dg0 H) with (/dg0 H * x) in H1 by ring.
    rewrite (real_mult_inv) in H1.
    exact H1.
  Qed.

  Lemma prec_monotone : forall n m, (n < m)%nat -> prec m < prec n.
  Proof.
    intros.
    induction H.
    apply prec_S.
    pose proof (prec_S m).
    apply (real_lt_lt_lt _ _ _ H0 IHle).
  Qed.

  Lemma W_complete_aux_2 : forall (P : Real -> Prop) x,
      ~ W_is_strict_upper_bound P x -> exists y, x <= y /\ P y.
  Proof.
    intros.
    unfold W_is_strict_upper_bound in H.
    destruct (lem (exists y : Real, x <= y /\ P y)); auto.
    contradict H.
    intros.
    destruct (lem (z < x)); auto.
    contradict H0.
    exists z.
    split; auto.
    destruct (real_total_order x z).
    left; exact H0.
    destruct H0.
    right; exact H0.
    contradict (H1 H0).
  Qed.

  Lemma real_le_lt_plus_lt : forall a b c d : Real, a <= b -> c < d -> a + c < b + d.
  Proof.
    intros.
    destruct H.
    apply (real_lt_lt_plus_lt _ _ _ _ H H0).
    rewrite H.
    apply (real_lt_plus_lt b  _ _ H0).
  Qed.

  Theorem W_complete : forall P : Real -> Prop,
      W_is_non_empty P ->  W_is_bounded_above P ->
       exists z, W_is_sup P z.
  Proof.
    intros P H H0.
    destruct H0.
    destruct (lem (W_is_strict_upper_bound P x)).
    assert (W_is_strictly_bounded_above P) by (exists x; auto).
    pose proof (W_complete_aux P H H2) as [w [pw [f h]]].
    pose proof (W_limit_p f).
    assert (is_W_cauchy_p f ).
    intros n.
    +                           (* prove is Cauchy *)

    destruct (W_log _ pw) as [i j].
    exists (i + n + 1)%nat.
    intros.
    (* destruct (lem (f m - f n > prec n \/ f n - f m > prec n)). *)
    (* destruct H6. *)
    pose proof (h m) as [pm nm].
    pose proof (h k) as [pk nk].
    pose proof (W_complete_aux_2 P _ pm) as [q [qq qqq] ].
    pose proof (nk _ qqq).

    pose proof (W_complete_aux_2 P _ pk) as [p [pp ppp]].
    pose proof (nm _ ppp).
    pose proof (@real_le_lt_plus_lt _ _ _ _ qq H6).
    pose proof (@real_le_lt_plus_lt _ _ _ _ pp H7).
    apply (real_lt_plus_lt (- q - f k)) in H8.
    apply (real_lt_plus_lt (- p - f k - w * prec m)) in H9.
    ring_simplify in H8.
    ring_simplify in H9.
    replace (f m - f k) with (- f k + f m) by ring.
    split; left.
    apply (fun a => real_lt_lt_lt _ _ _ a H9).
    apply (real_lt_add_r (prec n + w * prec m)).
    ring_simplify.
    apply (real_lt_mult_pos_lt (prec n) _ _ (prec_pos _)) in j.
    ring_simplify in j.
    apply (fun a => real_lt_lt_lt _ _ _ a j).
    replace (prec n * w * prec i) with (w * (prec n  * prec i)) by ring.
    apply (real_lt_mult_pos_lt w _ _ pw).
    rewrite <- prec_hom.
    apply prec_monotone.
    lia.

    apply (real_lt_lt_lt _ _ _ H8).
    apply (real_lt_mult_pos_lt (prec n) _ _ (prec_pos _)) in j.
    ring_simplify in j.
    apply (fun a => real_lt_lt_lt _ _ _ a j).
    replace (prec n * w * prec i) with (w * (prec n  * prec i)) by ring.
    apply (real_lt_mult_pos_lt w _ _ pw).
    rewrite <- prec_hom.
    apply prec_monotone.
    lia.

    +
    destruct (H3 H4).
    exists x0.
    split.
    intros z p.
    destruct (real_total_order z x0).
    left; auto.
    destruct H6.
    right; auto.
    destruct (padding _ _ H6) as [eps [pos e]].
    destruct (real_Archimedean _ pos) as [k pk].

    destruct (W_log _ pw) as [i j].

    destruct (H5 (k + 1 )%nat) as [N g].

    pose proof (g (N + k + 2 + i)%nat).
    assert (N <= N + k  + 2 + i)%nat by lia.
    apply H7 in H8.
    clear H7.
    pose proof (h (N + k  + 2 + i)%nat) as [_ hh].
    assert (f (N + k  + 2 + i)%nat + w * prec (N + k  + 2 + i) < z).
    rewrite e.
    rewrite prec_hom.
    pose proof (real_lt_mult_pos_lt (prec (N + k + 2 )) _ _ (prec_pos (N + k + 2 )) j ).
    apply (real_lt_plus_lt (f (N + k  + 2 + i)%nat)) in H7.
    replace ( f (N + k  + 2 + i)%nat + prec (N  + k + 2 ) * (w * prec i)) with ( f (N + k  + 2 + i)%nat + w * (prec (N + k + 2 ) * prec i)) in H7 by ring.
    apply (real_lt_lt_lt _ _ _ H7).

    destruct H8 as [H8 _].
    apply (real_le_plus_le (f (N + k  + 2 + i)%nat + prec (k + 1) + prec (N + k + 2 ))) in H8.
    ring_simplify in H8.
    replace (prec (N +  k + 2 ) * real_1) with (prec (N + k + 2 )) by ring.
    apply (real_le_lt_lt _ _ _ H8).
    apply (real_lt_add_r (-x0)).
    ring_simplify.
    apply (fun a => real_lt_lt_lt _ _ _ a pk).
    rewrite <- (prec_twice k).
    apply (real_lt_add_r (-prec (k + 1))).
    ring_simplify.
    apply prec_monotone.
    lia.
    pose proof (hh _ p).
    contradict (real_nlt_triv _ (real_lt_lt_lt _ _ _ H7 H9)).

    intros z qp.
    destruct (real_total_order z x0).
    destruct (padding _ _ H6) as [eps [pos e]].
    destruct (real_Archimedean _ pos) as [k pk].

    destruct (W_log _ pw) as [i j].

    destruct (H5 (k + 1 )%nat) as [N g].

    pose proof (g (N)%nat).
    assert (N <= N)%nat by lia.
    apply H7 in H8.
    clear H7.
    pose proof (h (N)%nat) as [hh _].
    assert (z < f N).
    apply (lp _ _ (fun k => k - eps)) in e.
    ring_simplify in e.
    rewrite <- e.
    destruct H8 as [_ H8].
    assert (x0 - f N + prec k < prec (k + 1) + eps).
    destruct H8.
    apply (real_lt_lt_plus_lt _ _ _ _ H7 pk).
    rewrite H7.
    apply (real_lt_plus_lt (prec (k + 1))  _ _   pk).
    apply (real_lt_plus_lt (-eps + f N - prec k)) in H7.
    ring_simplify in H7.
    replace (- eps + x0) with (x0 - eps) in H7 by ring.
    apply (real_lt_lt_lt _ _ _ H7).
    apply (real_lt_add_r (- f N + prec k)).
    ring_simplify.
    apply prec_monotone.
    lia.

    contradict hh.
    intros sp ep.
    pose proof (qp _ ep).
    apply (real_le_lt_lt _ _ _ H9 H7).

    unfold real_le.
    destruct H6; auto.

    +
    exists x.
    split; auto.
    intros.
    assert (P x).
    destruct (lem (P x)); auto.
    contradict H1.
    intros z H1.
     pose proof (H0 _ H1).
    destruct H4; auto.
    rewrite H4 in H1; induction (H3 H1).
    exact (H2 _ H3).
  Qed.

End RealLimit0.


Require Export Bool.
Require Export ZArith.
Require Export Reals.
Require Export Flocq.Core.Raux.
Require Export Gappa_real.
Require Export Gappa_definitions.
Require Export Gappa_dyadic.

Lemma Zeq_bool_correct_t :
  forall m n : Z, Zeq_bool m n = true -> (m = n)%Z.
Proof.
intros m n H.
apply Zcompare_Eq_eq.
unfold Zeq_bool in H.
induction (m ?= n)%Z ; try discriminate.
exact (refl_equal _).
Qed.

Lemma Zlt_bool_correct_t :
  forall m n : Z, Zlt_bool m n = true -> (m < n)%Z.
Proof.
intros m n H.
generalize (Zlt_cases m n).
rewrite H.
trivial.
Qed.


Require Import Coq.Logic.Classical_Pred_Type.
Require Import TLC.LibTactics.
Require Import TLC.LibAxioms.
Require Import TLC.LibLogic.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import ssreflect.
Require Import LibRewrite.
Require Import ZArith Reals.
Require Import Psatz.

(* We could in principle perform this construction using [bool] instead of [Prop]
   as the codomain of predicates. However, [bool] does not support quantification
   over an infinite set, whereas [Prop] does. *)

Notation pred A := (A -> Prop) (only parsing).

(* ---------------------------------------------------------------------------- *)

Module Filter.

(* Technically, a filter is a nonempty set of subsets of A, which is
   closed under inclusion and (finite) intersection. *)

Definition filter A := pred (pred A).

Record mixin_of (A : Type) := Mixin {

(* Let us write [ultimately] for a filter.  A filter is a modality: if [P] is a
   predicate, then [ultimately P] is a proposition. In other words, a filter is
   a quantifier: if [P] is a predicate, then [ultimately (fun x => P x)] is a
   proposition. Intuitively, this proposition means that ``ultimately'' [P]
   holds. In other words, for every sufficiently ''large'' [x], [P] holds. *)

  ultimately : filter A;

(* A filter is nonempty. In fact, it contains the universe. In other words,
   [ultimately x => True] is just [True]. Thus, the quantifier [ultimately]
   is weaker than a universal quantifier: [forall x, P x] implies
   [ultimately x, P x]. *)

  _ :
    ultimately (fun _ => True);

(* A filter is closed by inclusion and by (finite) intersection. In other
   words, the quantifier [ultimately] is covariant and commutes with (finite)
   conjunction. The last condition means that [ultimately] is universal in
   nature, as opposed to existential. In particular, the universal quantifier
   can be viewed as a filter, but the existential quantifier cannot. *)

  _ :
    forall P1 P2 P : pred A,
    ultimately P1 ->
    ultimately P2 ->
    (forall a, P1 a -> P2 a -> P a) ->
    ultimately P
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.
  Record type : Type := Pack { sort : Type ; class : class_of sort }.
End ClassDef.

Module Exports.
  Coercion sort : type >-> Sortclass.
  Notation filterType := type.
  Notation FilterMixin := Mixin.
  Notation FilterType T m := (@Pack T m).
End Exports.

End Filter.
Export Filter.Exports.

Definition ultimately T := Filter.ultimately (Filter.class T).
Arguments ultimately : clear implicits.

(* ---------------------------------------------------------------------------- *)

Section FilterLaws.

Variable A : filterType.

Implicit Type P : pred A.

(* Re-statement of the defining laws. *)

Lemma filter_universe:
  ultimately A (fun _ => True).
Proof. destruct A as [? M]. destruct M. eauto. Qed.

Lemma filter_closed_under_intersection:
  forall P1 P2 P,
  ultimately A P1 ->
  ultimately A P2 ->
  (forall a, P1 a -> P2 a -> P a) ->
  ultimately A P.
Proof. destruct A as [? M]. destruct M. eauto. Qed.

(* A filter is closed by subset inclusion.
   That is, [ultimately] is covariant. *)

Lemma filter_closed_under_inclusion:
  forall P1 P2,
  ultimately A P1 ->
  (forall a, P1 a -> P2 a) ->
  ultimately A P2.
Proof.
  eauto using filter_closed_under_intersection.
Qed.

(* If [P] holds everywhere, then [ultimately P] holds. *)

Lemma filter_universe_alt:
  forall P,
  (forall a, P a) ->
  ultimately A P.
Proof.
  (* A filter is nonempty, so it has one inhabitant. *)
  pose filter_universe.
  (* A filter is closed by inclusion, so the universe is also
     an inhabitant of the filter. *)
  eauto using filter_closed_under_inclusion.
Qed.

(* [ultimately] commutes with conjunction. *)

Lemma filter_conj:
  forall P1 P2,
  ultimately A P1 /\ ultimately A P2 <-> ultimately A (fun x => P1 x /\ P2 x).
Proof.
  intros P1 P2. split.
  { intros [ h1 h2 ].
    apply (filter_closed_under_intersection h1 h2).
    tauto. }
  { intros h. split;
    apply (filter_closed_under_inclusion h);
    tauto. }
Qed.

Lemma filter_conj_alt :
  forall P1 P2,
    ultimately A P1 ->
    ultimately A P2 ->
    ultimately A (fun x => P1 x /\ P2 x).
Proof. intros. apply filter_conj. tauto. Qed.

(* An existential quantifier can be pushed into [ultimately]. That is,
   [exists/ultimately] implies [ultimately/exists]. The converse is false; to
   see this, replace [ultimately] with [forall], which is one possible
   interpretation of [ultimately]. *)

Lemma ultimately_exists:
  forall B (Q : A -> pred B),
  (exists y, ultimately A (fun x => Q x y)) ->
  ultimately A (fun x => exists y, Q x y).
Proof.
  intros B Q [ y HQ ].
  eapply filter_closed_under_inclusion.
  { exact HQ. }
  simpl. intros. exists y. assumption.
Qed.

(* [ultimately] can be pushed into a universal quantifier. That is,
   [ultimately/forall] implies [forall/ultimately]. The converse is false:
   for instance, on the natural numbers, [forall x, [ultimately y, x <= y]]
   obviously holds, whereas [ultimately y, forall x, x <= y] does not.
   A fortiori, two [ultimately] quantifiers do not in general commute. *)

Lemma forall_ultimately:
  forall B (Q : B -> pred A),
  ultimately A (fun y => forall x, Q x y) ->
  forall x, ultimately A (fun y => Q x y).
Proof.
  intros. eapply filter_closed_under_inclusion; eauto.
Qed.

End FilterLaws.

(* TEMPORARY define rewriting-rule versions of these laws? *)

(* Instance for rewriting under [ultimately] *)

Program Instance Pw_eq_ultimately_proper (A : filterType) :
  Proper (pw eq ==> Basics.flip Basics.impl) (ultimately A).
Next Obligation.
  intros. unfold respectful, pointwise_relation, Basics.flip, Basics.impl.
  intros P1 P2 H U. apply (filter_closed_under_inclusion U).
  intros. rewrite H. assumption.
Qed.

(* ---------------------------------------------------------------------------- *)
(* A set of tactics useful to intersect an arbitrary number of filters.

   [filter_intersect] turns a goal of the form:

     ultimately A P1 -> ... ultimately A Pn -> Q

   into:

     ultimately A (P1 /\ ... /\ Pn) -> Q

   [filter_closed_under_intersection] turns a goal of the form:

     ultimately A P1 -> ... ultimately A Pn -> ultimately A P

   into:

     forall x, P1 x /\ ... /\ Pn x -> P
 *)

Ltac filter_intersect_two_base I U1 U2 :=
  lets I: filter_conj_alt U1 U2.

Ltac filter_intersect_two :=
  let U1 := fresh in
  let U2 := fresh in
  let U := fresh in
  intros U1 U2;
  filter_intersect_two_base U U1 U2;
  revert U; clear U1; clear U2.

Ltac filter_intersect :=
  match goal with
  | |- (ultimately ?A _) -> (ultimately ?A _) -> _ =>
    let U := fresh in
    intro U;
    filter_intersect;
    revert U;
    filter_intersect_two
  | |- (ultimately ?A _) -> (ultimately ?B _) -> _ =>
    idtac
  | |- (ultimately _ _) -> _ =>
    idtac
  end.

Ltac filter_closed_under_intersection :=
  filter_intersect;
  let U := fresh in
  intro U;
  applys filter_closed_under_inclusion U;
  clear U.

(* Test goals *)

Goal
  forall A P1 P2 P3 B P4 P5,
  (ultimately A (fun x => P1 x /\ P2 x /\ P3 x) -> ultimately B P4 -> ultimately B P5 -> False) ->
  ultimately A P1 ->
  ultimately A P2 ->
  ultimately A P3 ->
  ultimately B P4 ->
  ultimately B P5 ->
  False.
Proof.
  do 8 intro.
  filter_intersect.
  assumption.
Qed.

Goal
  forall (A: filterType) (P1 P2 P3 P4 : A -> Prop),
  (forall x, (P1 x /\ P2 x /\ P3 x) -> P4 x) ->
  ultimately A P1 ->
  ultimately A P2 ->
  ultimately A P3 ->
  ultimately A P4.
Proof.
  do 6 intro.
  filter_closed_under_intersection.
  assumption.
Abort.

(* ---------------------------------------------------------------------------- *)

(* Inclusion of filters. *)

Definition finer A (ult1 ult2 : Filter.filter A) :=
  forall P, ult2 P -> ult1 P.

(* ---------------------------------------------------------------------------- *)

(* Applying a function [f] to a filter [ult] produces another filter, known as
   the image of [ult] under [f]. *)

Section Image.

  Variable A : filterType.
  Variable B : Type.

  Variable f : A -> B.

  Definition image : Filter.filter B :=
    fun P => ultimately A (fun x => P (f x)).

  Definition image_filterMixin : Filter.mixin_of B.
  Proof.
    eapply Filter.Mixin with image.
    { apply filter_universe. }
    { intros P1 P2 P I1 I2 H.
      unfold image in *.
      apply (filter_closed_under_intersection I1 I2).
      eauto. }
  Defined.

  Definition image_filterType :=
    FilterType B image_filterMixin.

End Image.
Arguments image A [B] f P.
Arguments image_filterType A [B] f.

Lemma imageP :
  forall (A : filterType) B (f : A -> B),
  forall (P: B -> Prop),
  ultimately (image_filterType A f) P =
  ultimately A (fun x => P (f x)).
Proof. reflexivity. Qed.

(* ---------------------------------------------------------------------------- *)

(* The filter [on Q] represents validity everywhere in the set [Q].
   In other words, [on Q P] holds if and only if [Q] implies [P]. *)

Section On.

Variable A : Type.

Variable Q : pred A.

Definition on : Filter.filter A :=
  fun P => forall x, Q x -> P x.

Definition on_filterMixin : Filter.mixin_of A.
Proof.
  eapply Filter.Mixin with on; unfold on; eauto.
Defined.

Definition on_filterType := FilterType A on_filterMixin.

Goal ultimately on_filterType = on.
Proof. reflexivity. Qed.

Lemma onP:
  forall P : pred A,
  ultimately on_filterType P =
  forall x, Q x -> P x.
Proof. reflexivity. Qed.

End On.

(* ---------------------------------------------------------------------------- *)
(* As an instance of [on_filterType], the filter of positive elements on Z. *)

Definition positive_filterType : filterType := on_filterType (Z.le 0).

Lemma positiveP:
  forall P : pred Z,
  ultimately positive_filterType P =
  forall x, (0 <= x)%Z -> P x.
Proof. reflexivity. Qed.

(* ---------------------------------------------------------------------------- *)

(* The singleton set that contains just the set [A] is a filter. We call this
   modality [everywhere]. *)

Section FilterEverywhere.

Variable A : Type.

Definition everywhere_filterMixin : Filter.mixin_of A.
Proof.
  eapply Filter.Mixin with
    (fun (P: A -> Prop) => forall a, P a); eauto.
Defined.

Definition everywhere_filterType := FilterType A everywhere_filterMixin.

End FilterEverywhere.

Lemma everywhereP A :
  forall (P : A -> Prop),
  ultimately (everywhere_filterType A) P =
  forall a, P a.
Proof. reflexivity. Qed.

(* ---------------------------------------------------------------------------- *)

(* A filter on [unit], as an instance of [everywhere]. *)

Definition unit_filterType := everywhere_filterType unit.

Lemma unitP :
  forall (P : unit -> Prop), ultimately unit_filterType P = P tt.
Proof.
  intro P.
  assert (H: ultimately unit_filterType P = (forall tt, P tt)) by reflexivity.
  rewrite H.
  apply prop_ext. splits; auto. intros ? x. dependent inversion x. assumption.
Qed.

(* ---------------------------------------------------------------------------- *)

(* The filter of all subsets that contain a particular value [x]. For a property
   to hold on [singleton x], it only needs to hold on [x]. *)

Section Singleton.

Variable A : Type.
Variable x : A.

Definition singleton_filterMixin : Filter.mixin_of A.
Proof.
  eapply Filter.Mixin with (fun P => P x); eauto.
Defined.

Definition singleton_filterType := FilterType A singleton_filterMixin.

Lemma singletonP :
  forall (P : A -> Prop),
  ultimately singleton_filterType P =
  P x.
Proof. reflexivity. Qed.

End Singleton.

(* ---------------------------------------------------------------------------- *)

Section Order.

Variable A : Type.
Variable le : A -> A -> Prop.
Hypothesis IA : Inhab A.
Hypothesis upper_bound : forall x y : A, exists z, le x z /\ le y z.
Hypothesis le_trans : forall x y z, le x y -> le y z -> le x z.

Definition order : Filter.filter A :=
  fun P => exists x0, forall x, le x0 x -> P x.

Definition order_filterMixin : Filter.mixin_of A.
Proof.
  eapply Filter.Mixin with order.
  - unfold order. exists arbitrary. eauto.
  - introv [x1 H1] [x2 H2] HH. destruct (upper_bound x1 x2) as (z & Hz1 & Hz2).
    exists z. intros. eauto 10 using le_trans.
Defined.

Definition order_filterType := FilterType A order_filterMixin.

Lemma orderP :
  forall (P : A -> Prop),
  ultimately order_filterType P =
  exists x0, forall x, le x0 x -> P x.
Proof. reflexivity. Qed.

End Order.

(* ---------------------------------------------------------------------------- *)

(* The standard filter on [nat]. *)

Definition nat_filterMixin : Filter.mixin_of nat.
Proof.
  eapply Filter.Mixin with
    (fun (P: nat -> Prop) => exists n0, forall n, le n0 n -> P n).
  - exists 0%nat. eauto with arith.
  - { introv [n0 H0] [n1 H1] H. exists (max n0 n1).
      intros n ?. apply H.
      - apply H0. lia.
      - apply H1. lia. }
Defined.

Definition nat_filterType := FilterType nat nat_filterMixin.

Lemma natP :
  forall (P : nat -> Prop),
  ultimately nat_filterType P =
  exists n0, forall n, le n0 n -> P n.
Proof. reflexivity. Qed.

Lemma ultimately_ge_nat (n0: nat) :
  ultimately nat_filterType (fun n => le n0 n).
Proof.
  rewrite natP. exists n0. eauto.
Qed.

Lemma natP_ultimately (cond : nat -> Prop) :
  forall (P : nat -> Prop),
  ultimately nat_filterType cond ->
  ultimately nat_filterType P =
  exists x0, cond x0 /\ forall x, le x0 x -> P x.
Proof.
  intros P Ucond. rewrite natP. rewrite natP in Ucond.
  destruct Ucond as (ncond & Hcond).
  apply prop_ext. split.
  { intros [n0 H]. exists (max ncond n0). splits.
    - apply Hcond. lia.
    - intros. apply H. lia. }
  { intros (n0 & lo_le_n0 & H). eauto. }
Qed.

Arguments natP_ultimately [cond] [P] _.

(* ---------------------------------------------------------------------------- *)

(* The standard filter on [Z]. *)

Definition Z_filterMixin : Filter.mixin_of Z.
Proof.
  eapply Filter.Mixin with
    (fun (P: Z -> Prop) => exists n0, forall n, Z.le n0 n -> P n).
  - exists 0%Z. eauto with arith.
  - { introv [n0 H0] [n1 H1] H. exists (Z.max n0 n1).
      intros n ?. apply H.
      - apply H0. lia.
      - apply H1. lia. }
Defined.

Definition Z_filterType := FilterType Z Z_filterMixin.

Lemma ZP :
  forall (P : Z -> Prop),
  ultimately Z_filterType P =
  exists n0, forall n, Z.le n0 n -> P n.
Proof. reflexivity. Qed.

Lemma ultimately_ge_Z (x0: Z) :
  ultimately Z_filterType (fun x => Z.le x0 x).
Proof.
  rewrite ZP. exists x0. eauto.
Qed.

Lemma ZP_ultimately (cond : Z -> Prop) :
  forall (P : Z -> Prop),
  ultimately Z_filterType cond ->
  ultimately Z_filterType P =
  exists x0, cond x0 /\ forall x, Z.le x0 x -> P x.
Proof.
  intros P Ucond. rewrite ZP. rewrite ZP in Ucond.
  destruct Ucond as (ncond & Hcond).
  apply prop_ext. split.
  { intros [n0 H]. exists (Z.max ncond n0). splits.
    - apply Hcond. lia.
    - intros. apply H. lia. }
  { intros (n0 & lo_le_n0 & H). eauto. }
Qed.

Arguments ZP_ultimately [cond] [P] _.

Definition Zshift (x0 : Z) : Z -> Z :=
  fun x => (x0 + x)%Z.

Lemma Zshift_inv (x0 : Z) :
  forall x, Zshift (- x0) (Zshift x0 x) = x.
Proof.
  unfold Zshift. intros. omega.
Qed.

Lemma ZshiftP (x0 : Z) :
  forall P,
  ultimately Z_filterType (fun x => P (Zshift x0 x)) =
  ultimately Z_filterType P.
Proof.
  intros. apply prop_ext.
  split; do 2 rewrite ZP; intros (x1 & H1); unfold Zshift in *.
  { exists (x1 + x0)%Z. intros.
    assert (HH: n = (x0 + (n - x0))%Z) by lia. rewrite HH.
    apply H1. lia. }
  { exists (x1 - x0)%Z. intros. apply H1. lia. }
Qed.

(* ---------------------------------------------------------------------------- *)

(* The standard filter on [R]. *)

Definition R_filterMixin : Filter.mixin_of R.
Proof.
  eapply Filter.Mixin with
    (fun (P: R -> Prop) => exists x0, forall x, Rle x0 x -> P x).
  - exists 0%R. eauto with arith.
  - { introv [x0 H0] [x1 H1] H. exists (Rmax x0 x1).
      intros x ?. apply H.
      - apply H0. lets: Rmax_l x0 x1. lra.
      - apply H1. lets: Rmax_r x0 x1. lra. }
Defined.

Definition R_filterType := FilterType R R_filterMixin.

Lemma RP :
  forall (P : R -> Prop),
  ultimately R_filterType P =
  exists x0, forall x, Rle x0 x -> P x.
Proof. reflexivity. Qed.

(* ---------------------------------------------------------------------------- *)

(* The product of two filters. *)

(* The members of the product filter are all subsets [P] which contain a product
   [P1] * [P2], where [P1] and [P2] are members of the left-hand and right-hand
   filters, respectively. *)

(* This is a symmetric notion of product. It is *not* the same as writing
   [ultimately A1 (fun a1 => ultimately A2 (fun a2 => P (a1, a2)))], which is
   dissymmetric.

   The symmetric product implies the dissymetric ones, but the converse is
   false. For example, if P (x, y) = (x <= y), then
   [ultimately (fun x => ultimately (fun y => P (x, y)))] is true, but not
   [ultimately P].
*)

Section FilterProduct.

Variable A1 A2 : filterType.

Definition product : Filter.filter (A1 * A2) :=
  fun P =>
    exists P1 P2,
    ultimately A1 P1 /\ ultimately A2 P2 /\
    forall a1 a2, P1 a1 -> P2 a2 -> P (a1, a2).

Definition product_filterMixin : Filter.mixin_of (A1 * A2).
Proof.
  eapply Filter.Mixin with product.
  { do 2 (eexists (fun _ => True)).
    repeat split; apply filter_universe. }
  { intros P Q R.
    intros (P1 & P2 & uP1 & uP2 & ?).
    intros (Q1 & Q2 & uQ1 & uQ2 & ?).
    intros HH.
    exists (fun a1 => P1 a1 /\ Q1 a1).
    exists (fun a2 => P2 a2 /\ Q2 a2).
    repeat split; try (apply filter_conj; eauto).
    intuition eauto. }
Defined.

Definition product_filterType :=
  FilterType (A1 * A2) product_filterMixin.

End FilterProduct.

Arguments product : clear implicits.

Lemma productP :
  forall (A1 A2 : filterType) P,
  ultimately (product_filterType A1 A2) P =
  (exists P1 P2,
   ultimately A1 P1 /\
   ultimately A2 P2 /\
   (forall a1 a2, P1 a1 -> P2 a2 -> P (a1, a2))).
Proof. reflexivity. Qed.

Definition fswap (A1 A2 B : Type) (f: A1 * A2 -> B) : A2 * A1 -> B :=
  fun '(x, y) => f (y, x).

Lemma product_fswap :
  forall (A1 A2 : filterType) P,
  ultimately (product_filterType A1 A2) P <->
  ultimately (product_filterType A2 A1) (fswap P).
Proof.
  intros. do 2 rewrite productP.
  split; introv (P1 & P2 & UP1 & UP2 & HP); exists P2 P1; unfold fswap in *; splits~.
Qed.

Definition liftl (A1 A2 B : Type) (f: A1 -> B) : A1 * A2 -> B * A2 :=
  fun '(x, y) => (f x, y).

Definition liftr (A1 A2 B : Type) (f: A2 -> B) : A1 * A2 -> A1 * B :=
  fun '(x, y) => (x, f y).

(* Symmetric product implies both dissymetric products. *)

Lemma product_dissym_l :
  forall (A1 A2 : filterType) P,
  ultimately (product_filterType A1 A2) P ->
  ultimately A1 (fun x => ultimately A2 (fun y => P (x, y))).
Proof.
  introv UP. rewrite productP in UP.
  destruct UP as (P1 & P2 & UP1 & UP2 & HP).
  revert UP1; filter_closed_under_intersection. introv P1a.
  revert UP2; filter_closed_under_intersection. introv P2a.
  apply HP; eauto.
Qed.

Lemma product_dissym_r :
  forall (A1 A2 : filterType) P,
  ultimately (product_filterType A1 A2) P ->
  ultimately A2 (fun y => ultimately A1 (fun x => P (x, y))).
Proof.
  introv UP.
  forwards UP': proj1 product_fswap UP.
  apply (product_dissym_l UP').
Qed.

(* Disprove some facts about [product] that may seem true. *)

(* Dissymetric products do not imply symmetric product.
   Symmetric product is strictly stronger than dissymetric products. *)

Lemma product_counter_example_1 :
  (forall (A1 A2 : filterType) P,
   (forall x, ultimately A2 (fun y => P (x, y))) ->
   (forall y, ultimately A1 (fun x => P (x, y))) ->
   ultimately (product_filterType A1 A2) P) ->
  False.
Proof.
  intro H.
  specializes H nat_filterType nat_filterType
    (fun '(x, y) => x < y \/ y < x).
  simpl in H.
  specializes H ___.
  { intro x. rewrite natP. exists (x+1). intros. lia. }
  { intro y. rewrite natP. exists (y+1). intros. lia. }
  rewrite productP in H. destruct H as (P1 & P2 & UP1 & UP2 & HP).
  rewrite natP in UP1, UP2. destruct UP1 as (x0 & HP1). destruct UP2 as (y0 & HP2).

  destruct (Nat.le_gt_cases x0 y0).
  { specializes HP y0 y0 ___. lia. }
  { specializes HP x0 x0 ___. apply HP2. lia. lia. }
Qed.

Lemma product_counter_example_2 :
  (forall (A1 A2 : filterType) P,
   ultimately A1 (fun x => ultimately A2 (fun y => P (x, y))) ->
   ultimately A2 (fun y => ultimately A1 (fun x => P (x, y))) ->
   ultimately (product_filterType A1 A2) P) ->
  False.
Proof.
  intro H.
  apply product_counter_example_1.
  introv H1 H2.
  apply H; apply filter_universe_alt; auto.
Qed.

(* Similarly, one cannot prove a property on a product filter by proving it
   component-by-component. *)
Goal
  (forall (A1 A2 : filterType) P Q,
   ultimately A1 (fun x =>
     ultimately A2 (fun y => P (x, y)) ->
     ultimately A2 (fun y => Q (x, y))) ->
   ultimately (product_filterType A1 A2) P ->
   ultimately (product_filterType A1 A2) Q) ->
  False.
Proof.
  intro H.
  specializes H Z_filterType Z_filterType
    (fun (_: Z * Z) => True)
    (fun '(x, y) => Z.le x y).
  simpl in H.
  specializes H ___.
  { rewrite ZP. exists 0%Z. intros.
    rewrite ZP. exists n. eauto. }
  { apply filter_universe. }
  rewrite productP in H. destruct H as (P1 & P2 & UP1 & UP2 & HP).
  rewrite ZP in UP1, UP2. destruct UP1 as (x0 & HP1). destruct UP2 as (y0 & HP2).

  destruct (Z.le_gt_cases x0 y0).
  { specializes HP (y0 + 1)%Z y0 ___.
    apply HP1. lia. apply HP2. lia.
    lia. }
  { specializes HP x0 y0 ___.
    apply HP1. lia. apply HP2. lia.
    lia. }
Qed.

(* ---------------------------------------------------------------------------- *)

Section FilterOr.

Variable A : Type.
Variable F1 F2 : Filter.mixin_of A.

Definition or : Filter.filter A :=
  fun P =>
    exists P1 P2,
    ultimately (FilterType A F1) P1 /\ ultimately (FilterType A F2) P2 /\
    (forall a, P1 a \/ P2 a -> P a).

Definition or_filterMixin : Filter.mixin_of A.
Proof.
  eapply Filter.Mixin with or.
  { do 2 (eexists (fun _ => True)).
    repeat split; apply filter_universe. }
  { intros P Q R.
    intros (P1 & P2 & uP1 & uP2 & HP).
    intros (Q1 & Q2 & uQ1 & uQ2 & HQ).
    intros HH.
    exists (fun a1 => P1 a1 /\ Q1 a1).
    exists (fun a2 => P2 a2 /\ Q2 a2).
    repeat split; try apply filter_conj; eauto.
    intros a [[? ?]|[? ?]]; apply HH; eauto. }
Defined.

Definition or_filterType :=
  FilterType A or_filterMixin.

End FilterOr.

Section FilterOrP.

Variable A1 A2 : filterType.

Definition orp : Filter.filter (A1 * A2) :=
  fun P =>
    exists P1 P2,
    ultimately A1 P1 /\ ultimately A2 P2 /\
    (forall a1 a2, P1 a1 -> P (a1, a2)) /\
    (forall a1 a2, P2 a2 -> P (a1, a2)).

Definition orp_filterMixin : Filter.mixin_of (A1 * A2).
Proof.
  eapply Filter.Mixin with orp.
  { do 2 (eexists (fun _ => True)).
    repeat split; apply filter_universe. }
  { intros P Q R.
    intros (P1 & P2 & uP1 & uP2 & HP1 & HP2).
    intros (Q1 & Q2 & uQ1 & uQ2 & HQ1 & HQ2).
    intros HH.
    exists (fun a1 => P1 a1 /\ Q1 a1).
    exists (fun a2 => P2 a2 /\ Q2 a2).
    repeat split; try apply filter_conj; eauto.
    all: intros; unpack; eauto. }
Defined.

Definition orp_filterType :=
  FilterType (A1 * A2) orp_filterMixin.

End FilterOrP.

Lemma orp_equiv_or_product : forall (A1 A2: filterType) P,
  ultimately (orp_filterType A1 A2) P <->
  ultimately
    (@or_filterType (A1 * A2)
       (product_filterMixin (everywhere_filterType A1) A2)
       (product_filterMixin A1 (everywhere_filterType A2)))
    P.
Proof.
  intros. split.
  { intros (P1 & P2 & uP1 & uP2 & H1 & H2). cbn. unfold or.
    eexists (fun '(_, a2) => P2 a2).
    eexists (fun '(a1, _) => P1 a1). cbn. repeat split.
    - exists (fun _:A1 => True) P2. repeat split; eauto.
    - exists P1 (fun _:A2 => True). repeat split; eauto.
    - intros [? ?] [?|?]; eauto. }
  { intros (P1 & P2 & uP1 & uP2 & HH).
    rewrite -/(product_filterType (everywhere_filterType A1) A2) in uP1.
    rewrite -/(product_filterType A1 (everywhere_filterType A2)) in uP2.
    cbn in HH, P1, P2. cbn. unfold orp.
    exists (fun a1 => forall a2, P2 (a1, a2)).
    exists (fun a2 => forall a1, P1 (a1, a2)). repeat split; eauto.
    { destruct uP2 as (P21 & P22 & U21 & U22 & H2).
      rewrite everywhereP in U22. revert U21.
      filter_closed_under_intersection. eauto. }
    { destruct uP1 as (P11 & P12 & U11 & U12 & H1).
      rewrite everywhereP in U11. revert U12.
      filter_closed_under_intersection. eauto. } }
Qed.

(* ---------------------------------------------------------------------------- *)

Section FilterAsymProduct.

Variable A1 A2 : filterType.

Definition asymproduct : Filter.filter (A1 * A2) :=
  fun P => ultimately A1 (fun a1 => ultimately A2 (fun a2 => P (a1, a2))).

Definition asymproduct_filterMixin : Filter.mixin_of (A1 * A2).
Proof.
  eapply Filter.Mixin with asymproduct.
  { repeat (apply filter_universe_alt; intro). trivial. }
  { intros P Q R H1 H2 HH.
    revert H1 H2. unfold asymproduct. filter_closed_under_intersection.
    intro. intros [H1 H2]. revert H1 H2. filter_closed_under_intersection.
    intro. intros [? ?]. eauto. }
Defined.

Definition asymproduct_filterType :=
  FilterType (A1 * A2) asymproduct_filterMixin.

End FilterAsymProduct.

Arguments asymproduct : clear implicits.

Lemma asymproductP :
  forall (A1 A2 : filterType) P,
  ultimately (asymproduct_filterType A1 A2) P =
  ultimately A1 (fun a1 => ultimately A2 (fun a2 => P (a1, a2))).
Proof. reflexivity. Qed.

(* ---------------------------------------------------------------------------- *)

(* The dual of [ultimately] is [often]. Whereas [ultimately x, P x] intuitively
   means that, once [x] is large enough, [P x] holds always, [often x, P x]
   means that it is not the case that, once [x] is large enough, [P x] is false
   always. In other words, [often x, P x] means that there exist arbitrarily
   large [x]'s such that [P x] holds. We use the positive formulation as a
   definition. The fact this is equivalent to the doubly-negated form can be
   proved by exploiting the principle of excluded middle. *)

Section Often.

Variable A : filterType.

Implicit Type P Q : pred A.

Definition often P :=
  forall Q, ultimately A Q -> exists a, P a /\ Q a.

Lemma often_characterization:
  forall P,
  ~ ultimately A (fun x => ~ P x) <-> often P.
Proof.
  unfold often. split.

  (* Left-to-right implication. *) {
  (* Reductio ad absurdum. If there did not exist [a] that satisfies [P /\ Q],
     then [~ (P /\ Q)] would hold everywhere. *)
  intros oftenP Q ultQ.
  apply not_all_not_ex. intros nPQ.
  (* Thus, [~ (P /\ Q)] would hold ultimately. *)
  specialize (filter_universe_alt nPQ). intro nPQ'.
  (* However, by hypothesis, [Q] holds ultimately. By combining these facts,
     we find that [~P] holds ultimately. *)
  assert (ultimately A (fun a => ~ P a)).
  { eapply filter_closed_under_intersection.
    - exact ultQ.
    - exact nPQ'.
    - eauto. }
  (* This contradicts the hypothesis [~ ultimately ~ P]. *)
  tauto. }

  (* Right-to-left implication. *)
  { intros H unP. destruct (H _ unP). tauto. }
Qed.

(* TEMPORARY the definition of [often] looks like a [limit] assertion. Is it one?
   Is there a connection? *)

End Often.

Arguments often : clear implicits.

(* ---------------------------------------------------------------------------- *)

Section InvImage.
  Variable A : Type.
  Variable B : filterType.

  Variable f : A -> B.

  Definition invimage : Filter.filter A :=
    fun P => exists Q,
        ultimately B Q /\
        (forall a, Q (f a) -> P a).

  Definition invimage_filterMixin : Filter.mixin_of A.
  Proof.
    eapply Filter.Mixin with invimage.
    { unfold invimage. exists (fun _:B => True).
      eauto using filter_universe_alt. }
    { intros P1 P2 P [Q1 [UQ1 I1]] [Q2 [UQ2 I2]] HH. unfold invimage.
      exists (fun b => Q1 b /\ Q2 b). split.
      revert UQ1 UQ2; filter_closed_under_intersection; eauto.
      intros a [? ?]. eauto. }
  Defined.

  Definition invimage_filterType := FilterType A invimage_filterMixin.

End InvImage.

Arguments invimage : clear implicits.
Arguments invimage_filterType : clear implicits.

Lemma invimageP : forall A B f P,
  ultimately (invimage_filterType A B f) P =
  (exists Q, ultimately B Q /\ (forall a, Q (f a) -> P a)).
Proof. reflexivity. Qed.

(* ---------------------------------------------------------------------------- *)

Section Within.

(* If we have a filter on [A], and if [P] is a subset of [A], then [within P] is
   also a filter on [A]. By definition, a formula [Q] is ultimately holds within
   [P] if and only if [P -> Q] is ultimately true. *)

Variable A : filterType.

Variable P : pred A.

Definition within : Filter.filter A :=
  fun Q => ultimately A (fun x => P x -> Q x).

Definition within_filterMixin : Filter.mixin_of A.
Proof.
  eapply Filter.Mixin with within.
  { apply filter_universe_alt. tauto. }
  { intros Q1 Q2 Q hPQ1 hPQ2 ?.
    eapply filter_closed_under_intersection.
    - exact hPQ1.
    - exact hPQ2.
    - eauto. }
Defined.

Definition within_filterType := FilterType A within_filterMixin.

Goal ultimately within_filterType = within.
Proof. reflexivity. Qed.

End Within.

Arguments within : clear implicits.
Arguments within_filterType : clear implicits.

Lemma withinP:
  forall (A : filterType) (P : A -> Prop),
  forall Q,
  ultimately (within_filterType A P) Q =
  ultimately A (fun x => P x -> Q x).
Proof. reflexivity. Qed.

Lemma within_finer :
  forall (A : filterType) P,
  finer (ultimately (within_filterType A P)) (ultimately A) .
Proof.
  introv. unfold finer. intros Q. rewrite withinP.
  filter_closed_under_intersection. tauto.
Qed.

(* ---------------------------------------------------------------------------- *)

Definition measure {A} (m: A -> Z) : Filter.filter A :=
  invimage A Z_filterType m.

Definition measure_filterType {A} (m: A -> Z) :=
  invimage_filterType A Z_filterType m.

Lemma measureP : forall A (m: A -> Z) P,
  ultimately (measure_filterType m) P =
  exists x0, forall x, (x0 <= m x)%Z -> P x.
Proof.
  intros. apply prop_ext. cbn. unfold invimage.
  split; intros H.
  - destruct H as [Q [HQ H]]. rewrite ZP in HQ.
    destruct HQ as [x0 H0]. exists x0. auto.
  - destruct H as [x0 H0]. exists (fun x => x0 <= x)%Z.
    rewrite ZP. eauto.
Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Require Export common.lhs_nil_reduce.rhs_nil_reduce.
Require Export common.lhs_nil_reduce.rhs_other_reduce.

Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_nil_reduce :
  forall T, subtype t_nil T = match T with
                         | t_nil => true
                         | _ => false
                         end.
Proof.
  intros; subst; destruct T;
    try solve [eapply subtype_nil_other_reduce; crush].
  apply subtype_nil_nil_reduce; auto.
Qed.


Require Import
  HoTT.HProp
  HoTT.Classes.interfaces.canonical_names
  HoTT.Classes.interfaces.ua_algebra.

Import algebra_notations ne_list.notations.

Section congruence.
  Context {σ : Signature} (A : Algebra σ) (Φ : ∀ s, Relation (A s)).

(** An operation [f : A s1 → A s2 → ... → A sn → A t] satisfies
    [OpCompatible f] iff

    <<
      Φ s1 x1 y1 ∧ Φ s2 x2 y2 ∧ ... ∧ Φ sn xn yn
    >>

    implies

    <<
      Φ t (f x1 x2 ... xn) (f y1 y2 ... yn).
    >>
*)

  Definition OpCompatible {w : SymbolType σ} (f : Operation A w)
    : Type
    := ∀ (a b : FamilyProd A (dom_symboltype w)),
       for_all_2_family_prod A A Φ a b ->
       Φ (cod_symboltype w) (ap_operation f a) (ap_operation f b).

  Class OpsCompatible : Type
    := ops_compatible : ∀ (u : Symbol σ), OpCompatible u.#A.

  Global Instance trunc_ops_compatible `{Funext} {n : trunc_index}
    `{!∀ s x y, IsTrunc n (Φ s x y)}
    : IsTrunc n OpsCompatible.
  Proof.
    apply istrunc_forall.
  Qed.

  (** A family of relations [Φ] is a congruence iff it is a family of
      mere equivalence relations and [OpsCompatible A Φ] holds. *)

  Class IsCongruence : Type := BuildIsCongruence
   { is_mere_relation_cong : ∀ (s : Sort σ), is_mere_relation (A s) (Φ s)
   ; equiv_rel_cong : ∀ (s : Sort σ), EquivRel (Φ s)
   ; ops_compatible_cong : OpsCompatible }.

  Global Arguments BuildIsCongruence {is_mere_relation_cong}
                                     {equiv_rel_cong}
                                     {ops_compatible_cong}.

  Global Existing Instance is_mere_relation_cong.

  Global Existing Instance equiv_rel_cong.

  Global Existing Instance ops_compatible_cong.

  Global Instance hprop_is_congruence `{Funext} : IsHProp IsCongruence.
  Proof.
    apply (equiv_hprop_allpath _)^-1.
    intros [C1 C2 C3] [D1 D2 D3].
    by destruct (path_ishprop C1 D1),
                (path_ishprop C2 D2),
                (path_ishprop C3 D3).
  Defined.

End congruence.

(** If [Φ] is a congruence and [f : A s1 → A s2 → ... → A sn] an
    operation such that [OpCompatible A Φ f] holds.
    Then [OpCompatible (f x)] holds for all [x : A s1]. *)

Lemma op_compatible_cons {σ : Signature} {A : Algebra σ}
  (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}
  (s : Sort σ) (w : SymbolType σ) (f : Operation A (s ::: w))
  (x : A s) (P : OpCompatible A Φ f)
  : OpCompatible A Φ (f x).
Proof.
  intros a b R.
  exact (P (x,a) (x,b) (EquivRel_Reflexive x, R)).
Defined.


Require Import ct00.
(* ct00 contains the original conjecture. *)

Require Import ct02 ct06 ct09 ct10.
(* ct02 ct06 ct09 contains the following proven lemmas:
 * - sort_prog_base
 * - perm_nil_sort_cons
 * - perm_tail_cross
 * - inserted_sorted
 *)

Lemma sort_ind_case : forall (a a0 : nat) (l' l x : list nat),
  sorted (a0 :: l') -> permutation (a0 :: l') l
  -> sorted x -> permutation x (a :: l')
  -> {l'0 : list nat | sorted l'0 /\ permutation l'0 (a :: l)}.
Proof.
intros; destruct (le_lt_dec a a0).
- exists (a :: a0 :: l'); split; constructor; auto.
- exists (a0 :: x); split.
  + eapply inserted_sorted; eassumption.
  + eapply perm_tail_cross; eassumption.
Defined.

Lemma sort_prog_IH : forall (a : nat) (l l' : list nat),
  sorted l' -> permutation l' l ->
  {l'0 : list nat | sorted l'0 /\ permutation l'0 (a :: l)}.
Proof.
intros; revert l H H0; induction l'; intros.
- apply perm_nil_sort_cons; eassumption.
- destruct (IHl' l'); clear IHl'.
  + inversion H; eassumption.
  + apply Permutation_refl.
  + destruct a1; eapply sort_ind_case; eassumption.
Defined.

Lemma isort_prog :
  forall (l : list nat), {l' : list nat | sorted l' /\ permutation l' l}.
Proof.
induction l.
- apply sort_prog_base.
- destruct IHl; destruct a0; eapply sort_prog_IH; eassumption.
Defined.

(*---------------------------------Extraction---------------------------------*)

Require Extraction.
Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.
(* Suppose all the packages above are embedded in some trans *)

Extraction Language OCaml.
Set Extraction AccessOpaque.

Definition insert_prog (a : nat) (l : list nat) := sort_prog_IH a l l.

Extraction "extraction/insert.ml" insert_prog.
Extraction "extraction/isort.ml" isort_prog.


(* Make [omega] work for [N] *)

Require Import Coq.Arith.Arith Coq.omega.Omega Coq.NArith.NArith.

Local Open Scope N_scope.

Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus
  N_of_nat_of_N nat_of_N_of_nat
  nat_of_P_o_P_of_succ_nat_eq_succ nat_of_P_succ_morphism : N.

Theorem nat_of_N_eq : forall n m,
  nat_of_N n = nat_of_N m
  -> n = m.
  intros ? ? H; apply (f_equal N_of_nat) in H;
    autorewrite with N in *; assumption.
Qed.

Theorem Nneq_in : forall n m,
  nat_of_N n <> nat_of_N m
  -> n <> m.
  congruence.
Qed.

Theorem Nneq_out : forall n m,
  n <> m
  -> nat_of_N n <> nat_of_N m.
  intuition.
  match goal with H0 : _ |- _ => apply nat_of_N_eq in H0; tauto end.
Qed.

Theorem Nlt_out : forall n m, n < m
  -> (nat_of_N n < nat_of_N m)%nat.
  unfold Nlt; intros ?? H.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_Lt_lt; assumption.
Qed.

Theorem Nlt_in : forall n m, (nat_of_N n < nat_of_N m)%nat
  -> n < m.
  unfold Nlt; intros.
  rewrite nat_of_Ncompare.
  apply (proj1 (nat_compare_lt _ _)); assumption.
Qed.

Theorem Nge_out : forall n m, n >= m
  -> (nat_of_N n >= nat_of_N m)%nat.
  unfold Nge; intros ?? H.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_ge; assumption.
Qed.

Theorem Nge_in : forall n m, (nat_of_N n >= nat_of_N m)%nat
  -> n >= m.
  unfold Nge; intros.
  rewrite nat_of_Ncompare.
  apply nat_compare_ge; assumption.
Qed.

Ltac nsimp H := simpl in H; repeat progress (autorewrite with N in H; simpl in H).

Ltac pre_nomega :=
  try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in); simpl;
    repeat (progress autorewrite with N; simpl);
    repeat match goal with
             | [ H : _ <> _ |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ = _ -> False |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H
               || apply Nlt_out in H || apply Nge_out in H); nsimp H
           end.

Ltac nomega := pre_nomega; omega || (unfold nat_of_P in *; simpl in *; omega).


Require Import
  HoTT.Classes.theory.apartness
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.theory.rings.
Require Export
  HoTT.Classes.orders.orders
  HoTT.Classes.orders.maps.

Generalizable Variables R Rlt f.

Section semiring_order.
  Context `{SemiRingOrder R} `{!IsSemiRing R}.
(*   Add Ring R : (stdlib_semiring_theory R). *)

  Global Instance plus_le_embed_l : forall (z : R), OrderEmbedding (+z).
  Proof.
  intro. split.
  - apply order_preserving_flip.
  - apply order_reflecting_flip.
  Qed.

  Global Instance plus_ordered_cancel_l : forall z, LeftCancellation (+) z.
  Proof.
  intros z x y E.
  apply (antisymmetry (≤)); apply (order_reflecting (z+)); apply eq_le;trivial.
  apply symmetry;trivial.
  Qed.

  Global Instance plus_ordered_cancel_r : forall z, RightCancellation (+) z.
  Proof.
  intros. apply (right_cancel_from_left (+)).
  Qed.

  Lemma nonneg_plus_le_compat_r x z : 0 ≤ z <-> x ≤ x + z.
  Proof.
  pattern x at 1. apply (transport _ (plus_0_r x)).
  split; intros.
  - apply (order_preserving _). trivial.
  - apply (order_reflecting (x+)). trivial.
  Qed.

  Lemma nonneg_plus_le_compat_l x z : 0 ≤ z <-> x ≤ z + x.
  Proof.
  rewrite (commutativity (f:=plus)).
  apply nonneg_plus_le_compat_r.
  Qed.

  Lemma plus_le_compat x₁ y₁ x₂ y₂ : x₁ ≤ y₁ -> x₂ ≤ y₂ -> x₁ + x₂ ≤ y₁ + y₂.
  Proof.
  intros E1 E2.
  transitivity (y₁ + x₂).
  - apply (order_preserving (+ x₂));trivial.
  - apply (order_preserving (y₁ +));trivial.
  Qed.

  Lemma plus_le_compat_r x y z : 0 ≤ z -> x ≤ y -> x ≤ y + z.
  Proof.
  intros. rewrite <-(plus_0_r x).
  apply plus_le_compat;trivial.
  Qed.

  Lemma plus_le_compat_l x y z : 0 ≤ z -> x ≤ y -> x ≤ z + y.
  Proof.
  rewrite (commutativity (f:=plus)).
  apply plus_le_compat_r.
  Qed.

  Lemma nonpos_plus_compat x y : x ≤ 0 -> y ≤ 0 -> x + y ≤ 0.
  Proof.
  intros. rewrite <-(plus_0_r 0).
  apply plus_le_compat;trivial.
  Qed.

  Instance nonneg_plus_compat (x y : R)
    : PropHolds (0 ≤ x) -> PropHolds (0 ≤ y) -> PropHolds (0 ≤ x + y).
  Proof.
  intros.
  apply plus_le_compat_l;trivial.
  Qed.

  Lemma decompose_le {x y} : x ≤ y -> exists z, 0 ≤ z /\ y = x + z.
  Proof.
  intros E.
  destruct (srorder_partial_minus x y E) as [z Ez].
  exists z. split; [| trivial].
  apply (order_reflecting (x+)).
  rewrite plus_0_r, <-Ez.
  trivial.
  Qed.

  Lemma compose_le x y z : 0 ≤ z -> y = x + z -> x ≤ y.
  Proof.
  intros E1 E2.
  rewrite E2.
  apply nonneg_plus_le_compat_r.
  trivial.
  Qed.

  Global Instance nonneg_mult_le_l : forall (z : R), PropHolds (0 ≤ z) ->
    OrderPreserving (z *.).
  Proof.
  intros z E.
  repeat (split; try apply _).
  intros x y F.
  destruct (decompose_le F) as [a [Ea1 Ea2]].
  rewrite Ea2, plus_mult_distr_l.
  apply nonneg_plus_le_compat_r.
  apply nonneg_mult_compat;trivial.
  Qed.

  Global Instance nonneg_mult_le_r : forall (z : R), PropHolds (0 ≤ z) ->
    OrderPreserving (.* z).
  Proof.
  intros. apply order_preserving_flip.
  Qed.

  Lemma mult_le_compat x₁ y₁ x₂ y₂ :
    0 ≤ x₁ -> 0 ≤ x₂ -> x₁ ≤ y₁ -> x₂ ≤ y₂ -> x₁ * x₂ ≤ y₁ * y₂.
  Proof.
  intros Ex₁ Ey₁ E1 E2.
  transitivity (y₁ * x₂).
  - apply (order_preserving_flip_nonneg (.*.) x₂);trivial.
  - apply (order_preserving_nonneg (.*.) y₁); [| trivial].
    transitivity x₁;trivial.
  Qed.

  Lemma ge_1_mult_le_compat_r x y z : 1 ≤ z -> 0 ≤ y -> x ≤ y -> x ≤ y * z.
  Proof.
  intros.
  transitivity y; [trivial |].
  pattern y at 1;apply (transport _ (mult_1_r y)).
  apply (order_preserving_nonneg (.*.) y);trivial.
  Qed.

  Lemma ge_1_mult_le_compat_l x y z : 1 ≤ z -> 0 ≤ y -> x ≤ y -> x ≤ z * y.
  Proof.
  rewrite (commutativity (f:=mult)).
  apply ge_1_mult_le_compat_r.
  Qed.

  Lemma flip_nonpos_mult_l x y z : z ≤ 0 -> x ≤ y -> z * y ≤ z * x.
  Proof.
  intros Ez Exy.
  destruct (decompose_le Ez) as [a [Ea1 Ea2]], (decompose_le Exy) as [b [Eb1 Eb2]].
  rewrite Eb2.
  apply compose_le with (a * b).
  - apply nonneg_mult_compat;trivial.
  - transitivity (z * x + (z + a) * b).
    + rewrite <-Ea2. rewrite mult_0_l,plus_0_r. reflexivity.
    + rewrite plus_mult_distr_r,plus_mult_distr_l.
      apply associativity.
  Qed.

  Lemma flip_nonpos_mult_r x y z : z ≤ 0 -> x ≤ y -> y * z ≤ x * z.
  Proof.
  rewrite 2!(commutativity _ z).
  apply flip_nonpos_mult_l.
  Qed.

  Lemma nonpos_mult x y : x ≤ 0 -> y ≤ 0 -> 0 ≤ x * y.
  Proof.
  intros.
  rewrite <-(mult_0_r x).
  apply flip_nonpos_mult_l;trivial.
  Qed.

  Lemma nonpos_nonneg_mult x y : x ≤ 0 -> 0 ≤ y -> x * y ≤ 0.
  Proof.
  intros.
  rewrite <-(mult_0_r x).
  apply flip_nonpos_mult_l;trivial.
  Qed.

  Lemma nonneg_nonpos_mult x y : 0 ≤ x -> y ≤ 0 -> x * y ≤ 0.
  Proof.
  intros.
  rewrite (commutativity (f:=mult)).
  apply nonpos_nonneg_mult;trivial.
  Qed.
End semiring_order.

(* Due to bug #2528 *)
#[export]
Hint Extern 7 (PropHolds (0 ≤ _ + _)) =>
  eapply @nonneg_plus_compat : typeclass_instances.

Section strict_semiring_order.
  Context `{IsSemiRing R} `{!StrictSemiRingOrder Rlt}.
(*   Add Ring Rs : (stdlib_semiring_theory R). *)

  Global Instance plus_lt_embed : forall (z : R), StrictOrderEmbedding (+z).
  Proof.
  intro. split.
  - apply strictly_order_preserving_flip.
  - apply strictly_order_reflecting_flip.
  Qed.

  Lemma pos_plus_lt_compat_r x z : 0 < z <-> x < x + z.
  Proof.
  pattern x at 1;apply (transport _ (plus_0_r x)).
  split; intros.
  - apply (strictly_order_preserving _);trivial.
  - apply (strictly_order_reflecting (x+));trivial.
  Qed.

  Lemma pos_plus_lt_compat_l x z : 0 < z -> x < z + x.
  Proof.
  rewrite (commutativity (f:=plus)).
  apply pos_plus_lt_compat_r.
  Qed.

  Lemma plus_lt_compat x₁ y₁ x₂ y₂ : x₁ < y₁ -> x₂ < y₂ -> x₁ + x₂ < y₁ + y₂.
  Proof.
  intros E1 E2.
  transitivity (y₁ + x₂).
  - apply (strictly_order_preserving (+ x₂));trivial.
  - apply (strictly_order_preserving (y₁ +));trivial.
  Qed.

  Lemma plus_lt_compat_r x y z : 0 < z -> x < y -> x < y + z.
  Proof.
  intros. rewrite <-(plus_0_r x). apply plus_lt_compat;trivial.
  Qed.

  Lemma plus_lt_compat_l x y z : 0 < z -> x < y -> x < z + y.
  Proof.
  rewrite (commutativity (f:=plus)).
  apply plus_lt_compat_r.
  Qed.

  Lemma neg_plus_compat x y : x < 0 -> y < 0 -> x + y < 0.
  Proof.
  intros. rewrite <-(plus_0_r 0).
  apply plus_lt_compat;trivial.
  Qed.

  Instance pos_plus_compat (x y : R)
    : PropHolds (0 < x) -> PropHolds (0 < y) -> PropHolds (0 < x + y).
  Proof.
  intros. apply plus_lt_compat_l;trivial.
  Qed.

  Lemma compose_lt x y z : 0 < z -> y = x + z -> x < y.
  Proof.
  intros E1 E2.
  rewrite E2.
  apply pos_plus_lt_compat_r;trivial.
  Qed.

  Lemma decompose_lt {x y} : x < y -> exists z, 0 < z /\ y = x + z.
  Proof.
  intros E.
  destruct (strict_srorder_partial_minus x y E) as [z Ez].
  exists z. split; [| trivial].
  apply (strictly_order_reflecting (x+)).
  rewrite <-Ez, rings.plus_0_r. trivial.
  Qed.

  Global Instance pos_mult_lt_l : forall (z : R), PropHolds (0 < z) ->
    StrictlyOrderPreserving (z *.).
  Proof.
  intros z E x y F.
  destruct (decompose_lt F) as [a [Ea1 Ea2]].
  rewrite Ea2, plus_mult_distr_l.
  apply pos_plus_lt_compat_r.
  apply pos_mult_compat;trivial.
  Qed.

  Global Instance pos_mult_lt_r : forall (z : R), PropHolds (0 < z) ->
    StrictlyOrderPreserving (.* z).
  Proof.
  intros. apply strictly_order_preserving_flip.
  Qed.

  Lemma mult_lt_compat x₁ y₁ x₂ y₂ :
    0 < x₁ -> 0 < x₂ -> x₁ < y₁ -> x₂ < y₂ -> x₁ * x₂ < y₁ * y₂.
  Proof.
  intros Ex₁ Ey₁ E1 E2.
  transitivity (y₁ * x₂).
  - apply (strictly_order_preserving_flip_pos (.*.) x₂);trivial.
  - apply (strictly_order_preserving_pos (.*.) y₁); [| trivial ].
    transitivity x₁;trivial.
  Qed.

  Lemma gt_1_mult_lt_compat_r x y z : 1 < z -> 0 < y -> x < y -> x < y * z.
  Proof.
  intros.
  transitivity y; [ trivial |].
  pattern y at 1;apply (transport _ (mult_1_r y)).
  apply (strictly_order_preserving_pos (.*.) y);trivial.
  Qed.

  Lemma gt_1_mult_lt_compat_l x y z : 1 < z -> 0 < y -> x < y -> x < z * y.
  Proof.
  rewrite (commutativity (f:=mult)).
  apply gt_1_mult_lt_compat_r.
  Qed.

  Lemma flip_neg_mult_l x y z : z < 0 -> x < y -> z * y < z * x.
  Proof.
  intros Ez Exy.
  destruct (decompose_lt Ez) as [a [Ea1 Ea2]], (decompose_lt Exy) as [b [Eb1 Eb2]].
  rewrite Eb2.
  apply compose_lt with (a * b).
  - apply pos_mult_compat;trivial.
  - transitivity (z * x + (z + a) * b).
    + rewrite <-Ea2. rewrite mult_0_l,plus_0_r;reflexivity.
    + rewrite plus_mult_distr_r,plus_mult_distr_l.
      apply associativity.
  Qed.

  Lemma flip_neg_mult_r x y z : z < 0 -> x < y -> y * z < x * z.
  Proof.
  rewrite 2!(commutativity _ z).
  apply flip_neg_mult_l.
  Qed.

  Lemma neg_mult x y : x < 0 -> y < 0 -> 0 < x * y.
  Proof.
  intros.
  rewrite <-(mult_0_r x).
  apply flip_neg_mult_l;trivial.
  Qed.

  Lemma pos_mult x y : 0 < x -> 0 < y -> 0 < x * y.
  Proof.
    intros xpos ypos.
    rewrite <-(mult_0_r x).
    apply (pos_mult_lt_l); assumption.
  Qed.

  Lemma neg_pos_mult x y : x < 0 -> 0 < y -> x * y < 0.
  Proof.
  intros.
  rewrite <-(mult_0_r x).
  apply flip_neg_mult_l;trivial.
  Qed.

  Lemma pos_neg_mult x y : 0 < x -> y < 0 -> x * y < 0.
  Proof.
  intros. rewrite (commutativity (f:=mult)).
  apply neg_pos_mult;trivial.
  Qed.
End strict_semiring_order.

(* Due to bug #2528 *)
#[export]
Hint Extern 7 (PropHolds (0 < _ + _)) =>
  eapply @pos_plus_compat : typeclass_instances.

Section pseudo_semiring_order.
  Context `{PseudoSemiRingOrder R} `{!IsSemiRing R}.
(*   Add Ring Rp : (stdlib_semiring_theory R). *)

  Local Existing Instance pseudo_order_apart.

  Global Instance pseudosrorder_strictsrorder : StrictSemiRingOrder (_ : Lt R).
  Proof.
  split; try apply _.
  - intros. apply pseudo_srorder_partial_minus, lt_flip. trivial.
  - apply pseudo_srorder_pos_mult_compat.
  Qed.

  Global Instance plus_strong_ext : StrongBinaryExtensionality (+).
  Proof.
  assert (forall z, StrongExtensionality (z +)).
  - intros. apply pseudo_order_embedding_ext.
  - apply apartness.strong_binary_setoid_morphism_commutative.
  Qed.

  Global Instance plus_strong_cancel_l
    : forall z, StrongLeftCancellation (+) z.
  Proof.
  intros z x y E.
  apply apart_iff_total_lt in E;apply apart_iff_total_lt.
  destruct E; [left | right]; apply (strictly_order_preserving (z +));trivial.
  Qed.

  Global Instance plus_strong_cancel_r
    : forall z, StrongRightCancellation (+) z.
  Proof.
  intros. apply (strong_right_cancel_from_left (+)).
  Qed.

  Lemma neg_mult_decompose x y : x * y < 0 -> (x < 0 /\ 0 < y) |_| (0 < x /\ y < 0).
  Proof.
  intros.
  assert (0 ≶ x) as Ex;[|assert (apart 0 y) as Ey].
  - apply (strong_extensionality (.* y)).
    rewrite mult_0_l. apply pseudo_order_lt_apart_flip;trivial.
  - apply (strong_extensionality (x *.)).
    rewrite mult_0_r. apply pseudo_order_lt_apart_flip;trivial.
  - apply apart_iff_total_lt in Ex;apply apart_iff_total_lt in Ey.
    destruct Ex as [Ex|Ex], Ey as [Ey|Ey]; try auto.
    + destruct (irreflexivity (<) 0).
      transitivity (x * y); [| trivial].
      apply pos_mult_compat;trivial.
    + destruct (irreflexivity (<) 0).
      transitivity (x * y); [| trivial].
      apply neg_mult;trivial.
  Qed.

  Lemma pos_mult_decompose x y : 0 < x * y -> (0 < x /\ 0 < y) |_| (x < 0 /\ y < 0).
  Proof.
  intros.
  assert (0 ≶ x /\ apart 0 y) as [Ex Ey];[split|].
  - apply (strong_extensionality (.* y)).
    rewrite mult_0_l. apply pseudo_order_lt_apart;trivial.
  - apply (strong_extensionality (x *.)).
    rewrite mult_0_r. apply pseudo_order_lt_apart;trivial.
  - apply apart_iff_total_lt in Ex;apply apart_iff_total_lt in Ey.
    destruct Ex as [Ex|Ex], Ey as [Ey|Ey]; try auto.
    + destruct (irreflexivity (<) 0).
      transitivity (x * y); [trivial |].
      apply pos_neg_mult;trivial.
    + destruct (irreflexivity (<) 0).
      transitivity (x * y); [trivial |].
      apply neg_pos_mult;trivial.
  Qed.

  Global Instance pos_mult_reflect_l
    : forall (z : R), PropHolds (0 < z) -> StrictlyOrderReflecting (z *.).
  Proof.
  intros z Ez x y E1.
  apply not_lt_apart_lt_flip.
  + intros E2. apply (lt_flip _ _ E1).
    apply (strictly_order_preserving (z *.));trivial.
  + apply (strong_extensionality (z *.)).
    apply pseudo_order_lt_apart_flip;trivial.
  Qed.

  Global Instance pos_mult_reflect_r
    : forall (z : R), PropHolds (0 < z) -> StrictlyOrderReflecting (.* z).
  Proof.
  intros.
  apply strictly_order_reflecting_flip.
  Qed.

  Global  Instance apartzero_mult_strong_cancel_l
    : forall z, PropHolds (z ≶ 0) -> StrongLeftCancellation (.*.) z.
  Proof.
  intros z Ez x y E. red in Ez.
  apply apart_iff_total_lt in E;apply apart_iff_total_lt in Ez;
  apply apart_iff_total_lt.
  destruct E as [E|E], Ez as [Ez|Ez].
  - right. apply flip_neg_mult_l;trivial.
  - left. apply (strictly_order_preserving_pos (.*.) z);trivial.
  - left. apply flip_neg_mult_l;trivial.
  - right. apply (strictly_order_preserving_pos (.*.) z);trivial.
  Qed.

  Global Instance apartzero_mult_strong_cancel_r
    : forall z, PropHolds (z ≶ 0) -> StrongRightCancellation (.*.) z.
  Proof.
  intros.
  apply (strong_right_cancel_from_left (.*.)).
  Qed.

  Global Instance apartzero_mult_cancel_l
    : forall z, PropHolds (z ≶ 0) -> LeftCancellation (.*.) z.
  Proof.
  intros. apply _.
  Qed.

  Global Instance apartzero_mult_cancel_r
    : forall z, PropHolds (z ≶ 0) -> RightCancellation (.*.) z.
  Proof.
  intros. apply _.
  Qed.

  Lemma square_pos x : x ≶ 0 -> 0 < x * x.
  Proof.
  intros E. apply apart_iff_total_lt in E.
  destruct E as [E|E].
  - destruct (decompose_lt E) as [z [Ez1 Ez2]].
    apply compose_lt with (z * z).
    + apply pos_mult_compat;trivial.
    + rewrite plus_0_l.
      apply (left_cancellation (+) (x * z)).
      rewrite <-plus_mult_distr_r, <-plus_mult_distr_l.
      rewrite (commutativity (f:=plus) z x), <-!Ez2.
      rewrite mult_0_l,mult_0_r. reflexivity.
  - apply pos_mult_compat;trivial.
  Qed.

  Lemma pos_mult_rev_l x y : 0 < x * y -> 0 < y -> 0 < x.
  Proof.
  intros. apply (strictly_order_reflecting (.* y)).
  rewrite rings.mult_0_l;trivial.
  Qed.

  Lemma pos_mult_rev_r x y : 0 < x * y -> 0 < x -> 0 < y.
  Proof.
  intros. apply pos_mult_rev_l with x.
  - rewrite (commutativity (f:=mult));trivial.
  - trivial.
  Qed.

  Context `{PropHolds (1 ≶ 0)}.

  Instance lt_0_1 : PropHolds (0 < 1).
  Proof.
  red.
  rewrite <-(mult_1_l 1).
  apply square_pos;trivial.
  Qed.

  Instance lt_0_2 : PropHolds (0 < 2).
  Proof.
  apply _.
  Qed.

  Instance lt_0_3 : PropHolds (0 < 3).
  Proof.
  apply _.
  Qed.

  Instance lt_0_4 : PropHolds (0 < 4).
  Proof.
  apply _.
  Qed.

  Lemma lt_1_2 : 1 < 2.
  Proof.
  apply pos_plus_lt_compat_r, lt_0_1.
  Qed.

  Lemma lt_1_3 : 1 < 3.
  Proof.
  apply pos_plus_lt_compat_r, lt_0_2.
  Qed.

  Lemma lt_1_4 : 1 < 4.
  Proof.
  apply pos_plus_lt_compat_r, lt_0_3.
  Qed.

  Lemma lt_2_3 : 2 < 3.
  Proof.
  apply (strictly_order_preserving (1+)), lt_1_2.
  Qed.

  Lemma lt_2_4 : 2 < 4.
  Proof.
  apply (strictly_order_preserving (1+)), lt_1_3.
  Qed.

  Lemma lt_3_4 : 3 < 4.
  Proof.
  apply (strictly_order_preserving (1+)), lt_2_3.
  Qed.

  Instance apart_0_2 : PropHolds (2 ≶ 0).
  Proof.
  red. apply symmetry.
  apply pseudo_order_lt_apart, lt_0_2.
  Qed.
End pseudo_semiring_order.

#[export]
Hint Extern 7 (PropHolds (0 < 1)) => eapply @lt_0_1 : typeclass_instances.
#[export]
Hint Extern 7 (PropHolds (0 < 2)) => eapply @lt_0_2 : typeclass_instances.
#[export]
Hint Extern 7 (PropHolds (0 < 3)) => eapply @lt_0_3 : typeclass_instances.
#[export]
Hint Extern 7 (PropHolds (0 < 4)) => eapply @lt_0_4 : typeclass_instances.
#[export]
Hint Extern 7 (PropHolds (2 ≶ 0)) => eapply @apart_0_2 : typeclass_instances.

Section full_pseudo_semiring_order.
  Context `{FullPseudoSemiRingOrder R} `{!IsSemiRing R}.

(*   Add Ring Rf : (stdlib_semiring_theory R). *)

  Global Instance fullpseudosrorder_fullpseudoorder
    : FullPseudoOrder (_ : Le R) (_ : Lt R).
  Proof.
  split.
  - apply _.
  - apply _.
  - apply full_pseudo_srorder_le_iff_not_lt_flip.
  Qed.

  Global Instance fullpseudosrorder_srorder : SemiRingOrder (_ : Le R).
  Proof.
  split; try apply _.
  - intros x y E. apply le_iff_not_lt_flip in E.
    apply pseudo_srorder_partial_minus;trivial.
  - intros z. repeat (split; try apply _).
    + intros x y E1. apply le_iff_not_lt_flip in E1;apply le_iff_not_lt_flip.
      intros E2. apply E1.
      apply (strictly_order_reflecting (z+)). trivial.
    + intros x y E1.  apply le_iff_not_lt_flip in E1;apply le_iff_not_lt_flip.
      intros E2. apply E1.
      apply (strictly_order_preserving _);trivial.
  - intros x y Ex Ey.
    apply le_iff_not_lt_flip in Ex;apply le_iff_not_lt_flip in Ey;
    apply le_iff_not_lt_flip.
    intros E.
    destruct (neg_mult_decompose x y E) as [[? ?]|[? ?]];auto.
  Qed.

  Global Instance : forall (z : R), PropHolds (0 < z) -> OrderReflecting (z *.).
  Proof.
  intros z E. apply full_pseudo_order_reflecting.
  Qed.

  Global Instance: forall (z : R), PropHolds (0 < z) -> OrderReflecting (.* z).
  Proof.
  intros. apply order_reflecting_flip.
  Qed.

  Lemma plus_lt_le_compat x₁ y₁ x₂ y₂ : x₁ < y₁ -> x₂ ≤ y₂ -> x₁ + x₂ < y₁ + y₂.
  Proof.
  intros E1 E2.
  apply lt_le_trans with (y₁ + x₂).
  - apply (strictly_order_preserving (+ x₂));trivial.
  - apply (order_preserving (y₁ +));trivial.
  Qed.

  Lemma plus_le_lt_compat x₁ y₁ x₂ y₂ : x₁ ≤ y₁ -> x₂ < y₂ -> x₁ + x₂ < y₁ + y₂.
  Proof.
  intros E1 E2.
  apply le_lt_trans with (y₁ + x₂).
  - apply (order_preserving (+ x₂));trivial.
  - apply (strictly_order_preserving (y₁ +));trivial.
  Qed.

  Lemma nonneg_plus_lt_compat_r x y z : 0 ≤ z -> x < y -> x < y + z.
  Proof.
  intros. rewrite <-(plus_0_r x). apply plus_lt_le_compat;trivial.
  Qed.

  Lemma nonneg_plus_lt_compat_l x y z : 0 ≤ z -> x < y -> x < z + y.
  Proof.
  intros. rewrite (commutativity (f:=plus)).
  apply nonneg_plus_lt_compat_r;trivial.
  Qed.

  Lemma pos_plus_le_lt_compat_r x y z : 0 < z -> x ≤ y -> x < y + z.
  Proof.
  intros. rewrite <-(plus_0_r x). apply plus_le_lt_compat;trivial.
  Qed.

  Lemma pos_plus_le_lt_compat_l x y z : 0 < z -> x ≤ y -> x < z + y.
  Proof.
  intros. rewrite (commutativity (f:=plus)).
  apply pos_plus_le_lt_compat_r;trivial.
  Qed.

  Lemma square_nonneg x : 0 ≤ x * x.
  Proof.
  apply not_lt_le_flip. intros E.
  destruct (lt_antisym (x * x) 0).
  split; [trivial |].
  apply square_pos.
  pose proof pseudo_order_apart.
  apply (strong_extensionality (x *.)).
  rewrite mult_0_r.
  apply lt_apart. trivial.
  Qed.

  Lemma nonneg_mult_rev_l x y : 0 ≤ x * y -> 0 < y -> 0 ≤ x.
  Proof.
  intros. apply (order_reflecting (.* y)).
  rewrite rings.mult_0_l. trivial.
  Qed.

  Lemma nonneg_mult_rev_r x y : 0 ≤ x * y -> 0 < x -> 0 ≤ y.
  Proof.
  intros. apply nonneg_mult_rev_l with x.
  - rewrite (commutativity (f:=mult)). trivial.
  - trivial.
  Qed.

  Instance le_0_1 : PropHolds (0 ≤ 1).
  Proof.
  red. rewrite <-(mult_1_r 1). apply square_nonneg.
  Qed.

  Instance le_0_2 : PropHolds (0 ≤ 2).
  Proof. solve_propholds. Qed.

  Instance le_0_3 : PropHolds (0 ≤ 3).
  Proof. solve_propholds. Qed.

  Instance le_0_4 : PropHolds (0 ≤ 4).
  Proof. solve_propholds. Qed.

  Lemma le_1_2 : 1 ≤ 2.
  Proof.
  apply nonneg_plus_le_compat_r, le_0_1.
  Qed.

  Lemma le_1_3 : 1 ≤ 3.
  Proof.
  apply nonneg_plus_le_compat_r, le_0_2.
  Qed.

  Lemma le_1_4 : 1 ≤ 4.
  Proof.
  apply nonneg_plus_le_compat_r, le_0_3.
  Qed.

  Lemma le_2_3 : 2 ≤ 3.
  Proof.
  apply (order_preserving (1+)), le_1_2.
  Qed.

  Lemma le_2_4 : 2 ≤ 4.
  Proof.
  apply (order_preserving (1+)), le_1_3.
  Qed.

  Lemma le_3_4 : 3 ≤ 4.
  Proof.
  apply (order_preserving (1+)), le_2_3.
  Qed.

  Lemma ge_1_mult_compat x y : 1 ≤ x -> 1 ≤ y -> 1 ≤ x * y.
  Proof.
  intros.
  apply ge_1_mult_le_compat_r; trivial.
  transitivity 1.
  - apply le_0_1.
  - trivial.
  Qed.

  Lemma gt_1_ge_1_mult_compat x y : 1 < x -> 1 ≤ y -> 1 < x * y.
  Proof.
  intros.
  apply lt_le_trans with x; trivial.
  apply ge_1_mult_le_compat_r;[trivial| |apply reflexivity].
  transitivity 1.
  - apply le_0_1.
  - apply lt_le;trivial.
  Qed.

  Lemma ge_1_gt_1_mult_compat x y : 1 ≤ x -> 1 < y -> 1 < x * y.
  Proof.
  intros.
  rewrite (commutativity (f:=mult)).
  apply gt_1_ge_1_mult_compat;trivial.
  Qed.

  Lemma pos_mult_le_lt_compat : forall a b c d, 0 <= a /\ a <= b -> 0 < b ->
    0 <= c /\ c < d ->
    a * c < b * d.
  Proof.
  intros a b c d [E1 E2] E3 [E4 E5] .
  apply le_lt_trans with (b * c).
  - apply mult_le_compat;auto.
  - apply (strictly_order_preserving (b *.)). trivial.
  Qed.

  Context `{PropHolds (1 ≶ 0)}.

  Lemma not_le_1_0 : ~(1 ≤ 0).
  Proof.
  apply lt_not_le_flip, lt_0_1.
  Qed.

  Lemma not_le_2_0 : ~(2 ≤ 0).
  Proof.
  apply lt_not_le_flip, lt_0_2.
  Qed.

  Lemma repeat_nat_nonneg : forall n, 0 <= Core.nat_iter n (plus 1) 0.
  Proof.
  induction n;simpl.
  - reflexivity.
  - apply nonneg_plus_compat.
    + apply _.
    + apply IHn.
  Qed.

  Lemma repeat_nat_pos : forall n, 0 < Core.nat_iter (S n) (plus 1) 0.
  Proof.
  intros n. simpl.
  apply pos_plus_le_lt_compat_l.
  - solve_propholds.
  - apply repeat_nat_nonneg.
  Qed.

  Local Existing Instance pseudo_order_apart.

  Global Instance ordered_characteristic_0 : FieldCharacteristic R 0.
  Proof.
  hnf. intros [|n] _;split.
  - intros E'. destruct (E' O). reflexivity.
  - intros E';apply (irreflexivity _) in E';destruct E'.
  - intros _;apply apart_iff_total_lt;right;apply repeat_nat_pos.
  - intros _ m;simpl. intros E.
    apply (ap (fun n => match n with | S _ => Unit | _ => Empty end)) in E;
    simpl in E. rewrite <-E. trivial.
  Qed.
End full_pseudo_semiring_order.

(* Due to bug #2528 *)
#[export]
Hint Extern 7 (PropHolds (0 ≤ 1)) => eapply @le_0_1 : typeclass_instances.
#[export]
Hint Extern 7 (PropHolds (0 ≤ 2)) => eapply @le_0_2 : typeclass_instances.
#[export]
Hint Extern 7 (PropHolds (0 ≤ 3)) => eapply @le_0_3 : typeclass_instances.
#[export]
Hint Extern 7 (PropHolds (0 ≤ 4)) => eapply @le_0_4 : typeclass_instances.

Section dec_semiring_order.
  (* Maybe these assumptions can be weakened? *)
  Context `{SemiRingOrder R} `{Apart R} `{!TrivialApart R}
    `{!NoZeroDivisors R} `{!TotalRelation (≤)} `{DecidablePaths R}.

  Context `{Rlt : Lt R} `{is_mere_relation R lt}
    (lt_correct : forall x y, x < y <-> x ≤ y /\ x <> y).

  Instance dec_srorder_fullpseudo
    : FullPseudoOrder _ _ := dec_full_pseudo_order lt_correct.
  Local Existing Instance pseudo_order_apart.

  Instance dec_pseudo_srorder: PseudoSemiRingOrder (<).
  Proof.
  split; try apply _.
  - intros x y E. apply srorder_partial_minus, not_lt_le_flip;trivial.
  - intros z. repeat (split; try apply _).
    intros x y E. apply lt_correct in E;apply lt_correct.
    destruct E as [E2a E2b]. split.
    + apply (order_preserving (z+));trivial.
    + intros E3. apply E2b. apply (left_cancellation (+) z);trivial.
  - apply (apartness.dec_strong_binary_morphism (.*.)).
  - intros x y E1 E2.
    apply lt_correct in E1;apply lt_correct in E2;apply lt_correct.
    destruct E1 as [E1a E1b], E2 as [E2a E2b]. split.
    + apply nonneg_mult_compat;trivial.
    + apply symmetric_neq.
      apply mult_ne_0; apply symmetric_neq;trivial.
  Qed.

  Instance dec_full_pseudo_srorder: FullPseudoSemiRingOrder (≤) (<).
  Proof.
  split; try apply _.
  apply le_iff_not_lt_flip.
  Qed.
End dec_semiring_order.

Section another_semiring.
  Context `{SemiRingOrder R1}.

  Lemma projected_srorder `{IsSemiRing R2} `{R2le : Le R2}
    `{is_mere_relation R2 R2le} (f : R2 -> R1)
    `{!IsSemiRingPreserving f} `{!IsInjective f}
    : (forall x y, x ≤ y <-> f x ≤ f y) -> (forall x y : R2, x ≤ y -> exists z, y = x + z) ->
      SemiRingOrder R2le.
  Proof.
  intros P. pose proof (projected_partial_order f P).
  repeat (split; try apply _).
  - assumption.
  - red;intros. apply P.
    rewrite 2!(preserves_plus (f:=f)). apply (order_preserving _), P. trivial.
  - red;intros. apply P. apply (order_reflecting (f z +)).
    rewrite <-2!preserves_plus. apply P. trivial.
  - intros. apply P. rewrite preserves_mult, preserves_0.
    apply nonneg_mult_compat; rewrite <-(preserves_0 (f:=f)); apply P;trivial.
  Qed.

 Context `{!IsSemiRing R1} `{SemiRingOrder R2} `{!IsSemiRing R2}
   `{!IsSemiRingPreserving (f : R1 -> R2)}.

  (* If a morphism agrees on the positive cone then it is order preserving *)
  Lemma preserving_preserves_nonneg : (forall x, 0 ≤ x -> 0 ≤ f x) -> OrderPreserving f.
  Proof.
  intros E.
  repeat (split; try apply _).
  intros x y F.
  destruct (decompose_le F) as [z [Ez1 Ez2]].
  apply compose_le with (f z).
  - apply E;trivial.
  - rewrite Ez2, (preserves_plus (f:=f)). trivial.
  Qed.

  Instance preserves_nonneg `{!OrderPreserving f} x
    : PropHolds (0 ≤ x) -> PropHolds (0 ≤ f x).
  Proof.
  intros. rewrite <-(preserves_0 (f:=f)). apply (order_preserving f);trivial.
  Qed.

  Lemma preserves_nonpos `{!OrderPreserving f} x : x ≤ 0 -> f x ≤ 0.
  Proof.
  intros. rewrite <-(preserves_0 (f:=f)). apply (order_preserving f);trivial.
  Qed.

  Lemma preserves_ge_1 `{!OrderPreserving f} x : 1 ≤ x -> 1 ≤ f x.
  Proof.
  intros. rewrite <-(preserves_1 (f:=f)). apply (order_preserving f);trivial.
  Qed.

  Lemma preserves_le_1 `{!OrderPreserving f} x : x ≤ 1 -> f x ≤ 1.
  Proof.
  intros. rewrite <-(preserves_1 (f:=f)). apply (order_preserving f);trivial.
  Qed.
End another_semiring.

Section another_semiring_strict.
  Context `{StrictSemiRingOrder R1} `{StrictSemiRingOrder R2}
    `{!IsSemiRing R1} `{!IsSemiRing R2}
    `{!IsSemiRingPreserving (f : R1 -> R2)}.

  Lemma strictly_preserving_preserves_pos
    : (forall x, 0 < x -> 0 < f x) -> StrictlyOrderPreserving f.
  Proof.
  intros E.
  repeat (split; try apply _).
  intros x y F.
  destruct (decompose_lt F) as [z [Ez1 Ez2]].
  apply compose_lt with (f z).
  - apply E. trivial.
  - rewrite Ez2, (preserves_plus (f:=f)). trivial.
  Qed.

  Instance preserves_pos `{!StrictlyOrderPreserving f} x
   : PropHolds (0 < x) -> PropHolds (0 < f x).
  Proof.
  intros. rewrite <-(preserves_0 (f:=f)).
  apply (strictly_order_preserving f);trivial.
  Qed.

  Lemma preserves_neg `{!StrictlyOrderPreserving f} x
    : x < 0 -> f x < 0.
  Proof.
  intros. rewrite <-(preserves_0 (f:=f)).
  apply (strictly_order_preserving f);trivial.
  Qed.

  Lemma preserves_gt_1 `{!StrictlyOrderPreserving f} x
    : 1 < x -> 1 < f x.
  Proof.
  intros. rewrite <-(preserves_1 (f:=f)).
  apply (strictly_order_preserving f);trivial.
  Qed.

  Lemma preserves_lt_1 `{!StrictlyOrderPreserving f} x
    : x < 1 -> f x < 1.
  Proof.
  intros. rewrite <-(preserves_1 (f:=f)).
  apply (strictly_order_preserving f);trivial.
  Qed.
End another_semiring_strict.

(* Due to bug #2528 *)
#[export]
Hint Extern 15 (PropHolds (_ ≤ _ _)) =>
  eapply @preserves_nonneg : typeclass_instances.
#[export]
Hint Extern 15 (PropHolds (_ < _ _)) =>
  eapply @preserves_pos : typeclass_instances.

(* Oddly enough, the above hints do not work for goals of the following shape? *)
#[export]
Hint Extern 15 (PropHolds (_ ≤ '_)) =>
  eapply @preserves_nonneg : typeclass_instances.
#[export]
Hint Extern 15 (PropHolds (_ < '_)) =>
  eapply @preserves_pos : typeclass_instances.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Combination_D.

Coq < Goal forall a b c d:Prop, (((a \/ c) /\ b /\ (c -> d)) -> (b \/ d)).
1 subgoal

  ============================
   forall a b c d : Prop, (a \/ c) /\ b /\ (c -> d) -> b \/ d

Unnamed_thm < intros.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  H : (a \/ c) /\ b /\ (c -> d)
  ============================
   b \/ d

Unnamed_thm < destruct H.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  H : a \/ c
  H0 : b /\ (c -> d)
  ============================
   b \/ d

Unnamed_thm < destruct H0.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  H : a \/ c
  H0 : b
  H1 : c -> d
  ============================
   b \/ d

Unnamed_thm < left.
1 subgoal

  a : Prop
  b : Prop
  c : Prop
  d : Prop
  H : a \/ c
  H0 : b
  H1 : c -> d
  ============================
   b

Unnamed_thm < exact H0.
No more subgoals.

Unnamed_thm < Qed.
intros.
destruct H.
destruct H0.
left.
exact H0.

Unnamed_thm is defined

Coq <

*)

Section Combination_D.
Goal forall a b c d:Prop, (((a \/ c) /\ b /\ (c -> d)) -> (b \/ d)).
intros.
destruct H.
destruct H0.
left.
exact H0.
Qed.