Section list_hsOrd.
Context {A : Type} {PROSET : isProset A} {ORD : hsOrd A (PROSET := PROSET)}.
Fixpoint lex_compare (xs : list A) (ys : list A) {struct xs} : comparison :=
match xs, ys with
| [], [] => Eq
| [], y :: ys => Lt
| x :: xs, [] => Gt
| x :: xs, y :: ys =>
match compare x y with
| Lt => Lt
| Eq => lex_compare xs ys
| Gt => Gt
end
end.
Definition lex_eq lhs rhs : Prop :=
lex_compare lhs rhs = Eq.
Definition lex_le lhs rhs : Prop :=
lex_compare lhs rhs = Lt \/ lex_compare lhs rhs = Eq.
#[global]
Instance lex_eq_Equivalence
: Equivalence lex_eq.
Proof with discriminate || eauto with *.
unfold lex_eq. split.
- intros xs1; induction xs1 as [ | x1 xs1 IH]; simpl...
pose proof (claim1 := compare_spec x1 x1).
destruct (compare x1 x1) eqn: H_OBS1...
all: contradiction (proj2 claim1)...
- intros xs1 xs2; revert xs1 xs2; induction xs1 as [ | x1 xs1 IH]; destruct xs2 as [ | x2 xs2]; simpl...
pose proof (claim1 := compare_spec x1 x2); pose proof (claim2 := compare_spec x2 x1).
destruct (compare x1 x2) eqn: H_OBS1; destruct (compare x2 x1) eqn: H_OBS2...
all: contradiction (proj2 claim2)...
- intros xs1 xs2 xs3; revert xs1 xs3; induction xs2 as [ | x2 xs2 IH]; destruct xs1 as [ | x1 xs1]; destruct xs3 as [ | x3 xs3]; simpl...
pose proof (claim1 := compare_spec x1 x2); pose proof (claim2 := compare_spec x2 x3); pose proof (claim3 := compare_spec x1 x3).
destruct (compare x1 x2) eqn: H_OBS1; destruct (compare x2 x3) eqn: H_OBS2; destruct (compare x1 x3) eqn: H_OBS3...
all: contradiction (proj2 claim3)...
Qed.
#[local]
Instance list_isSetoid_of_elementwise_comparison : isSetoid (list A) :=
{ eqProp := lex_eq
; eqProp_Equivalence := lex_eq_Equivalence
}.
#[local]
Instance lex_le_PreOrder
: PreOrder lex_le.
Proof with discriminate || eauto with *.
assert (lemma1 : forall x1 : A, forall x2 : A, x1 =< x2 -> x2 =< x1 -> x1 == x2). { ii... }
assert (lemma2 : forall x1 : A, forall x2 : A, x1 == x2 -> x1 =< x2). { ii... }
assert (lemma3 : forall x1 : A, forall x2 : A, x1 == x2 -> x2 =< x1). { ii... }
unfold lex_le. split.
- intros xs1; right. eapply lex_eq_Equivalence.
- intros xs1 xs2 xs3; revert xs1 xs3; induction xs2 as [ | x2 xs2 IH]; destruct xs1 as [ | x1 xs1]; destruct xs3 as [ | x3 xs3]; simpl...
intros [H_false | H_false]...
pose proof (claim1 := compare_spec x1 x2); pose proof (claim2 := compare_spec x2 x3); pose proof (claim3 := compare_spec x1 x3); pose proof (claim4 := IH xs1 xs3).
destruct (compare x1 x2) eqn: H_OBS1; destruct (compare x2 x3) eqn: H_OBS2; destruct (compare x1 x3) eqn: H_OBS3...
+ contradiction (proj2 claim3)...
+ contradiction (proj2 claim2)...
+ contradiction (proj2 claim3); eapply lemma1; [transitivity x2 | exact (proj1 claim3)]. eapply lemma2... exact (proj1 claim2).
+ contradiction (proj2 claim2)...
+ contradiction (proj2 claim1)...
+ contradiction (proj2 claim3); eapply lemma1; [transitivity x2 | exact (proj1 claim3)]. exact (proj1 claim1). eapply lemma2...
+ contradiction (proj2 claim1); eapply lemma1; [exact (proj1 claim1) | transitivity x3]. exact (proj1 claim2). eapply lemma2...
+ contradiction (proj2 claim1); eapply lemma1; [exact (proj1 claim1) | transitivity x3]. exact (proj1 claim2). exact (proj1 claim3).
+ intros ? [? | ?]...
+ intros [? | ?]...
+ intros [? | ?]...
+ intros [? | ?]...
Qed.

Lemma lex_le_flip_spec lhs rhs :
match lex_compare lhs rhs with
| Lt => lex_compare rhs lhs = Gt
| Eq => lex_compare rhs lhs = Eq
| Gt => lex_compare rhs lhs = Lt
end.