(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)
Local Obligation Tactic := intros.
(** A comparable type is equiped with a [compare] function, that define an order relation. **)
Class Comparable (A:Type) := {
compare : A -> A -> comparison;
compare_antisym : forall x y, CompOpp (compare x y) = compare y x;
compare_trans :  forall x y z c,
(compare x y) = c -> (compare y z) = c -> (compare x z) = c
}.
(** The corresponding order is a strict order. **)
Definition comparableLt {A:Type} (C: Comparable A) : relation A :=
fun x y => compare x y = Lt.
Instance ComparableLtStrictOrder {A:Type} (C: Comparable A) :
StrictOrder (comparableLt C).
(** nat is comparable. **)
Program Instance natComparable : Comparable nat :=
{ compare := Nat.compare }.
Next Obligation.
symmetry.
destruct (Nat.compare x y)  as [] eqn:?.
rewrite Nat.compare_eq_iff in Heqc.
destruct Heqc.
rewrite Nat.compare_eq_iff.
trivial.
rewrite <- nat_compare_lt in *.
rewrite <- nat_compare_gt in *.
trivial.
rewrite <- nat_compare_lt in *.
rewrite <- nat_compare_gt in *.
trivial.
Qed.
Next Obligation.
destruct c.
rewrite Nat.compare_eq_iff in *; destruct H; assumption.
rewrite <- nat_compare_lt in *.
apply (Nat.lt_trans _ _ _ H H0).
rewrite <- nat_compare_gt in *.
apply (gt_trans _ _ _ H H0).
Qed.
(** A pair of comparable is comparable. **)
Program Instance PairComparable {A:Type} (CA:Comparable A) {B:Type} (CB:Comparable B) :
Comparable (A*B) :=
{ compare := fun x y =>
let (xa, xb) := x in let (ya, yb) := y in
match compare xa ya return comparison with
| Eq => compare xb yb
| x => x
end }.
Next Obligation.
destruct x, y.
rewrite <- (compare_antisym a a0).
rewrite <- (compare_antisym b b0).
destruct (compare a a0); intuition.
Qed.
Next Obligation.
destruct x, y, z.
destruct (compare a a0) as [] eqn:?, (compare a0 a1) as [] eqn:?;
try (rewrite <- H0 in H; discriminate);
try (destruct (compare a a1) as [] eqn:?;
try (rewrite <- compare_antisym in Heqc0;
rewrite CompOpp_iff in Heqc0;
rewrite (compare_trans _ _ _  _ Heqc0 Heqc2) in Heqc1;
discriminate);
try (rewrite <- compare_antisym in Heqc1;
rewrite CompOpp_iff in Heqc1;
rewrite (compare_trans _ _ _ _ Heqc2 Heqc1) in Heqc0;
discriminate);
assumption);
rewrite (compare_trans _ _ _ _ Heqc0 Heqc1);
try assumption.
apply (compare_trans _ _ _ _ H H0).
Qed.
(** Special case of comparable, where equality is Leibniz equality. **)
Class ComparableLeibnizEq {A:Type} (C: Comparable A) :=
compare_eq : forall x y, compare x y = Eq -> x = y.
(** Boolean equality for a [Comparable]. **)
Definition compare_eqb {A:Type} {C:Comparable A} (x y:A) :=
match compare x y with
| Eq => true
| _ => false
end.

Theorem compare_eqb_iff {A:Type} {C:Comparable A} {U:ComparableLeibnizEq C} :
forall x y, compare_eqb x y = true <-> x = y.