(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

Require Import Int31.
Require Import Cyclic31.
Require Import Omega.
Require Import List.
Require Import Syntax.
Require Import Relations.
Require Import RelationClasses.

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
}.

Theorem compare_refl {A:Type} (C: Comparable A) :
  forall x, compare x x = Eq.
Proof.
(* Goal: forall (x : A) (_ : @eq comparison (@compare A C x x) Lt), False *)
(* Goal: @Transitive A (@comparableLt A C) *)
intros.
(* Goal: @eq comparison (@compare A C x x) Eq *)
pose proof (compare_antisym x x).
(* Goal: @eq comparison (@compare A C x x) Eq *)
destruct (compare x x); intuition; try discriminate.
Qed.

(** 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).
Proof.
(* Goal: @StrictOrder A (@comparableLt A C) *)
apply Build_StrictOrder.
(* Goal: @Irreflexive A (@comparableLt A C) *)
(* Goal: @Transitive A (@comparableLt A C) *)
unfold Irreflexive, Reflexive, complement, comparableLt.
(* Goal: forall (x : A) (_ : @eq comparison (@compare A C x x) Lt), False *)
(* Goal: @Transitive A (@comparableLt A C) *)
intros.
(* Goal: False *)
(* Goal: @Transitive A (@comparableLt A C) *)
pose proof H.
(* Goal: False *)
(* Goal: @Transitive A (@comparableLt A C) *)
rewrite <- compare_antisym in H.
(* Goal: False *)
(* Goal: @Transitive A (@comparableLt A C) *)
rewrite H0 in H.
(* Goal: False *)
(* Goal: @Transitive A (@comparableLt A C) *)
discriminate H.
(* Goal: @Transitive A (@comparableLt A C) *)
unfold Transitive, comparableLt.
(* Goal: forall (x y z : A) (_ : @eq comparison (@compare A C x y) Lt) (_ : @eq comparison (@compare A C y z) Lt), @eq comparison (@compare A C x z) Lt *)
intros x y z.
(* Goal: forall (_ : @eq comparison (compare x y) c) (_ : @eq comparison (compare y z) c), @eq comparison (compare x z) c *)
apply compare_trans.
Qed.

(** nat is comparable. **)
Program Instance natComparable : Comparable nat :=
  { compare := Nat.compare }.
Next Obligation.
(* Goal: @eq comparison (CompOpp (Nat.compare x y)) (Nat.compare y x) *)
symmetry.
destruct (Nat.compare x y)  as [] eqn:?.
(* Goal: @eq comparison (Nat.compare y x) (CompOpp Eq) *)
(* Goal: @eq comparison (Nat.compare y x) (CompOpp Lt) *)
(* Goal: @eq comparison (Nat.compare y x) (CompOpp Gt) *)
rewrite Nat.compare_eq_iff in Heqc.
(* Goal: @eq comparison (Nat.compare y x) (CompOpp Eq) *)
(* Goal: @eq comparison (Nat.compare y x) (CompOpp Lt) *)
(* Goal: @eq comparison (Nat.compare y x) (CompOpp Gt) *)
destruct Heqc.
(* Goal: @eq comparison (Nat.compare x x) (CompOpp Eq) *)
(* Goal: @eq comparison (Nat.compare y x) (CompOpp Lt) *)
(* Goal: @eq comparison (Nat.compare y x) (CompOpp Gt) *)
rewrite Nat.compare_eq_iff.
(* Goal: lt y x *)
trivial.
(* Goal: @eq comparison (Nat.compare x z) Lt *)
(* Goal: @eq comparison (Nat.compare x z) Gt *)
rewrite <- nat_compare_lt in *.
(* Goal: @eq comparison (Nat.compare x z) Gt *)
rewrite <- nat_compare_gt in *.
(* Goal: lt y x *)
trivial.
(* Goal: @eq comparison (Nat.compare x z) Lt *)
(* Goal: @eq comparison (Nat.compare x z) Gt *)
rewrite <- nat_compare_lt in *.
(* Goal: @eq comparison (Nat.compare x z) Gt *)
rewrite <- nat_compare_gt in *.
(* Goal: lt y x *)
trivial.
Qed.
Next Obligation.
(* Goal: @eq comparison (Nat.compare x z) c *)
destruct c.
(* Goal: @eq comparison (Nat.compare x z) Eq *)
(* Goal: @eq comparison (Nat.compare x z) Lt *)
(* Goal: @eq comparison (Nat.compare x z) Gt *)
rewrite Nat.compare_eq_iff in *; destruct H; assumption.
(* Goal: @eq comparison (Nat.compare x z) Lt *)
(* Goal: @eq comparison (Nat.compare x z) Gt *)
rewrite <- nat_compare_lt in *.
(* Goal: lt x z *)
(* Goal: @eq comparison (Nat.compare x z) Gt *)
apply (Nat.lt_trans _ _ _ H H0).
(* Goal: @eq comparison (Nat.compare x z) Gt *)
rewrite <- nat_compare_gt in *.
(* Goal: gt x z *)
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.
(* Goal: @eq comparison (CompOpp ((fun x y : prod A B => let (xa, xb) := x in let (ya, yb) := y in match @compare A CA xa ya with | Eq => @compare B CB xb yb | Lt => Lt | Gt => Gt end) x y)) ((fun x y : prod A B => let (xa, xb) := x in let (ya, yb) := y in match @compare A CA xa ya with | Eq => @compare B CB xb yb | Lt => Lt | Gt => Gt end) y x) *)
destruct x, y.
(* Goal: @eq comparison (CompOpp match @compare A CA a a0 with | Eq => @compare B CB b b0 | Lt => Lt | Gt => Gt end) match @compare A CA a0 a with | Eq => @compare B CB b0 b | Lt => Lt | Gt => Gt end *)
rewrite <- (compare_antisym a a0).
(* Goal: @eq comparison (CompOpp match @compare A CA a a0 with | Eq => @compare B CB b b0 | Lt => Lt | Gt => Gt end) match CompOpp (@compare A CA a a0) with | Eq => @compare B CB b0 b | Lt => Lt | Gt => Gt end *)
rewrite <- (compare_antisym b b0).
(* Goal: @eq comparison (CompOpp match @compare A CA a a0 with | Eq => @compare B CB b b0 | Lt => Lt | Gt => Gt end) match CompOpp (@compare A CA a a0) with | Eq => CompOpp (@compare B CB b b0) | Lt => Lt | Gt => Gt end *)
destruct (compare a a0); intuition.
Qed.
Next Obligation.
(* Goal: @eq comparison ((fun x y : prod A B => let (xa, xb) := x in let (ya, yb) := y in match @compare A CA xa ya with | Eq => @compare B CB xb yb | Lt => Lt | Gt => Gt end) x z) c *)
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.
(* Goal: @eq comparison (@compare A C a a1) c *)
apply (compare_trans _ _ _ _ H H0).
Qed.

(** Special case of comparable, where equality is usual equality. **)
Class ComparableUsualEq {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:ComparableUsualEq C} :
  forall x y, compare_eqb x y = true <-> x = y.
Proof.
(* Goal: forall x y : A, iff (@eq bool (@compare_eqb A C x y) true) (@eq A x y) *)
unfold compare_eqb.
(* Goal: forall _ : @eq comparison (@compare B CB b b0) Eq, @eq (prod A B) (@pair A B a b) (@pair A B a0 b0) *)
intuition.
(* Goal: @eq A x y *)
(* Goal: @eq bool match @compare A C x y with | Eq => true | Lt => false | Gt => false end true *)
apply compare_eq.
(* Goal: @eq comparison (@compare A C x y) Eq *)
(* Goal: @eq bool match @compare A C x y with | Eq => true | Lt => false | Gt => false end true *)
destruct (compare x y); intuition; discriminate.
(* Goal: @eq bool match @compare A C x y with | Eq => true | Lt => false | Gt => false end true *)
destruct H.
(* Goal: forall _ : @eq comparison (@compare B CB b b0) Eq, @eq (prod A B) (@pair A B a b) (@pair A B a0 b0) *)
rewrite compare_refl; intuition.
Qed.

(** [Comparable] provides a decidable equality. **)
Definition compare_eqdec {A:Type} {C:Comparable A} {U:ComparableUsualEq C} (x y:A):
  {x = y} + {x <> y}.
Proof.
destruct (compare x y) as [] eqn:?; [left; apply compare_eq; intuition | ..];
  right; intro; destruct H; rewrite compare_refl in Heqc; discriminate.
Defined.

Instance NComparableUsualEq : ComparableUsualEq natComparable := Nat.compare_eq.

(** A pair of ComparableUsualEq is ComparableUsualEq **)
Instance PairComparableUsualEq
  {A:Type} {CA:Comparable A} (UA:ComparableUsualEq CA)
  {B:Type} {CB:Comparable B} (UB:ComparableUsualEq CB) :
    ComparableUsualEq (PairComparable CA CB).
Proof.
(* Goal: @ComparableUsualEq (prod A B) (@PairComparable A CA B CB) *)
intros x y; destruct x, y; simpl.
(* Goal: forall _ : @eq comparison match @compare A CA a a0 with | Eq => @compare B CB b b0 | Lt => Lt | Gt => Gt end Eq, @eq (prod A B) (@pair A B a b) (@pair A B a0 b0) *)
pose proof (compare_eq a a0); pose proof (compare_eq b b0).
(* Goal: forall _ : @eq comparison match @compare A CA a a0 with | Eq => @compare B CB b b0 | Lt => Lt | Gt => Gt end Eq, @eq (prod A B) (@pair A B a b) (@pair A B a0 b0) *)
destruct (compare a a0); try discriminate.
(* Goal: forall _ : @eq comparison (@compare B CB b b0) Eq, @eq (prod A B) (@pair A B a b) (@pair A B a0 b0) *)
intuition.
(* Goal: @eq (prod A B) (@pair A B a b) (@pair A B a0 b0) *)
destruct H2, H0.
(* Goal: @eq (prod A B) (@pair A B a b) (@pair A B a b) *)
reflexivity.
Qed.

(** An [Finite] type is a type with the list of all elements. **)
Class Finite (A:Type) := {
  all_list : list A;
  all_list_forall : forall x:A, In x all_list
}.

(** An alphabet is both [ComparableUsualEq] and [Finite]. **)
Class Alphabet (A:Type) := {
  AlphabetComparable :> Comparable A;
  AlphabetComparableUsualEq :> ComparableUsualEq AlphabetComparable;
  AlphabetFinite :> Finite A
}.

(** The [Numbered] class provides a conveniant way to build [Alphabet] instances,
   with a good computationnal complexity. It is mainly a injection from it to
   [Int31] **)
Class Numbered (A:Type) := {
  inj : A -> int31;
  surj : int31 -> A;
  surj_inj_compat : forall x, surj (inj x) = x;
  inj_bound : int31;
  inj_bound_spec : forall x, (phi (inj x) < phi inj_bound)%Z
}.

Program Instance NumberedAlphabet {A:Type} (N:Numbered A) : Alphabet A :=
  { AlphabetComparable :=
      {| compare := fun x y => compare31 (inj x) (inj y) |};
    AlphabetFinite :=
      {| all_list := fst (iter_int31 inj_bound _
        (fun p => (cons (surj (snd p)) (fst p), incr (snd p))) ([], 0%int31)) |} }.
Next Obligation. apply Zcompare_antisym. Qed.
Next Obligation.
(* Goal: @eq comparison (Nat.compare x z) c *)
destruct c. unfold compare31 in *.
(* Goal: @eq A x y *)
rewrite Z.compare_eq_iff in *. congruence.
eapply Zcompare_Lt_trans. apply H. apply H0.
eapply Zcompare_Gt_trans. apply H. apply H0.
Qed.
Next Obligation.
(* Goal: @ComparableUsualEq A (Build_Comparable A (fun x y : A => compare31 (@inj A N x) (@inj A N y)) ((fun (A : Type) (N : Numbered A) (x y : A) => NumberedAlphabet_obligation_1 A N x y) A N) ((fun (A : Type) (N : Numbered A) (x y z : A) (c : comparison) (H : @eq comparison (compare31 (@inj A N x) (@inj A N y)) c) (H0 : @eq comparison (compare31 (@inj A N y) (@inj A N z)) c) => NumberedAlphabet_obligation_2 A N x y z c H H0) A N)) *)
intros x y H. unfold compare, compare31 in H.
(* Goal: @eq A x y *)
rewrite Z.compare_eq_iff in *.
(* Goal: @eq A x y *)
rewrite <- surj_inj_compat, <- phi_inv_phi with (inj y), <- H.
(* Goal: @eq (prod A B) (@pair A B a b) (@pair A B a b) *)
rewrite phi_inv_phi, surj_inj_compat; reflexivity.
Qed.
Next Obligation.
(* Goal: @In A x (@fst (list A) int31 (iter_int31 (@inj_bound A N) (prod (list A) int31) (fun p : prod (list A) int31 => @pair (list A) int31 (@cons A (@surj A N (@snd (list A) int31 p)) (@fst (list A) int31 p)) (incr (@snd (list A) int31 p))) (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0)))) *)
rewrite iter_int31_iter_nat.
(* Goal: @In A x (@fst (list A) int31 (nat_rect (fun _ : nat => prod (list A) int31) (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0)) (fun (_ : nat) (p : prod (list A) int31) => @pair (list A) int31 (@cons A (@surj A N (@snd (list A) int31 p)) (@fst (list A) int31 p)) (incr (@snd (list A) int31 p))) (Z.abs_nat (phi (@inj_bound A N))))) *)
pose proof (inj_bound_spec x).
(* Goal: @In A x (@fst (list A) int31 (nat_rect (fun _ : nat => prod (list A) int31) (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0)) (fun (_ : nat) (p : prod (list A) int31) => @pair (list A) int31 (@cons A (@surj A N (@snd (list A) int31 p)) (@fst (list A) int31 p)) (incr (@snd (list A) int31 p))) (Z.abs_nat (phi (@inj_bound A N))))) *)
match goal with |- In x (fst ?p) => destruct p as [] eqn:? end.
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
replace inj_bound with i in H.
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
revert l i Heqp x H.
(* Goal: forall (x : A) (_ : @eq comparison (@compare A C x x) Lt), False *)
(* Goal: @Transitive A (@comparableLt A C) *)
induction (Z.abs_nat (phi inj_bound)); intros.
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
inversion Heqp; clear Heqp; subst.
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0))) *)
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
rewrite spec_0 in H. pose proof (phi_bounded (inj x)). omega.
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
simpl in Heqp.
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
destruct nat_rect; specialize (IHn _ _ (eq_refl _) x); simpl in *.
(* Goal: @In A x l *)
(* Goal: @eq int31 i (@inj_bound A N) *)
inversion Heqp. subst. clear Heqp.
(* Goal: @In A x (@cons A (@surj A N i0) l0) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
rewrite phi_incr in H.
(* Goal: @eq nat (Z.abs_nat (phi (incr (@snd (list A) int31 (@pair (list A) int31 l0 i0))))) (S n) *)
pose proof (phi_bounded i0).
(* Goal: @In A x (@cons A (@surj A N i0) l0) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
pose proof (phi_bounded (inj x)).
(* Goal: @In A x (@cons A (@surj A N i0) l0) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
destruct (Z_lt_le_dec (Z.succ (phi i0)) (2 ^ Z.of_nat size)%Z).
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0))) *)
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
rewrite Zmod_small in H by omega.
(* Goal: @In A x (@cons A (@surj A N i0) l0) *)
(* Goal: @In A x (@cons A (@surj A N i0) l0) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
apply Zlt_succ_le, Zle_lt_or_eq in H.
(* Goal: @In A x (@cons A (@surj A N i0) l0) *)
(* Goal: @In A x (@cons A (@surj A N i0) l0) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
destruct H; simpl; auto. left.
(* Goal: @eq (prod A B) (@pair A B a b) (@pair A B a b) *)
rewrite <- surj_inj_compat, <- phi_inv_phi with (inj x), H, phi_inv_phi; reflexivity.
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0))) *)
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
replace (Z.succ (phi i0)) with (2 ^ Z.of_nat size)%Z in H by omega.
(* Goal: @In A x (@cons A (@surj A N i0) l0) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
rewrite Z_mod_same_full in H.
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0))) *)
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
exfalso; omega.
(* Goal: @eq int31 i (@inj_bound A N) *)
rewrite <- phi_inv_phi with i, <- phi_inv_phi with inj_bound; f_equal.
(* Goal: @eq Z (phi i) (phi (@inj_bound A N)) *)
pose proof (phi_bounded inj_bound); pose proof (phi_bounded i).
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0))) *)
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
rewrite <- Z.abs_eq with (phi i), <- Z.abs_eq with (phi inj_bound) by omega.
(* Goal: @eq Z (Z.abs (phi i)) (Z.abs (phi (@inj_bound A N))) *)
clear H H0 H1.
(* Goal: @eq Z (Z.abs (phi i)) (Z.abs (phi (@inj_bound A N))) *)
do 2 rewrite <- Zabs2Nat.id_abs.
(* Goal: @eq Z (Z.of_nat (Z.abs_nat (phi i))) (Z.of_nat (Z.abs_nat (phi (@inj_bound A N)))) *)
f_equal.
(* Goal: @eq nat (Z.abs_nat (phi i)) (Z.abs_nat (phi (@inj_bound A N))) *)
revert l i Heqp.
(* Goal: forall (l : list A) (i : int31) (_ : @eq (prod (list A) int31) (nat_rect (fun _ : nat => prod (list A) int31) (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0)) (fun (_ : nat) (p : prod (list A) int31) => @pair (list A) int31 (@cons A (@surj A N (@snd (list A) int31 p)) (@fst (list A) int31 p)) (incr (@snd (list A) int31 p))) (Z.abs_nat (phi (@inj_bound A N)))) (@pair (list A) int31 l i)), @eq nat (Z.abs_nat (phi i)) (Z.abs_nat (phi (@inj_bound A N))) *)
assert (Z.abs_nat (phi inj_bound) < Z.abs_nat (2^31)).
(* Goal: lt (Z.abs_nat (phi (@inj_bound A N))) (Z.abs_nat (Z.pow (Zpos (xO xH)) (Zpos (xI (xI (xI (xI xH))))))) *)
(* Goal: forall (l : list A) (i : int31) (_ : @eq (prod (list A) int31) (nat_rect (fun _ : nat => prod (list A) int31) (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0)) (fun (_ : nat) (p : prod (list A) int31) => @pair (list A) int31 (@cons A (@surj A N (@snd (list A) int31 p)) (@fst (list A) int31 p)) (incr (@snd (list A) int31 p))) (Z.abs_nat (phi (@inj_bound A N)))) (@pair (list A) int31 l i)), @eq nat (Z.abs_nat (phi i)) (Z.abs_nat (phi (@inj_bound A N))) *)
apply Zabs_nat_lt, phi_bounded.
(* Goal: forall (x : A) (_ : @eq comparison (@compare A C x x) Lt), False *)
(* Goal: @Transitive A (@comparableLt A C) *)
induction (Z.abs_nat (phi inj_bound)); intros.
(* Goal: @eq (prod A B) (@pair A B a b) (@pair A B a b) *)
inversion Heqp; reflexivity.
(* Goal: @eq nat (Z.abs_nat (phi i)) (S n) *)
inversion Heqp; clear H1 H2 Heqp.
(* Goal: @eq nat (Z.abs_nat (phi (incr (@snd (list A) int31 (nat_rect (fun _ : nat => prod (list A) int31) (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0)) (fun (_ : nat) (p : prod (list A) int31) => @pair (list A) int31 (@cons A (@surj A N (@snd (list A) int31 p)) (@fst (list A) int31 p)) (incr (@snd (list A) int31 p))) n))))) (S n) *)
match goal with |- _ (_ (_ (snd ?p))) = _ => destruct p end.
(* Goal: @eq nat (Z.abs_nat (phi (incr (@snd (list A) int31 (@pair (list A) int31 l0 i0))))) (S n) *)
pose proof (phi_bounded i0).
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0))) *)
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
erewrite <- IHn, <- Zabs2Nat.inj_succ in H |- *; eauto; try omega.
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 (@nil A) (I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0))) *)
(* Goal: @In A x (@fst (list A) int31 (@pair (list A) int31 l i)) *)
(* Goal: @eq int31 i (@inj_bound A N) *)
rewrite phi_incr, Zmod_small; intuition; try omega.
(* Goal: Z.lt (Z.succ (phi (@snd (list A) int31 (@pair (list A) int31 l0 i0)))) (Z.pow (Zpos (xO xH)) (Z.of_nat size)) *)
apply inj_lt in H.
(* Goal: Z.lt (Z.succ (phi (@snd (list A) int31 (@pair (list A) int31 l0 i0)))) (Z.pow (Zpos (xO xH)) (Z.of_nat size)) *)
pose proof Z.le_le_succ_r.
(* Goal: Z.lt (Z.succ (phi (@snd (list A) int31 (@pair (list A) int31 l0 i0)))) (Z.pow (Zpos (xO xH)) (Z.of_nat size)) *)
do 2 rewrite Zabs2Nat.id_abs, Z.abs_eq in H; now eauto.
Qed.

(** Previous class instances for [option A] **)
Program Instance OptionComparable {A:Type} (C:Comparable A) : Comparable (option A) :=
  { compare := fun x y =>
      match x, y return comparison with
        | None, None => Eq
        | None, Some _ => Lt
        | Some _, None => Gt
        | Some x, Some y => compare x y
      end }.
Next Obligation.
(* Goal: forall _ : @eq comparison (@compare B CB b b0) Eq, @eq (prod A B) (@pair A B a b) (@pair A B a0 b0) *)
destruct x, y; intuition.
(* Goal: @eq comparison (CompOpp (@compare A C a a0)) (@compare A C a0 a) *)
apply compare_antisym.
Qed.
Next Obligation.
destruct x, y, z; try now intuition;
try (rewrite <- H in H0; discriminate).
(* Goal: @eq comparison (@compare A C a a1) c *)
apply (compare_trans _ _ _ _ H H0).
Qed.

Instance OptionComparableUsualEq {A:Type} {C:Comparable A} (U:ComparableUsualEq C) :
  ComparableUsualEq (OptionComparable C).
Proof.
(* Goal: @ComparableUsualEq (option A) (@OptionComparable A C) *)
intros x y.
(* Goal: forall _ : @eq comparison (@compare (option A) (@OptionComparable A C) x y) Eq, @eq (option A) x y *)
destruct x, y; intuition; try discriminate.
(* Goal: forall _ : @eq comparison (@compare B CB b b0) Eq, @eq (prod A B) (@pair A B a b) (@pair A B a0 b0) *)
rewrite (compare_eq a a0); intuition.
Qed.

Program Instance OptionFinite {A:Type} (E:Finite A) : Finite (option A) :=
  { all_list := None :: map Some all_list }.
Next Obligation.
(* Goal: forall _ : @eq comparison (@compare B CB b b0) Eq, @eq (prod A B) (@pair A B a b) (@pair A B a0 b0) *)
destruct x; intuition.
(* Goal: @In (option A) (@Some A a) (@cons (option A) (@None A) (@map A (option A) (@Some A) (@all_list A E))) *)
right.
(* Goal: @In (option A) (@Some A a) (@map A (option A) (@Some A) (@all_list A E)) *)
apply in_map.
(* Goal: @In A a (@all_list A E) *)
apply all_list_forall.
Defined.

(** Definitions of [FSet]/[FMap] from [Comparable] **)
Require Import OrderedTypeAlt.
Require FSetAVL.
Require FMapAVL.
Import OrderedType.

Module Type ComparableM.
  Parameter t : Type.
  Declare Instance tComparable : Comparable t.
End ComparableM.

Module OrderedTypeAlt_from_ComparableM (C:ComparableM) <: OrderedTypeAlt.
  Definition t := C.t.
  Definition compare : t -> t -> comparison := compare.

  Infix "?=" := compare (at level 70, no associativity).

  Lemma compare_sym x y : (y?=x) = CompOpp (x?=y).
  Proof. exact (Logic.eq_sym (compare_antisym x y)). Qed.
  Lemma compare_trans c x y z :
    (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
  Proof.
(* Goal: forall (_ : @eq comparison (compare x y) c) (_ : @eq comparison (compare y z) c), @eq comparison (compare x z) c *)
  apply compare_trans.
  Qed.
End OrderedTypeAlt_from_ComparableM.

Module OrderedType_from_ComparableM (C:ComparableM) <: OrderedType.
  Module Alt := OrderedTypeAlt_from_ComparableM C.
  Include (OrderedType_from_Alt Alt).
End OrderedType_from_ComparableM.
