(**************************************************************************
* TLC: A library for Coq                                                  *
* Binary relations                                                        *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibBool LibLogic LibProd LibSum.
Require Export LibOperation.

(* ********************************************************************** *)
(** * Generalities on binary relations *)

Definition binary (A : Type) := A -> A -> Prop.

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

Instance binary_inhab : forall A, Inhab (binary A).
Proof. intros. apply (prove_Inhab (fun _ _ => True)). Qed.

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

Lemma binary_extensional : forall A (R1 R2:binary A),
  (forall x y, R1 x y <-> R2 x y) -> R1 = R2.
Proof. intros_all. apply~ prop_ext_2. Qed.

Instance binary_extensional_inst : forall A, Extensional (binary A).
Proof. intros. apply (Build_Extensional _ (@binary_extensional A)). Defined.

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

Section Properties.
Variables (A:Type).
Implicit Types x y z : A.
Implicit Types R : binary A.

(** Reflexivity, irreflexivity, transitivity, symmetry, totality *)

Definition refl R :=
  forall x, R x x.
Definition irrefl R :=
  forall x, ~ (R x x).
Definition trans R :=
  forall y x z, R x y -> R y z -> R x z.
Definition sym R :=
  forall x y, R x y -> R y x.
Definition asym R :=
  forall x y, R x y -> ~ R y x.
Definition total R :=
  forall x y, R x y \/ R y x.

(** Antisymmetry with respect to an equivalence relation,
    antisymmetry with respect to Leibnitz equality,
     i.e. [forall x y, R x y -> R y x -> x = y] *)

Definition antisym_wrt (E:binary A) R :=
  forall x y, R x y -> R y x -> E x y.
Definition antisym :=
  antisym_wrt (@eq A).

(** Inclusion between relations *)

Definition incl R1 R2 :=
  forall x y, R1 x y -> R2 x y.

(** Equality between relations *)

Lemma rel_eq_intro : forall R1 R2,
  (forall x y, R1 x y <-> R2 x y) -> R1 = R2.
Proof. intros. extens*. Qed.

Lemma rel_eq_elim : forall R1 R2,
  R1 = R2 -> (forall x y, R1 x y <-> R2 x y).
Proof. intros. subst*. Qed.

End Properties.

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

Section Constructions.
Variable (A : Type).
Implicit Types R : binary A.
Implicit Types x y z : A.

(** The empty relation *)

Definition empty : binary A :=
  fun x y => False.

(** Swap (i.e. symmetric, converse, or transpose) of a relation *)

Definition flip R : binary A :=
  fun x y => R y x.

(** Complement of a relation *)

Definition compl R : binary A :=
  fun x y => ~ R y x.

(** Union of two relations *)

Definition union R1 R2 : binary A :=
  fun x y => R1 x y \/ R2 x y.

(** Strict order associated with an order, wrt Leibnitz' equality *)

Definition strict R : binary A :=
  fun x y => R x y /\ x <> y.

(** Large order associated with an order, wrt Leibnitz' equality *)

Definition large R : binary A :=
  fun x y => R x y \/ x = y.

End Constructions.

(** Inverse image *)

Definition inverse_image (A B:Type) (R:binary B) (f:A->B) : binary A :=
  fun x y => R (f x) (f y).

(** Pointwise product *)

Definition prod2 (A1 A2:Type)
 (R1:binary A1) (R2:binary A2) : binary (A1*A2) :=
  fun p1 p2 : A1*A2 => match p1,p2 with (x1,x2),(y1,y2) =>
    R1 x1 y1 /\ R2 x2 y2 end.

Definition prod3 (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3)
 : binary (A1*A2*A3) :=
  prod2 (prod2 R1 R2) R3.

Definition prod4 (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4)
 : binary (A1*A2*A3*A4) :=
  prod2 (prod3 R1 R2 R3) R4.

Tactic Notation "unfold_prod" :=
  unfold prod4, prod3, prod2.

Tactic Notation "unfolds_prod" :=
  unfold prod4, prod3, prod2 in *.

(** Lexicographical order *)

Definition lexico2 {A1 A2} (R1:binary A1) (R2:binary A2)
  : binary (A1*A2) :=
  fun p1 p2 : A1*A2 => let (x1,x2) := p1 in let (y1,y2) := p2 in
  (R1 x1 y1) \/ (x1 = y1) /\ (R2 x2 y2).

Definition lexico3 {A1 A2 A3}
 (R1:binary A1) (R2:binary A2) (R3:binary A3) : binary (A1*A2*A3) :=
  lexico2 (lexico2 R1 R2) R3.

Definition lexico4 {A1 A2 A3 A4}
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4)
 : binary (A1*A2*A3*A4) :=
  lexico2 (lexico3 R1 R2 R3) R4.

Tactic Notation "unfold_lexico" :=
  unfold lexico4, lexico3, lexico2.

Tactic Notation "unfolds_lexico" :=
  unfold lexico4, lexico3, lexico2 in *.

(* ---------------------------------------------------------------------- *)
(** ** Properties of constructions *)

Section ConstructionsProp.
Variable (A : Type).
Implicit Types R : binary A.
Implicit Types x y z : A.

Lemma refl_elim : forall x y R,
  refl R -> x = y -> R x y.
Proof. intros_all. subst~. Qed.

Lemma sym_elim : forall x y R,
  sym R -> R x y -> R y x.
Proof. introv Sy R1. apply* Sy. Qed.

Lemma antisym_elim : forall x y R,
  antisym R -> R x y -> R y x -> x <> y -> False.
Proof. intros_all*. Qed.

Lemma irrefl_neq : forall R,
  irrefl R ->
  forall x y, R x y -> x <> y.
Proof. introv H P E. subst. apply* H. Qed.

Lemma irrefl_elim : forall R,
  irrefl R ->
  forall x, R x x -> False.
Proof. introv H P. apply* H. Qed.

Lemma sym_to_eq : forall R,
  sym R ->
  forall x y, R x y = R y x.
Proof. introv H. intros. apply prop_ext. split; apply H. Qed.

Lemma sym_flip : forall R,
  sym R -> flip R = R.
Proof. intros. unfold flip. apply* prop_ext_2. Qed.

Lemma trans_strict : forall R,
  trans R -> antisym R -> trans (strict R).
Proof.
  introv T S. unfold strict. introv [H1 H2] [H3 H4]. split.
    apply* T.
    intros K. subst. apply H2. apply~ S.
Qed.

Lemma flip_flip : forall R,
  flip (flip R) = R.
Proof. intros. apply* prop_ext_2. Qed.

Lemma flip_refl : forall R,
  refl R -> refl (flip R).
Proof. intros_all. unfolds flip. auto. Qed.

Lemma flip_trans : forall R,
  trans R -> trans (flip R).
Proof. intros_all. unfolds flip. eauto. Qed.

Lemma flip_antisym : forall R,
  antisym R -> antisym (flip R).
Proof. intros_all. unfolds flip. auto. Qed.

Lemma flip_asym : forall R,
  asym R -> asym (flip R).
Proof. intros_all. unfolds flip. apply* H. Qed.

Lemma flip_total : forall R,
  total R -> total (flip R).
Proof. intros_all. unfolds flip. auto. Qed.

Lemma flip_strict : forall R,
  flip (strict R) = strict (flip R).
Proof. intros. unfold flip, strict. apply* prop_ext_2. Qed.

Lemma flip_large : forall R,
  flip (large R) = large (flip R).
Proof. intros. unfold flip, large. apply* prop_ext_2. Qed.

Lemma large_refl : forall R,
  refl (large R).
Proof. unfold large. intros_all~. Qed.

Lemma large_trans : forall R,
  trans R -> trans (large R).
Proof. unfold large. introv Tr [H1|E1] [H2|E2]; subst*. Qed.

Lemma large_antisym : forall R,
  antisym R -> antisym (large R).
Proof. introv T. introv H1 H2. (* todo: bug introv *)
  unfolds large. destruct H1; destruct H2; auto. Qed.

Lemma large_total : forall R,
  total R -> total (large R).
Proof. unfold large. intros_all~. destruct* (H x y). Qed.

Lemma strict_large : forall R,
  irrefl R -> strict (large R) = R.
Proof.
  intros. unfold large, strict. apply prop_ext_2.
  intros_all. split; intros K.
  auto*.
  split. left*. apply* irrefl_neq.
Qed.

Lemma large_strict : forall R,
  refl R -> large (strict R) = R.
Proof.
  intros. unfold large, strict. apply prop_ext_2.
  intros_all. split; intros K.
  destruct K. auto*. subst*.
  destruct (classic (x1 = x2)). subst. right*. left*.
  (* todo: cases *)
Qed.

Lemma double_incl : forall R1 R2,
  incl R1 R2 -> incl R2 R1 -> R1 = R2.
Proof. unfolds incl. intros. apply* prop_ext_2. Qed.

Lemma flip_injective : injective (@flip A).
Proof.
  intros R1 R2 E. apply prop_ext_2. intros x y.
  unfolds flip. rewrite* (func_same_2 y x E).
Qed.

Lemma eq_by_flip_l : forall R1 R2,
  R1 = flip R2 -> flip R1 = R2.
Proof. intros. apply flip_injective. rewrite~ flip_flip. Qed.

Lemma eq_by_flip_r : forall R1 R2,
  flip R1 = R2 -> R1 = flip R2.
Proof. intros. apply flip_injective. rewrite~ flip_flip. Qed.

(* TODO: do we really need this extensional version? *)

Lemma flip_flip_applied : forall R x y,
  (flip (flip R)) x y = R x y.
Proof. auto. Qed.

End ConstructionsProp.

Lemma trans_elim : forall A (y x z : A) R,
  trans R -> R x y -> R y z -> R x z.
Proof. introv Tr R1 R2. apply* Tr. Qed.

Lemma trans_sym : forall A (y x z : A) R,
  trans R -> sym R -> R z y -> R y x -> R x z.
Proof. introv Tr Sy R1 R2. apply* Tr. Qed.

Lemma trans_sym_1 : forall A (y x z : A) R,
  trans R -> sym R -> R y x -> R y z -> R x z.
Proof. introv Tr Sy R1 R2. apply* Tr. Qed.

Lemma trans_sym_2 : forall A (y x z : A) R,
  trans R -> sym R -> R x y -> R z y -> R x z.
Proof. introv Tr Sy R1 R2. apply* Tr. Qed.

Implicit Arguments trans_elim [A x z R].
Implicit Arguments trans_sym [A x z R].
Implicit Arguments trans_sym_1 [A x z R].
Implicit Arguments trans_sym_2 [A x z R].

(** Other forms of transitivity *)

Lemma large_strict_trans : forall A y x z (R:binary A),
  trans R -> large R x y -> R y z -> R x z.
Proof. introv T [E|H] H'; subst*. Qed.

Lemma strict_large_trans : forall A y x z (R:binary A),
  trans R -> R x y -> large R y z -> R x z.
Proof. introv T H [E|H']; subst*. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of inclusion *)

Lemma incl_refl : forall A (R:binary A), incl R R.
Proof. unfolds incl. auto. Qed.

Hint Resolve incl_refl.

Lemma lexico2_incl : forall A1 A2
 (R1 R1':binary A1) (R2 R2':binary A2),
  incl R1 R1' -> incl R2 R2' -> incl (lexico2 R1 R2) (lexico2 R1' R2').
Proof.
  introv I1 I2. intros [x1 x2] [y1 y2] [H1|[H1 H2]].
  left~. subst. right~.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of lexicographical composition *)

Section LexicoApp.
Variables (A1 A2 A3 A4:Type).
Variables (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4).

Lemma lexico2_app_1 : forall x1 x2 y1 y2,
  R1 x1 y1 ->
  lexico2 R1 R2 (x1,x2) (y1,y2).
Proof. intros. left~. Qed.

Lemma lexico2_app_2 : forall x1 x2 y1 y2,
  x1 = y1 -> R2 x2 y2 ->
  lexico2 R1 R2 (x1,x2) (y1,y2).
Proof. intros. right~. Qed.

Lemma lexico3_app_1 : forall x1 x2 x3 y1 y2 y3,
  R1 x1 y1 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof. intros. left. left~. Qed.

Lemma lexico3_app_2 : forall x1 x2 x3 y1 y2 y3,
  x1 = y1 -> R2 x2 y2 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof. intro. left. right~. Qed.

Lemma lexico3_app_3 : forall x1 x2 x3 y1 y2 y3,
  x1 = y1 -> x2 = y2 -> R3 x3 y3 ->
  lexico3 R1 R2 R3 (x1,x2,x3) (y1,y2,y3).
Proof. intros. right~. Qed.

Lemma lexico4_app_1 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  R1 x1 y1 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof. intros. left. left. left~. Qed.

Lemma lexico4_app_2 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 -> R2 x2 y2 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof. intros. left. left. right~. Qed.

Lemma lexico4_app_3 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 -> x2 = y2 -> R3 x3 y3 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof. intros. left. right~. Qed.

Lemma lexico4_app_4 : forall x1 x2 x3 x4 y1 y2 y3 y4,
  x1 = y1 -> x2 = y2 -> x3 = y3 -> R4 x4 y4 ->
  lexico4 R1 R2 R3 R4 (x1,x2,x3,x4) (y1,y2,y3,y4).
Proof. intros. right~. Qed.

End LexicoApp.

(** Transitivity *)

Lemma lexico2_trans : forall A1 A2
 (R1:binary A1) (R2:binary A2),
  trans R1 -> trans R2 -> trans (lexico2 R1 R2).
Proof.
  introv Tr1 Tr2. intros [x1 x2] [y1 y2] [z1 z2] Rxy Ryz.
  simpls. destruct Rxy as [L1|[Eq1 L1]];
   destruct Ryz as [M2|[Eq2 M2]]; subst*.
Qed.

Lemma lexico3_trans : forall A1 A2 A3
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  trans R1 -> trans R2 -> trans R3 -> trans (lexico3 R1 R2 R3).
Proof.
  introv Tr1 Tr2 Tr3. applys~ lexico2_trans. applys~ lexico2_trans.
Qed.

Lemma lexico4_trans : forall A1 A2 A3 A4
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  trans R1 -> trans R2 -> trans R3 -> trans R4 -> trans (lexico4 R1 R2 R3 R4).
Proof.
  introv Tr1 Tr2 Tr3. applys~ lexico3_trans. applys~ lexico2_trans.
Qed.

(* ********************************************************************** *)
(** * Equivalence relations *)

Record equiv A (R:binary A) :=
 { equiv_refl : refl R;
   equiv_sym : sym R;
   equiv_trans : trans R }.

(** Equality is an equivalence *)

Lemma eq_equiv : forall A, equiv (@eq A).
Proof. intros. constructor; intros_all; subst~. Qed.

Hint Resolve eq_equiv.

(** Symmetric of an equivalence is an equivalence *)

Lemma flip_equiv : forall A (E:binary A),
  equiv E -> equiv (flip E).
Proof.
  introv Equi. unfold flip. constructor; intros_all*.
Qed.

(** Product of two equivalences is an equivalence *)

Lemma prod2_equiv : forall A1 A2 (E1:binary A1) (E2:binary A2),
  equiv E1 -> equiv E2 -> equiv (prod2 E1 E2).
Proof.
  introv Equi1 Equi2. constructor.
  intros [x1 x2]. simple*.
  intros [x1 x2] [y1 y2]. simple*.
  intros [x1 x2] [y1 y2] [z1 z2]. simple*.
Qed.

(* todo: other arities of Prod *)

(**************************************************************************)
(* * Closures *)

Section Closures.
Variables (A : Type) (R : binary A).

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

(** Reflexive-transitive closure ( R* ) *)

Inductive rtclosure : binary A :=
  | rtclosure_refl : forall x,
      rtclosure x x
  | rtclosure_step : forall y x z,
      R x y -> rtclosure y z -> rtclosure x z.

(** Transitive closure ( R+ ) *)

Inductive tclosure : binary A :=
  | tclosure_intro : forall x y z,
     R x y -> rtclosure y z -> tclosure x z.

(** Another definition of transitive closure ( R+ ) *)

Inductive tclosure' : binary A :=
  | tclosure'_step : forall x y,
     R x y -> tclosure' x y
  | tclosure'_trans : forall y x z,
     tclosure' x y -> tclosure' y z -> tclosure' x z.

(** Symmetric-transitive closure *)

Inductive stclosure (A:Type) (R:binary A) : binary A :=
  | stclosure_step : forall x y,
      R x y -> stclosure R x y
  | stclosure_sym : forall x y,
      stclosure R x y -> stclosure R y x
  | stclosure_trans : forall y x z,
      stclosure R x y -> stclosure R y z -> stclosure R x z.

(* TODO Reflexive-symmetric-transitive closure ( R== )

Inductive equiv : binary A :=
  | equiv_step : forall x y,
      R x y -> equiv x y
  | equiv_refl : forall x,
      equiv x x
  | equiv_sym : forall x y,
      equiv x y -> equiv y x
  | equiv_trans : forall y x z,
      equiv x y -> equiv y z -> equiv x z.
*)

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

Hint Constructors tclosure rtclosure equiv.

Lemma rtclosure_once : forall x y,
  R x y -> rtclosure x y.
Proof. auto*. Qed.

Hint Resolve rtclosure_once.

Lemma rtclosure_trans : trans rtclosure.
Proof. introv R1 R2. induction* R1. Qed.

Lemma rtclosure_last : forall y x z,
  rtclosure x y -> R y z -> rtclosure x z.
Proof. introv R1 R2. induction* R1. Qed.

Hint Resolve rtclosure_trans.

Lemma tclosure_once : forall x y,
  R x y -> tclosure x y.
Proof. eauto. Qed.

Lemma tclosure_rtclosure : forall x y,
  tclosure x y -> rtclosure x y.
Proof. intros. destruct* H. Qed.

Hint Resolve tclosure_once tclosure_rtclosure.

Lemma tclosure_rtclosure_step : forall x y z,
  rtclosure x y -> R y z -> tclosure x z.
Proof. intros. induction* H. Qed.

Lemma tclosure_step_rtclosure : forall x y z,
  R x y -> rtclosure y z -> tclosure x z.
Proof. intros. gen x. induction* H0. Qed.

Lemma tclosure_step_tclosure : forall x y z,
  R x y -> tclosure y z -> tclosure x z.
Proof. intros. inverts* H0. Qed.

Hint Resolve tclosure_rtclosure_step tclosure_step_rtclosure.

Lemma tclosure_rtclosure_tclosure : forall y x z,
  rtclosure x y -> tclosure y z -> tclosure x z.
Proof. intros. gen z. induction* H. Qed.

Lemma tclosure_tclosure_rtclosure : forall y x z,
  tclosure x y -> rtclosure y z -> tclosure x z.
Proof. intros. induction* H. Qed.

Lemma tclosure_trans : trans tclosure.
Proof. intros_all. auto* tclosure_tclosure_rtclosure. Qed.

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

(** Star induction principle with transitivity hypothesis *)

Lemma rtclosure_ind_trans : forall (P : A -> A -> Prop),
  (forall x : A, P x x) ->
  (forall x y : A, R x y -> P x y) ->
  (forall y x z : A, rtclosure x y -> P x y -> rtclosure y z -> P y z -> P x z) ->
  forall x y : A, rtclosure x y -> P x y.
Proof.
  introv Hrefl Hstep Htrans S. induction S.
  auto. apply~ (@Htrans y).
Qed.

(** Star induction principle with steps at the end *)

Lemma rtclosure_ind_right : forall (P : A -> A -> Prop),
  (forall x : A, P x x) ->
  (forall y x z : A, rtclosure x y -> P x y -> R y z -> P x z) ->
  forall x y : A, rtclosure x y -> P x y.
Proof.
  introv Hrefl Hlast. apply rtclosure_ind_trans.
  auto.
  intros. apply~ (Hlast x).
  introv S1 P1 S2 _. gen x. induction S2; introv S1 P1.
     auto.
     apply IHS2. eauto. apply~ (Hlast x).
Qed.

End Closures.

Hint Resolve rtclosure_refl rtclosure_step rtclosure_once : rtclosure.
(* TODO: should rename and complete the [closure] database *)
(* TODO: should not need to re-export the following version *)

Lemma incl_tclosure_self : forall A (R:binary A),
   incl R (tclosure R).
Proof. unfolds incl. intros. apply~ tclosure_once. Qed.
Hint Resolve incl_tclosure_self.

(* TODO: sort and complete the following *)

Hint Resolve stclosure_step stclosure_sym stclosure_trans.

Lemma stclosure_le : forall A (R1 R2 : binary A),
  incl R1 R2 -> incl (stclosure R1) (stclosure R2).
Proof. unfolds incl. introv Le H. induction* H. Qed.


(* 2.6 Realizing Specifications *)
Require Import Arith ZArith Bool.
Open Scope Z_scope.

Section realization.
  Variables (A B : Set).
  Let spec: Set := (((A -> B) -> B) -> B) -> A -> B.
  Let realization : spec := fun f a => f (fun g => g a).
  Print realization.
  (* realization : spec :=
     fun (f : ((A -> B) -> B) -> B) (a : A)
         => f (fun g : A -> B => g a) *)

  Example spec_proof : spec.
  Proof using A B.
    intros f a. apply f. intro g. apply g, a.
  Qed.

  Print spec_proof.
  (* spec_proof : spec =
     fun (f : ((A -> B) -> B) -> B) (a : A)
         => f (fun g : A -> B => g a) *)

End realization.

Definition nat_fun_to_Z_fun : Set := (nat -> nat) -> Z -> Z.

Definition absolute_fun : nat_fun_to_Z_fun
  := fun f z => Z_of_nat (f (Z.abs_nat z)).

Definition always_O : nat_fun_to_Z_fun
  := fun _ _ => 0%Z.

Definition to_marignan : nat_fun_to_Z_fun
  := fun _ _ => 1515%Z.

Definition ignore_f : nat_fun_to_Z_fun
  := fun _ z => z.

Definition from_marignan : nat_fun_to_Z_fun
  := fun f _ => Z_of_nat (f 1515%nat).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (lf3 : natural) (lf2 : natural) : natural :=
  plus (plus lf3 z) lf2.


(**
   Bounded join-semilattices over natural numbers.

   Logic and Lattices in Distributed Programming
   by Conway, Marczak, Alvaro, Hellerstein, Maier.
   http://db.cs.berkeley.edu/papers/UCB-lattice-tr.pdf
**)

Require Export Max.
Require Export Min.
Require Export Sets.Ensembles.

Module JoinSemiLattice.

(* Boolean lattice, values advance from false -> true *)
Inductive lbool : Type :=
  | LBoolValue  : bool -> lbool.

Hint Constructors lbool.

Definition lbool_reveal lb :=
  match lb with
    | LBoolValue b => b
  end.

Definition lbool_merge lb1 lb2 :=
  match (lb1, lb2) with
    | (LBoolValue b1, LBoolValue b2) => (LBoolValue (orb b1 b2))
  end.

(* Proofs regarding the merge operation follows ACI *)
Theorem lbool_merge_assoc : forall (lb1 lb2 lb3 : lbool),
  lbool_merge (lbool_merge lb1 lb2) lb3 =
    lbool_merge lb3 (lbool_merge lb1 lb2).
Proof with eauto.
  destruct lb1; destruct lb2; destruct lb3...
    destruct b; destruct b0; destruct b1...
Qed.

Theorem lbool_merge_comm : forall (lb1 lb2 : lbool),
  lbool_merge lb1 lb2 = lbool_merge lb2 lb1.
Proof with eauto.
  induction lb1; induction lb2...
    destruct b; destruct b0...
Qed.

Theorem lbool_merge_idemp : forall (lb : lbool),
  lbool_merge lb lb = lb.
Proof with eauto.
  induction lb... destruct b...
Qed.

(* Max-value lattice, values monotonically advance upwards. *)
Inductive lmax_nat : Type :=
  | LMaxNatValue  : forall (n : nat), lmax_nat.

Hint Constructors lmax_nat.

Definition lmax_nat_reveal lm :=
  match lm with
    | LMaxNatValue n => n
  end.

Definition lmax_nat_merge lm1 lm2 :=
  match (lm1, lm2) with
    | (LMaxNatValue n1, LMaxNatValue n2) => (LMaxNatValue (max n1 n2))
  end.

(* Proofs regarding the merge operation follows ACI *)
Theorem lmax_nat_merge_assoc : forall (lm1 lm2 lm3 : lmax_nat),
  lmax_nat_merge (lmax_nat_merge lm1 lm2) lm3 =
    lmax_nat_merge lm3 (lmax_nat_merge lm1 lm2).
Proof with eauto.
  destruct lm1; destruct lm2; destruct lm3; eauto;
    unfold lmax_nat_merge; rewrite max_comm...
Qed.

Theorem lmax_nat_merge_comm : forall (lm1 lm2 : lmax_nat),
  lmax_nat_merge lm1 lm2 = lmax_nat_merge lm2 lm1.
Proof with eauto.
  destruct lm1; destruct lm2...
    try unfold lmax_nat_merge; rewrite max_comm...
Qed.

Theorem lmax_nat_merge_idemp : forall (lm : lmax_nat),
  lmax_nat_merge lm lm = lm.
Proof with eauto.
  destruct lm; unfold lmax_nat_merge...
    rewrite max_idempotent...
Qed.

(* Min-value lattice, values monotonically advance downwards. *)
Inductive lmin_nat : Type :=
  | LMinNatValue  : forall (n : nat), lmin_nat.

Hint Constructors lmin_nat.

Definition lmin_nat_reveal lm :=
  match lm with
    | LMinNatValue n => n
  end.

Definition lmin_nat_merge lm1 lm2 :=
  match (lm1, lm2) with
    | (LMinNatValue n1, LMinNatValue n2) => (LMinNatValue (min n1 n2))
  end.

(* Proofs regarding the merge operation follows ACI *)
Theorem lmin_nat_merge_assoc : forall (lm1 lm2 lm3 : lmin_nat),
  lmin_nat_merge (lmin_nat_merge lm1 lm2) lm3 =
    lmin_nat_merge lm3 (lmin_nat_merge lm1 lm2).
Proof with eauto.
  destruct lm1; destruct lm2; destruct lm3; eauto;
    unfold lmin_nat_merge; rewrite min_comm...
Qed.

Theorem lmin_nat_merge_comm : forall (lm1 lm2 : lmin_nat),
  lmin_nat_merge lm1 lm2 = lmin_nat_merge lm2 lm1.
Proof with eauto.
  destruct lm1; destruct lm2...
    try unfold lmin_nat_merge; rewrite min_comm...
Qed.

Theorem lmin_nat_merge_idemp : forall (lm : lmin_nat),
  lmin_nat_merge lm lm = lm.
Proof with eauto.
  destruct lm; unfold lmin_nat_merge...
    rewrite min_idempotent...
Qed.

End JoinSemiLattice.


Require Import List.
Require Import Arith.
Require Import Omega.
Require Import lex_order.
Section IS.
Variable V : nat. (* The number of vertices *)
Variable E : list (nat*nat).

Variable NoSelfEdges : forall x : nat, ~ In (x,x) E.
Variable Edges_lt_V : forall x y, In (x, y) E -> x < V.
Variable EdgesBidirectional :
  forall x y : nat, In (x,y) E -> In (y,x) E.

Definition ValidSet (X : list nat) :=
  forall x : nat, In x X -> x < V.

Definition Independent (X : list nat) :=
  forall x y, In x X -> In y X -> ~ In (x,y) E.

Inductive IndSet (X : list nat) : Prop :=
| defIndSet : ValidSet X -> Independent X -> IndSet X.

Inductive MaximalIndSet (X : list nat) : Prop :=
| defMaximalIndSet :
    IndSet X ->
    (forall x, IndSet (x::X) -> In x X) ->
      MaximalIndSet X.

Inductive MaximalIndSet_contrapos (X : list nat) : Prop :=
| defMaximalIndSet_contrapos :
    IndSet X ->
    (forall x, ~ In x X -> ~ IndSet (x::X)) ->
      MaximalIndSet_contrapos X.

Theorem MaximalIndSet_eq : forall X, MaximalIndSet X <-> MaximalIndSet_contrapos X.
Proof.
  split; intros; constructor; intros. inversion H. auto.
  inversion H. intros Hcontra. apply H0. apply H2. auto.
  inversion H. auto. inversion H. destruct (in_dec eq_nat_dec x X).
  auto. apply H2 in n. contradiction.
Qed.

Theorem validSetRecr :
  forall (x : nat) (X : list nat), ValidSet (x::X) -> ValidSet X.
Proof.
  intros. intros y H0.
  apply H. right. auto.
Qed.

Theorem ValidSet_dec :
  forall X : list nat, {ValidSet X}+{~ValidSet X}.
Proof.
  intros. induction X.
  left. intros x H. inversion H.
  destruct IHX. assert ( {V <= a} + {a < V}).
  apply le_lt_dec. destruct H.
  right. intros H0.
  assert (In a (a::X)). left. auto.
  apply H0 in H. omega. left.
  intros b H. destruct H. omega.
  apply v in H. auto. right.
  intros H. apply validSetRecr in H.
  auto.
Defined.

Theorem edgeEqDec : forall X Y : (nat*nat), {X=Y} + {X<>Y}.
Proof.
  intros.
  destruct X.
  destruct Y.
  assert ({n=n1}+{n<>n1}).
  apply eq_nat_dec.
  assert ({n0= n2}+{n0<>n2}).
  apply eq_nat_dec.
  destruct H.
  destruct H0.
  left. intuition.
  right.
  intuition. inversion H.
  intuition.
  right.
  unfold not. intros.
  inversion H.
  intuition.
Defined.

Theorem inEdgeDec : forall X : (nat*nat), {In X E}+{~In X E}.
Proof.
  intros.
  clear NoSelfEdges Edges_lt_V EdgesBidirectional.
  induction E.
  right. unfold not. intros. inversion H.
  destruct IHl.
  left. intuition.
  assert ({X =a}+{~X=a}).
  apply edgeEqDec.
  destruct H.
  left. intuition.
  simpl.
  left. intuition.
  right. simpl.
  unfold not. intros.
  intuition.
Defined.

Fixpoint vertexConnected (v : nat) (S : list nat) : bool :=
  match S with
  | nil => false
  | cons s S' => if inEdgeDec (v,s) then true else vertexConnected v S'
  end.

Theorem vertexConnected_spec :
forall (v : nat) (S: list nat),
    vertexConnected v S = true <-> exists (v' : nat), In v' S /\ In (v,v') E.
Proof.
  split; intros;
  induction S.
  simpl in H.
  inversion H.
  simpl vertexConnected in H.
  destruct inEdgeDec in H.
  exists a.
  split; intuition.
  apply IHS in H.
  destruct H.
  exists x. split; intuition.
  destruct H.
  destruct H.
  inversion H.
  simpl.
  destruct inEdgeDec.
  intuition.
  destruct H.
  destruct H.
  apply IHS.
  exists x.
  simpl in H.
  destruct H.
  replace x in H0.
  intuition.
  intuition.
Qed.

Theorem vertexConnected_spec_neg :
forall (v : nat) (S: list nat),
  vertexConnected v S = false <-> ~ exists (v' : nat), In v' S /\ In (v,v') E.
Proof.
  split.
  unfold not.
  intros.
  apply vertexConnected_spec in H0.
  replace (vertexConnected v S) with false in H0.
  intuition.
  intros.
  unfold not in H.
  assert ({vertexConnected v S = true} + {vertexConnected v S = false}).
  destruct vertexConnected; intuition.
  destruct H0.
  apply vertexConnected_spec in e.
  intuition.
  intuition.
Qed.

Fixpoint independent (X :  list nat) :=
  match X with
  | nil => true
  | x::X' => if vertexConnected x X then false else independent X'
  end.

Theorem independent_spec :
forall X : list nat,
  independent X = true <-> Independent X.
Proof.
  unfold Independent. split.
  intros. induction X. inversion H0.
  simpl In in H0. simpl In in H1.
  destruct H0; destruct H1;
  repeat subst. inversion H.
  destruct inEdgeDec in H1.
  inversion H1. assumption.
  inversion H. destruct inEdgeDec in H2.
  inversion H2. remember (vertexConnected x X).
  destruct b. inversion H2.
  symmetry in Heqb. apply vertexConnected_spec_neg in Heqb.
  intros H3. apply Heqb. exists y; split; assumption.
  inversion H. destruct inEdgeDec in H2.
  inversion H2. remember (vertexConnected y X).
  destruct b. inversion H2.
  symmetry in Heqb. apply vertexConnected_spec_neg in Heqb.
  intros H3. apply Heqb. exists x; split; try assumption.
  apply EdgesBidirectional. auto. apply IHX; try auto.
  inversion H. destruct inEdgeDec. inversion H3.
  destruct vertexConnected. inversion H3.
  reflexivity. intros. induction X. auto.
  simpl independent. destruct inEdgeDec.
  apply False_rec. specialize (H a a).
  apply H; try (left; auto). assumption.
  remember (vertexConnected a X).
  destruct b. symmetry in Heqb.
  apply vertexConnected_spec in Heqb.
  destruct Heqb as [v' [H0 H1]].
  apply False_rec. apply H with (x :=  a) (y := v');
  auto. left. auto. right. auto.
  apply IHX. intros. symmetry in Heqb.
  apply H; right; auto.
Qed.

Theorem Independent_dec : forall X, {Independent X} + {~ Independent X}.
Proof.
  intros X. remember (independent X).
  destruct b; [left | right]. apply independent_spec.
  auto. intros H. apply independent_spec in H.
  rewrite <- Heqb in H. inversion H.
Defined.

Theorem IndSetDec : forall X : list nat, {IndSet X} + {~IndSet X}.
  intros. destruct (ValidSet_dec X);
  [destruct (Independent_dec X) | right].
  left; constructor; auto.
  right. intros H. inversion H. auto.
  intros H. inversion H. auto.
Defined.

Theorem MaximalBound :
forall (x : nat) (X : list nat),
  x >= V -> ~ MaximalIndSet (x::X).
Proof.
  unfold not. intros.
  inversion H0. subst.
  inversion H1. subst.
  assert (In x (x::X)).
  left. auto. apply H3 in H5.
  omega.
Qed.

Fixpoint StepMaximalIndSet (X : list nat) (n : nat) :=
  match n with
  | O => if (IndSetDec (n::X)) then (n::X) else X
  | S m => if IndSetDec (n::(StepMaximalIndSet X m))
             then (n::(StepMaximalIndSet X m))
             else StepMaximalIndSet X m
  end.

Definition MkMaximalIndSet (S : list nat) : list nat :=
  StepMaximalIndSet S (pred V).

Theorem StepMaximalIndSet_spec : forall (n : nat) (X : list nat), IndSet X -> IndSet (StepMaximalIndSet X n).
Proof.
  intros.
  induction n.
  unfold StepMaximalIndSet.
  case IndSetDec; intuition.
  simpl.
  case IndSetDec;
  intuition.
Qed.

Theorem ConnectedApp :
  forall (X X' : list nat) (n : nat), vertexConnected n X = true -> vertexConnected n (X'++ X) = true.
Proof.
  intros.
  apply vertexConnected_spec in H.
  apply vertexConnected_spec.
  destruct H.
  destruct H.
  exists x.
  intuition.
Qed.

Theorem TrivialIndSet : V = 0 -> forall X, MaximalIndSet X -> X = nil.
Proof.
  intros. inversion H0. inversion H1.
  destruct X. auto.
  assert (In n (n::X)) as H5.
  left. auto. apply H3 in H5.
  omega.
Qed.

Theorem nilIndSet : IndSet nil.
Proof.
  constructor. unfold ValidSet. intros x H0.
  inversion H0. unfold Independent. intros.
  inversion H.
Qed.

Theorem IndCons : forall (x : nat) (X : list nat), Independent (x::X) -> Independent X.
Proof.
  intros. unfold Independent in *.
  intros. apply H; right; auto.
Qed.

Theorem IndSetCons :
  forall (x : nat) (X : list nat), IndSet (x::X) -> IndSet X.
Proof.
  intros. inversion H.
  constructor. intros y H2.
  apply H0. right. auto.
  apply IndCons in H1. auto.
Qed.

Theorem IndSetApp :
  forall (x : nat) (X X': list nat),
    IndSet X ->
    ~ IndSet (x::X) -> ~ IndSet (x::(X' ++ X)).
Proof.
  intros. intros H1. apply H0.
  constructor. intros y H2. inversion H1.
  apply H3. destruct H2 as [H2 | H2].
  left. auto. right. apply in_or_app.
  auto. unfold Independent.
  intros y z H2 H3. inversion H1.
  apply H5. destruct H2. left. auto.
  right. apply in_or_app. right. auto.
  destruct H3. left. auto.
  right. apply in_or_app. right. auto.
Qed.

Theorem MkMaximalIndSet_spec1 : forall X, IndSet X -> IndSet(MkMaximalIndSet X).
Proof.
  intros. induction X. simpl.
  unfold MkMaximalIndSet. destruct V.
  simpl. case IndSetDec;
  intuition. apply StepMaximalIndSet_spec.
  assumption. unfold MkMaximalIndSet in *.
  destruct V. simpl.
  case IndSetDec;
  intuition.
  apply StepMaximalIndSet_spec.
  intuition.
Qed.

Theorem StepMaximalIndSet_decons :
  forall (n : nat)(X : list nat),
    IndSet X -> exists (X' : list nat), StepMaximalIndSet X n = X' ++ X.
Proof.
  intros.
  induction n.
  unfold StepMaximalIndSet.
  destruct IndSetDec.
  exists (cons 0 nil).
  intuition.
  exists nil.
  intuition.
  simpl StepMaximalIndSet.
  destruct IHn.
  destruct IndSetDec.
  replace (StepMaximalIndSet X n).
  exists (S n :: x).
  intuition.
  replace (StepMaximalIndSet X n).
  exists x.
  intuition.
Qed.

Theorem MkMIS_to_StepMIS :
  forall X, exists n, MkMaximalIndSet X = StepMaximalIndSet X n.
Proof.
  intros.
  remember V.
  induction n;
  unfold MkMaximalIndSet;
  replace V;
  [exists 0 | exists n];
  induction X;
  intuition.
Qed.

Theorem MkMaximalIndSet_deapp :
  forall X, IndSet X -> exists X', MkMaximalIndSet X = X'++X.
Proof.
  intros.
  assert (exists n : nat, MkMaximalIndSet X = StepMaximalIndSet X n).
  apply MkMIS_to_StepMIS.
  destruct H0.
  replace (MkMaximalIndSet X).
  apply (StepMaximalIndSet_decons).
  intuition.
Qed.

Theorem IndSet_destr :
  forall (X : list nat) (m : nat), IndSet X -> m < V -> ~ IndSet (m::X) -> vertexConnected m X = true.
Proof.
  intros.
  induction X.
  assert (IndSet (m::nil)).
  constructor.
  unfold ValidSet.
  simpl In.
  intros. destruct H2;
  intuition. unfold Independent.
  intros.
  destruct H2, H3; auto.
  repeat subst. apply NoSelfEdges.
  auto.
  simpl vertexConnected.
  destruct inEdgeDec. auto.
  apply IHX. apply IndSetCons in H.
  auto. intros H2. apply H1.
  constructor. inversion H2.
  intros y H5. destruct H5 as [H5 | [H5| H5]];
  subst. apply H2. left. auto. apply H. left. auto.
  apply H3. right. auto. intros y z H3 H4.
  destruct H3 as [H3 | H3];
  destruct H4 as [H4 | H4]; repeat subst.
  apply NoSelfEdges. destruct H4 as [H4 | H4].
  subst. auto. apply H2. left. auto.
  right. auto. destruct H3 as [H3 | H3].
  subst. intros n'. apply n.
  apply EdgesBidirectional. auto.
  apply H2. right. auto. left. auto.
  apply H; auto.
Qed.

(*show that for everything less than n, this has to either contain that value or there's an edge between the constructed set. *)
Theorem IndSetConstraint :
  forall (X : list nat) (m : nat),
    IndSet X ->
    m < V ->
    ~ In m (StepMaximalIndSet X m) ->
      vertexConnected m (StepMaximalIndSet X m) = true.
Proof.
  intros.
  induction m.
  simpl StepMaximalIndSet in *.
  destruct IndSetDec.
  assert False.
  apply H1.
  intuition.
  intuition.
  apply IndSet_destr;
  intuition.
  simpl StepMaximalIndSet in *.
  destruct IndSetDec.
  assert False.
  apply H1.
  intuition.
  intuition.
  apply IndSet_destr.
  apply StepMaximalIndSet_spec.
  intuition.
  intuition.
  exact n.
Qed.

Theorem StepMaximalIndSet_decomp :
  forall (X : list nat) (n m: nat),
    m <= n -> exists (X' : list nat), (StepMaximalIndSet X n) = X'++(StepMaximalIndSet X m) /\
                                      forall y : nat, In y X' -> y > m.
Proof.
  intros.
  induction n.
  assert (m = 0).
  omega.
  replace m.
  exists nil.
  intuition. inversion H1.
  assert (m <= n \/ m = S n).
  omega.
  destruct H0.
  assert (m <= n) as i.
  intuition.
  apply IHn in H0.
  destruct H0.
  destruct H0.
  simpl StepMaximalIndSet.
  destruct IndSetDec.
  exists (S n :: x).
  replace (StepMaximalIndSet X n).
  intuition.
  simpl In in H3.
  destruct H3.
  omega.
  intuition.
  exists x.
  intuition.
  replace m.
  exists nil.
  intuition. inversion H1.
Qed.

Theorem IndSetConstraint_gen :
  forall (X : list nat ) (n m : nat),
    IndSet X ->
    n < V ->
    m <= n ->
    ~ In m (StepMaximalIndSet X n) ->
      vertexConnected m (StepMaximalIndSet X n) = true.
Proof.
  intros.
  assert (exists (X' : list nat),
            (StepMaximalIndSet X n) = X'++(StepMaximalIndSet X m) /\
            forall y : nat, In y X' -> y > m).
  apply StepMaximalIndSet_decomp; intuition.
  destruct H3.
  destruct H3.
  replace (StepMaximalIndSet X n) in *.
  apply ConnectedApp.
  assert (~ In m (StepMaximalIndSet X m)).
  unfold not.
  intros.
  apply H2.
  apply in_or_app.
  intuition.
  induction m.
  simpl StepMaximalIndSet in *.
  destruct IndSetDec.
  intuition.
  apply IndSet_destr;
  intuition.
  simpl StepMaximalIndSet in *.
  destruct IndSetDec.
  intuition.
  apply IndSet_destr; intuition.
  apply StepMaximalIndSet_spec.
  intuition.
Qed.

Theorem MkMaximalIndSet_red : forall (X : list nat) (n : nat), V = S n -> MkMaximalIndSet X = StepMaximalIndSet X n.
Proof.
  intros.
  unfold MkMaximalIndSet;
  intros.
  replace V;
  induction X; intuition.
Qed.

 (*Find a limit on expanding the S' in the proof below *)
Theorem MkMaximalIndSet_spec2 : forall X, IndSet X -> MaximalIndSet (MkMaximalIndSet X).
Proof.
  intros. apply MaximalIndSet_eq. constructor.
  apply MkMaximalIndSet_spec1. auto.
  intros. assert (x < V \/ x >= V).
  omega.
  destruct H1.
  assert ( {m : nat | S m = V} + {0 = V}).
  apply O_or_S.
  destruct H2.
  destruct s.
  assert ( MkMaximalIndSet X = StepMaximalIndSet X x0).
  apply MkMaximalIndSet_red. auto. rewrite -> H2 in H0.
  assert (vertexConnected x (StepMaximalIndSet X x0) = true).
  apply IndSetConstraint_gen;
  auto; omega.
  apply vertexConnected_spec in H3.
  intros H4. destruct H3 as [v' [H3 H3']].
  apply H4 in H3'; auto. left. auto.
  rewrite -> H2. right. auto.
  unfold MkMaximalIndSet in H0.
  rewrite <- e in H0. simpl in H0.
  destruct IndSetDec. inversion i.
  unfold ValidSet in H2. assert (In 0 (0::X)) as H4.
  left. auto. apply H2 in H4. omega.
  omega. intros H2. inversion H2.
  assert (In x (x::(MkMaximalIndSet X))).
  left. auto. apply H3 in H5. omega.
Qed.

Theorem MIS_nil_iff_0 : MaximalIndSet nil <-> V = 0.
Proof.
  rewrite -> MaximalIndSet_eq. split.
  (* -> *)
  intros H0.
  assert ( {V <= 0} + {0 < V} ) as H1. apply le_lt_dec.
  destruct H1 as [H1 | H1].
    (* V <= 0 *)
    omega.
    (* 0 < v *)
    inversion H0.
    apply False_rec.
    specialize (H2 0).
    apply H2. intros H3. inversion H3.
    constructor. intros x H3. inversion H3.
    omega. inversion H4.
    intros x y H3 H4. destruct H3;
    destruct H4; repeat subst.
    apply NoSelfEdges. inversion H4.
    inversion H3. inversion H3.
  intros. constructor. apply nilIndSet.
  intros x H0 H1. inversion H1.
  specialize (H2 x). assert (In x (x::nil)) as H4.
  left. auto. apply H2 in H4. omega.
Qed.

Theorem IndSet_cons : forall (l : list nat) (x : nat), ~IndSet l -> ~ IndSet (x::l).
Proof.
  intros l x H0 H1.
  apply H0. apply IndSetCons in H1.
  auto.
Qed.

Theorem IndSet_lift_spec : forall (l : list nat) (x : nat),
  MaximalIndSet l -> x < V -> IndSet (x::l) -> In x l.
Proof.
  intros. rewrite -> MaximalIndSet_eq in H. destruct H as [[H2 H3] H4].
  assert ( {In x l}+{~In x l} ) as H5 by (apply in_dec; apply (eq_nat_dec)).
  destruct H5 as [H5 | H5]. assumption.
  apply False_rec. apply H4 in H5. contradiction.
Qed.

Theorem IndSet_order : forall X Y : list nat, IndSet (X++Y) -> IndSet (Y ++ X).
Proof.
  intros X Y H0. inversion H0. constructor.
  unfold ValidSet. intros x H2. apply H0.
  apply in_or_app. apply in_app_or in H2.
  destruct H2 as [H2 | H2]; [right | left]; auto.
  intros x y H2 H3. apply H1;
  apply in_or_app; apply in_app_or in H2;
  apply in_app_or in H3; destruct H2 as [H2 | H2];
  destruct H3 as [H3 | H3]; auto.
Qed.

Theorem VertexConnected_order :
  forall (x : nat) (X Y : list nat),
    vertexConnected x (X++Y) = vertexConnected x (Y++X).
  intros x X Y.
    assert ({vertexConnected x (X++Y) = true} + {vertexConnected x (X++Y) = false}).
      destruct (vertexConnected x (X++Y)); intuition.
    assert ({vertexConnected x (Y++X) = true} + {vertexConnected x (Y++X) = false}).
      destruct (vertexConnected x (Y++X)); intuition.
    destruct H; destruct H0.
      rewrite -> e. intuition.
      apply vertexConnected_spec in e.
        apply vertexConnected_spec_neg in e0.
        assert False as F. apply e0. destruct e as [e [H0 H1]].
        exists e. split.
          apply in_app_or in H0. apply in_or_app. intuition.
          apply H1.
        inversion F.
      apply vertexConnected_spec in e0.
        apply vertexConnected_spec_neg in e.
        assert False as F. apply e. destruct e0 as [e0 [H0 H1]].
        exists e0. split.
          apply in_app_or in H0. apply in_or_app. intuition.
          apply H1.
        inversion F.
      rewrite -> e. intuition.
Qed.

Theorem MaximalIndSet_order : forall ( X Y : list nat), MaximalIndSet (X ++ Y) -> MaximalIndSet (Y ++ X).
Proof.
  intros X Y H0. rewrite -> MaximalIndSet_eq in *. inversion H0. constructor. apply IndSet_order. auto.
  intros x H2 H3. assert (~ In x (X++Y)) as H4.
  intros H4. apply H2. apply in_app_or in H4.
  apply in_or_app. destruct H4 as [H4 | H4]; auto.
  apply H1 in H4. apply H4.
  constructor. intros. intros y H5.
  destruct H5 as [H5 | H5]. apply H3.
  left. auto. apply H0. auto.
  intros y z H5 H6. apply H3.
  destruct H5 as [H5 | H5].
  left. auto. right. apply in_app_or in H5.
  destruct H5 as [H5 | H5];
  apply in_or_app; auto.
  destruct H6 as [H6 | H6].
  left. auto. right. apply in_app_or in H6.
  destruct H6 as [H6 | H6];
  apply in_or_app; auto.
Qed.

Theorem neg_incl_witness : forall X Y : list nat, ~ incl Y X -> exists n : nat, In n Y /\ ~ In n X.
Proof.
  intros. induction Y.
    assert (incl nil X). unfold incl. intros a H0. inversion H0. apply H in H0. destruct H0.
    unfold incl in H.
    assert ({In a X} + {~In a X}).
      apply in_dec. apply eq_nat_dec.
    destruct H0 as [H0 | H0].
    assert (~ incl Y X).
      intros H1.
      unfold incl in H1.
      assert (forall a0 : nat, In a0 (a :: Y) -> In a0 X).
        intros a0 H2. specialize (H1 a0). simpl In in H2. destruct H2 as [H2 | H2].
          rewrite <- H2. apply H0.
          apply H1 in H2. apply H2.
      apply H in H2.
      apply H2.
    apply IHY in H1.
    destruct H1 as [n0 [H1 H2]].
    exists n0.
    split.
      simpl. right. apply H1.
      apply H2.
    exists a. split.
      simpl. left. reflexivity.
      apply H0.
Qed.

Theorem MaximalIndSet_subs : forall X Y : list nat, incl X Y -> MaximalIndSet X -> MaximalIndSet Y -> list_eq X Y.
Proof.
  intros X Y H0 H1 H2. rewrite -> MaximalIndSet_eq in *.
  unfold incl in H0. unfold list_eq. intros x. split; intros H3.
  (* -> *)
  apply H0 in H3. apply H3.
  (* <- *)
  assert ({In x X} + {~ In x X}) as H4. apply in_dec. apply eq_nat_dec.
  destruct H4 as [H4| H4]. apply H4.
  (*We're now in a contradictory state *)
  assert (False).
  assert (~IndSet (x::X)) as H5. destruct H1 as [H1 H5]. apply H5. apply H4.
  apply H5. constructor. intros y H6.
  destruct H6 as [H6 | H6]. apply H2.
  subst. auto. apply H1. auto.
  intros y z H6 H7. apply H2.
  destruct H6 as [H6 | H6].
  subst. auto. auto. destruct H7 as [H7 | H7].
  subst. auto. apply H0. auto. inversion H.
Qed.

Theorem StepMaximalIndSet_in : forall n x X, In x (StepMaximalIndSet X n) -> In x X \/ x <= n.
Proof.
  intros n. induction n; intros x X H0.
  (* n = 0 *)
  simpl in H0. destruct IndSetDec in H0.
    (* IndSet *)
      simpl In in H0. intuition. left. intuition.
    (* ~ INdSet *)
      simpl in H0. destruct IndSetDec. simpl In in H0. intuition. apply IHn in H. intuition omega.
  (* n = S n' *)
  apply IHn in H0. intuition omega.
Qed.

Lemma MkMaximalIndSet_spec3_help : forall X Y : list nat,
  IndSet X -> MaximalIndSet Y -> incl X Y ->
    forall x : nat, delta_min (MkMaximalIndSet X) Y = Some x ->
    forall y : nat, delta_min Y (MkMaximalIndSet X) = Some y ->
      x < y.
Proof.
  intros X Y H0 H1 H2 x H3 y H4.
  assert (exists n : nat, n = V) as H5. exists V. reflexivity.
  destruct H5 as [n H5].
  destruct n.
  (*V = 0*)
    assert (MkMaximalIndSet X = nil).
      assert (MaximalIndSet (MkMaximalIndSet X)). apply MkMaximalIndSet_spec2. apply H0.
      destruct (MkMaximalIndSet X).
        reflexivity. inversion H.
        inversion H. assert (In n (n::l)).
        left. auto. apply H6 in H10. omega.
        rewrite -> H in H3. rewrite -> delta_min_r_nil in H3. inversion H3.
  (* V = S n *)
    assert (MaximalIndSet (MkMaximalIndSet X)) as H6. apply MkMaximalIndSet_spec2.
    apply H0.
    assert (MkMaximalIndSet X = StepMaximalIndSet X n) as H7.
    apply MkMaximalIndSet_red. rewrite -> H5. reflexivity.
    assert ( y < V ) as H8.
      destruct H1 as [[H0' H1'] H2']. apply H0'. apply (delta_min_in y Y (MkMaximalIndSet X) H4).
    assert ( ~ In y (MkMaximalIndSet X)) as H9.
      apply ((delta_min_neg_in y Y (MkMaximalIndSet X) )H4).
    assert (y <= n) as H10. omega.
    assert (exists X' : list nat, StepMaximalIndSet X n = X' ++ (StepMaximalIndSet X y) /\
                                  forall z : nat, In z X' -> z > y) as H11.
      apply StepMaximalIndSet_decomp. apply H10.
      destruct H11 as [X' [H11 H12]].
    assert (vertexConnected y (StepMaximalIndSet X y) = true) as H13. apply IndSetConstraint_gen.
      apply H0. apply H8. omega. rewrite -> H7 in H9. rewrite -> H11 in H9. intros H13. apply H9. apply in_or_app. right. apply H13.
    apply vertexConnected_spec in H13. destruct H13 as [z [H13 H14]].
    assert (In z (StepMaximalIndSet X n)) as H15. rewrite -> H11. apply in_or_app. right. apply H13.
    assert (z < y) as H16. assert (z <= y) as H0'.
      apply StepMaximalIndSet_in in H13. destruct H13 as [H13 | H13].
        (* Left *)
          assert (In z Y) as H1'. apply H2. apply H13.
          inversion H1. inversion H. apply False_rec.
          apply (H18 y z). apply (delta_min_in _ _ _ H4).
          apply H1'. apply H14. auto.
        (* Right *)
      assert (z <> y) as H16. intros H1'. rewrite H1' in H14. apply NoSelfEdges in H14. apply H14. omega.
      assert (delta_min (MkMaximalIndSet X) Y = None \/
             (exists p : nat,
               delta_min (MkMaximalIndSet X) Y = Some p /\
               In p (MkMaximalIndSet X) /\
               ~ In p Y /\
               (forall q : nat, In q (MkMaximalIndSet X) -> ~ In q Y -> p <= q))) as H17.
     apply delta_min_dec.
     destruct H17 as [H17 | H17]. rewrite -> H3 in H17. inversion H17.
     destruct H17 as [p [H0' [H1' [H2' H3']]]].
     assert (p = x) as H17. rewrite H3 in H0'. inversion H0'. reflexivity.
     assert (x <= z) as H18.
       rewrite <- H17. apply H3'. rewrite -> H7. apply H15.
       inversion H1. inversion H.
       specialize (H20 y z). intros H21. apply H20.
         apply (delta_min_in _ _ _ H4). auto. auto. omega.
Qed.

Theorem MkMaximalIndSet_spec3 : forall X Y : list nat,
  IndSet X -> MaximalIndSet Y -> incl X Y ->
    dec_order (MkMaximalIndSet X) Y = lt_list \/ dec_order (MkMaximalIndSet X) Y = eq_list.
Proof.
  intros X Y H0 H1 H2. rewrite -> MaximalIndSet_eq in H1.
  assert ( {dec_order (MkMaximalIndSet X) Y = lt_list} +
           {dec_order (MkMaximalIndSet X) Y = eq_list} +
           {dec_order (MkMaximalIndSet X) Y = gt_list}) as H5.
  apply dec_order_dec.
  destruct H5 as [[H5 | H5] | H5].
  (* Let's eliminate the trivial cases *)
    intuition. intuition. (*add in an ability to reorder/rename nodes? *)
  (* Now we're in the contradictory cases -> @H5 *)
  (* Let's set up some basic facts about the lists here *)
  assert (dec_order Y (MkMaximalIndSet X) = lt_list) as H6.
    apply dec_order_dual_spec. apply H5.
  assert (MaximalIndSet (MkMaximalIndSet X)) as H12.
    apply MkMaximalIndSet_spec2. apply H0.
  (* Let's introduce some facts about dec_order *)
  assert ( delta_min (MkMaximalIndSet X) Y = None \/ (exists x : nat,
    delta_min (MkMaximalIndSet X) Y = Some x /\
    In x (MkMaximalIndSet X) /\ ~ In x Y /\ (forall y : nat, In y (MkMaximalIndSet X) -> ~ In y Y -> x <= y))) as H7.
    apply delta_min_dec.
  assert ( delta_min Y (MkMaximalIndSet X) = None \/ (exists x : nat,
    delta_min Y (MkMaximalIndSet X) = Some x /\
    In x Y /\ ~ In x (MkMaximalIndSet X) /\ (forall y : nat, In y Y -> ~ In y (MkMaximalIndSet X) -> x <= y))) as H8.
    apply delta_min_dec.
  destruct H7 as [H7 | H7]; destruct H8 as [H8 | H8].
  (* delta_mins : None None *)
    right. unfold dec_order. destruct (MkMaximalIndSet X);
    rewrite -> H7; rewrite -> H8; reflexivity.
  (* delta_mins : None Some *)
    destruct H8 as [x [H8 [H9 [H10 H11]]]].
    assert (forall a : nat, In a (MkMaximalIndSet X) -> In a Y) as H13.
      apply delta_min_subs. apply H7.
    assert (~ IndSet(x::(MkMaximalIndSet X))) as H14.
       destruct H12 as [H12 H14]. intros H15.
      apply H14 in H15. contradiction.
    assert ({ValidSet (x::(MkMaximalIndSet X))} + {~ ValidSet (x::(MkMaximalIndSet X))}) as H15.
      apply ValidSet_dec.
    assert ( {independent (x :: MkMaximalIndSet X) = true} + {independent (x :: MkMaximalIndSet X) = false} ) as H16.
      intuition.
    destruct H15 as [H15 | H15]; destruct H16 as [H16 | H16]; assert False.
      apply H14. constructor. intuition. apply independent_spec. auto. inversion H.
      apply H14. constructor. apply H15. unfold Independent. intros a b  H0' H1'.
        destruct H1 as [H1 H17].
        destruct H1 as [H1 H18]. assert (forall x y : nat, In x Y -> In y Y -> ~ In (x, y) E) as H2'.
        apply H18. specialize (H2' a b). apply H2'.
          simpl in H0'. destruct H0' as [H0' | H0']. rewrite -> H0' in H9. apply H9. apply H13. apply H0'.
          simpl in H1'. destruct H1' as [H1' | H1']. rewrite -> H1' in H9. apply H9. apply H13. apply H1'.
        inversion H.
      apply H15. unfold ValidSet. intros a H0'. simpl In in H0'. destruct H0' as [H0' | H0'].
        destruct H1 as [H1 H1']. destruct H1 as [H1 H2'].
        unfold ValidSet in H1. apply H1. rewrite -> H0' in H9. apply H9.
        destruct H12 as [H12 H1']. destruct H12 as [H12 H2']. apply H12. apply H0'. inversion H.
      apply H15. unfold ValidSet. intros a H0'. simpl In in H0'. destruct H0' as [H0' | H0'].
         destruct H1 as [H1 H1']. destruct H1 as [H1 H2'].
        unfold ValidSet in H1. apply H1. rewrite -> H0' in H9. apply H9.
        destruct H12 as [H12 H1'].
        unfold ValidSet in H12. destruct H12 as [H12 H2']. apply H12. apply H0'. inversion H.
  (* delta_mins : Some None *)
    destruct H7 as [x [H7 [H9 [H10 H11]]]]. left.
    unfold dec_order. destruct (MkMaximalIndSet X);
    rewrite -> H7; rewrite -> H8; reflexivity.
  (* Some Some *)
    destruct H7 as [x [H7 [H9 [H10 H11]]]].
    destruct H8 as [y [H8 [H13 [H14 H15]]]].
    assert (y < x) as H0'.
      unfold dec_order in H6; destruct Y; rewrite -> H7 in H6; rewrite -> H8 in H6;
      destruct lt_dec; try (apply l); try inversion H6.
    assert (x < y) as H1'.
    apply (MkMaximalIndSet_spec3_help X Y).
      apply H0. rewrite -> MaximalIndSet_eq. apply H1. apply H2.
      destruct H12 as [H0'' H1'']. apply H7. apply H8.
    omega.
Qed.

Theorem independent_dec : forall X : list nat, {independent X = true} + {independent X = false}.
Proof. intuition. Qed.

Theorem IndSet_dec : forall (X : list nat), {IndSet X} + {~ IndSet X}.
Proof.
  intros X.
    assert ({ValidSet X} + {~ValidSet X}) as H0. apply ValidSet_dec.
    assert ({Independent X} + {~Independent X }) as H1. apply Independent_dec.
    destruct H0 as [H0 | H0]; destruct H1 as [H1 | H1]; [left | right | right | right]; intuition.
    constructor; auto. inversion H. auto. inversion H. auto. inversion H. auto.
Qed.

Theorem Independent_spec_neg :
  forall F : list nat,
    independent F = false <-> (exists x y, In x F /\ In y F /\ In (x, y) E).
Proof.
  split; intros; induction F. inversion H.
  {
    simpl in H. destruct inEdgeDec.
    apply NoSelfEdges in i. inversion i. remember (vertexConnected a F) as b.
    destruct b. symmetry in Heqb. apply vertexConnected_spec in Heqb.
    destruct Heqb as [v' [H0 H1]]. exists a. exists v'. repeat split.
    left. reflexivity. right. assumption. assumption. apply IHF in H.
    destruct H as [v [v' [H0 [H1 H2]]]]. exists v. exists v'. repeat split;
    try right; assumption.
  }
  destruct H as [x [y [H0 H1]]]. inversion H0.
  {
    destruct H as [x [y [H0 [H1 H2]]]].
    destruct H0 as [H0 | H0]; destruct H1 as [H1 | H1]; repeat subst.
    apply NoSelfEdges in H2. inversion H2. simpl.
    destruct inEdgeDec. reflexivity. remember (vertexConnected x F) as b.
    destruct b. reflexivity. symmetry in Heqb.
    apply vertexConnected_spec_neg in Heqb. apply False_rec.
    apply Heqb. exists y. split; assumption. simpl.
    destruct inEdgeDec. reflexivity. remember (vertexConnected y F) as b.
    destruct b. reflexivity. symmetry in Heqb.
    apply vertexConnected_spec_neg in Heqb. apply False_rec.
    apply Heqb. apply EdgesBidirectional in H2. exists x. split; assumption.
    simpl. destruct inEdgeDec. reflexivity. destruct vertexConnected.
    reflexivity. apply IHF. exists x. exists y.
    repeat split; try assumption.
  }
Qed.

Theorem eq_preserves_MIS : forall X Y: list nat, list_eq X Y -> MaximalIndSet X -> MaximalIndSet Y.
Proof.
  intros X Y H0 H1. rewrite -> MaximalIndSet_eq in *.
  unfold list_eq in H0. inversion H1. constructor. constructor.
  intros z H3. apply H1. apply H0. auto. intros a b H3 H4.  apply H1.
  apply H0. auto. apply H0. auto. intros x H3 H4.
  apply (H2 x). intros H5. apply H3. apply H0. auto.
  constructor. intros y H5. apply H4.  inversion H5.
  left. auto. right. apply H0. auto. intros y z H5 H6.
  apply H4. inversion H5. left. auto. right. apply H0.
  auto. inversion H6. left. auto. right. apply H0. auto.
Qed.

Theorem MIS_MKMIS : forall X : list nat, IndSet X -> (list_eq X (MkMaximalIndSet X) -> MaximalIndSet X).
Proof.
  intros X H0 H2.
  eapply eq_preserves_MIS.
    { apply list_eq_symmetric in H2. apply H2. }
    { apply MkMaximalIndSet_spec2. apply H0. }
Qed.

End IS.


From Ordinal Require Import sflib Basics.
From Ordinal Require Export Ordinal.

Require Import Coq.Classes.RelationClasses Coq.Classes.Morphisms. (* TODO: Use Morphisms *)

Set Implicit Arguments.
Set Primitive Projections.

Module OrdArith.
  Section ARITHMETIC.
    Let flip A B C (f: A -> B -> C): B -> A -> C := fun b a => f a b.

    Section ADD.
      Definition add (o0: Ord.t): forall (o1: Ord.t), Ord.t := Ord.orec o0 Ord.S.

      Let _S_le o: Ord.le o (Ord.S o).
      Proof.
        eapply Ord.S_le.
      Qed.

      Let _le_S o0 o1 (LE: Ord.le o0 o1): Ord.le (Ord.S o0) (Ord.S o1).
      Proof.
        apply Ord.le_S. auto.
      Qed.

      Lemma add_base_l o0 o1: Ord.le o0 (add o0 o1).
      Proof.
        eapply Ord.orec_le_base; auto.
      Qed.

      Lemma add_base_r o0 o1: Ord.le o1 (add o0 o1).
      Proof.
        transitivity (Ord.orec Ord.O Ord.S o1).
        { eapply Ord.orec_of_S. }
        { eapply Ord.orec_mon; auto. eapply Ord.O_bot. }
      Qed.

      Lemma add_O_r o: Ord.eq (add o Ord.O) o.
      Proof.
        eapply (@Ord.orec_O o Ord.S); auto.
      Qed.

      Lemma add_S o0 o1: Ord.eq (add o0 (Ord.S o1)) (Ord.S (add o0 o1)).
      Proof.
        eapply (@Ord.orec_S o0 Ord.S); auto.
      Qed.

      Lemma add_join o A (os: A -> Ord.t):
        Ord.eq (add o (Ord.join os)) (Ord.union o (Ord.join (fun a => add o (os a)))).
      Proof.
        eapply (@Ord.orec_join o Ord.S); eauto.
      Qed.

      Lemma add_join_inhabited o A (os: A -> Ord.t)
            (INHABITED: inhabited A):
        Ord.eq (add o (Ord.join os)) (Ord.join (fun a => add o (os a))).
      Proof.
        eapply (@Ord.orec_join_inhabited o Ord.S); eauto.
      Qed.

      Lemma add_build o A (os: A -> Ord.t)
        :
          Ord.eq (add o (Ord.build os)) (Ord.union o (Ord.join (fun a => Ord.S (add o (os a))))).
      Proof.
        eapply Ord.orec_build.
      Qed.

      Lemma add_union o0 o1 o2
        :
          Ord.eq (add o0 (Ord.union o1 o2)) (Ord.union (add o0 o1) (add o0 o2)).
      Proof.
        eapply Ord.orec_union; auto.
      Qed.

      Lemma le_add_r o0 o1 o2 (LE: Ord.le o1 o2)
        :
          Ord.le (add o0 o1) (add o0 o2).
      Proof.
        eapply Ord.le_orec; auto.
      Qed.

      Lemma lt_add_r o0 o1 o2 (LT: Ord.lt o1 o2)
        :
          Ord.lt (add o0 o1) (add o0 o2).
      Proof.
        eapply Ord.S_supremum in LT.
        eapply Ord.lt_le_lt.
        2: { eapply le_add_r. eapply LT. }
        eapply Ord.lt_eq_lt.
        { eapply add_S. }
        eapply Ord.S_lt.
      Qed.

      Lemma eq_add_r o0 o1 o2 (EQ: Ord.eq o1 o2)
        :
          Ord.eq (add o0 o1) (add o0 o2).
      Proof.
        split.
        - eapply le_add_r; eauto. eapply EQ.
        - eapply le_add_r; eauto. eapply EQ.
      Qed.

      Lemma le_add_l o0 o1 o2 (LE: Ord.le o0 o1)
        :
          Ord.le (add o0 o2) (add o1 o2).
      Proof.
        eapply (@Ord.orec_mon o0 Ord.S o1 Ord.S); auto.
      Qed.

      Lemma eq_add_l o0 o1 o2 (EQ: Ord.eq o0 o1)
        :
          Ord.eq (add o0 o2) (add o1 o2).
      Proof.
        split.
        - eapply le_add_l; eauto. eapply EQ.
        - eapply le_add_l; eauto. eapply EQ.
      Qed.

      Lemma add_O_l o: Ord.eq (add Ord.O o) o.
      Proof.
        induction o. etransitivity.
        { eapply add_build. }
        { split.
          - eapply Ord.union_spec.
            + eapply Ord.O_bot.
            + eapply Ord.join_supremum. i. eapply Ord.S_supremum.
              eapply Ord.eq_lt_lt.
              * eapply H.
              * eapply Ord.build_upperbound.
          - eapply Ord.build_supremum. i.
            eapply (@Ord.lt_le_lt (Ord.join (fun a0 => Ord.S (Ord.orec Ord.O Ord.S (os a0))))).
            2: { eapply Ord.union_r. }
            eapply Ord.eq_lt_lt.
            { symmetry. eapply H. }
            eapply Ord.lt_le_lt.
            { eapply Ord.S_lt. }
            { eapply (@Ord.join_upperbound _ (fun a0 => Ord.S (Ord.orec Ord.O Ord.S (os a0)))). }
        }
      Qed.

      Lemma add_assoc o0 o1 o2: Ord.eq (add (add o0 o1) o2) (add o0 (add o1 o2)).
      Proof.
        revert o0 o1. induction o2. i. etransitivity.
        { eapply add_build. } etransitivity.
        2: {
          eapply eq_add_r; auto.
          { symmetry. eapply add_build. }
        }
        etransitivity.
        2: { symmetry. eapply add_union; auto. }
        split.
        { eapply Ord.union_spec.
          { eapply Ord.union_l. }
          { eapply Ord.join_supremum. i. etransitivity.
            { apply Ord.le_S. eapply H. }
            etransitivity.
            2: { eapply Ord.union_r. }
            etransitivity.
            2: {
              eapply le_add_r.
              eapply (@Ord.join_upperbound _ (fun a0 : A => Ord.S (add o1 (os a0))) a).
            }
            eapply add_S.
          }
        }
        { eapply Ord.union_spec.
          { eapply Ord.union_l. }
          etransitivity.
          { eapply add_join. }
          eapply Ord.union_spec.
          { etransitivity.
            { eapply add_base_l. }
            { eapply Ord.union_l. }
          }
          etransitivity.
          2: { eapply Ord.union_r. }
          eapply Ord.le_join. i. exists a0.
          etransitivity.
          { eapply add_S. }
          { apply Ord.le_S. eapply H. }
        }
      Qed.

      Lemma add_lt_l o0 o1 (LT: Ord.lt Ord.O o1): Ord.lt o0 (add o0 o1).
      Proof.
        eapply Ord.S_supremum in LT. eapply (@Ord.lt_le_lt (add o0 (Ord.S Ord.O))).
        { eapply Ord.lt_eq_lt.
          { eapply add_S. }
          eapply Ord.lt_le_lt.
          { eapply Ord.S_lt. }
          eapply Ord.le_S. eapply add_base_l.
        }
        { eapply le_add_r. auto. }
      Qed.
    End ADD.

    Section RECAPP.
      Variable D: Type.
      Variable next: D -> D.
      Variable djoin: forall (A: Type) (ds: A -> D), D.

      Variable dle: D -> D -> Prop.
      Variable wf: D -> Prop.

      Hypothesis dle_reflexive: forall d (WF: wf d), dle d d.
      Hypothesis dle_transitive: forall d1 d0 d2 (WF0: wf d0) (WF1: wf d1) (WF2: wf d2) (LE0: dle d0 d1) (LE1: dle d1 d2),
          dle d0 d2.

      Hypothesis djoin_upperbound: forall A (ds: A -> D) (a: A) (WF: forall a, wf (ds a)), dle (ds a) (djoin ds).
      Hypothesis djoin_supremum: forall A (ds: A -> D) (d: D) (WF: forall a, wf (ds a)) (WFD: wf d) (LE: forall a, dle (ds a) d), dle (djoin ds) d.
      Hypothesis djoin_wf: forall A (ds: A -> D) (WF: forall a, wf (ds a)), wf (djoin ds).

      Hypothesis next_wf: forall d (WF: wf d), wf (next d).

      Hypothesis next_le: forall d (WF: wf d), dle d (next d).
      Hypothesis next_mon: forall d0 d1 (WF0: wf d0) (WF1: wf d1) (LE: dle d0 d1), dle (next d0) (next d1).

      Let deq: D -> D -> Prop :=
        fun d0 d1 => dle d0 d1 /\ dle d1 d0.

      Let dunion (d0 d1: D): D := djoin (fun b: bool => if b then d0 else d1).

      Let dunion_l d0 d1 (WF0: wf d0) (WF1: wf d1): dle d0 (dunion d0 d1).
      Proof.
        eapply (@djoin_upperbound _ (fun b: bool => if b then d0 else d1) true). i. destruct a; auto.
      Qed.

      Let dunion_r d0 d1 (WF0: wf d0) (WF1: wf d1): dle d1 (dunion d0 d1).
      Proof.
        eapply (@djoin_upperbound _ (fun b: bool => if b then d0 else d1) false). i. destruct a; auto.
      Qed.

      Let dunion_supremum d0 d1 u (WF0: wf d0) (WF1: wf d1) (WFU: wf u) (LE0: dle d0 u) (LE1: dle d1 u):
        dle (dunion d0 d1) u.
      Proof.
        eapply djoin_supremum; auto.
        { i. destruct a; auto. }
        { i. destruct a; auto. }
      Qed.

      Let dunion_wf d0 d1 (WF0: wf d0) (WF1: wf d1): wf (dunion d0 d1).
      Proof.
        eapply djoin_wf. i. destruct a; auto.
      Qed.

      Let drec_wf base (WF: wf base) o: wf (Ord.rec base next djoin o).
      Proof.
        eapply (Ord.rec_wf base next djoin dle wf); auto.
      Qed.

      Let drec_rec_wf base (WF: wf base) o0 o1:
        wf (Ord.rec (Ord.rec base next djoin o0) next djoin o1).
      Proof.
        eapply (Ord.rec_wf _ next djoin dle wf); auto.
      Qed.

      Let djoin_le A (ds0 ds1: A -> D)
          (WF0: forall a, wf (ds0 a))
          (WF1: forall a, wf (ds1 a))
          (LE: forall a, dle (ds0 a) (ds1 a))
        :
          dle (djoin ds0) (djoin ds1).
      Proof.
        eapply djoin_supremum; auto.
        i. eapply (@dle_transitive (ds1 a)); auto.
      Qed.

      Let djoin_eq A (ds0 ds1: A -> D)
          (WF0: forall a, wf (ds0 a))
          (WF1: forall a, wf (ds1 a))
          (EQ: forall a, deq (ds0 a) (ds1 a))
        :
          deq (djoin ds0) (djoin ds1).
      Proof.
        split.
        { eapply djoin_le; auto. i. eapply EQ. }
        { eapply djoin_le; auto. i. eapply EQ. }
      Qed.

      Let dunion_le dl0 dl1 dr0 dr1
          (WFL0: wf dl0) (WFL1: wf dl1) (WFR0: wf dr0) (WFR1: wf dr1)
          (LEL: dle dl0 dl1) (LER: dle dr0 dr1):
        dle (dunion dl0 dr0) (dunion dl1 dr1).
      Proof.
        eapply djoin_le.
        { i. destruct a; auto. }
        { i. destruct a; auto. }
        { i. destruct a; auto. }
      Qed.

      Let next_eq d0 d1
          (WF0: wf d0) (WF1: wf d1) (EQ: deq d0 d1)
        :
          deq (next d0) (next d1).
      Proof.
        split; eapply next_mon; auto; apply EQ.
      Qed.

      Let dunion_eq dl0 dl1 dr0 dr1
          (WFL0: wf dl0) (WFL1: wf dl1) (WFR0: wf dr0) (WFR1: wf dr1)
          (EQL: deq dl0 dl1) (EQR: deq dr0 dr1):
        deq (dunion dl0 dr0) (dunion dl1 dr1).
      Proof.
        eapply djoin_eq; auto.
        { i. destruct a; auto. }
        { i. destruct a; auto. }
        { i. destruct a; auto. }
      Qed.

      Let deq_transitive: forall d1 d0 d2 (WF0: wf d0) (WF1: wf d1) (WF2: wf d2) (LE0: deq d0 d1) (LE1: deq d1 d2),
          deq d0 d2.
      Proof.
        i. inv LE0. inv LE1. split; eauto.
      Qed.

      Let drec_red base A (os: A -> Ord.t):
        Ord.rec base next djoin (Ord.build os) =
        dunion base (djoin (fun a => next (Ord.rec base next djoin (os a)))).
      Proof.
        eapply Ord.rec_red.
      Qed.

      Lemma rec_app base o0 o1 (WF: wf base):
        deq (Ord.rec base next djoin (add o0 o1)) (Ord.rec (Ord.rec base next djoin o0) next djoin o1).
      Proof.
        Local Transparent Ord.rec Ord.union.
        induction o1.

        eapply (@deq_transitive (dunion (Ord.rec base next djoin o0) (dunion base (djoin (fun a => next (Ord.rec (Ord.rec base next djoin o0) next djoin (os a))))))); auto.
        { eapply dunion_wf; auto. }
        { eapply (@deq_transitive (Ord.rec base next djoin (Ord.union o0 (Ord.join (fun a : A => Ord.S (add o0 (os a))))))); auto.
          { eapply dunion_wf; auto. }
          { eapply (@Ord.eq_rec _ base next djoin dle wf); auto.
            symmetry. eapply add_build. }
          eapply (@deq_transitive (dunion (Ord.rec base next djoin o0) (Ord.rec base next djoin (Ord.join (fun a : A => Ord.S (add o0 (os a))))))); auto.
          { eapply dunion_wf; auto. }
          { eapply (Ord.rec_union base next djoin dle wf); auto. }
          eapply dunion_eq; auto.
          { split; apply dle_reflexive; auto. }
          { eapply (@deq_transitive (dunion base (djoin (fun a : A => Ord.rec base next djoin ((fun a0 : A => Ord.S (add o0 (os a0))) a))))); auto.
            { eapply (Ord.rec_join base next djoin dle wf); auto. }
            { eapply dunion_eq; auto.
              { split; auto. }
              { eapply djoin_eq; auto. i.
                eapply (@deq_transitive (next (Ord.rec base next djoin (add o0 (os a))))); auto.
                eapply (Ord.rec_S base next djoin dle wf); auto.
              }
            }
          }
        }

        rewrite drec_red. split.
        { eapply dunion_supremum; auto.
          eapply dunion_supremum; auto.
          eapply (@dle_transitive (Ord.rec base next djoin o0)); auto.
          eapply (Ord.rec_le_base base next djoin dle wf); auto.
        }
        { eapply dunion_le; auto. }
      Qed.
    End RECAPP.

    Section ORECAPP.
      Variable next: Ord.t -> Ord.t.
      Hypothesis next_le: forall o, Ord.le o (next o).
      Hypothesis next_mon: forall o0 o1 (LE: Ord.le o0 o1), Ord.le (next o0) (next o1).

      Lemma orec_app base o0 o1:
        Ord.eq (Ord.orec base next (add o0 o1)) (Ord.orec (Ord.orec base next o0) next o1).
      Proof.
        eapply (rec_app next Ord.join Ord.le (fun _ => True)); auto.
        { i. reflexivity. }
        { i. transitivity d1; auto. }
        { i. eapply Ord.join_upperbound. }
        { i. eapply Ord.join_supremum. auto. }
      Qed.
    End ORECAPP.

    Section MULT.
      Definition mult (o0: Ord.t): forall (o1: Ord.t), Ord.t := Ord.orec Ord.O (flip add o0).

      Lemma mult_gen_le o0 o1: Ord.le o1 (flip add o0 o1).
      Proof.
        eapply add_base_l.
      Qed.
      Let _mult_gen_le := mult_gen_le.

      Lemma mult_gen_mon o o0 o1 (LE: Ord.le o0 o1): Ord.le (flip add o o0) (flip add o o1).
      Proof.
        eapply le_add_l. auto.
      Qed.
      Let _mult_gen_mon := mult_gen_mon.

      Lemma mult_O_r o: Ord.eq (mult o Ord.O) Ord.O.
      Proof.
        eapply (@Ord.orec_O Ord.O (flip add o)); auto.
      Qed.

      Lemma mult_S o0 o1: Ord.eq (mult o0 (Ord.S o1)) (add (mult o0 o1) o0).
      Proof.
        eapply (@Ord.orec_S Ord.O (flip add o0)); auto.
      Qed.

      Lemma mult_join o A (os: A -> Ord.t):
        Ord.eq (mult o (Ord.join os)) (Ord.join (fun a => mult o (os a))).
      Proof.
        transitivity (Ord.union Ord.O (Ord.join (fun a => mult o (os a)))).
        { eapply (@Ord.orec_join Ord.O (flip add _)); eauto. }
        { eapply Ord.union_max. eapply Ord.O_bot. }
      Qed.

      Lemma mult_build o A (os: A -> Ord.t)
        :
          Ord.eq (mult o (Ord.build os)) (Ord.join (fun a => add (mult o (os a)) o)).
      Proof.
        transitivity (Ord.union Ord.O (Ord.join (fun a => add (mult o (os a)) o))).
        { eapply (@Ord.orec_build Ord.O (flip add _)); eauto. }
        { eapply Ord.union_max. eapply Ord.O_bot. }
      Qed.

      Lemma mult_union o0 o1 o2
        :
          Ord.eq (mult o0 (Ord.union o1 o2)) (Ord.union (mult o0 o1) (mult o0 o2)).
      Proof.
        eapply Ord.orec_union; auto.
      Qed.

      Lemma le_mult_r o0 o1 o2 (LE: Ord.le o1 o2)
        :
          Ord.le (mult o0 o1) (mult o0 o2).
      Proof.
        eapply Ord.le_orec; auto.
      Qed.

      Lemma eq_mult_r o0 o1 o2 (EQ: Ord.eq o1 o2)
        :
          Ord.eq (mult o0 o1) (mult o0 o2).
      Proof.
        split.
        - eapply le_mult_r; eauto. eapply EQ.
        - eapply le_mult_r; eauto. eapply EQ.
      Qed.

      Lemma le_mult_l o0 o1 o2 (LE: Ord.le o0 o1)
        :
          Ord.le (mult o0 o2) (mult o1 o2).
      Proof.
        eapply (@Ord.orec_mon Ord.O (flip add o0) Ord.O (flip add o1)); auto.
        { reflexivity. }
        { i. unfold flip. transitivity (add o4 o0).
          { eapply le_add_l; auto. }
          { eapply le_add_r; auto. }
        }
      Qed.

      Lemma eq_mult_l o0 o1 o2 (EQ: Ord.eq o0 o1)
        :
          Ord.eq (mult o0 o2) (mult o1 o2).
      Proof.
        split.
        - eapply le_mult_l; eauto. eapply EQ.
        - eapply le_mult_l; eauto. eapply EQ.
      Qed.

      Lemma lt_mult_r o0 o1 o2 (LT: Ord.lt o1 o2) (POS: Ord.lt Ord.O o0)
        :
          Ord.lt (mult o0 o1) (mult o0 o2).
      Proof.
        eapply Ord.S_supremum in LT.
        eapply Ord.lt_le_lt.
        2: { eapply le_mult_r. eapply LT. }
        eapply Ord.lt_eq_lt.
        { eapply mult_S. }
        eapply add_lt_l. auto.
      Qed.

      Lemma mult_O_l o: Ord.eq (mult Ord.O o) Ord.O.
      Proof.
        induction o. etransitivity.
        { eapply mult_build. }
        { split.
          - eapply Ord.join_supremum. i.
            transitivity (mult Ord.O (os a)); auto.
            { eapply add_O_r. }
            { eapply H. }
          - eapply Ord.O_bot. }
      Qed.

      Lemma mult_1_r o: Ord.eq (mult o (Ord.S Ord.O)) o.
      Proof.
        etransitivity.
        { eapply mult_S. }
        etransitivity.
        { eapply eq_add_l. eapply mult_O_r. }
        eapply add_O_l.
      Qed.

      Lemma mult_1_l o: Ord.eq (mult (Ord.S Ord.O) o) o.
      Proof.
        transitivity (Ord.orec Ord.O Ord.S o).
        2: { symmetry. eapply Ord.orec_of_S. }
        split.
        { eapply Ord.orec_mon.
          { reflexivity. }
          { i. unfold flip. etransitivity.
            { eapply add_S. }
            { apply Ord.le_S. transitivity o0; auto.
              eapply add_O_r.
            }
          }
        }
        { eapply Ord.orec_mon.
          { reflexivity. }
          { i. unfold flip. etransitivity.
            { apply Ord.le_S. eapply LE. }
            transitivity (Ord.S (add o1 Ord.O)); auto.
            { apply Ord.le_S. eapply add_O_r. }
            { eapply add_S. }
          }
        }
      Qed.

      Lemma mult_dist o0 o1 o2: Ord.eq (mult o0 (add o1 o2)) (add (mult o0 o1) (mult o0 o2)).
      Proof.
        revert o0 o1. induction o2. i. etransitivity.
        { eapply eq_mult_r. eapply add_build. }
        etransitivity.
        2: { eapply eq_add_r. symmetry. eapply mult_build. }
        etransitivity.
        { eapply mult_union. }
        etransitivity.
        { eapply Ord.eq_union.
          { reflexivity. }
          { eapply mult_join. }
        }
        etransitivity.
        2: { symmetry. eapply add_join. }
        eapply Ord.eq_union.
        { reflexivity. } split.
        { eapply Ord.le_join. i. exists a0.
          etransitivity.
          { eapply mult_S. }
          etransitivity.
          { eapply eq_add_l. symmetry. eapply H. }
          eapply add_assoc.
        }
        { eapply Ord.le_join. i. exists a0.
          etransitivity.
          { eapply add_assoc. }
          etransitivity.
          { eapply eq_add_l. eapply H. }
          eapply mult_S.
        }
      Qed.

      Lemma mult_assoc o0 o1 o2: Ord.eq (mult (mult o0 o1) o2) (mult o0 (mult o1 o2)).
      Proof.
        revert o0 o1. induction o2. i. etransitivity.
        { eapply mult_build. } etransitivity.
        2: {
          eapply eq_mult_r; auto.
          { symmetry. eapply mult_build. }
        }
        etransitivity.
        2: { symmetry. eapply mult_join. }
        split.
        { eapply Ord.le_join. i. exists a0.
          etransitivity.
          { eapply le_add_l. eapply H. }
          { eapply mult_dist. }
        }
        { eapply Ord.le_join. i. exists a0.
          etransitivity.
          { eapply mult_dist. }
          { eapply le_add_l. eapply H. }
        }
      Qed.

      Lemma mult_le_l o0 o1 (POS: Ord.lt Ord.O o0): Ord.le o1 (mult o1 o0).
      Proof.
        eapply Ord.S_supremum in POS. etransitivity.
        2: { eapply le_mult_r in POS. eauto. }
        eapply mult_1_r.
      Qed.

      Lemma mult_lt_l o0 o1 (POS: Ord.lt Ord.O o1)
            (TWO: Ord.lt (Ord.S Ord.O) o0): Ord.lt o1 (mult o1 o0).
      Proof.
        eapply Ord.S_supremum in TWO. eapply (@Ord.lt_le_lt (mult o1 (Ord.S (Ord.S Ord.O)))).
        { eapply Ord.lt_eq_lt.
          { eapply mult_S. }
          eapply Ord.lt_eq_lt.
          { eapply eq_add_l. eapply mult_S. }
          eapply Ord.lt_eq_lt.
          { eapply add_assoc. }
          eapply Ord.lt_le_lt.
          2: { eapply add_base_r. }
          eapply add_lt_l. apply POS.
        }
        { eapply le_mult_r. auto. }
      Qed.

    End MULT.

    Section EXPN.
      Definition expn (o0: Ord.t): forall (o1: Ord.t), Ord.t := Ord.orec (Ord.S Ord.O) (flip mult o0).

      Let expn_gen_mon o o0 o1 (LE: Ord.le o0 o1):
        Ord.le (flip mult o o0) (flip mult o o1).
      Proof.
        eapply le_mult_l. auto.
      Qed.

      Section BASE.
        Variable base: Ord.t.

        Lemma expn_O o: Ord.eq (expn o Ord.O) (Ord.S Ord.O).
        Proof.
          eapply Ord.orec_O; auto.
        Qed.

        Lemma expn_pos o: Ord.lt Ord.O (expn base o).
        Proof.
          eapply Ord.lt_le_lt.
          { eapply Ord.S_lt. }
          { eapply Ord.orec_le_base. auto. }
        Qed.

        Section POSITIVE.
          Hypothesis POS: Ord.lt Ord.O base.

          Let expn_gen_le o: Ord.le o (flip mult base o).
          Proof.
            eapply mult_le_l; auto.
          Qed.

          Lemma expn_S o:
            Ord.eq (expn base (Ord.S o)) (mult (expn base o) base).
          Proof.
            eapply Ord.orec_S; auto.
          Qed.

          Lemma le_expn_r o0 o1 (LE: Ord.le o0 o1):
            Ord.le (expn base o0) (expn base o1).
          Proof.
            eapply Ord.le_orec; auto.
          Qed.

          Lemma eq_expn_r o0 o1 (EQ: Ord.eq o0 o1):
            Ord.eq (expn base o0) (expn base o1).
          Proof.
            eapply Ord.eq_orec; auto.
          Qed.

          Lemma expn_join A (os: A -> Ord.t):
            Ord.eq (expn base (Ord.join os)) (Ord.union (Ord.S Ord.O) (Ord.join (fun a => expn base (os a)))).
          Proof.
            eapply Ord.orec_join; auto.
          Qed.

          Lemma expn_join_inhabited A (os: A -> Ord.t)
                (INHABITED: inhabited A):
            Ord.eq (expn base (Ord.join os)) (Ord.join (fun a => expn base (os a))).
          Proof.
            eapply Ord.orec_join_inhabited; auto.
          Qed.

          Lemma expn_build A (os: A -> Ord.t):
            Ord.eq (expn base (Ord.build os)) (Ord.union (Ord.S Ord.O) (Ord.join (fun a => mult (expn base (os a)) base))).
          Proof.
            eapply Ord.orec_build.
          Qed.

          Lemma expn_union o0 o1
            :
              Ord.eq (expn base (Ord.union o0 o1)) (Ord.union (expn base o0) (expn base o1)).
          Proof.
            eapply Ord.orec_union; auto.
          Qed.

          Lemma expn_1_r: Ord.eq (expn base (Ord.S Ord.O)) base.
          Proof.
            etransitivity.
            { eapply expn_S. }
            etransitivity.
            { eapply eq_mult_l. eapply expn_O. }
            eapply mult_1_l.
          Qed.

          Lemma expn_add o0 o1:
            Ord.eq (expn base (add o0 o1)) (mult (expn base o0) (expn base o1)).
          Proof.
            revert o0. induction o1. i. etransitivity.
            { eapply eq_expn_r. eapply add_build. }
            etransitivity.
            { eapply expn_union. }
            etransitivity.
            2: { eapply eq_mult_r. symmetry. eapply expn_build. }
            etransitivity.
            2: { symmetry. eapply mult_union. }
            etransitivity.
            { eapply Ord.eq_union.
              { reflexivity. }
              eapply expn_join.
            }
            etransitivity.
            { eapply Ord.union_assoc. }
            eapply Ord.eq_union.
            { etransitivity.
              { eapply Ord.union_comm. }
              { etransitivity.
                2: { symmetry. eapply mult_1_r. }
                { eapply Ord.union_max. eapply Ord.S_supremum. eapply expn_pos. }
              }
            }
            etransitivity.
            2: { symmetry. eapply mult_join. }
            eapply Ord.eq_join. i.
            etransitivity.
            { eapply expn_S. }
            etransitivity.
            2: { eapply mult_assoc. }
            eapply eq_mult_l.
            eapply H.
          Qed.
        End POSITIVE.

        Lemma lt_expn_r (TWO: Ord.lt (Ord.S Ord.O) base) o0 o1 (LT: Ord.lt o0 o1):
          Ord.lt (expn base o0) (expn base o1).
        Proof.
          assert (POS: Ord.lt Ord.O base).
          { eapply Ord.le_lt_lt; eauto. eapply Ord.S_le. }
          eapply (@Ord.lt_le_lt (expn base (Ord.S o0))).
          { eapply Ord.lt_eq_lt.
            { eapply expn_S. auto. }
            { eapply mult_lt_l; auto. eapply expn_pos. }
          }
          { eapply le_expn_r. eapply Ord.S_supremum. auto. }
        Qed.
      End BASE.

      Lemma expn_1_l o: Ord.eq (expn (Ord.S Ord.O) o) (Ord.S Ord.O).
      Proof.
        induction o. etransitivity.
        { eapply expn_build. }
        etransitivity.
        { eapply Ord.union_comm. }
        eapply Ord.union_max. eapply Ord.join_supremum.
        i. eapply Ord.eq_le_le.
        { eapply mult_1_r. }
        eapply H.
      Qed.

      Lemma le_expn_l o0 o1 o2 (LE: Ord.le o0 o1):
        Ord.le (expn o0 o2) (expn o1 o2).
      Proof.
        eapply Ord.orec_mon.
        { reflexivity. }
        { i. transitivity (mult o3 o1).
          { eapply le_mult_r. auto. }
          { eapply le_mult_l. auto. }
        }
      Qed.

      Lemma eq_expn_l o0 o1 o2 (EQ: Ord.eq o0 o1):
        Ord.eq (expn o0 o2) (expn o1 o2).
      Proof.
        split; eapply le_expn_l; apply EQ.
      Qed.

      Lemma expn_mult o0 (POS: Ord.lt Ord.O o0) o1 o2:
        Ord.eq (expn o0 (mult o1 o2)) (expn (expn o0 o1) o2).
      Proof.
        induction o2.
        etransitivity.
        { eapply eq_expn_r. eapply mult_build. }
        etransitivity.
        { eapply expn_join. auto. }
        etransitivity.
        2: { symmetry. eapply expn_build. }
        eapply Ord.eq_union.
        { reflexivity. }
        eapply Ord.eq_join. i.
        etransitivity.
        { eapply expn_add. auto. }
        eapply eq_mult_l. auto.
      Qed.
    End EXPN.

    Section PROPER.
      Global Program Instance add_eq_proper: Proper (Ord.eq ==> Ord.eq ==> Ord.eq) (add).
      Next Obligation.
        ii.
        etransitivity.
        - eapply eq_add_l; eauto.
        - eapply eq_add_r; eauto.
      Qed.

      Global Program Instance add_le_proper: Proper (Ord.le ==> Ord.le ==> Ord.le) (add).
      Next Obligation.
        ii.
        etransitivity.
        - eapply le_add_l; eauto.
        - eapply le_add_r; eauto.
      Qed.

      Global Program Instance mult_eq_proper: Proper (Ord.eq ==> Ord.eq ==> Ord.eq) (mult).
      Next Obligation.
        ii.
        etransitivity.
        - eapply eq_mult_l; eauto.
        - eapply eq_mult_r; eauto.
      Qed.

      Global Program Instance mult_le_proper: Proper (Ord.le ==> Ord.le ==> Ord.le) (mult).
      Next Obligation.
        ii.
        etransitivity.
        - eapply le_mult_l; eauto.
        - eapply le_mult_r; eauto.
      Qed.

      Global Program Instance expn_eq_proper: Proper (Ord.eq ==> Ord.eq ==> Ord.eq) (expn).
      Next Obligation.
        ii.
        etransitivity.
        - eapply eq_expn_l; eauto.
        - eapply eq_expn_r; eauto.
      Qed.

      Global Program Instance expn_le_proper: Proper (Ord.le ==> Ord.le ==> Ord.le) (expn).
      Next Obligation.
        ii.
        etransitivity.
        - eapply le_expn_l; eauto.
        - eapply le_expn_r; eauto.
      Qed.
    End PROPER.

    Section FROMNAT.
      Lemma le_from_nat n0 n1 (LE: Peano.le n0 n1):
        Ord.le n0 n1.
      Proof.
        induction LE.
        { reflexivity. }
        { etransitivity; eauto. ss. eapply Ord.S_le. }
      Qed.

      Lemma lt_from_nat n0 n1 (LT: Peano.lt n0 n1):
        Ord.lt n0 n1.
      Proof.
        eapply Ord.lt_le_lt.
        2: { eapply le_from_nat. eapply LT. }
        { ss. eapply Ord.S_lt. }
      Qed.

      Lemma add_from_nat n0 n1:
        Ord.eq (n0 + n1) (add (Ord.from_nat n0) (Ord.from_nat n1)).
      Proof.
        Local Transparent Ord.from_nat.
        induction n1; ss.
        { rewrite PeanoNat.Nat.add_0_r.
          symmetry. eapply add_O_r. }
        { rewrite PeanoNat.Nat.add_succ_r. ss.
          etransitivity.
          { eapply Ord.eq_S. eapply IHn1. }
          symmetry. eapply add_S.
        }
      Qed.

      Lemma mult_from_nat n0 n1:
        Ord.eq (Ord.from_nat (n0 * n1)) (mult (Ord.from_nat n0) (Ord.from_nat n1)).
      Proof.
        induction n1; ss.
        { rewrite PeanoNat.Nat.mul_0_r.
          symmetry. eapply mult_O_r. }
        { rewrite PeanoNat.Nat.mul_succ_r.
          etransitivity.
          { eapply add_from_nat. }
          etransitivity.
          { eapply eq_add_l. eapply IHn1. }
          symmetry. eapply mult_S.
        }
      Qed.

      Lemma expn_from_nat n0 (POS: 0 < n0) n1:
        Ord.eq (Ord.from_nat (Nat.pow n0 n1)) (expn (Ord.from_nat n0) (Ord.from_nat n1)).
      Proof.
        induction n1; ss.
        { symmetry. eapply expn_O. }
        { etransitivity.
          { rewrite PeanoNat.Nat.mul_comm. eapply mult_from_nat. }
          etransitivity.
          { eapply eq_mult_l. eapply IHn1. }
          symmetry. eapply expn_S.
          eapply (@lt_from_nat 0 n0). auto.
        }
      Qed.
    End FROMNAT.
  End ARITHMETIC.
End OrdArith.

Global Opaque OrdArith.add OrdArith.mult OrdArith.expn.

Infix "+" := OrdArith.add : ord_scope.
Infix "*" := OrdArith.mult : ord_scope.
Infix "^" := OrdArith.expn : ord_scope.


(* Exercise 20 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_020 :
  (exists x : D, P x /\ Q x)
->
  (exists x : D, P x) /\ (exists x : D, Q x).
Proof.
imp_i a1.
con_i.
exi_e (exists x:D, P x /\ Q x) a a2.
hyp a1.
exi_i a.
con_e1 (Q a).
hyp a2.
exi_e (exists x:D, P x /\ Q x) a a2.
hyp a1.
exi_i a.
con_e2 (P a).
hyp a2.
Qed.


Require Export FiniteTypes.
Require Import InfiniteTypes.
Require Import CSB.
Require Import DecidableDec.
Require Export Relation_Definitions.
Require Import Relation_Definitions_Implicit.
Require Import Description.
Require Import Proj1SigInjective.
Require Import DependentTypeChoice.

Set Asymmetric Patterns.

Inductive CountableT (X:Type) : Prop :=
  | intro_nat_injection: forall f:X->nat, injective f -> CountableT X.

Lemma CountableT_is_FiniteT_or_countably_infinite:
  forall X:Type, CountableT X ->
      {FiniteT X} + {exists f:X->nat, bijective f}.
Proof.
intros.
apply exclusive_dec.
red; intro.
destruct H0 as [? [f ?]].
contradiction nat_infinite.
apply bij_finite with _ f; trivial.
apply bijective_impl_invertible; trivial.

case (classic (FiniteT X)).
left; trivial.
right.
apply infinite_nat_inj in H0.
destruct H.
destruct H0 as [g].
apply CSB with f g; trivial.
Qed.

Lemma countable_nat_product: CountableT (nat*nat).
Proof.
pose (sum_1_to_n := fix sum_1_to_n n:nat := match n with
  | O => O
  | S m => (sum_1_to_n m) + n
end).
exists (fun p:nat*nat => let (m,n):=p in
  (sum_1_to_n (m+n)) + n).
assert (forall m n:nat, m<n ->
  sum_1_to_n m + m < sum_1_to_n n).
intros.
induction H.
simpl.
auto with arith.
apply lt_trans with (sum_1_to_n m0).
assumption.
simpl.
assert (0 < S m0); auto with arith.
assert (sum_1_to_n m0 + 0 < sum_1_to_n m0 + S m0); auto with arith.
assert (sum_1_to_n m0 + 0 = sum_1_to_n m0); auto with arith.
rewrite H2 in H1; assumption.

red; intros.
destruct x1 as [x1 y1].
destruct x2 as [x2 y2].
Require Import Compare_dec.
case (lt_eq_lt_dec (x1+y1) (x2+y2)); intro.
case s; intro.
assert (sum_1_to_n (x1+y1) + y1 < sum_1_to_n (x2+y2) + y2).
apply le_lt_trans with (sum_1_to_n (x1+y1) + (x1+y1)).
assert (sum_1_to_n (x1+y1) + (x1+y1) =
  (sum_1_to_n (x1+y1) + y1) + x1).
Require Import ArithRing.
ring.
auto with arith.
apply lt_le_trans with (sum_1_to_n (x2+y2)).
apply H; trivial.
auto with arith.
rewrite H0 in H1.
contradict H1.
auto with arith.

assert (y1=y2).
rewrite e in H0.
Require Import Arith.
apply plus_reg_l in H0.
assumption.
f_equal; trivial.
rewrite H1 in e.
rewrite plus_comm in e.
rewrite (plus_comm x2 y2) in e.
apply plus_reg_l in e.
assumption.

assert (sum_1_to_n (x2+y2) + y2 < sum_1_to_n (x1+y1) + y1).
apply le_lt_trans with (sum_1_to_n (x2+y2) + (x2+y2)).
auto with arith.
apply lt_le_trans with (sum_1_to_n (x1+y1)); auto with arith.
rewrite H0 in H1.
contradict H1.
auto with arith.
Qed.

Lemma countable_sum: forall X Y:Type,
  CountableT X -> CountableT Y -> CountableT (X+Y).
Proof.
intros.
destruct H as [f].
destruct H0 as [g].
destruct countable_nat_product as [h].
exists (fun s:X+Y => match s with
  | inl x => h (0, f x)
  | inr y => h (1, g y)
end).
red; intros s1 s2 ?.
destruct s1 as [x1|y1]; destruct s2 as [x2|y2];
  apply H1 in H2; try discriminate H2;
  intros; f_equal; (apply H || apply H0); injection H2; trivial.
Qed.

Lemma countable_product: forall X Y:Type,
  CountableT X -> CountableT Y -> CountableT (X*Y).
Proof.
intros.
destruct H as [f].
destruct H0 as [g].
pose (fg := fun (p:X*Y) => let (x,y):=p in (f x, g y)).
destruct countable_nat_product as [h].
exists (fun p:X*Y => h (fg p)).
red; intros.
apply H1 in H2.
destruct x1 as [x1 y1].
destruct x2 as [x2 y2].
unfold fg in H2.
injection H2; intros.
apply H0 in H3.
apply H in H4.
f_equal; trivial.
Qed.

Require Import FunctionalExtensionality.

Lemma countable_exp: forall X Y:Type,
  FiniteT X -> CountableT Y -> CountableT (X->Y).
Proof.
intros.
induction H.
exists (fun _ => 0).
red; intros.
extensionality f.
destruct f.

destruct (countable_product (T->Y) Y); trivial.

exists (fun (g:option T->Y) =>
  f (fun x:T => g (Some x), g None)).
red; intros g1 g2 ?.
apply H1 in H2.
extensionality o.
destruct o.
injection H2; intros.
pose proof (equal_f H4).
simpl in H5.
apply H5.
injection H2; trivial.

destruct H1.
destruct IHFiniteT.
exists (fun (h:Y0->Y) => f0 (fun x:X => h (f x))).
red; intros h1 h2 ?.
apply H3 in H4.
pose proof (equal_f H4).
simpl in H5.
extensionality y.
rewrite <- (H2 y).
apply H5.
Qed.

Definition Countable {X:Type} (S:Ensemble X) : Prop :=
  CountableT {x:X | In S x}.

Lemma inj_countable: forall {X Y:Type} (f:X->Y),
  CountableT Y -> injective f -> CountableT X.
Proof.
intros.
destruct H as [g].
exists (fun x:X => g (f x)).
red; intros; auto.
Qed.

Lemma surj_countable: forall {X Y:Type} (f:X->Y),
  CountableT X -> surjective f -> CountableT Y.
Proof.
intros.
Require Import ClassicalChoice.

pose proof (choice (fun (y:Y) (x:X) => f x = y)).
destruct H1 as [finv].
exact H0.

apply inj_countable with finv.
assumption.
red; intros.
congruence.
Qed.

Lemma countable_downward_closed: forall {X:Type} (S T:Ensemble X),
  Countable T -> Included S T -> Countable S.
Proof.
intros.
destruct H.
exists (fun x:{x:X | In S x} => match x with
  | exist x0 i => f (exist _ x0 (H0 _ i))
  end).
red; intros.
destruct x1 as [x1].
destruct x2 as [x2].
apply H in H1.
injection H1; intros.
destruct H2.
destruct (proof_irrelevance _ i i0).
trivial.
Qed.

Lemma countable_img: forall {X Y:Type} (f:X->Y) (S:Ensemble X),
  Countable S -> Countable (Im S f).
Proof.
intros.
assert (forall x:X, In S x -> In (Im S f) (f x)).
auto with sets.
pose (fS := fun x:{x:X | In S x} =>
  match x return {y:Y | In (Im S f) y} with
  | exist x0 i => exist _ (f x0) (H0 x0 i)
  end).
apply surj_countable with fS; trivial.
red; intros.
destruct y.
destruct i.
exists (exist _ x i).
simpl.
generalize (H0 x i); intro.
generalize (Im_intro X Y S f x i y e); intro.
destruct e.
destruct (proof_irrelevance _ i0 i1).
trivial.
Qed.

Lemma countable_type_ensemble: forall {X:Type} (S:Ensemble X),
  CountableT X -> Countable S.
Proof.
intros.
red.
apply inj_countable with (@proj1_sig _ (fun x:X => In S x)).
assumption.
red; intros.
apply proj1_sig_injective.
assumption.
Qed.

Lemma FiniteT_impl_CountableT: forall X:Type,
  FiniteT X -> CountableT X.
Proof.
intros.
induction H.
exists (False_rect nat).
red; intros.
destruct x1.
destruct IHFiniteT.
exists (fun x:option T => match x with
  | Some x0 => S (f x0)
  | None => 0
end).
red; intros.
destruct x1; destruct x2; try (injection H1 || discriminate H1); trivial.
intro.
apply H0 in H2.
destruct H2; trivial.

destruct IHFiniteT as [g].
destruct H0 as [finv].
exists (fun y:Y => g (finv y)).
red; intros y1 y2 ?.
apply H1 in H3.
congruence.
Qed.

Lemma Finite_impl_Countable: forall {X:Type} (S:Ensemble X),
  Finite _ S -> Countable S.
Proof.
intros.
apply FiniteT_impl_CountableT.
apply Finite_ens_type; trivial.
Qed.

Require Export ZArith.

Lemma positive_countable: CountableT positive.
Proof.
exists nat_of_P.
red; intros.
apply nat_of_P_inj; trivial.
Qed.

Lemma Z_countable: CountableT Z.
Proof.
destruct (countable_nat_product) as [f].
destruct positive_countable as [g].
exists (fun n:Z => match n with
  | Z0 => f (0, 0)
  | Zpos p => f (1, g p)
  | Zneg p => f (2, g p)
end).
red; intros n1 n2 ?.
destruct n1 as [|p1|p1]; destruct n2 as [|p2|p2]; apply H in H1;
  try discriminate H1.
trivial.
injection H1; intro; f_equal; auto.
injection H1; intro; f_equal; auto.
Qed.

Require Export QArith.

Lemma Q_countable: CountableT Q.
Proof.
destruct countable_nat_product as [f].
destruct positive_countable as [g].
destruct Z_countable as [h].
exists (fun q:Q => match q with
  n # d => f (h n, g d)
end).
red; intros q1 q2 ?.
destruct q1 as [n1 d1]; destruct q2 as [n2 d2].
apply H in H2.
injection H2; intros.
f_equal; auto.
Qed.

Require Export IndexedFamilies.

Lemma countable_union: forall {X A:Type}
  (F:IndexedFamily A X), CountableT A ->
    (forall a:A, Countable (F a)) ->
    Countable (IndexedUnion F).
Proof.
intros.
destruct (choice_on_dependent_type (fun (a:A)
                               (f:{x:X | In (F a) x} -> nat) =>
  injective f)) as [choice_fun_inj].
intro.
destruct (H0 a).
exists f; trivial.

destruct (choice (fun (x:{x:X | In (IndexedUnion F) x}) (a:A) =>
  In (F a) (proj1_sig x))) as [choice_fun_a].
destruct x as [x [a]].
exists a.
assumption.

destruct countable_nat_product as [g].
destruct H as [h].
exists (fun x:{x:X | In (IndexedUnion F) x} =>
  g (h (choice_fun_a x), choice_fun_inj (choice_fun_a x)
                                   (exist _ (proj1_sig x) (H2 x)))).
red; intros.
apply H3 in H4.
injection H4; intros.
apply H in H6.
revert H5.
generalize (H2 x1).
generalize (H2 x2).
rewrite H6.
intros.
apply H1 in H5.
injection H5.
apply proj1_sig_injective.
Qed.