Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.orders.orders
  HoTT.Classes.theory.apartness.

Generalizable Variables A B C R S f g z.

(* If a function between strict partial orders is order preserving (back), we can
  derive that it is strictly order preserving (back) *)
Section strictly_order_preserving.
  Context `{FullPartialOrder A} `{FullPartialOrder B}.

  Global Instance strictly_order_preserving_inj  `{!OrderPreserving (f : A -> B)}
    `{!IsStrongInjective f} :
    StrictlyOrderPreserving f | 20.
  Proof.
  intros x y E.
  apply lt_iff_le_apart in E. apply lt_iff_le_apart.
  destruct E as [E1 E2]. split.
  - apply (order_preserving f);trivial.
  - apply (strong_injective f);trivial.
  Qed.

  Global Instance strictly_order_reflecting_mor `{!OrderReflecting (f : A -> B)}
    `{!StrongExtensionality f} :
    StrictlyOrderReflecting f | 20.
  Proof.
  intros x y E.
  apply lt_iff_le_apart in E. apply lt_iff_le_apart.
  destruct E as [E1 E2]. split.
  - apply (order_reflecting f);trivial.
  - apply (strong_extensionality f);trivial.
  Qed.
End strictly_order_preserving.

(* For structures with a trivial apartness relation
   we have a stronger result of the above *)
Section strictly_order_preserving_dec.
  Context `{FullPartialOrder A} `{!TrivialApart A}
          `{FullPartialOrder B} `{!TrivialApart B}.

  Local Existing Instance strict_po_apart.

  Global Instance dec_strictly_order_preserving_inj
    `{!OrderPreserving (f : A -> B)}
    `{!IsInjective f} :
    StrictlyOrderPreserving f | 19.
  Proof.
  pose proof (dec_strong_injective f).
  apply _.
  Qed.

  Global Instance dec_strictly_order_reflecting_mor
    `{!OrderReflecting (f : A -> B)}
    : StrictlyOrderReflecting f | 19.
  Proof.
  pose proof (dec_strong_morphism f). apply _.
  Qed.
End strictly_order_preserving_dec.

Section pseudo_injective.
  Context `{PseudoOrder A} `{PseudoOrder B}.

  Local Existing Instance pseudo_order_apart.

  Instance pseudo_order_embedding_ext `{!StrictOrderEmbedding (f : A -> B)} :
    StrongExtensionality f.
  Proof.
  intros x y E.
  apply apart_iff_total_lt;apply apart_iff_total_lt in E.
  destruct E; [left | right]; apply (strictly_order_reflecting f);trivial.
  Qed.

  Lemma pseudo_order_embedding_inj `{!StrictOrderEmbedding (f : A -> B)} :
    IsStrongInjective f.
  Proof.
  split;try apply _.
  intros x y E.
  apply apart_iff_total_lt;apply apart_iff_total_lt in E.
  destruct E; [left | right]; apply (strictly_order_preserving f);trivial.
  Qed.
End pseudo_injective.

(* If a function between pseudo partial orders is strictly order preserving (back),
   we can derive that it is order preserving (back) *)
Section full_pseudo_strictly_preserving.
  Context `{FullPseudoOrder A} `{FullPseudoOrder B}.

  Local Existing Instance pseudo_order_apart.

  Lemma full_pseudo_order_preserving `{!StrictlyOrderReflecting (f : A -> B)}
    : OrderPreserving f.
  Proof.
  intros x y E1.
  apply le_iff_not_lt_flip;apply le_iff_not_lt_flip in E1.
  intros E2. apply E1.
  apply (strictly_order_reflecting f).
  trivial.
  Qed.

  Lemma full_pseudo_order_reflecting `{!StrictlyOrderPreserving (f : A -> B)}
    : OrderReflecting f.
  Proof.
  intros x y E1.
  apply le_iff_not_lt_flip;apply le_iff_not_lt_flip in E1.
  intros E2. apply E1.
  apply (strictly_order_preserving f).
  trivial.
  Qed.
End full_pseudo_strictly_preserving.

(* Some helper lemmas to easily transform order preserving instances. *)
Section order_preserving_ops.
  Context `{Le R}.

  Lemma order_preserving_flip {op} `{!Commutative op} `{!OrderPreserving (op z)}
    : OrderPreserving (fun y => op y z).
  Proof.
  intros x y E.
  rewrite 2!(commutativity _ z).
  apply order_preserving;trivial.
  Qed.

  Lemma order_reflecting_flip {op} `{!Commutative op}
    `{!OrderReflecting (op z) }
    : OrderReflecting (fun y => op y z).
  Proof.
  intros x y E.
  apply (order_reflecting (op z)).
  rewrite 2!(commutativity (f:=op) z).
  trivial.
  Qed.

  Lemma order_preserving_nonneg (op : R -> R -> R) `{!Zero R}
    `{forall z, PropHolds (0 ≤ z) -> OrderPreserving (op z)} z
    : 0 ≤ z -> forall x y, x ≤ y -> op z x ≤ op z y.
  Proof.
  auto.
  Qed.

  Lemma order_preserving_flip_nonneg (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 ≤ z) -> OrderPreserving (fun y => op y z)} z
    : 0 ≤ z -> forall x y, x ≤ y -> op x z ≤ op y z.
  Proof.
  apply E.
  Qed.

  Context `{Lt R}.

  Lemma order_reflecting_pos (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 < z) -> OrderReflecting (op z)} z
    : 0 < z -> forall x y, op z x ≤ op z y -> x ≤ y.
  Proof.
  apply E.
  Qed.

  Lemma order_reflecting_flip_pos (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 < z) -> OrderReflecting (fun y => op y z)} z
    : 0 < z -> forall x y, op x z ≤ op y z -> x ≤ y.
  Proof.
  apply E.
  Qed.

End order_preserving_ops.

Section strict_order_preserving_ops.
  Context `{Lt R}.

  Lemma strictly_order_preserving_flip {op} `{!Commutative op}
    `{!StrictlyOrderPreserving (op z)}
    : StrictlyOrderPreserving (fun y => op y z).
  Proof.
  intros x y E.
  rewrite 2!(commutativity _ z).
  apply strictly_order_preserving;trivial.
  Qed.

  Lemma strictly_order_reflecting_flip {op} `{!Commutative op}
    `{!StrictlyOrderReflecting (op z) }
    : StrictlyOrderReflecting (fun y => op y z).
  Proof.
  intros x y E.
  apply (strictly_order_reflecting (op z)).
  rewrite 2!(commutativity (f:=op) z).
  trivial.
  Qed.

  Lemma strictly_order_preserving_pos (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 < z) -> StrictlyOrderPreserving (op z)} z
    : 0 < z -> forall x y, x < y -> op z x < op z y.
  Proof.
  apply E.
  Qed.

  Lemma strictly_order_preserving_flip_pos (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 < z) -> StrictlyOrderPreserving (fun y => op y z)} z
    : 0 < z -> forall x y, x < y -> op x z < op y z.
  Proof.
  apply E.
  Qed.

End strict_order_preserving_ops.

Lemma projected_partial_order `{IsHSet A} {Ale : Le A}
  `{is_mere_relation A Ale} `{Ble : Le B}
  (f : A -> B) `{!IsInjective f} `{!PartialOrder Ble}
  : (forall x y, x ≤ y <-> f x ≤ f y) -> PartialOrder Ale.
Proof.
intros P. repeat split.
- apply _.
- apply _.
- intros x. apply P. apply reflexivity.
- intros x y z E1 E2. apply P.
  transitivity (f y); apply P;trivial.
- intros x y E1 E2. apply (injective f).
  apply (antisymmetry (≤)); apply P;trivial.
Qed.

Lemma projected_total_order `{Ale : Le A} `{Ble : Le B}
  (f : A -> B) `{!TotalRelation Ble}
  : (forall x y, x ≤ y <-> f x ≤ f y) -> TotalRelation Ale.
Proof.
intros P x y.
destruct (total (≤) (f x) (f y)); [left | right]; apply P;trivial.
Qed.

Lemma projected_strict_order `{Alt : Lt A} `{is_mere_relation A lt} `{Blt : Lt B}
  (f : A -> B) `{!StrictOrder Blt}
  : (forall x y, x < y <-> f x < f y) -> StrictOrder Alt.
Proof.
intros P. split.
- apply _.
- intros x E. destruct (irreflexivity (<) (f x)). apply P. trivial.
- intros x y z E1 E2. apply P. transitivity (f y); apply P;trivial.
Qed.

Lemma projected_pseudo_order `{IsApart A} `{Alt : Lt A} `{is_mere_relation A lt}
  `{Apart B} `{Blt : Lt B}
  (f : A -> B) `{!IsStrongInjective f} `{!PseudoOrder Blt}
  : (forall x y, x < y <-> f x < f y) -> PseudoOrder Alt.
Proof.
pose proof (strong_injective_mor f).
intros P. split; try apply _.
- intros x y E. apply (pseudo_order_antisym (f x) (f y)).
  split; apply P,E.
- intros x y E z. apply P in E.
  apply (merely_destruct (cotransitive E (f z)));
  intros [?|?];apply tr; [left | right]; apply P;trivial.
- intros x y; split; intros E.
  + apply (strong_injective f) in E.
    apply apart_iff_total_lt in E.
    destruct E; [left | right]; apply P;trivial.
  + apply (strong_extensionality f).
    apply apart_iff_total_lt.
    destruct E; [left | right]; apply P;trivial.
Qed.

Lemma projected_full_pseudo_order `{IsApart A} `{Ale : Le A} `{Alt : Lt A}
  `{is_mere_relation A le} `{is_mere_relation A lt}
  `{Apart B} `{Ble : Le B} `{Blt : Lt B}
  (f : A -> B) `{!IsStrongInjective f} `{!FullPseudoOrder Ble Blt}
  : (forall x y, x ≤ y <-> f x ≤ f y) -> (forall x y, x < y <-> f x < f y) ->
    FullPseudoOrder Ale Alt.
Proof.
intros P1 P2. split.
- apply _.
- apply (projected_pseudo_order f);assumption.
- intros x y; split; intros E.
  + intros F. destruct (le_not_lt_flip (f y) (f x));[apply P1|apply P2];trivial.
  + apply P1. apply not_lt_le_flip.
    intros F. apply E,P2. trivial.
Qed.

Global Instance id_order_preserving `{PartialOrder A} : OrderPreserving (@id A).
Proof.
red;trivial.
Qed.

Global Instance id_order_reflecting `{PartialOrder A} : OrderReflecting (@id A).
Proof.
red;trivial.
Qed.

Section composition.
  Context {A B C} `{Le A} `{Le B} `{Le C} (f : A -> B) (g : B -> C).

  Instance compose_order_preserving:
    OrderPreserving f -> OrderPreserving g -> OrderPreserving (g ∘ f).
  Proof.
  red;intros. unfold Compose.
  do 2 apply (order_preserving _).
  trivial.
  Qed.

  Instance compose_order_reflecting:
    OrderReflecting f -> OrderReflecting g -> OrderReflecting (g ∘ f).
  Proof.
  intros ?? x y E. unfold Compose in E.
  do 2 apply (order_reflecting _) in E.
  trivial.
  Qed.

  Instance compose_order_embedding:
    OrderEmbedding f -> OrderEmbedding g -> OrderEmbedding (g ∘ f) := {}.
End composition.

#[export]
Hint Extern 4 (OrderPreserving (_ ∘ _)) =>
  class_apply @compose_order_preserving : typeclass_instances.
#[export]
Hint Extern 4 (OrderReflecting (_ ∘ _)) =>
  class_apply @compose_order_reflecting : typeclass_instances.
#[export]
Hint Extern 4 (OrderEmbedding (_ ∘ _)) =>
  class_apply @compose_order_embedding : typeclass_instances.

