Require Import Classical.
Require Import ZFnats.

(** Classical ordinals: hereditarily transitive well-founded sets *)
Definition isOrd x :=
  forall P : set -> Prop,
  (forall y,
   (forall a b, a ∈ b -> b ∈ y -> a ∈ y) ->
   (forall z, z ∈ y -> P z)-> P y) -> P x.

Lemma isOrd_intro x :
  (forall a b, a ∈ b -> b ∈ x -> a ∈ x) ->
  (forall y, y ∈ x -> isOrd y) ->
  isOrd x.
red; intros.
apply H1; trivial.
intros.
red in H0.
apply H0; trivial.
Qed.

Lemma isOrd_elim x :
  isOrd x ->
  (forall a b, a ∈ b -> b ∈ x -> a ∈ x) /\
  (forall y, y ∈ x -> isOrd y).
intro xo; apply xo; intros.
split; intros; eauto.
apply H0 in H1.
destruct H1.
apply isOrd_intro; intros; eauto.
Qed.

Lemma isOrd_inv x y :
  isOrd x -> lt y x -> isOrd y.
intros.
apply isOrd_elim in H; destruct H; eauto.
Qed.

Lemma isOrd_trans x y z :
  isOrd x -> lt z y -> lt y x -> lt z x.
intros xo.
unfold lt.
apply isOrd_elim in xo; destruct xo; eauto.
Qed.

Lemma isOrd_ext : forall x y, x == y -> isOrd x -> isOrd y.
intros.
apply isOrd_elim in H0; destruct H0.
apply isOrd_intro; intros.
 rewrite <- H in H3|-*; eauto.

 rewrite <- H in H2; auto.
Qed.

Instance isOrd_morph : Proper (eq_set ==> iff) isOrd.
apply morph_impl_iff1; auto with *.
exact isOrd_ext.
Qed.

Lemma isOrd_ind : forall x (P:set->Prop),
  (forall y, isOrd y -> y ⊆ x ->
   (forall z, lt z y -> P z) -> P y) ->
  isOrd x -> P x.
intros.
cut (isOrd x /\ (x ⊆ x -> P x)).
 destruct 1 as (_,?); auto with *.
pattern x at -3.
apply H0; intros.
assert (isOrd y).
 apply isOrd_intro; intros; eauto.
 apply H2; trivial.
split; intros; trivial.
apply H; intros; trivial.
destruct H2 with (1:=H5) as (_,?).
apply H6.
red; intros.
apply H4.
apply isOrd_trans with z; auto.
Qed.

Lemma isOrd_le : forall x y,
  isOrd x -> le y x -> isOrd y.
intros.
apply le_case in H0; destruct H0.
 rewrite H0; trivial.

 apply isOrd_inv with x; trivial.
Qed.

Lemma isOrd_zero : isOrd zero.
apply isOrd_intro; intros.
 elim empty_ax with b; trivial.
 elim empty_ax with y; trivial.
Qed.

Lemma isOrd_succ : forall n, isOrd n -> isOrd (succ n).
intros.
apply isOrd_intro; intros.
 apply succ_intro2.
 elim le_case with (1:=H1); clear H1; intros.
  rewrite <- H1; trivial.

  apply isOrd_trans with b; trivial.

 elim le_case with (1:=H0); clear H0; intros.
  apply isOrd_ext with n; trivial.
  symmetry; trivial.

  apply isOrd_inv with n; trivial.
Qed.

Lemma le_lt_trans : forall x y z, isOrd z -> le x y -> lt y z -> lt x z.
intros.
apply le_case in H0; destruct H0.
 rewrite H0; trivial.
 apply isOrd_trans with y; trivial.
Qed.

Lemma lt_le_trans : forall x y z, isOrd z -> lt x y -> le y z -> lt x z.
intros.
apply le_case in H1; destruct H1.
 rewrite <- H1; trivial.
 apply isOrd_trans with y; trivial.
Qed.

Lemma lt_antirefl : forall x, isOrd x -> ~ lt x x.
induction 1 using isOrd_ind; intros.
red; intros; apply H1 with y; trivial.
Qed.

Lemma isOrd_eq : forall o, isOrd o -> o == sup o succ.
intros.
apply eq_intro; intros.
 rewrite sup_ax.
 2:do 2 red; intros; apply succ_morph; trivial.
 exists z; trivial.
 apply le_refl.

 rewrite sup_ax in H0.
 2:do 2 red; intros; apply succ_morph; trivial.
 destruct H0.
 apply le_lt_trans with x; trivial.
Qed.

Lemma ord_le_incl : forall x y, isOrd x -> isOrd y -> le x y -> x ⊆ y.
red; intros.
apply lt_le_trans with x; auto.
Qed.

Module ClassicOrdinal.

Axiom EM : forall A, A \/ ~A.

Lemma ord_tricho : forall x y,
  isOrd x -> isOrd y -> lt x y \/ x == y \/ lt y x.
intros x y xord; revert y.
apply isOrd_ind with (2:=xord).
clear xord; intros x0 xord _ Hrec y yord; clear x; rename x0 into x.
apply isOrd_ind with (2:=yord).
clear yord; intros y0 yord _ Hrecy; clear y; rename y0 into y.
destruct (EM (exists2 x1, lt x1 x & forall y1, lt y1 y -> lt y1 x1)).
 right; right.
 destruct H.
 destruct (Hrec x0 H y yord).
  elim (@lt_antirefl x0); auto.
  apply isOrd_inv with y; trivial.
 destruct H1.
  rewrite <- H1; trivial.

  apply isOrd_trans with x0; trivial.

destruct (EM (exists2 y1, lt y1 y & forall x1, lt x1 x -> lt x1 y1)).
 left.
 destruct H0.
 destruct (Hrecy x0 H0).
  apply isOrd_trans with x0; trivial.
 destruct H2.
  rewrite H2; trivial.

  elim (@lt_antirefl x0); auto.
  apply isOrd_inv with x; trivial.

 assert (forall x1, lt x1 x -> exists2 y1, lt y1 y & le x1 y1).
  intros.
  destruct (EM (exists2 y1, lt y1 y & le x1 y1)); trivial.
  elim H.
  exists x1; trivial.
  intros.
  destruct (Hrec _ H1 y1).
   apply isOrd_inv with y; trivial.

   elim H2.
   exists y1; trivial.
   apply lt_is_le; trivial.

   destruct H4; trivial.
   elim H2.
   exists y1; trivial.
   rewrite <- H4; apply le_refl.
 assert (forall y1, lt y1 y -> exists2 x1, lt x1 x &  le y1 x1).
  intros.
  destruct (EM (exists2 x1, lt x1 x & le y1 x1)); trivial.
  elim H0.
  exists y1; trivial.
  intros.
  destruct (Hrec _ H4 y1); trivial.
   apply isOrd_inv with y; trivial.

   elim H3.
   exists x1; trivial.
   destruct H5; auto with *.
   rewrite <- H5; apply le_refl.
 right; left.
 apply eq_intro; intros.
  destruct H1 with (1:=H3).
  apply le_lt_trans with x0; trivial.

  destruct H2 with (1:=H3).
  apply le_lt_trans with x0; trivial.
Qed.

Lemma ord_total : forall x y,
  isOrd x -> isOrd y -> le x y \/ lt y x.
intros.
destruct (ord_tricho _ _ H H0); auto.
destruct H1; auto.
left; rewrite H1.
apply le_refl.
Qed.

Lemma ord_incl_le : forall x y, isOrd x -> isOrd y -> x ⊆ y -> le x y.
intros.
destruct (ord_total x y); trivial.
apply H1 in H2.
apply lt_antirefl in H2; trivial.
contradiction.
Qed.

End ClassicOrdinal.

Definition increasing F :=
  forall x y, isOrd x -> isOrd y -> y ⊆ x -> F y ⊆ F x.

Lemma increasing_le : forall F x y,
  increasing F -> isOrd x -> le y x -> F y ⊆ F x.
unfold increasing; intros.
assert (isOrd y).
 apply isOrd_inv with (succ x); trivial.
 apply isOrd_succ; trivial.
apply H; trivial.
apply ord_le_incl; trivial.
Qed.

Lemma isOrd_N : isOrd N.
apply isOrd_intro; intros.
 generalize a H; clear a H.
 elim H0 using N_ind; intros.
  rewrite <- H1 in H3; auto.

  elim empty_ax with a; trivial.
  elim le_case with (1:=H2); clear H2; intros; auto.
  rewrite H2; trivial.

 elim H using N_ind; intros.
  apply isOrd_ext with n; trivial.
  apply isOrd_zero.
  apply isOrd_succ; trivial.
Qed.

Lemma natOrd : forall n, n ∈ N -> isOrd n.
intros.
apply isOrd_inv with N; trivial.
apply isOrd_N.
Qed.

Hint Resolve natOrd isOrd_N.

Definition succOrd o := exists2 o', isOrd o' & o == succ o'.

(* Limit ordinals *)

Definition limitOrd o := isOrd o /\ union o == o.
Definition limitOrd' o := isOrd o /\ (forall x, lt x o -> lt (succ x) o).

Lemma limit_equiv : forall o, limitOrd' o -> limitOrd o.
destruct 1; split; trivial.
apply eq_intro; intros.
 apply union_elim in H1; destruct H1.
 apply isOrd_trans with x; trivial.

 apply union_intro with (succ z).
  apply le_refl.
  apply H0; trivial.
Qed.

Lemma N_limit_ord : limitOrd' N.
split; intros.
 apply isOrd_N.
 apply succ_typ; trivial.
Qed.

Lemma limit_is_ord : forall o, limitOrd o -> isOrd o.
destruct 1; trivial.
Qed.
Hint Resolve limit_is_ord.
Lemma limit'_is_ord : forall o, limitOrd' o -> isOrd o.
destruct 1; trivial.
Qed.
Hint Resolve limit'_is_ord.

Lemma discr_lim_succ : forall o, limitOrd o -> succOrd o -> False.
destruct 1; destruct 1.
assert (x == o).
 rewrite <- H0; rewrite H2.
 apply eq_intro; intros.
  apply union_intro with x; trivial.
  apply succ_intro1; reflexivity.

  rewrite union_ax in H3; destruct H3.
  apply le_case in H4; destruct H4.
   rewrite <- H4; trivial.
   apply isOrd_trans with x0; trivial.
elim lt_antirefl with x; trivial.
generalize (succ_intro1 x x); intros.
rewrite <- H2 in H4; rewrite <- H3 in H4.
apply H4; reflexivity.
Qed.

(*****************************************************************************)

Lemma isOrd_union2 : forall x y,
  isOrd x ->
  isOrd y ->
  isOrd (x ∪ y).
intros.
apply isOrd_intro; intros.
 apply union2_elim in H2; destruct H2.
  apply union2_intro1.
  apply isOrd_trans with b; trivial.

  apply union2_intro2.
  apply isOrd_trans with b; trivial.

 apply union2_elim in H1; destruct H1.
  apply isOrd_inv with x; trivial.
  apply isOrd_inv with y; trivial.
Qed.

Lemma ord1_union : forall a P Q,
  subset a P ∪ subset a Q ==
  subset a (fun x => P x\/Q x).
intros.
apply eq_intro; intros.
 apply union2_elim in H; destruct H.
  rewrite subset_ax in H; destruct H.
  destruct H0.
  rewrite H0 in H|-*.
  apply subset_intro; auto.

  rewrite subset_ax in H; destruct H.
  destruct H0.
  rewrite H0 in H|-*.
  apply subset_intro; auto.

 rewrite subset_ax in H; destruct H.
 destruct H0.
 rewrite H0 in H|-*; clear H0 z.
 destruct H1.
  apply union2_intro1.
  apply subset_intro; trivial.

  apply union2_intro2.
  apply subset_intro; trivial.
Qed.

Lemma isOrd_union2_lub : forall o x y,
  isOrd o ->
  lt x o ->
  lt y o ->
  lt (x ∪ y) o.
intros.
assert (uord : isOrd (x ∪ y)).
 apply isOrd_union2.
  apply isOrd_inv with o; trivial.
  apply isOrd_inv with o; trivial.
destruct (ClassicOrdinal.ord_total o (x ∪ y)); trivial.
assert (o ⊆ x ∪ y).
 apply ord_le_incl; trivial.
assert (isOrd x).
 apply isOrd_inv with o; trivial.
assert (isOrd y).
 apply isOrd_inv with o; trivial.
apply H3 in H0.
apply H3 in H1.
apply union2_elim in H0.
apply union2_elim in H1.
destruct H0.
 elim (lt_antirefl x); trivial.
destruct H1.
 elim (lt_antirefl x); trivial.
 apply isOrd_trans with y; trivial.
elim (lt_antirefl y); trivial.
Qed.

(* least ordinal... *)

Definition least_ord o (P:set->Prop) :=
  union (subset o (fun y => P y /\ forall x, isOrd x -> P x -> le y x)).

Lemma least_ord_morph : forall o o' (P P':set->Prop),
  isOrd o -> o == o' ->
  (forall x x', isOrd x -> x == x' -> (P x <-> P' x')) ->
  least_ord o P == least_ord o' P'.
unfold least_ord; intros.
apply union_morph.
apply subset_morph; auto.
red; intros.
split; destruct 1; split; intros.
 rewrite <- (H1 x x); trivial; try reflexivity.
 apply isOrd_inv with o; trivial.

 rewrite <- (H1 x0 x0) in H6; auto; try reflexivity.

 rewrite (H1 x x); trivial; try reflexivity.
 apply isOrd_inv with o; trivial.

 rewrite (H1 x0 x0) in H6; auto; try reflexivity.
Qed.

Lemma least_ord1 : forall o (P:set->Prop),
  (forall x x', isOrd x -> x == x' -> P x -> P x') ->
  isOrd o ->
  forall x,
  lt x o ->
  P x ->
  P (least_ord o P) /\ isOrd (least_ord o P) /\ le (least_ord o P) x /\
  forall y, lt y (least_ord o P) -> ~ P y.
induction 2 using isOrd_ind; intros.
Import ClassicOrdinal.
elim (EM (exists2 z, lt z x & P z)); intro.
 destruct H5.
 assert (least_ord y P == least_ord x P).
  apply eq_intro; intros.
   apply union_elim in H7; destruct H7.
   rewrite subset_ax in H8; destruct H8.
   destruct H9.
   destruct H10.
   rewrite H9 in H7,H8|-;clear H9 x1.
   apply union_intro with x2; auto.
   apply subset_intro; auto.
   apply H11 in H6.
   2:apply isOrd_inv with x; trivial; apply isOrd_inv with y; trivial.
   apply le_lt_trans with x0; trivial.
   apply isOrd_inv with y; trivial.

   apply union_elim in H7; destruct H7.
   specialize subset_elim2 with (1:=H8); intro.
   apply subset_elim1 in H8.
   destruct H9.
   rewrite H9 in H7,H8|-; clear H9 x1.
   destruct H10.
   assert (isOrd x2).
    apply isOrd_inv with x; trivial.
    apply isOrd_inv with y; trivial.
   apply union_intro with x2; trivial.
   apply subset_intro; auto.
   apply isOrd_trans with x; trivial.
 destruct H2 with x x0; auto.
 destruct H9.
 destruct H10.
 split.
  apply H with (least_ord x P); trivial.
  symmetry; trivial.

  rewrite H7; split; trivial.
  split; intros.
   apply lt_is_le; apply le_lt_trans with x0; trivial.
   apply isOrd_inv with y; trivial.

   rewrite H7 in H12; auto.

 assert (least_ord y P == x).
  apply eq_intro; intros.
   apply union_elim in H6; destruct H6.
   apply subset_elim2 in H7.
   destruct H7.
   destruct H8.
   rewrite H7 in H6; clear H7 x0.
   assert (le x1 x).
    apply H9; trivial.
    apply isOrd_inv with y; trivial.
   apply le_case in H7; destruct H7.
    rewrite <- H7; trivial.
    elim H5; exists x1; trivial.

   unfold least_ord.
   apply union_intro with x; trivial.
   apply subset_intro; trivial.
   split; trivial; intros.
   elim (ord_total x x0); intros; trivial.
    elim H5.
    exists x0; trivial.

    apply isOrd_inv with y; auto.
 split.
  symmetry in H6.
  apply H with x; auto.
  apply isOrd_inv with y; auto.

  rewrite H6; split; auto.
   apply isOrd_inv with y; auto.

   split; auto.
   red; intros; apply H5.
   exists y0; trivial.
   rewrite H6 in H7; trivial.
Qed.

(********************************************************************)

Require Import ZFrepl.

Section LimOrd.

  Variable f : nat -> set.
  Variable ford : forall n, isOrd (f n).

  Definition ord_sup :=
    union (repl N (fun x y => exists2 n, x == nat2set n & f n == y)).

  Lemma repl_sup :
    repl_rel N (fun x y => exists2 n, x == nat2set n & f n == y).
split; intros.
 destruct H2.
 exists x0.
  rewrite <- H0; trivial.
  rewrite <- H1; trivial.

 destruct H0.
 destruct H1.
 rewrite <- H2; rewrite <- H3.
 replace x1 with x0; try reflexivity.
 apply nat2set_inj.
 rewrite <- H0; trivial.
Qed.

  Lemma isOrd_sup_intro : forall n, f n ⊆ ord_sup.
unfold ord_sup.
red; intros.
apply union_intro with (f n); trivial.
apply repl_intro with (nat2set n).
 exact repl_sup.

 apply nat2set_typ.

 exists n; reflexivity.
Qed.

  Lemma isOrd_sup_elim : forall x, lt x ord_sup -> exists n, lt x (f n).
unfold ord_sup; intros.
elim union_elim with (1:=H); clear H; intros.
elim repl_elim with (1:=repl_sup) (2:=H0); intros.
destruct H2.
exists x2.
rewrite H3; trivial.
Qed.

  Lemma isOrd_sup : isOrd ord_sup.
apply isOrd_intro; intros.
 elim isOrd_sup_elim with (1:=H0); intros.
 apply isOrd_sup_intro with x.
 apply isOrd_trans with b; trivial.

 elim isOrd_sup_elim with (1:=H); intros.
 apply isOrd_inv with (f x); trivial.
Qed.

End LimOrd.

Section LimOrdRel.

  Variable R : nat -> set -> Prop.
  Variable Rmorph : forall n x x', isOrd x -> x == x' -> R n x -> R n x'.
  Variable Rtot : forall n, exists x, R n x.
  Variable Rfun : forall n x x',
    isOrd x -> isOrd x' -> R n x -> R n x' -> x == x'.
  Variable Rord : forall n x, R n x -> isOrd x.

  Definition sup_rel :=
    union (repl N (fun x y => exists2 n, x == nat2set n & R n y)).

  Lemma repl_sup_rel :
    repl_rel N (fun x y => exists2 n, x == nat2set n & R n y).
split; intros.
 destruct H2.
 exists x0.
  rewrite <- H0; trivial.
  apply Rmorph with y; eauto.

 destruct H0.
 destruct H1.
 apply Rfun with x0; trivial; eauto.
 replace x0 with x1; trivial.
 apply nat2set_inj.
 rewrite <- H1; trivial.
Qed.

  Lemma isOrd_sup_rel_intro2 : forall n y, R n y -> y ⊆ sup_rel.
unfold sup_rel.
red; intros.
apply union_intro with y; trivial.
apply repl_intro with (nat2set n).
 exact repl_sup_rel.

 apply nat2set_typ.

 exists n; trivial; reflexivity.
Qed.

  Lemma isOrd_sup_rel_intro : forall n,
    exists2 y, R n y & y ⊆ sup_rel.
intros.
elim (Rtot n); intros.
exists x; trivial.
apply isOrd_sup_rel_intro2 with n; trivial.
Qed.

  Lemma isOrd_sup_rel_elim :
    forall x, lt x sup_rel -> exists n, exists2 y, R n y & lt x y.
unfold sup_rel; intros.
elim union_elim with (1:=H); clear H; intros.
elim repl_elim with (1:=repl_sup_rel) (2:=H0); intros.
destruct H2.
exists x2.
exists x0; trivial.
Qed.

  Lemma isOrd_sup_rel : isOrd sup_rel.
apply isOrd_intro; intros.
 elim isOrd_sup_rel_elim with (1:=H0); intros.
 destruct H1.
 apply (isOrd_sup_rel_intro2 x x0); trivial.
 apply isOrd_trans with b; eauto.

 elim isOrd_sup_rel_elim with (1:=H); intros.
 destruct H0.
 apply isOrd_inv with x0; eauto.
Qed.

End LimOrdRel.

Section TransfiniteRecursion.

  Variable F : (set -> set) -> set -> set.
  Hypothesis Fmorph : forall o o' f f',
    o == o' -> eq_fun o f f' -> F f o == F f' o'.

  Definition TR_rel o y :=
    forall P,
    Proper (eq_set ==> eq_set ==> iff) P ->
    (forall o' f, ext_fun o' f ->
     (forall n, lt n o' -> P n (f n)) ->
     P o' (F f o')) ->
    P o y.

  Instance TR_rel_morph : Proper (eq_set ==> eq_set ==> iff) TR_rel.
do 3 red; unfold TR_rel; split; intros.
 rewrite <- H; rewrite <- H0; apply H1; auto.

 rewrite H; rewrite H0; apply H1; auto.
Qed.

  Lemma TR_rel_intro : forall x f,
    ext_fun x f ->
    (forall y, y ∈ x -> TR_rel y (f y)) ->
    TR_rel x (F f x).
red; intros.
apply H2; trivial; intros.
apply H0; trivial.
Qed.

  Lemma TR_rel_inv : forall x y,
    TR_rel x y ->
    exists2 f,
      ext_fun x f /\ (forall y, y ∈ x -> TR_rel y (f y)) &
      y == F f x.
intros.
apply (@proj2 (TR_rel x y)).
apply H; intros.
 do 3 red; intros.
 rewrite <- H0; rewrite <- H1.
 split; destruct 1 as (Htr,(f,(fm,eqf),eqF)); split; trivial; exists f; trivial.
  split; intros.
   do 2 red; intros.
   rewrite <- H0 in H2; auto.
   rewrite <- H0 in H2; auto.
  rewrite <- H1; rewrite eqF; apply Fmorph; intros; auto.
  split; intros.
   do 2 red; intros.
   rewrite H0 in H2; auto.
   rewrite H0 in H2; auto.
  symmetry in H0; rewrite H1; rewrite eqF; apply Fmorph; intros; auto.
assert (TR_relsub := fun n h => proj1 (H1 n h)); clear H1.
split.
 apply TR_rel_intro; trivial.

 exists f; auto with *.
Qed.

  Lemma TR_rel_fun :
    forall x y, TR_rel x y -> forall y', TR_rel x y' -> y == y'.
intros x y H.
apply H; intros.
 do 3 red; intros.
 split; intros.
  rewrite <- H1; rewrite <- H0 in H3; auto.
  rewrite H1; rewrite H0 in H3; auto.
apply TR_rel_inv in H2; destruct H2.
destruct H2.
rewrite H3; clear y' H3.
apply Fmorph; intros.
 reflexivity.
red; intros.
apply H1; trivial.
rewrite H5 in H3|-*; auto.
Qed.

  Lemma TR_rel_repl_rel :
    forall x, repl_rel x TR_rel.
split; intros.
 rewrite <- H0; rewrite <- H1; trivial.

 apply TR_rel_fun with x0; trivial.
Qed.

  Lemma TR_rel_def : forall o, isOrd o -> exists y, TR_rel o y.
induction 1 using isOrd_ind; intros.
assert (forall z, lt z y -> uchoice_pred (fun y => TR_rel z y)).
 intros.
 specialize H1 with (1:=H2).
 destruct H1.
 split; intros.
  rewrite <- H3; trivial.
 split; intros.
  exists x; trivial.
 apply TR_rel_fun with z; trivial.
exists (F (fun z => uchoice (fun y => TR_rel z y)) y).
apply TR_rel_intro; intros.
 do 2 red; intros.
 apply uchoice_morph; intros; auto.
 rewrite H4; reflexivity.
apply uchoice_def; auto.
Qed.

  Lemma TR_rel_choice_pred : forall o, isOrd o ->
    uchoice_pred (fun y => TR_rel o y).
split; intros.
 rewrite <- H0; trivial.
split; intros.
 apply TR_rel_def; trivial.
apply TR_rel_fun with o; trivial.
Qed.

  Definition TR o := uchoice (fun y => TR_rel o y).

  Lemma TR_morph : forall x x', isOrd x -> x == x' -> TR x == TR x'.
intros.
unfold TR.
apply uchoice_morph.
 apply TR_rel_choice_pred; trivial.

 intros.
 apply TR_rel_morph; auto with *.
Qed.

  Lemma TR_eqn : forall o, isOrd o -> TR o == F TR o.
unfold TR; intros.
specialize TR_rel_choice_pred with (1:=H); intro.
apply uchoice_def in H0.
apply TR_rel_inv in H0.
destruct H0.
destruct H0.
rewrite H1.
apply Fmorph; intros; auto with *.
red; intros.
apply TR_rel_fun with x'.
 rewrite <- H4; auto.

 apply uchoice_def.
 apply TR_rel_choice_pred.
 rewrite <- H4; apply isOrd_inv with o; trivial.
Qed.

  Lemma TR_ind : forall o (P:set->set->Prop),
    (forall x x', isOrd x -> x ⊆ o -> x == x' ->
     forall y y', y == y' -> P x y -> P x' y') ->
    isOrd o ->
    (forall y, isOrd y -> y ⊆ o ->
     (forall x, lt x y -> P x (TR x)) ->
     P y (F TR y)) ->
    P o (TR o).
induction 2 using isOrd_ind; intros.
apply H with y (F TR y); auto with *.
 symmetry; apply TR_eqn; trivial.
apply H3; trivial; intros.
 reflexivity.
apply H2; trivial; intros.
apply H3; trivial.
red; intros.
apply H6 in H8.
apply isOrd_trans with x; trivial.
Qed.

  Lemma TR_typ : forall n X,
    morph1 X ->
    isOrd n ->
    (forall y f, isOrd y -> y ⊆ n ->
     (forall z, lt z y -> f z ∈ X z) -> F f y ∈ X y) ->
    TR n ∈ X n.
intros n X Xm is_ord.
apply TR_ind with (o:=n); intros; trivial.
 rewrite <- H2; rewrite <- H1; apply H3; intros.
 rewrite H1 in H6; auto.
apply H2; intros; auto with *.
apply H1; trivial; intros.
apply H2; auto.
red; intros.
apply H5 in H7.
apply isOrd_trans with z; trivial.
Qed.

End TransfiniteRecursion.

(* Specialized version where the case of limit ordinals is union *)
Section TransfiniteIteration.

  Variable F : set -> set.
  Hypothesis Fmorph : Proper (eq_set ==> eq_set) F.

Let G f o := sup o (fun o' => F (f o')).

Lemma Gmorph : forall o o' f f',
    o == o' -> eq_fun o f f' -> G f o == G f' o'.
unfold G; intros.
apply sup_morph; trivial.
red; auto.
Qed.
Hint Resolve Gmorph.

  Definition TI := TR G.

  Lemma TI_morph : forall x x', isOrd x -> x == x' -> TI x == TI x'.
unfold TI; intros.
apply TR_morph; auto with *.
Qed.

  Lemma TI_fun_ext : forall x, isOrd x -> ext_fun x (fun y => F (TI y)).
do 2 red; intros.
apply Fmorph.
apply TI_morph; trivial.
apply isOrd_inv with x; trivial.
Qed.
Hint Resolve TI_fun_ext.

  Lemma TI_eq : forall o,
    isOrd o ->
    TI o == sup o (fun o' => F (TI o')).
intros.
unfold TI.
apply TR_eqn; auto.
Qed.

  Lemma TI_intro : forall o o' x,
    isOrd o ->
    lt o' o ->
    x ∈ F (TI o') ->
    x ∈ TI o.
intros.
rewrite TI_eq; trivial.
rewrite sup_ax; auto.
exists o'; trivial.
Qed.

  Lemma TI_elim : forall o x,
    isOrd o ->
    x ∈ TI o ->
    exists2 o', lt o' o & x ∈ F (TI o').
intros.
rewrite TI_eq in H0; trivial.
rewrite sup_ax in H0; auto.
Qed.

  Lemma TI_initial : TI zero == empty.
apply empty_ext; red; intros.
apply TI_elim in H.
 destruct H.
 elim empty_ax with (1:=H).

 apply isOrd_zero.
Qed.

  Lemma TI_typ : forall n X,
    (forall a, a ∈ X -> F a ∈ X) ->
    isOrd n ->
    (forall m G, le m n ->
     ext_fun m G ->
     (forall x, lt x m -> G x ∈ X) -> sup m G ∈ X) ->
    TI n ∈ X.
induction 2 using isOrd_ind; intros.
rewrite TI_eq; trivial.
apply H3 with (G:=fun o => F (TI o)); intros; auto.
apply H.
apply H2; trivial; intros.
apply H3; auto.
apply lt_is_le.
apply le_lt_trans with x; trivial.
Qed.

End TransfiniteIteration.
Hint Resolve TI_fun_ext.


(*! This file is part of the raft implementation with velisarios. !*)

(*! Context definitions !*)
(** This file defines the context, which means the abstract definitions replaced
 ** by the realization of some program. Also, the definition of a node and the
 ** realization of a quorum. **)
Require Export Velisarios.Quorum.
(* the process module provides the abstraction which is implemented by the protocols *)
Require Export Velisarios.Process.
Require Export String.

Section RaftContext.

  (* needed? *)
  Local Open Scope eo.
  Local Open Scope proc.

  (*! Context !*)
  (** The context provides abstract definitions which are replaced by real ones
   ** within the simulation. **)
  Class RaftContext :=
    MkRaftContext
      {
        (* number of possible faults *)
        F : nat;
        (* number of replicas needed *)
        num_replicas := (3 * F) + 1;

        (* the replicas are only some type *)
        Rep : Set;
        (* replicas have decidable equality *)
        rep_deq : Deq Rep;
        (* replicas can be associated with some natural number *)
        reps2nat : Rep -> nat_n num_replicas;
        (* the projection is bijective; bijective is defined in Quorum *)
        reps_bij : bijective reps2nat;

        (* the number of clients allowed *)
        num_clients : nat;
        (* clients are just some ordenary type *)
        Client : Set;
        (* clients have decidable equality *)
        client_deq : Deq Client;
        (* clients can be associated with some number *)
        clients2nat : Client -> nat_n num_clients;
        (* the projections ist bijective *)
        clients_bij : bijective clients2nat;

        (* the content type for the log *)
        Content : Set;
        (* get a textual representation from the content *)
        content2string : Content -> string;
        (* This is the state of the program to distribute. *)
        RaftSM : Set;
        (* the result type which gets issued by the state update function *)
        RaftSM_result : Set;
        (* the initial state of the state machine *)
        RaftSM_initial_state : RaftSM;
        (* the update function which produces a new state and a result. *)
        RaftSM_update_state : RaftSM -> Content -> RaftSM * RaftSM_result
      }.
  (** To get this construct clear: The proposed functions and types are used by the protocol
   ** but get instantiated in the RaftSim.v file or some other file which uses the raft protocol. **)

  (** Declares the context type class as new variable with implicit
   ** generalization of free terms. Since everything is typed no free terms are gneralized? **)
  Context { raft_context : RaftContext }.

  (*! Nodes !*)
  (** Nodes are used to distinguish between server and clients.
   ** The parameters are defined in the RaftContext, the real implementation is provided by the simulation. **)
  Inductive RaftNode :=
  (* The normal server is a replica which is denoted by the nat/name Rep provided as context information. *)
  | replica (n : Rep)
  (* The other node is the client which is in fact not modeled within COQ.
   * It is modeled in ocaml outside the protocol and only feeds the input. *)
  | client (n : Client).

  (** Get the replica name/nat of some node. **)
  Definition replica2rep (n : RaftNode) : option Rep :=
    match n with
    | replica n => Some n
    | _ => None
    end.

  (** Get the client name/nat of some node. **)
  Definition client2rep (n : RaftNode) : option Client :=
    match n with
    | client n => Some n
    | _ => None
    end.

  (** Prove that raft nodes have decidable equality like the one from Leibnitz. **)
  Lemma RaftnodeDeq : Deq RaftNode.
  Proof.
    introv.
    destruct x as [r1|c1], y as [r2|c2].
    + destruct (rep_deq r1 r2); [left|right]; subst; auto.
      intro xx. inversion xx. subst. tcsp.
    + right; intro xx. inversion xx; subst.
    + right; intro xx. inversion xx; subst.
    + destruct (client_deq c1 c2); [left|right]; subst; auto.
      intro xx. inversion xx. subst. tcsp.
  Defined.

  (** Bind the real node definition as instance to the abstract definition from velisarios. **)
  Global Instance Raft_I_Node : Node := MkNode RaftNode RaftnodeDeq.

  (*! Quorum instance !*)
  (** Replicas are an injective image between names/nats and real implementations **)
  Lemma replica_inj : injective replica.
  Proof.
    introv h. ginv. auto.
  Qed.

  (** Define a quorum as a set of node names with the property of being
   ** depictable into the set of natural numbers. **)
  Global Instance Raft_I_Quorum : Quorum_context :=
    MkQuorumContext
      Rep (* the node type *)
      num_replicas (* size of the set *)
      rep_deq (* the nodes have to be decidable equality *)
      reps2nat (* fn which translates nodes to nats *)
      reps_bij (* node translation is bijective *)
      replica (* the inductive arm indicates the nodes name *)
      replica_inj. (* prove that the function is injective *)

  (* can we have something like this?
   * Since Rep is the node type it would be Rep->Rep *)
  Definition rep2node := Rep -> node_type.

  (*! More about nodes !*)
  (* 0 is less than 2*F+1 *)
  Definition nat_n_2Fp1_0 : nat_n num_replicas.
  Proof.
    exists 0.
    apply leb_correct.
    unfold num_replicas.
    omega.
  Defined.

  Definition replica0 : Rep := bij_inv reps_bij nat_n_2Fp1_0.

  Eval simpl in (name_dec (replica replica0) (replica replica0)).

  (* We'll return the node as given by our bijection if n < num_nodes,
     otherwise we return a default value (replica0) *)
  Definition nat2rep (n : nat) : Rep.
  Proof.
    destruct reps_bij as [f a b].
    destruct (lt_dec n num_replicas) as [d|d].
    - exact (f (mk_nat_n d)). (* here we now that n < num_replicas so we can use our bijection *)
    - exact replica0. (* here num_replicas <= n, so we return a default value: replica0 *)
  Defined.

  Definition reps : list Rep := (* list all nodes *)
   mapin
      (seq 0 num_replicas)
      (fun n i => bij_inv reps_bij (mk_nat_n (seq_0_lt i))).

  (* Convert node list to name list *)
  Definition nreps : list name := map replica reps.

  Lemma reps_prop : forall (x : Rep), In x reps.
  Proof.
    exact nodes_prop.
  Qed.

  Definition clients : list Client := (* list all clients *)
    mapin
      (seq 0 num_clients)
      (fun n i => bij_inv clients_bij (mk_nat_n (seq_0_lt i))).

  (* Convert client list to client name list *)
  Definition nclients : list name := map client clients.

  Lemma clients_prop : forall (x : Client), In x clients.
  Proof.
    introv.
    unfold clients.
    apply in_mapin.

    remember (clients2nat x) as nx.
    destruct nx as [nx condnx].

    pose proof (leb_complete _ _ condnx) as c.

    assert (In nx (seq O num_clients)) as i.
    { apply in_seq; omega. }

    exists nx i; simpl.

    unfold mk_nat_n.
    unfold bij_inv.
    destruct clients_bij.
    pose proof (bij_id1 x) as h.
    rewrite <- Heqnx in h; subst; simpl.

    f_equal; f_equal.
    apply UIP_dec; apply bool_dec.
  Qed.

  (*! Utilities !*)
  (** From the definition that lists all created replicas. **)
  Definition other_replicas (r : Rep) : list Rep := remove_elt rep_deq r reps.
  Definition other_names (r : Rep) : list name := map replica (other_replicas r).

End RaftContext.


Require Import rt.util.all.
Require Import rt.model.time rt.model.arrival.basic.job rt.model.arrival.basic.task rt.model.arrival.basic.arrival_sequence rt.model.priority.
Require Import rt.model.schedule.uni.schedule rt.model.schedule.uni.schedulability rt.model.schedule.uni.basic.platform.
Require Import rt.edf.total_service rt.edf.demand.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module EDFDemandAnalysis.

  Import UniprocessorSchedule Schedulability Priority Platform Job Demand.

  (* In this section, we prove some useful lemmas about demand and
     schedules which respect EDF. *)

  Section Lemmas.

    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any job arrival sequence with no duplicate jobs... *)
    Context {arr_seq: arrival_sequence Job}.
    Hypothesis H_arrival_sequence_is_a_set:
      arrival_sequence_is_a_set arr_seq.

    (* ... and any schedule of this arrival sequence. *)
    Variable sched: schedule Job.

    (* Assume that all jobs have valid job parameter and... *)
    Hypothesis H_valid_job_parameters:
      forall (j: Job),
        valid_realtime_job job_cost job_deadline j.
    (* ...and that jobs only execute after they arrived ... *)
    Hypothesis H_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute job_arrival sched.
    (* ...and don't execute after they completed. *)
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* For simplicity, let's define a function to check whether all
       deadlines have been met in a given schedule. *)
    Let no_deadline_miss_in (sched: schedule Job) :=
      forall j, job_misses_no_deadline job_arrival job_cost job_deadline sched j.

    (* For simplicity, let us define some local names about demand. *)
    Let absolute_deadline (j: Job) :=
      job_arrival j + job_deadline j.
    Let demand_during := total_demand_during job_arrival job_cost job_deadline arr_seq.
    Let demand_before := total_demand_before job_arrival job_cost job_deadline arr_seq.
    Let arrivals_and_deadline_between := jobs_with_arrival_and_deadline_between job_arrival job_deadline arr_seq.

    (* In this section, we prove that the demand gives a sufficient
       condition for schedulability under EDF. *)
    Section DemandUnderEDF.

      (* Let sched_edf be any EDF schedule ... *)
      Variable sched_edf: schedule Job.
      Hypothesis H_edf_policy: respects_JLFP_policy job_arrival job_cost arr_seq sched_edf (EDF job_cost job_deadline).

      (* ...where jobs must arrive to execute. *)
      Hypothesis H_jobs_must_arrive_to_execute_sched_edf:
        jobs_must_arrive_to_execute job_arrival sched_edf.

      (*added -- need to fix*)
      Hypothesis H_no_service_before_arrival:
        forall j,
        \sum_(0 <= i < job_arrival j) service_at sched_edf j i = 0.

      (* ...and don't execute after they completed. *)
      Hypothesis H_completed_jobs_dont_execute_sched_edf:
        completed_jobs_dont_execute job_cost sched_edf.

      (* If the demand during any interval is bounded by the length of the interval, ... *)
      Hypothesis H_demand_always_satisfied:
        forall t delta, demand_during t (t + delta) <= delta.

      (* added hyp *)
      Hypothesis H_no_time_means_no_cost:
        forall j,  job_deadline j = 0 -> job_cost j = 0.

      (*...then no deadline is missed. *)

      Lemma schedulable_if_demand_always_satisfied:
        no_deadline_miss_in sched_edf.
      Proof.
        unfold no_deadline_miss_in. intros j.
        unfold job_misses_no_deadline. unfold completed_by.
        unfold respects_JLFP_policy, backlogged, pending in H_edf_policy.
        unfold EDF in H_edf_policy. unfold service, service_during.

        rewrite -> big_cat_nat with (n := (job_arrival j)); [> | auto | apply leq_addr].
        replace (\big[addn_monoid/0]_(0 <= i < job_arrival j)_) with 0;
          [> | symmetry; apply H_no_service_before_arrival].
        replace (0 + _ ) with
           ((\big[addn_monoid/0]_(job_arrival j <= i < job_arrival j + job_deadline j)
              service_at sched_edf j i)); auto.
        Admitted.
    End DemandUnderEDF.

    (* Using the optimality of EDF, we prove the correctness of the
       demand-based, exact feasibility test. *)
    Section FeasibilityTest.

      (* First, we define the concept of feasibility of a job set. *)
      Let job_set_is_feasible :=
        exists sched,
          no_deadline_miss_in sched.

      (* Then, by testing whether the demand is satisfied for every
         interval, ... *)
      Let demand_is_satisfied :=
        forall t delta, demand_during t (t + delta) <= delta.

      (* ... we establish the exact feasibility analysis for
             uniprocessor scheduling. *)
      (* TODO: for now only stated. *)
      Theorem job_set_is_feasible_iff_demand_is_satisfied:
        job_set_is_feasible <->
        demand_is_satisfied.
      Proof.
        Admitted.

    End FeasibilityTest.

  End Lemmas.

End EDFDemandAnalysis.


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibProd LibContainer LibSet
     LibRelation LibPer.
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import TLCBuffer.

(* Definition of disjoint set forests. *)

Section DisjointSetForest.

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

(* A type of vertices. *)

Variable V : Type.

(* We restrict our attention to a certain set of vertices, the domain
   of the forest. Keeping track of [D] allows us to distinguish an
   isolated vertex from a vertex that does not exist at all. *)

Variable D : set V.

(* The type [binary V] is the type of binary relations over [V].
   It is defined as [V -> V -> Prop]. This type can also be viewed
   as the type of directed graphs over vertices of type [V]. In the
   following, we define a disjoint set forest (dsf, for short) as a
   directed graph that satisfies certain properties. *)

Variable F : binary V.

(* A vertex [x] is a root if it has no successor. *)

Definition is_root x :=
  forall y, ~ F x y.

(* The descendants of [r] are the vertices [x] such that there exists
   a path from [x] to [r]. *)

Definition descendants r : set V :=
  \set{ x | path F x r }.

(* In a functional graph (i.e., a graph where every vertex has at most one
   successor), the vertex [r] is the representative for the vertex [x] iff
   there is a path from [x] to [r] and [r] is a root. In other words, there
   exists a maximal path from [x] to [r]. *)

Definition is_repr x r :=
  path F x r /\ is_root r.

(* A graph is a disjoint set forest with domain [D] iff every edge begins and
   ends within [D] and the graph is functional (i.e., every vertex has at most
   one successor) and acyclic (i.e., every vertex has a representative). *)

Definition is_dsf :=
  confined D F /\
  functional F /\
  defined is_repr.

(* Two vertices are equivalent if they have a common representative. *)

Definition is_equiv x y :=
  exists r, is_repr x r /\ is_repr y r.

(* The partial equivalence relation (PER) encoded by this disjoint set forest
   is the restriction of [is_equiv] to the domain [D]. *)

Definition dsf_per : binary V :=
  confine D is_equiv.

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

(* In the following, we assume that [F] is a disjoint set forest with
   domain [D]. *)

Hypothesis is_dsf_F:
  is_dsf.

Definition is_dsf_confined := proj31 is_dsf_F.
Definition is_dsf_functional := proj32 is_dsf_F.
Definition is_dsf_defined_is_repr := proj33 is_dsf_F.

Hint Resolve is_dsf_confined : confined.

Hint Resolve is_dsf_functional : functional.

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

(* Basic properties of [is_root], [is_repr], [is_equiv]. *)

(* A root has no parent. *)

Lemma a_root_has_no_parent:
  forall x y,
  is_root x ->
  F x y ->
  False.
Proof using.
  (* This is an immediate consequence of the definition. *)
  unfold is_root, not. intuition eauto.
Qed.

Lemma a_root_has_no_parent_disequality:
  forall r x y,
  is_root r ->
  F x y ->
  x <> r.
Proof using.
  intros. intro. subst. eauto using a_root_has_no_parent.
Qed.

Lemma a_root_has_no_parent_contrapositive:
  forall x y,
  F x y ->
  ~ is_root x.
Proof using.
  intros. unfold is_root. rewrite not_forall_not_eq. eauto.
Qed.

(* Hence, a path out of a root must be a trivial path. *)

Lemma a_path_out_of_a_root_is_trivial:
  forall x y,
  is_root x ->
  path F x y ->
  x = y.
Proof using.
  induction 2 using rtclosure_ind_l. eauto. false. eauto using a_root_has_no_parent.
Qed.

(* [is_repr x r] implies the existence of a path from [x] to [r]. *)

Lemma is_repr_path:
  forall x r,
  is_repr x r ->
  path F x r.
Proof using.
  unfold is_repr. tauto.
Qed.

(* The relation [is_repr] is functional, i.e., a vertex has at most
   one representative. *)

Lemma functional_is_repr:
  functional is_repr.
Proof using is_dsf_F.
  (* Massage the goal. *)
  unfold functional, is_repr.
  intros x r1 r2 [ ? ? ] [ ? ? ].
  generalize dependent r2. generalize dependent r1. generalize dependent x.
  (* Prove it. *)
  induction 1 using rtclosure_ind_l; intros ? r2 [->|(?&?&?)]%rtclosure_inv_l ?;
    try solve [ false; eauto using a_root_has_no_parent ]; auto; [].
  exploit_functional F; eauto.
Qed.

Hint Resolve functional_is_repr : functional.

(* Two equivalent vertices must have the same representative. *)

Lemma is_repr_is_equiv_is_repr:
  forall x y r,
  is_repr x r ->
  is_equiv x y ->
  is_repr y r.
Proof using is_dsf_F.
  introv ? [ ? [ ? ? ]]. exploit_functional is_repr. eauto.
Qed.

Lemma is_repr_is_equiv_is_repr_bis:
  forall x y rx ry,
  is_repr x rx ->
  is_equiv x y ->
  is_repr y ry ->
  rx = ry.
Proof using is_dsf_F.
  introv ? [ ? [ ? ? ]] ?. do 2 exploit_functional is_repr. eauto.
Qed.

(* [is_equiv] is an equivalence relation. *)

Lemma is_equiv_refl:
  (* refl is_equiv *)
  forall x,
  is_equiv x x.
Proof using is_dsf_F.
  unfold is_equiv. intros x.
  forwards: is_dsf_defined_is_repr x.
  jauto.
Qed.

Lemma is_equiv_sym:
  (* sym is_equiv *)
  forall x y,
  is_equiv x y ->
  is_equiv y x.
Proof using.
  unfold is_equiv. intros x y (r & ? & ?). eauto.
Qed.

Lemma is_equiv_trans:
  (* trans is_equiv *)
  forall y x z,
  is_equiv x y ->
  is_equiv y z ->
  is_equiv x z.
Proof using is_dsf_F.
  unfold is_equiv.
  intros y x z (r1 & ? & ?) (r2 & ? & ?).
  exploit_functional is_repr. eauto.
Qed.

(* Two vertices that are connected by a path must be equivalent. *)

Lemma path_is_equiv:
  forall x y,
  path F x y ->
  is_equiv x y.
Proof using is_dsf_F.
  intros.
  forwards [ r ? ]: is_dsf_defined_is_repr y.
  assert (is_repr x r).
    { unfold is_repr in *. intuition eauto using rtclosure_trans_explicit. }
  exists r. eauto.
Qed.

(* [is_equiv] is the reflexive, symmetric, transitive closure of [F]. *)

Lemma is_equiv_rstclosure:
  is_equiv =
  rstclosure F.
Proof using is_dsf_F.
  extens. intros x y. split; intros.
  { unfold is_equiv, is_repr in *. unpack.
    hint rstclosure_of_rtclosure.
    applys* trans_rstclosure r. { applys* sym_rstclosure. } }
  { gen x y. induction 1;
    eauto using path_is_equiv, is_equiv_refl, is_equiv_sym, is_equiv_trans with rtclosure. }
Qed.

(* A representative is a root. *)

Lemma is_repr_is_root:
  forall x r,
  is_repr x r ->
  is_root r.
Proof using.
  unfold is_repr. tauto.
Qed.

(* A root is its own representative. *)

Lemma is_root_is_repr:
  forall r,
  is_root r ->
  is_repr r r.
Proof using.
  unfold is_repr. eauto with rtclosure.
Qed.

(* A vertex is equivalent to its representative. *)

Lemma is_repr_equiv_root:
  forall x r,
  is_repr x r ->
  is_equiv x r.
Proof using.
  intros. exists r. eauto using is_repr_is_root, is_root_is_repr.
Qed.

(* [dsf_per] is indeed a partial equivalence relation. *)

Lemma per_dsf_per:
  per dsf_per.
Proof using is_dsf_F.
  unfold dsf_per, confine. constructor.
  intros x y. intuition eauto using is_equiv_sym.
  intros x y z. intuition eauto using is_equiv_trans.
Qed.

(* Its domain is indeed [D]. *)

Lemma per_dom_dsf_per:
  per_dom dsf_per = D.
Proof using is_dsf_F.
  unfold dsf_per, per_dom, confine. eapply set_ext.
  split; intros; rew_set in *; unpack; eauto using is_equiv_refl.
Qed.

(* There is a path from the parent [y] of a non-root vertex [x]
   to the representative [z] of [x]. *)

Lemma path_from_parent_to_repr_F:
  forall x y z,
  is_repr x z ->
  F x y ->
  path F y z.
Proof using is_dsf_F.
  intros.
  eapply is_repr_path.
  eapply is_repr_is_equiv_is_repr; eauto.
  eapply path_is_equiv; eauto with rtclosure.
Qed.

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

(* Everything takes place within [D]. *)

Lemma sticky_path:
  sticky D (path F).
Proof using is_dsf_F.
  unfold sticky. induction 1 using rtclosure_ind_l; split; eauto 2 with confined.
    intros. eapply IHrtclosure. eauto with confined.
Qed.

Lemma sticky_is_repr:
  sticky D is_repr.
Proof using is_dsf_F.
  unfold sticky. intros. eapply sticky_path. eauto using is_repr_path.
Qed.

Lemma sticky_is_equiv:
  sticky D is_equiv.
Proof using is_dsf_F.
  unfold sticky. introv [ r [ ? ? ]].
  forwards: sticky_is_repr x r. eauto.
  forwards: sticky_is_repr y r. eauto.
  tauto.
Qed.

Hint Resolve sticky_path sticky_is_repr sticky_is_equiv : sticky.

Lemma is_equiv_in_D_direct:
  forall x y,
  is_equiv x y ->
  x \in D ->
  y \in D.
Proof using is_dsf_F.
  eauto with sticky.
Qed.

Lemma non_root_in_D:
  forall x,
  ~ is_root x ->
  x \in D.
Proof using is_dsf_F.
  unfold is_root. introv h. rewrite not_forall_not_eq in h. unpack. eauto with confined.
Qed.

Lemma only_roots_outside_D:
  forall x,
  x \notin D ->
  is_root x.
Proof using is_dsf_F.
  unfold notin. intros.
  destruct (classic (is_root x)).
  { assumption. }
  { forwards: non_root_in_D. eauto. tauto. }
Qed.

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

(* If we are in a cycle and make one step, then we are still in a cycle. *)

Lemma one_step_in_a_cycle:
  forall x z,
  tclosure F x z ->
  x = z ->
  forall y,
  F x y ->
  tclosure F y y.
Proof using is_dsf_F.
  induction 1 using tclosure_ind_l; intros; subst; exploit_functional F.
  applys~ tclosure_once.
  eauto using tclosure_intro_right.
Qed.

(* Thus, a path cannot leave a cycle. *)

Lemma cannot_escape_a_cycle:
  forall x,
  tclosure F x x ->
  forall z,
  path F x z ->
  tclosure F z z.
Proof using is_dsf_F.
  induction 2; eauto using one_step_in_a_cycle.
Qed.

(* Thus, the fact every vertex has a representative contradicts the
   existence of a cycle. *)

Lemma acyclicity:
  forall x,
  tclosure F x x ->
  False.
Proof using is_dsf_F.
  intros.
  forwards [ z [ ? ? ]]: is_dsf_defined_is_repr x.
  forwards hz: cannot_escape_a_cycle; eauto.
  (* [z] is a root and a member of a cycle. Contradiction. *)
  destruct (tclosure_inv_l hz) as [|(?&?&?)];
    subst; eauto using a_root_has_no_parent.
Qed.

(* If there is a non-empty path from [x] to [y], then [x] and [y] must be distinct. *)

Lemma paths_have_distinct_endpoints:
  forall x y,
  tclosure F x y ->
  x <> y.
Proof using is_dsf_F.
  intros. intro. subst y. eauto using acyclicity.
Qed.

(* If there is an edge from [x] to [y], then [x] and [y] must be distinct. *)

Lemma edges_have_distinct_endpoints:
  forall x y,
  F x y ->
  x <> y.
Proof using is_dsf_F.
  eauto using paths_have_distinct_endpoints, tclosure_once with rtclosure.
Qed.

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

(* Descendants. *)

(* [x] is a descendant of a root [r] iff [r] is the representative of [x]. *)

Lemma descendant_of_a_root:
  forall x r,
  is_root r ->
  (x \in descendants r <-> is_repr x r).
Proof using.
  clear is_dsf_F. (* prevent [set_prove] from using it. *)
  unfold descendants, is_repr. intros. set_prove.
Qed.

(* Two distinct roots have disjoint sets of descendants. *)

Lemma disjoint_descendants:
  forall x y,
  is_root x ->
  is_root y ->
  x <> y ->
  disjoint (descendants x) (descendants y).
Proof using is_dsf_F.
  intros. eapply prove_disjoint. intros v ? ?.
  rewrite descendant_of_a_root in * by eauto.
  exploit_functional is_repr. eauto.
Qed.

(* If [x] is in [D], then the set of its descendants is a subset of [D]. *)

Lemma descendants_subset_D:
  forall x,
  x \in D ->
  descendants x \c D.
Proof using is_dsf_F.
  unfold descendants. intros. eapply incl_prove. intros. rew_set in *. eauto with sticky.
Qed.

(* If a vertex [r] lies outside the domain, then a path that reaches [r]
   or leaves [r] must be trivial. *)

Lemma only_trivial_paths_outside_D:
  forall k x r,
  kpath F k x r ->
  x \notin D \/ r \notin D ->
  k = 0 /\ x = r.
Proof using is_dsf_F.
  induction 1 as [| y x r ]; intros.
  { eauto. }
  { false.
    assert (x \in D). { eauto with confined. }
    assert (y \in D). { eauto with confined. }
    assert (path F y r). { eauto using kpath_rtclosure. }
    assert (r \in D). { eauto with sticky. }
    unfold notin in *.
    tauto. }
Qed.

(* If a vertex [r] lies outside the domain, then its set of descendants is
   reduced to itself. *)

Lemma descendants_outside:
  forall r,
  r \notin D ->
  descendants r = \{r}.
Proof using is_dsf_F.
  unfold descendants. intros. eapply set_ext. split; intros; rew_set in *; subst.
  { forwards [ ? ? ]: rtclosure_kpath; eauto.
    forwards [ ? ? ]: only_trivial_paths_outside_D; eauto. }
  { eauto with rtclosure. }
Qed.

(* If [D] is finite, then every set of descendants is finite. *)

Lemma finite_descendants:
  forall x,
  finite D ->
  finite (descendants x).
Proof using is_dsf_F.
  intros.
  tests : (x \in D).
  { eauto using finite_incl, descendants_subset_D. }
  { rewrite descendants_outside by eauto.
    eauto with finite. }
Qed.

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

(* Ancestors. *)

(* The ancestors of [x] are the vertices that lie along the path from [x]
   to its representative. *)

Definition ancestors x :=
  \set{ y | path F x y }.

(* If [x] is in [D], then the set of its ancestors is a subset of [D]. *)

Lemma ancestors_subset_D:
  forall x,
  x \in D ->
  ancestors x \c D.
Proof using is_dsf_F.
  unfold ancestors. intros. eapply incl_prove. intros. rew_set in *. eauto with sticky.
Qed.

(* If a vertex [r] lies outside the domain, then its set of ancestors is
   reduced to itself. *)

Lemma ancestors_outside:
  forall r,
  r \notin D ->
  ancestors r = \{r}.
Proof using is_dsf_F.
  unfold ancestors. intros. eapply set_ext. split; intros; rew_set in *; subst.
  { forwards [ ? ? ]: rtclosure_kpath; eauto.
    forwards [ ? ? ]: only_trivial_paths_outside_D; eauto. }
  { eauto with rtclosure. }
Qed.

(* If [D] is finite, then every set of ancestors is finite. *)

Lemma finite_ancestors:
  forall x,
  finite D ->
  finite (ancestors x).
Proof using is_dsf_F.
  intros.
  tests : (x \in D).
  { eauto using finite_incl, ancestors_subset_D. }
  { rewrite ancestors_outside by eauto.
    eauto with finite. }
Qed.

(* If there is an edge from [x] to [y], then the ancestors of [x] are the
   union of the ancestors of [y] and [x] itself. This is a disjoint union,
   because the graph is acyclic. *)

Lemma ancestors_of_parent_inclusion:
  forall x y,
  F x y ->
  ancestors y \c ancestors x.
Proof using is_dsf_F.
  unfold ancestors. intros. eapply incl_prove. intros; rew_set in *.
  eauto with rtclosure.
Qed.

Lemma ancestors_of_parent:
  forall x y,
  F x y ->
  ancestors x = ancestors y \u \{x}.
Proof using is_dsf_F.
  unfold ancestors. intros. eapply set_ext. split; intros; rew_set in *.
  (* An ancestor of [x] is either an ancestor of [y] or [x] itself. *)
  { match goal with h: path _ _ _ |- _ => destruct (rtclosure_inv_l h) as [|(?&?&?)] end;
    try exploit_functional F; eauto. }
  (* An ancestor of [y] is an ancestor of [x], and [x] is an ancestor of itself. *)
  { branches; subst; eauto with rtclosure. }
Qed.

Lemma ancestors_of_parent_disjoint:
  forall x y,
  F x y ->
  ~ x \in ancestors y.
Proof using is_dsf_F.
  unfold ancestors, notin. intros. rew_set in *.
  intro. eapply acyclicity. applys* tclosure_of_rtclosure_l.
Qed.

(* A root has no ancestors but itself. *)

Lemma ancestors_of_root:
  forall x,
  is_root x ->
  ancestors x = \{x}.
Proof using is_dsf_F.
  unfold ancestors. intros. eapply set_ext; split; rew_set in *.
  intros M. destruct (rtclosure_inv_l M) as [|(?&?&?)];
    subst; try solve [ eauto | false; eauto using a_root_has_no_parent ].
  intro; subst; eauto with rtclosure.
Qed.

(* There is at most one root ancestor. *)

Lemma at_most_one_root_ancestor:
  forall x y z,
  is_repr x z ->
  y \in ancestors x ->
  y <> z ->
  ~ is_root y.
Proof using is_dsf_F.
  unfold ancestors. intros; intro. rew_set in *; unpack.
  assert (is_repr x y). { econstructor; eauto. }
  exploit_functional is_repr. tauto.
Qed.

(* A hereditary property holds of every ancestor. *)

Lemma hereditary_property:
  forall (P : V -> Prop),
  (forall x y, P x -> F x y -> P y) ->
  forall x,
  P x ->
  forall y,
  y \in ancestors x ->
  P y.
Proof using.
  unfold ancestors.
  introv hh px yax.
  rew_set in *.
  induction yax; eauto.
Qed.

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

(* The relation [is_repr] is defined and functional, so it is the graph of a
   function [R] which maps every vertex to its representative. One may wish
   to present the end user with a specification expressed in terms of [R]. *)

(* We assume that the relation [R] is given and agrees with [is_repr]. If
   desired, the user can construct [R] explicitly as [choose_ is_repr]. *)

Variable R : V -> V.

(* The function [R] and the relation [is_repr] coincide. *)

Hypothesis R_incl_is_repr : fun_in_rel R is_repr.

Lemma is_repr_incl_R:
  rel_in_fun is_repr R.
Proof using is_dsf_F R_incl_is_repr.
  eauto using rel_in_fun_of_fun_in_rel_functional, functional_is_repr.
Qed.

(* [x] and [y] have the same image through [R] if and only if they are
   equivalent. In other words, the relation [is_equiv] coincides with
   the relation [fun x y => R x = R y]. *)

Lemma same_R_incl_is_equiv:
  forall x y,
  R x = R y ->
  is_equiv x y.
Proof using is_dsf_F R_incl_is_repr.
  introv h.
  forwards: R_incl_is_repr x.
  forwards: R_incl_is_repr y.
  rewrite <- h in *.
  unfold is_equiv. eauto.
Qed.

Lemma is_equiv_incl_same_R:
  forall x y,
  is_equiv x y ->
  R x = R y.
Proof using is_dsf_F R_incl_is_repr.
  unfold is_equiv. intros. unpack.
  forwards: is_repr_incl_R x. eauto.
  forwards: is_repr_incl_R y. eauto.
  congruence.
Qed.

(* [x] is a root if and only if [R x = x]. *)

Lemma is_root_R_self:
  forall x,
  is_root x ->
  R x = x.
Proof using is_dsf_F R_incl_is_repr.
  intros.
  forwards: is_root_is_repr. eauto.
  eapply functional_is_repr; eauto.
Qed.

Lemma R_self_is_root:
  forall x,
  R x = x ->
  is_root x.
Proof using R_incl_is_repr.
  introv h1.
  forwards h2: R_incl_is_repr x.
  rewrite h1 in h2.
  eauto using is_repr_is_root.
Qed.

(* [R] is the identity outside [D]. *)

Lemma R_is_identity_outside_D:
  forall x,
  x \notin D ->
  R x = x.
Proof using is_dsf_F R_incl_is_repr.
  intros. eapply is_root_R_self.
  eauto using only_roots_outside_D.
Qed.

(* [R] is idempotent. *)

Lemma idempotent_R:
  idempotent R.
Proof using is_dsf_F R_incl_is_repr.
  intro x.
  tests h : (x \in D).
  { eapply is_root_R_self.
    eapply is_repr_is_root.
    eapply R_incl_is_repr. }
  { forwards: R_is_identity_outside_D h.
    congruence. }
Qed.

(* [R] is sticky. *)

Lemma sticky_R:
  forall x,
  x \in D ->
  R x \in D.
Proof using is_dsf_F R_incl_is_repr.
  intros.
  forwards: R_incl_is_repr x.
  forwards: sticky_is_repr. eauto.
  tauto.
Qed.

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

End DisjointSetForest.

Hint Resolve sticky_path sticky_is_repr sticky_is_equiv : sticky.

Hint Resolve is_dsf_functional functional_is_repr : functional.

Hint Resolve finite_descendants finite_ancestors : finite.

Hint Resolve is_repr_is_root : is_root.

Hint Resolve is_dsf_confined non_root_in_D : confined.

Hint Unfold is_repr : is_repr.

Hint Resolve is_repr_is_equiv_is_repr path_is_equiv : is_repr.

Hint Constructors rtclosure : is_repr.

Hint Unfold is_equiv : is_equiv.

Hint Resolve is_equiv_refl is_equiv_sym is_equiv_trans : is_equiv.


Require Import Init.Init.
Require Import Relation.Relation.

Definition less (x y R: J) := (⟨x, y⟩ ∈ R).
Notation " x <[ R ] y" := (less x y R).
Notation " x ≮[ R ] y" := (~(less x y R)).
Notation " x ≤[ R ] y" := ((x <[R] y) ∨ x = y).
Notation " x ≰[ R ] y" := (~(x ≤[R] y)).

Definition tricho (R A: J) := ∀ x, ∀ y, x ∈ A → y ∈ A
  → (( x <[R] y ∧ x ≠ y ∧ ~y <[R] x) ∨
     (~x <[R] y ∧ x = y ∧ ~y <[R] x) ∨
     (~x <[R] y ∧ x ≠ y ∧  y <[R] x)).

Definition tricho_weak (R A: J) := ∀ x, ∀ y, x ∈ A → y ∈ A
  → ( x <[R] y ∨ x = y ∨ y <[R] x).

Definition po (R A: J) := r_trans R A ∧ r_irrefl R A.

Definition lo (R A: J) := r_trans R A ∧ tricho R A.

Definition least       (R A s: J) := ∀ x, x ∈ A → s ≤[R] x.
Definition least_bound (R A: J)   := ∃ x, x ∈ A ∧ least R A x.
Definition least_prop  (R A: J)   := ∀ S, S ⊆ A → S ≠ ∅ → least_bound R S.

Definition wo (R A: J) := lo R A ∧ least_prop R A.

Definition isom (R A S B: J) :=  ∃ f, f ∈ A ↦ᵇ B ∧
  (∀ x, ∀ y, x ∈ A → y ∈ A → ⟨x, y⟩ ∈ R → ⟨f[x], f[y]⟩ ∈ S) ∧
  (∀ x, ∀ y, x ∈ A → y ∈ A → ⟨f[x], f[y]⟩ ∈ S → ⟨x, y⟩ ∈ R).

(* Trichotomy *)
Lemma tricho_to_weak: ∀ R, ∀ A, tricho R A → tricho_weak R A.
Proof.
  intros R A P1.
  intros x y P2 P3.
  destruct (P1 _ _ P2 P3) as [P4 | [P4 | P4]].
  + destruct P4 as [P4 _].
    left.
    apply P4.
  + destruct P4 as [_ [P4 _]].
    right. left.
    apply P4.
  + destruct P4 as [_ [_ P4]].
    right. right.
    apply P4.
Qed.

Lemma weak_to_tricho: ∀ R, ∀ A, tricho_weak R A → r_irrefl R A → r_trans R A
  → tricho R A.
Proof.
  intros R A P1 P2 P3 x y P4 P5.
  destruct (P1 _ _ P4 P5) as [Q1 | [Q1 | Q1]].
  + left.
    repeat split.
    - apply Q1.
    - intros Q2.
      apply (P2 _ P4).
      apply (eq_cr (λ y, x <[R] y) Q2 Q1).
    - intros Q2.
      apply (P2 _ P4).
      apply (P3 _ _ _ P4 P5 P4 Q1 Q2).
  + right. left.
    repeat split.
    - intros Q2.
      apply (P2 _ P4).
      apply (eq_cr (λ y, x <[R] y) Q1 Q2).
    - apply Q1.
    - intros Q2.
      apply (P2 _ P4).
      apply (eq_cr (λ y, y <[R] x) Q1 Q2).
  + right. right.
    repeat split.
    - intros Q2.
      apply (P2 _ P4).
      apply (P3 _ _ _ P4 P5 P4 Q2 Q1).
    - intros Q2.
      apply (P2 _ P4).
      apply (eq_cr (λ y, y <[R] x) Q2 Q1).
    - apply Q1.
Qed.

(* Partial Order *)
Lemma po_trans: ∀ R, ∀ A, po R A → r_trans R A.
Proof.
  intros R A P1.
  destruct P1 as [P1 _].
  apply P1.
Qed.

Lemma po_irrefl: ∀ R, ∀ A, po R A → r_irrefl R A.
Proof.
  intros R A P1.
  destruct P1 as [_ P1].
  apply P1.
Qed.

Lemma po_weak_at_most_1: ∀ R, ∀ A, ∀ x, ∀ y, po R A → x ∈ A → y ∈ A
  → ~(x <[R] y ∧ x = y).
Proof.
  intros R A x y P1 P2 P3 [P4 P5].
  apply (po_irrefl _ _ P1 _ P3).
  apply (eq_cl (λ x, x <[R] y) P5).
  apply P4.
Qed.

Lemma po_weak_at_most_2: ∀ R, ∀ A, ∀ x, ∀ y, po R A → x ∈ A → y ∈ A
  → ~(y <[R] x ∧ x = y).
Proof.
  intros R A x y P1 P2 P3 [P4 P5].
  apply (po_irrefl _ _ P1 _ P3).
  apply (eq_cl (λ x, y <[R] x) P5).
  apply P4.
Qed.

Lemma po_weak_at_most_3: ∀ R, ∀ A, ∀ x, ∀ y, po R A → x ∈ A → y ∈ A
  → ~(x <[R] y ∧ y <[R] x).
Proof.
  intros R A x y P1 P2 P3 [P4 P5].
  apply (po_irrefl _ _ P1 _ P2).
  apply (po_trans _ _ P1 _ _ _ P2 P3 P2 P4 P5).
Qed.

Lemma po_sandwich: ∀ R, ∀ A, ∀ x, ∀ y, po R A → x ∈ A → y ∈ A → x ≤[R] y
  → y ≤[R] x → x = y.
Proof.
  intros R A x y P1 P2 P3 [P4 | P4] [P5 | P5].
  + apply bot_e.
    apply (po_irrefl _ _ P1 _ P2).
    apply (po_trans _ _ P1 _ _ _ P2 P3 P2 P4 P5).
  + apply (eq_s P5).
  + apply P4.
  + apply P4.
Qed.
(*----------------------------------------------------------------------------*)

(* Linear Order *)
Lemma lo_is_po: ∀ R, ∀ A, lo R A → po R A.
Proof.
  intros R A [P1 P2].
  split.
  + apply P1.
  + intros x P3.
    destruct (P2 _ _ P3 P3) as [P4 | [P4 | P4]].
    - destruct P4 as [_ [_ P4]].
      apply P4.
    - destruct P4 as [_ [_ P4]].
      apply P4.
    - destruct P4 as [P4 _].
      apply P4.
Qed.

Lemma lo_irrefl: ∀ R, ∀ A, lo R A → r_irrefl R A.
Proof.
  intros R A P1.
  apply (po_irrefl _ _ (lo_is_po _ _ P1)).
Qed.

Lemma lo_trans: ∀ R, ∀ A, lo R A → r_trans R A.
  intros R A P1.
  apply (po_trans _ _ (lo_is_po _ _ P1)).
Qed.

Lemma lo_tricho: ∀ R, ∀ A, lo R A → tricho R A.
Proof.
  intros R A P1.
  destruct P1 as [_ P1].
  apply P1.
Qed.

Lemma lo_tricho_weak: ∀ R, ∀ A, lo R A → tricho_weak R A.
Proof.
  intros R A P1.
  apply (tricho_to_weak _ _ (lo_tricho _ _ P1)).
Qed.

Lemma lo_sandwich: ∀ R, ∀ A, ∀ x, ∀ y, lo R A → x ∈ A → y ∈ A → x ≤[R] y
  → y ≤[R] x → x = y.
  intros R A x y P1.
  apply (po_sandwich _ _ _ _ (lo_is_po _ _ P1)).
Qed.

Lemma lo_neq_e: ∀ R, ∀ A, ∀ x, ∀ y, lo R A → x ∈ A → y ∈ A → x ≠ y
  → (x <[R] y) ∨ (y <[R] x).
Proof.
  intros R A x y P1 P2 P3 P4.
  destruct (lo_tricho _ _ P1 _ _ P2 P3) as [P5 | [P5 | P5]].
  + destruct P5 as [P5 [_ P6]].
    left.
    apply (and_i P5 P6).
  + destruct P5 as [_ [P5 _]].
    apply bot_e.
    apply (P4 P5).
  + destruct P5 as [P5 [_ P6]].
    right.
    apply (and_i P5 P6).
Qed.

Lemma lo_neq_i: ∀ R, ∀ A, ∀ x, ∀ y, lo R A → x ∈ A → y ∈ A → x <[R] y → x ≠ y.
Proof.
  intros R A x y P1 P2 P3 P4.
  destruct (lo_tricho _ _ P1 _ _ P2 P3) as [P5 | [P5 | P5]].
  + destruct P5 as [_ [P5 _]].
    apply P5.
  + destruct P5 as [P5 _].
    apply bot_e.
    apply (P5 P4).
  + destruct P5 as [_ [P5 _]].
    apply P5.
Qed.

Lemma lo_nl_e: ∀ R, ∀ A, ∀ x, ∀ y, lo R A → x ∈ A → y ∈ A → x ≮[R] y
  → y ≤[R] x.
Proof.
  intros R A x y P1 P2 P3 P4.
  destruct (lo_tricho _ _ P1 _ _ P2 P3) as [P5 | [P5 | P5]].
  + destruct P5 as [P5 _].
    apply bot_e.
    apply (P4 P5).
  + destruct P5 as [_ [P5 _]].
    right.
    apply (eq_s P5).
  + destruct P5 as [_ [_ P5]].
    left.
    apply P5.
Qed.

Lemma lo_nl_i: ∀ R, ∀ A, ∀ x, ∀ y, lo R A → x ∈ A → y ∈ A → x ≤[R] y
  → y ≮[R] x.
Proof.
  intros R A x y P1 P2 P3 [P4 | P4].
  + destruct (lo_tricho _ _ P1 _ _ P3 P2) as [P5 | [P5 | P5]].
    - destruct P5 as [_ [_ P5]].
      apply bot_e.
      apply (P5 P4).
    - destruct P5 as [P5 _].
      apply P5.
    - destruct P5 as [P5 _].
      apply P5.
  + destruct (lo_tricho _ _ P1 _ _ P3 P2) as [P5 | [P5 | P5]].
    - destruct P5 as [_ [P5 _]].
      apply bot_e.
      apply (P5 (eq_s P4)).
    - destruct P5 as [P5 _].
      apply P5.
    - destruct P5 as [P5 _].
      apply P5.
Qed.

Lemma lo_nle_e: ∀ R, ∀ A, ∀ x, ∀ y, lo R A → x ∈ A → y ∈ A → x ≰[R] y
  → y <[R] x.
Proof.
  intros R A x y P1 P2 P3 P4.
  destruct (not_or_and P4) as [P5 P6].
  destruct (lo_tricho _ _ P1 _ _ P2 P3) as [P7 | [P7 | P7]].
  + destruct P7 as [P7 _].
    apply bot_e.
    apply (P5 P7).
  + destruct P7 as [_ [P7 _]].
    apply bot_e.
    apply (P6 P7).
  + destruct P7 as [_ [_ P7]].
    apply P7.
Qed.

Lemma lo_nle_i: ∀ R, ∀ A, ∀ x, ∀ y, lo R A → x ∈ A → y ∈ A → x <[R] y
  → y ≰[R] x.
Proof.
  intros R A x y P1 P2 P3 P4.
  apply and_not_or.
  split.
  + destruct (lo_tricho _ _ P1 _ _ P3 P2) as [P5 | [P5 | P5]].
    - destruct P5 as [_ [_ P5]].
      apply bot_e.
      apply (P5 P4).
    - destruct P5 as [_ [_ P5]].
      apply bot_e.
      apply (P5 P4).
    - destruct P5 as [P5 _].
      apply P5.
  + destruct (lo_tricho _ _ P1 _ _ P3 P2) as [P5 | [P5 | P5]].
    - destruct P5 as [_ [P5 _]].
      apply P5.
    - destruct P5 as [_ [_ P5]].
      apply bot_e.
      apply (P5 P4).
    - destruct P5 as [_ [P5 _]].
      apply P5.
Qed.
(*----------------------------------------------------------------------------*)

(* Well Order *)
Lemma wo_least_prop: ∀ R, ∀ A, wo R A → least_prop R A.
Proof.
  intros R A [_ P1].
  apply P1.
Qed.

Lemma wo_is_lo: ∀ R, ∀ A, wo R A → lo R A.
Proof.
  intros R A [P1 _].
  apply P1.
Qed.

Lemma wo_trans: ∀ R, ∀ A, wo R A → r_trans R A.
  intros R A P1.
  apply (lo_trans _ _ (wo_is_lo _ _ P1)).
Qed.

Lemma wo_tricho: ∀ R, ∀ A, wo R A → tricho R A.
Proof.
  intros R A P1.
  apply lo_tricho.
  apply (wo_is_lo _ _ P1).
Qed.

Lemma wo_tricho_weak: ∀ R, ∀ A, wo R A → tricho_weak R A.
Proof.
  intros R A P1.
  apply lo_tricho_weak.
  apply (wo_is_lo _ _ P1).
Qed.

Lemma wo_sandwich: ∀ R, ∀ A, ∀ x, ∀ y, wo R A → x ∈ A → y ∈ A → x ≤[R] y
  → y ≤[R] x → x = y.
  intros R A x y P1.
  apply (lo_sandwich _ _ _ _ (wo_is_lo _ _ P1)).
Qed.

Lemma wo_neq_e: ∀ R, ∀ A, ∀ x, ∀ y, wo R A → x ∈ A → y ∈ A → x ≠ y
  → (x <[R] y) ∨ (y <[R] x).
Proof.
  intros R A x y P1.
  apply lo_neq_e.
  apply (wo_is_lo _ _ P1).
Qed.

Lemma wo_neq_i: ∀ R, ∀ A, ∀ x, ∀ y, wo R A → x ∈ A → y ∈ A → x <[R] y
  → x ≠ y.
Proof.
  intros R A x y P1.
  apply lo_neq_i.
  apply (wo_is_lo _ _ P1).
Qed.

Lemma wo_nl_e: ∀ R, ∀ A, ∀ x, ∀ y, wo R A → x ∈ A → y ∈ A → x ≮[R] y
  → y ≤[R] x.
Proof.
  intros R A x y P1.
  apply lo_nl_e.
  apply (wo_is_lo _ _ P1).
Qed.

Lemma wo_nl_i: ∀ R, ∀ A, ∀ x, ∀ y, wo R A → x ∈ A → y ∈ A → x ≤[R] y
  → y ≮[R] x.
Proof.
  intros R A x y P1.
  apply lo_nl_i.
  apply (wo_is_lo _ _ P1).
Qed.

Lemma wo_nle_e: ∀ R, ∀ A, ∀ x, ∀ y, wo R A → x ∈ A → y ∈ A → x ≰[R] y
  → y <[R] x.
Proof.
  intros R A x y P1.
  apply lo_nle_e.
  apply (wo_is_lo _ _ P1).
Qed.

Lemma wo_nle_i: ∀ R, ∀ A, ∀ x, ∀ y, wo R A → x ∈ A → y ∈ A → x <[R] y
  → y ≰[R] x.
Proof.
  intros R A x y P1.
  apply lo_nle_i.
  apply (wo_is_lo _ _ P1).
Qed.

(*Lemma no_descend: ∀ R, ∀ A, ∀ f, wo R A → fnm f ω A → *)
  (*~(∀ n, n ∈ ω → f[S(n)] <[R] f[n]).*)
(*Proof.*)
  (*intros R A f P1 [P2 [P3 P4]] P5.*)
  (*assert (least_bound R (ran(f))) as P6.*)
  (*{ apply (wo_least_prop _ _ P1).*)
    (*+ apply P4.*)
    (*+ apply ex_nempty.*)
      (*exists (f[∅]).*)
      (*apply (fval_ran _ _ P2).*)
      (*apply (eq_cr (λ x, ∅ ∈ x) P3).*)
      (*apply empty_is_nat. }*)
  (*assert (~(least_bound R (ran(f)))) as P7.*)
  (*{ intros _.*)
    (*destruct P6 as [y [P7 P8]].*)
    (*destruct (ran_e _ _ P7) as [x P9].*)
    (*pose (eq_cl (λ s, x ∈ s) P3 (dom_i _ _ _ P9)) as P10.*)
    (*pose (fval_ran _ _ P2 (eq_cr (λ s, S(x) ∈ s) P3 (suc_is_nat _ P10))) as P11.*)
    (*apply (wo_nle_i _ _ (f[S(x)]) (f[x]) P1).*)
    (*+ apply P4.*)
      (*apply P11.*)
    (*+ apply P4.*)
      (*apply (fval_ran _ _ P2).*)
      (*apply (eq_cr (λ s, x ∈ s) P3).*)
      (*apply P10.*)
    (*+ apply (P5 _ P10).*)
    (*+ apply (eq_cl (λ s, s ≤[R] f[S(x)]) (fval_i _ _ _ P2 P9)).*)
      (*apply P8.*)
      (*apply P11. }*)
  (*apply bot_e.*)
  (*apply (P7 P6).*)
(*Qed.*)
(* Skip reverse *)

Lemma wo_prop_least: ∀ₚ P, ∀ R, ∀ A, ∀ x0, wo R A → x0 ∈ A → P x0
  → ∃ x, x ∈ A ∧ P x ∧ (∀ y, y ∈ A → P y → x ≤[R] y).
Proof.
  intros P R A x0 P1 P2 P3.
  pose ({x: A| P x}) as X.
  assert (X ≠ ∅) as P4.
  { apply ex_nempty.
    exists x0.
    apply sub_i.
    + apply P2.
    + apply P3. }
  destruct (wo_least_prop _ _ P1 X (sub_e1 _ _) P4) as [x [P5 P6]].
  destruct (sub_e _ _ _ P5) as [P7 P8].
  exists x.
  repeat split.
  + apply P7.
  + apply P8.
  + intros y P9 P10.
    apply P6.
    apply (sub_i _ _ _ P9 P10).
Qed.
(*----------------------------------------------------------------------------*)

(* Relation exten *)
Lemma rel_eq1: ∀ R1, ∀ R2, ∀ A, ∀ x, ∀ y, R1 ∩ (A ⨉ A) = R2 ∩ (A ⨉ A) → x ∈ A
  → y ∈ A → x <[R1] y → x <[R2] y.
Proof.
  intros R1 R2 A x y P1 P2 P3 P4.
  assert (⟨x, y⟩ ∈ (R1 ∩ (A ⨉ A))) as P5.
  { apply inter2_i.
    + apply P4.
    + apply (cp_i _ _ _ _ P2 P3). }
  pose (eq_cl (λ s, ⟨x, y⟩ ∈ s) P1 P5) as P6.
  destruct (inter2_e _ _ _ P6) as [P7 _].
  apply P7.
Qed.

Lemma rel_eq2: ∀ R1, ∀ R2, ∀ A, ∀ x, ∀ y, R1 ∩ (A ⨉ A) = R2 ∩ (A ⨉ A) → x ∈ A
  → y ∈ A → x ≮[R1] y → x ≮[R2] y.
Proof.
  intros R1 R2 A x y P1 P2 P3 P4 P5.
  apply P4.
  apply (rel_eq1 _ _ _ _ _ (eq_s P1) P2 P3 P5).
Qed.

Lemma rel_eq3: ∀ R1, ∀ R2, ∀ A, ∀ x, ∀ y, R1 ∩ (A ⨉ A) = R2 ∩ (A ⨉ A) → x ∈ A
  → y ∈ A → x ≤[R1] y → x ≤[R2] y.
Proof.
  intros R1 R2 A x y P1 P2 P3 [P4 | P4].
  + left.
    apply (rel_eq1 _ _ _ _ _ P1 P2 P3 P4).
  + right.
    apply P4.
Qed.

Lemma trans_rel_exten: ∀ R1, ∀ R2, ∀ A, R1 ∩ (A ⨉ A) = R2 ∩ (A ⨉ A)
  → r_trans R1 A → r_trans R2 A.
Proof.
  intros R1 R2 A P1 P2 x y z P3 P4 P5 P6 P7.
  apply (rel_eq1 _ _ _ _ _ P1 P3 P5).
  apply (P2 _ _ _ P3 P4 P5).
  + apply (rel_eq1 _ _ _ _ _ (eq_s P1) P3 P4 P6).
  + apply (rel_eq1 _ _ _ _ _ (eq_s P1) P4 P5 P7).
Qed.

Lemma tricho_rel_exten: ∀ R1, ∀ R2, ∀ A, R1 ∩ (A ⨉ A) = R2 ∩ (A ⨉ A)
  → tricho R1 A → tricho R2 A.
Proof.
  intros R1 R2 A P1 P2 x y P3 P4.
  destruct (P2 _ _ P3 P4) as [[P5 [P6 P7]] | [[P5 [P6 P7]] | [P5 [P6 P7]]]].
  + left.
    repeat split.
    - apply (rel_eq1 _ _ _ _ _ P1 P3 P4 P5).
    - apply P6.
    - apply (rel_eq2 _ _ _ _ _ P1 P4 P3 P7).
  + right. left.
    repeat split.
    - apply (rel_eq2 _ _ _ _ _ P1 P3 P4 P5).
    - apply P6.
    - apply (rel_eq2 _ _ _ _ _ P1 P4 P3 P7).
  + right. right.
    repeat split.
    - apply (rel_eq2 _ _ _ _ _ P1 P3 P4 P5).
    - apply P6.
    - apply (rel_eq1 _ _ _ _ _ P1 P4 P3 P7).
Qed.

Lemma least_prop_rel_exten: ∀ R1, ∀ R2, ∀ A, R1 ∩ (A ⨉ A) = R2 ∩ (A ⨉ A)
  → least_prop R1 A → least_prop R2 A.
Proof.
  intros R1 R2 A P1 P2 A' P3 P4.
  destruct (P2 _ P3 P4) as [x [P5 P6]].
  exists x.
  split.
  + apply P5.
  + intros x' P7.
    apply (rel_eq3 _ _ _ _ _ P1 (P3 _ P5) (P3 _ P7) (P6 _ P7)).
Qed.

Lemma lo_rel_exten: ∀ R1, ∀ R2, ∀ A, R1 ∩ (A ⨉ A) = R2 ∩ (A ⨉ A) → lo R1 A
  → lo R2 A.
Proof.
  intros R1 R2 A P1 [P2 P3].
  split.
  + apply (trans_rel_exten _ _ _ P1 P2).
  + apply (tricho_rel_exten _ _ _ P1 P3).
Qed.

Lemma wo_rel_exten: ∀ R1, ∀ R2, ∀ A, R1 ∩ (A ⨉ A) = R2 ∩ (A ⨉ A) → wo R1 A
  → wo R2 A.
Proof.
  intros R1 R2 A P1 [P2 P3].
  split.
  + apply (lo_rel_exten _ _ _ P1 P2).
  + apply (least_prop_rel_exten _ _ _ P1 P3).
Qed.
(*----------------------------------------------------------------------------*)

(* Add Largest Element *)
(*Lemma trans_add_largest: ∀ R, ∀ A, ∀ a, a ∉ A → r_trans R A *)
  (*→ r_trans (R ∪ (A ⨉ `{a})) (A ∪ `{a}).*)
(*Proof.*)
  (*intros R A a P1 P2 x y z P3 P4 P5 P6 P7.*)
  (*destruct (union2_sing_e _ _ _ P3) as [P8 | P8].*)
  (*+ destruct (union2_sing_e _ _ _ P4) as [P9 | P9].*)
    (*- destruct (union2_sing_e _ _ _ P5) as [P10 | P10].*)
      (** ...*)
        (*do many many case analysis...*)
(*----------------------------------------------------------------------------*)

(* Subset *)
Lemma sub_r_irrefl: ∀ R, ∀ A, ∀ B, r_irrefl R A → B ⊆ A → r_irrefl R B.
Proof.
  intros R A B P1 P2 x P3.
  apply (P1 _ (P2 _ P3)).
Qed.

Lemma sub_r_trans: ∀ R, ∀ A, ∀ B, r_trans R A → B ⊆ A → r_trans R B.
Proof.
  intros R A B P1 P2 x y z P3 P4 P5.
  apply (P1 _ _ _ (P2 _ P3) (P2 _ P4) (P2 _ P5)).
Qed.

Lemma sub_tricho: ∀ R, ∀ A, ∀ B, tricho R A → B ⊆ A → tricho R B.
Proof.
  intros R A B P1 P2 x y P3 P4.
  apply (P1 _ _ (P2 _ P3) (P2 _ P4)).
Qed.

Lemma sub_least_prop: ∀ R, ∀ A, ∀ B, least_prop R A → B ⊆ A → least_prop R B.
Proof.
  intros R A B P1 P2 x P3 P4.
  apply (P1 _ (sub_t _ _ _ P3 P2) P4).
Qed.

Lemma sub_po: ∀ R, ∀ A, ∀ B, po R A → B ⊆ A → po R B.
Proof.
  intros R A B [P1 P2] P3.
  split.
  + apply (sub_r_trans _ _ _ P1 P3).
  + apply (sub_r_irrefl _ _ _ P2 P3).
Qed.

Lemma sub_lo: ∀ R, ∀ A, ∀ B, lo R A → B ⊆ A → lo R B.
Proof.
  intros R A B [P1 P2] P3.
  split.
  + apply (sub_r_trans _ _ _ P1 P3).
  + apply (sub_tricho _ _ _ P2 P3).
Qed.

Lemma sub_wo: ∀ R, ∀ A, ∀ B, wo R A → B ⊆ A → wo R B.
Proof.
  intros R A B [P1 P2] P3.
  split.
  + apply (sub_lo _ _ _ P1 P3).
  + apply (sub_least_prop _ _ _ P2 P3).
Qed.
(*----------------------------------------------------------------------------*)

(* Better Transitive *)
Lemma l_l_t: ∀ R, ∀ A, ∀ x, ∀ y, ∀ z, r_trans R A → x ∈ A → y ∈ A → z ∈ A
  → x <[R] y → y <[R] z → x <[R] z.
Proof.
  intros R A x y z P1 P2 P3 P4 P5 P6.
  apply (P1 _ _ _ P2 P3 P4 P5 P6).
Qed.

Lemma l_le_t: ∀ R, ∀ A, ∀ x, ∀ y, ∀ z, r_trans R A → x ∈ A → y ∈ A → z ∈ A
  → x <[R] y → y ≤[R] z → x <[R] z.
Proof.
  intros R A x y z P1 P2 P3 P4 P5 [P6 | P6].
  + apply (P1 _ _ _ P2 P3 P4 P5 P6).
  + apply (eq_cl (λ y, x <[R] y) P6).
    apply P5.
Qed.

Lemma le_l_t: ∀ R, ∀ A, ∀ x, ∀ y, ∀ z, r_trans R A → x ∈ A → y ∈ A → z ∈ A
  → x ≤[R] y → y <[R] z → x <[R] z.
Proof.
  intros R A x y z P1 P2 P3 P4 [P5 | P5] P6.
  + apply (P1 _ _ _ P2 P3 P4 P5 P6).
  + apply (eq_cr (λ x, x <[R] z) P5).
    apply P6.
Qed.

Lemma le_le_t: ∀ R, ∀ A, ∀ x, ∀ y, ∀ z, r_trans R A → x ∈ A → y ∈ A → z ∈ A
  → x ≤[R] y → y ≤[R] z → x ≤[R] z.
Proof.
  intros R A x y z P1 P2 P3 P4 [P5 | P5] [P6 | P6].
  + left.
    apply (P1 _ _ _ P2 P3 P4 P5 P6).
  + left.
    apply (eq_cl (λ y, x <[R] y) P6).
    apply P5.
  + left.
    apply (eq_cr (λ x, x <[R] z) P5).
    apply P6.
  + right.
    apply (eq_t P5 P6).
Qed.

Lemma sub_exten: ∀R, ∀ A, ∀ t, t ∈ A → {x: A| x ≤[R] t} = {x: A| x <[R] t} ∪ `{t}.
Proof.
  intros R A t P0.
  apply sub_a.
  split.
  + intros x P1.
    destruct (sub_e _ _ _ P1) as [P2 [P3 | P3]].
    - apply union2_il.
      apply (sub_i _ _ _ P2 P3).
    - apply union2_ir.
      apply (eq_cr (λ x, x ∈ `{t}) P3).
      apply sing_i.
  + intros x P1.
    destruct (union2_e _ _ _ P1) as [P2 | P2].
    - destruct (sub_e _ _ _ P2) as [P3 P4].
      apply (sub_i _ _ _ P3 (or_il _ P4)).
    - apply (eq_cl (λ x, x ∈ {x0: A| x0 ≤[R] t}) (sing_e _ _ P2)).
      apply (sub_i _ _ _ P0 (or_ir _ (eq_r _))).
Qed.
(*----------------------------------------------------------------------------*)

(* Isomorphrism *)
Lemma isom_r: ∀ R, ∀ A, isom R A R A.
Proof.
  intros R A.
  exists (id A).
  split.
  + apply id_is_bij.
  + split.
    - intros x y P1 P2 P3.
      apply (eq_cr (λ s, ⟨s, id A[y]⟩ ∈ R) (id_fval _ _ P1)).
      apply (eq_cr (λ s, ⟨x, s⟩ ∈ R) (id_fval _ _ P2)).
      apply P3.
    - intros x y P1 P2 P3.
      apply (eq_cl (λ s, ⟨s, y⟩ ∈ R) (id_fval _ _ P1)).
      apply (eq_cl (λ s, ⟨id A[x], s⟩ ∈ R) (id_fval _ _ P2)).
      apply P3.
Qed.

Lemma isom_s: ∀ R, ∀ A, ∀ S, ∀ B, isom R A S B → isom S B R A.
Proof.
  intros R A S B [f [P1 [P2 P3]]].
  pose (inv_bij _ _ _ P1) as P4.
  exists (f⁻¹).
  split.
  + apply P4.
  + split.
    - intros x y P5 P6 P7.
      apply P3.
      * apply (fval_codom _ _ _ _ (bij_fmap _ _ _ P4) P5).
      * apply (fval_codom _ _ _ _ (bij_fmap _ _ _ P4) P6).
      * destruct (bij_e _ _ _ P1) as [_ P8].
        pose (eq_cr (λ s, x ∈ s) (bij_ran _ _ _ P1) P5) as P9.
        pose (eq_cr (λ s, y ∈ s) (bij_ran _ _ _ P1) P6) as P10.
        apply (eq_cr (λ s, ⟨s, _⟩ ∈ S) (inv_fval_cancel2 _ _ _ _ P8 P9)).
        apply (eq_cr (λ s, ⟨_, s⟩ ∈ S) (inv_fval_cancel2 _ _ _ _ P8 P10)).
        apply P7.
    - intros x y P5 P6 P7.
      destruct (bij_e _ _ _ P1) as [_ P8].
      pose (eq_cr (λ s, x ∈ s) (bij_ran _ _ _ P1) P5) as P9.
      pose (eq_cr (λ s, y ∈ s) (bij_ran _ _ _ P1) P6) as P10.
      apply (eq_cl (λ s, ⟨s, _⟩ ∈ S) (inv_fval_cancel2 _ _ _ _ P8 P9)).
      apply (eq_cl (λ s, ⟨_, s⟩ ∈ S) (inv_fval_cancel2 _ _ _ _ P8 P10)).
      apply P2.
      * apply (fval_codom _ _ _ _ (bij_fmap _ _ _ P4) P5).
      * apply (fval_codom _ _ _ _ (bij_fmap _ _ _ P4) P6).
      * apply P7.
Qed.

Lemma isom_t: ∀ R, ∀ A, ∀ S, ∀ B, ∀ T, ∀ C, isom R A S B → isom S B T C
  → isom R A T C.
Proof.
  intros R A S B T C [f [P1 [P2 P3]]] [g [P4 [P5 P6]]].
  exists (g ∘ f).
  split.
  + apply (comp_bij _ _ _ _ _ P1 P4).
  + split.
    - intros x y Q1 Q2 Q3.
      pose (comp_dom_fmap _ _ _ _ _ (bij_fmap _ _ _ P1) (bij_fmap _ _ _ P4))
        as Q4.
      pose (eq_cr (λ s, x ∈ s) Q4 Q1) as Q5.
      pose (eq_cr (λ s, y ∈ s) Q4 Q2) as Q6.
      pose (fval_codom _ _ _ _ (bij_fmap _ _ _ P1) Q1) as Q7.
      pose (fval_codom _ _ _ _ (bij_fmap _ _ _ P1) Q2) as Q8.
      apply (eq_cl (λ s, ⟨s, (g ∘ f)[y]⟩ ∈ T)
        (comp_fval _ _ _ (bij_fn _ _ _ P1) (bij_fn _ _ _ P4) Q5)).
      apply (eq_cl (λ s, ⟨g[f[x]], s⟩ ∈ T)
        (comp_fval _ _ _ (bij_fn _ _ _ P1) (bij_fn _ _ _ P4) Q6)).
      apply (P5 _ _ Q7 Q8).
      apply (P2 _ _ Q1 Q2 Q3).
    - intros x y Q1 Q2 Q3.
      pose (comp_dom_fmap _ _ _ _ _ (bij_fmap _ _ _ P1) (bij_fmap _ _ _ P4))
        as Q4.
      pose (eq_cr (λ s, x ∈ s) Q4 Q1) as Q5.
      pose (eq_cr (λ s, y ∈ s) Q4 Q2) as Q6.
      pose (fval_codom _ _ _ _ (bij_fmap _ _ _ P1) Q1) as Q7.
      pose (fval_codom _ _ _ _ (bij_fmap _ _ _ P1) Q2) as Q8.
      apply (P3 _ _ Q1 Q2).
      apply (P6 _ _ Q7 Q8).
      apply (eq_cr (λ s, ⟨s, g[f[y]]⟩ ∈ T)
        (comp_fval _ _ _ (bij_fn _ _ _ P1) (bij_fn _ _ _ P4) Q5)).
      apply (eq_cr (λ s, ⟨(g ∘ f)[x], s⟩ ∈ T)
        (comp_fval _ _ _ (bij_fn _ _ _ P1) (bij_fn _ _ _ P4) Q6)).
      apply Q3.
Qed.
(* Skip 7F *)

Lemma isom_r_irrefl: ∀ R, ∀ A, ∀ S, ∀ B, r_irrefl R A → isom R A S B
  → r_irrefl S B.
Proof.
  intros R A S B P1 [f [P2 [P3 P4]]] x P5 P6.
  assert ((inv f)[x] ∈ A) as Q1.
  { apply (eq_cl (λ s, _ ∈ s) (bij_dom _ _ _ P2)).
    apply (eq_cl (λ s, _ ∈ s) (inv_ran f)).
    apply fval_ran.
    + apply inv_fn.
      apply (bij_sing_rot _ _ _ P2).
    + apply (eq_cr (λ s, x ∈ s) (inv_dom f)).
      apply (eq_cr (λ s, x ∈ s) (bij_ran _ _ _ P2)).
      apply P5. }
  destruct (bij_e _ _ _ P2) as [_ P7].
  pose (eq_cr (λ s, x ∈ s) (bij_ran _ _ _ P2) P5) as P8.
  pose (eq_cr (λ s, ⟨s, s⟩ ∈ S) (inv_fval_cancel2 _ _ _ _ P7 P8) P6) as P9.
  apply (P1 (f⁻¹[x])).
  + apply Q1.
  + apply (P4 _ _ Q1 Q1).
    apply P9.
Qed.

Lemma isom_r_trans: ∀ R, ∀ A, ∀ S, ∀ B, r_trans R A → isom R A S B
  → r_trans S B.
Proof.
  intros R A S B P1 P2 x y z Q1 Q2 Q3 P3 P4.
  destruct (isom_s _ _ _ _ P2) as [f [P5 [P6 P7]]].
  pose (P6 _ _ Q1 Q2 P3) as P8.
  pose (P6 _ _ Q2 Q3 P4) as P9.
  pose (P1 _ _ _
    (fval_codom _ _ _ _ (bij_fmap _ _ _ P5) Q1)
    (fval_codom _ _ _ _ (bij_fmap _ _ _ P5) Q2)
    (fval_codom _ _ _ _ (bij_fmap _ _ _ P5) Q3) P8 P9) as P10.
  apply (P7 _ _ Q1 Q3 P10).
Qed.

Lemma isom_tricho: ∀ R, ∀ A, ∀ S, ∀ B, tricho R A → isom R A S B →
  tricho S B.
Proof.
  intros R A S B P1 P2 x y Q1 Q2.
  destruct (isom_s _ _ _ _ P2) as [f [P3 [P4 P5]]].
  destruct (P1 _ _
    (fval_codom _ _ _ _ (bij_fmap _ _ _ P3) Q1)
    (fval_codom _ _ _ _ (bij_fmap _ _ _ P3) Q2))
    as [[S1 [S2 S3]]|[[S1 [S2 S3]]|[S1 [S2 S3]]]].
  + left.
    repeat split.
    - apply (P5 _ _ Q1 Q2 S1).
    - intros S4.
      apply S2.
      apply (eq_cr (λ x, f[x] = f[y]) S4 (eq_r _)).
    - intros S4.
      apply S3.
      apply (P4 _ _ Q2 Q1 S4).
  + right. left.
    repeat split.
    - intros S4.
      apply S1.
      apply (P4 _ _ Q1 Q2 S4).
    - apply ((bij_sing_rot _ _ _ P3) _ _ (f[x])).
      * apply (fval_i2 _ _ (bij_fn _ _ _ P3)).
        apply (eq_cr (λ s, x ∈ s) (bij_dom _ _ _ P3) Q1).
      * apply (eq_cr (λ s, ⟨y, s⟩ ∈ f) S2).
        apply (fval_i2 _ _ (bij_fn _ _ _ P3)).
        apply (eq_cr (λ s, y ∈ s) (bij_dom _ _ _ P3) Q2).
    - intros S4.
      apply bot_e.
      apply S3.
      apply (P4 _ _ Q2 Q1 S4).
  + right. right.
    repeat split.
    - intros S4.
      apply S1.
      apply (P4 _ _ Q1 Q2 S4).
    - intros S4.
      apply S2.
      apply (eq_cr (λ x, f[x] = f[y]) S4).
      apply eq_r.
    - apply (P5 _ _ Q2 Q1 S3).
Qed.

Lemma isom_least_prop: ∀ R, ∀ A, ∀ S, ∀ B, least_prop R A → isom R A S B
  → least_prop S B.
Proof.
  intros R A S B P1 [f [P2 [P5 P6]]] C P3 P4.
  assert (f⁻¹⟦C⟧ ⊆ A) as Q1.
  { apply (eq_cl (λ x, f⁻¹⟦C⟧ ⊆ x) (bij_dom _ _ _ P2)).
    apply inv_image_ran. }
  assert (f⁻¹⟦C⟧ ≠ ∅) as Q2.
  { destruct (nempty_ex _ P4) as [x Q2].
    apply ex_nempty.
    exists (f⁻¹[x]).
    apply image_i.
    exists x.
    split.
    + apply fval_i2.
      - apply inv_fn.
        apply (bij_sing_rot _ _ _ P2).
      - apply (eq_cr (λ y, x ∈ y) (inv_dom f)).
        apply (eq_cr (λ y, x ∈ y) (bij_ran _ _ _ P2)).
        apply (P3 _ Q2).
    + apply Q2. }
  destruct (P1 _ Q1 Q2) as [x [Q3 Q4]].
  exists (f[x]).
  split.
  + destruct (image_e _ _ _ Q3) as [y [Q5 Q6]].
    apply (eq_cr (λ x, x ∈ C) (fval_i _ _ _ (bij_fn _ _ _ P2) (inv_e _ _ _ Q5))).
    apply Q6.
  + intros y P12.
    assert (f⁻¹[y] ∈ f⁻¹⟦C⟧) as P13.
    { apply image_i2.
      + apply inv_fn.
        apply (bij_sing_rot _ _ _ P2).
      + apply (eq_cr (λ x, y ∈ x) (inv_dom f)).
        apply (eq_cr (λ x, y ∈ x) (bij_ran _ _ _ P2)).
        apply (P3 _ P12).
      + apply P12. }
    destruct (bij_e _ _ _ P2) as  [_ P10].
    destruct (Q4 _ P13) as [Q5 | Q5].
    - left.
      assert (y ∈ ran(f)) as Q6.
      { apply (eq_cr (λ x, y ∈ x) (bij_ran _ _ _ P2)).
        apply (P3 _ P12). }
      apply (eq_cl (λ y, f[x] <[S] y) (inv_fval_cancel2 _ _ _ _ P10 Q6)).
      apply P5.
      * apply (eq_cl (λ y, x ∈ y) (bij_dom _ _ _ P2)).
        destruct (image_e _ _ _ Q3) as [s [Q8 _]].
        apply (dom_i _ _ _ (inv_e _ _ _ Q8)).
      * apply (eq_cl (λ x, (inv f)[y] ∈ x) (bij_dom _ _ _ P2)).
        apply (eq_cl (λ x, (inv f)[y] ∈ x) (inv_ran f)).
        apply fval_ran.
        ++apply inv_fn.
          apply (bij_sing_rot _ _ _ P2).
        ++apply (eq_cr (λ x, y ∈ x) (inv_dom f)).
          apply Q6.
      * apply Q5.
    - right.
      apply (eq_cr (λ x, f[x] = y) Q5).
      apply (inv_fval_cancel2 _ _ _ _ P10).
      apply (eq_cr (λ x, y ∈ x) (bij_ran _ _ _ P2)).
      apply (P3 _ P12).
Qed.

Lemma isom_po: ∀ R, ∀ A, ∀ S, ∀ B, po R A → isom R A S B → po S B.
Proof.
  intros R A S B [P1 P2] P3.
  split.
  + apply (isom_r_trans _ _ _ _ P1 P3).
  + apply (isom_r_irrefl _ _ _ _ P2 P3).
Qed.

Lemma isom_lo: ∀ R, ∀ A, ∀ S, ∀ B, lo R A → isom R A S B → lo S B.
Proof.
  intros R A S B [P1 P2] P3.
  split.
  + apply (isom_r_trans _ _ _ _ P1 P3).
  + apply (isom_tricho _ _ _ _ P2 P3).
Qed.

Lemma isom_wo: ∀ R, ∀ A, ∀ S, ∀ B, wo R A → isom R A S B → wo S B.
Proof.
  intros R A S B [P1 P2] P3.
  split.
  + apply (isom_lo _ _ _ _ P1 P3).
  + apply (isom_least_prop _ _ _ _ P2 P3).
Qed.

Lemma isom_bij_ex_rel: ∀ R, ∀ A, ∀ B, ∀ F, F ∈ A ↦ᵇ B
  → ∃ S, S ⊆ B ⨉ B ∧ isom R A S B.
Proof.
  intros R A B F P1.
  pose ({x: B ⨉ B| ∃ a1, ∃ a2, a1 ∈ A ∧ a2 ∈ A ∧ ⟨a1, a2⟩ ∈ R ∧
    x = ⟨F[a1], F[a2]⟩}) as S.
  exists S.
  split.
  + apply sub_e1.
  + exists F.
    split.
    - apply P1.
    - split.
      * intros x y Q1 Q2 Q3.
        apply sub_i.
        ++apply cp_i.
          --apply (fval_codom _ _ _ _ (bij_fmap _ _ _ P1) Q1).
          --apply (fval_codom _ _ _ _ (bij_fmap _ _ _ P1) Q2).
        ++exists x.
          exists y.
          repeat split.
          --apply Q1.
          --apply Q2.
          --apply Q3.
      * intros x y Q1 Q2 Q3.
        destruct (sub_e _ _ _ Q3) as [_ [x' [y' [Q4 [Q5 [Q6 Q7]]]]]].
        destruct (bij_e _ _ _ P1) as [_ Q8].
        apply (eq_cr (λ x, ⟨x, y⟩ ∈ R)
          (fval_inj _ _ _ _ _ Q8 Q1 Q4 (opair_eq_el _ _ _ _ Q7))).
        apply (eq_cr (λ y, ⟨x', y⟩ ∈ R)
          (fval_inj _ _ _ _ _ Q8 Q2 Q5 (opair_eq_er _ _ _ _ Q7))).
        apply Q6.
Qed.
(*----------------------------------------------------------------------------*)


Set Implicit Arguments.
Require Import Arith.
Require Import CpdtTactics.
Inductive color : Set := Red | Black.
Inductive rbtree : color -> nat -> Set :=
| Leaf : rbtree Black 0
| RedNode : forall n, rbtree Black n -> nat -> rbtree Black n -> rbtree Red n
| BlackNode : forall c1 c2 n, rbtree c1 n -> nat -> rbtree c2 n -> rbtree Black (S n).

Require Import Max Min.
Section depth.
  Variable f : nat -> nat -> nat.

  Fixpoint depth c n (t : rbtree c n) : nat :=
    match t with
      | Leaf => 0
      | RedNode _ t1 _ t2 => S (f (depth t1) (depth t2))
      | BlackNode _ _ _ t1 _ t2 => S (f (depth t1) (depth t2))
    end.
End depth.

Theorem depth_min : forall c n (t : rbtree c n), depth min t >= n.
  induction t; crush;
    match goal with
      | [ |- context[min ?X ?Y] ] => destruct (min_dec X Y)
    end; crush.
Qed.

Lemma depth_max' : forall c n (t : rbtree c n), match c with
                                                  | Red => depth max t <= 2 * n + 1
                                                  | Black => depth max t <= 2 * n
                                                end.
  induction t; crush;
    match goal with
      | [ |- context[max ?X ?Y] ] => destruct (max_dec X Y)
    end; crush;
    repeat (match goal with
              | [ H : context[match ?C with Red => _ | Black => _ end] |- _ ] =>
                destruct C
            end; crush).
Qed.

Theorem depth_max : forall c n (t : rbtree c n), depth max t <= 2 * n + 1.
  intros; generalize (depth_max' t); destruct c; crush.
Qed.

Theorem balanced : forall c n (t : rbtree c n), 2 * depth min t + 1 >= depth max t.
  intros; generalize (depth_min t); generalize (depth_max t); crush.
Qed.

Inductive rtree : nat -> Set :=
| RedNode' : forall c1 c2 n, rbtree c1 n -> nat -> rbtree c2 n -> rtree n.

Section present.
  Variable x : nat.

  Fixpoint present c n (t : rbtree c n) : Prop :=
    match t with
      | Leaf => False
      | RedNode _ a y b => present a \/ x = y \/ present b
      | BlackNode _ _ _ a y b => present a \/ x = y \/ present b
    end.

  Definition rpresent n (t : rtree n) : Prop :=
    match t with
      | RedNode' _ _ _ a y b => present a \/ x = y \/ present b
    end.
End present.

Notation "{< x >}" := (existT _ _ x).

Definition balance1 n (a : rtree n) (data : nat) c2 :=
  match a in rtree n return rbtree c2 n
    -> { c : color & rbtree c (S n) } with
    | RedNode' _ c0 _ t1 y t2 =>
      match t1 in rbtree c n return rbtree c0 n -> rbtree c2 n
        -> { c : color & rbtree c (S n) } with
        | RedNode _ a x b => fun c d =>
          {<RedNode (BlackNode a x b) y (BlackNode c data d)>}
        | t1' => fun t2 =>
          match t2 in rbtree c n return rbtree Black n -> rbtree c2 n
            -> { c : color & rbtree c (S n) } with
            | RedNode _ b x c => fun a d =>
              {<RedNode (BlackNode a y b) x (BlackNode c data d)>}
            | b => fun a t => {<BlackNode (RedNode a y b) data t>}
          end t1'
      end t2
  end.

Definition balance2 n (a : rtree n) (data : nat) c2 :=
  match a in rtree n return rbtree c2 n -> { c : color & rbtree c (S n) } with
    | RedNode' _ c0 _ t1 z t2 =>
      match t1 in rbtree c n return rbtree c0 n -> rbtree c2 n
        -> { c : color & rbtree c (S n) } with
        | RedNode _ b y c => fun d a =>
          {<RedNode (BlackNode a data b) y (BlackNode c z d)>}
        | t1' => fun t2 =>
          match t2 in rbtree c n return rbtree Black n -> rbtree c2 n
            -> { c : color & rbtree c (S n) } with
            | RedNode _ c z' d => fun b a =>
              {<RedNode (BlackNode a data b) z (BlackNode c z' d)>}
            | b => fun a t => {<BlackNode t data (RedNode a z b)>}
          end t1'
      end t2
  end.

Section insert.
  Variable x : nat.

  (** Most of the work of insertion is done by a helper function [ins], whose return types are expressed using a type-level function [insResult]. *)

  Definition insResult c n :=
    match c with
      | Red => rtree n
      | Black => { c' : color & rbtree c' n }
    end.

  (** That is, inserting into a tree with root color [c] and black depth [n], the variety of tree we get out depends on [c].  If we started with a red root, then we get back a possibly invalid tree of depth [n].  If we started with a black root, we get back a valid tree of depth [n] with a root node of an arbitrary color.

     Here is the definition of [ins].  Again, we do not want to dwell on the functional details. *)

  Fixpoint ins c n (t : rbtree c n) : insResult c n :=
    match t with
      | Leaf => {< RedNode Leaf x Leaf >}
      | RedNode _ a y b =>
        if le_lt_dec x y
          then RedNode' (projT2 (ins a)) y b
          else RedNode' a y (projT2 (ins b))
      | BlackNode c1 c2 _ a y b =>
        if le_lt_dec x y
          then
            match c1 return insResult c1 _ -> _ with
              | Red => fun ins_a => balance1 ins_a y b
              | _ => fun ins_a => {< BlackNode (projT2 ins_a) y b >}
            end (ins a)
          else
            match c2 return insResult c2 _ -> _ with
              | Red => fun ins_b => balance2 ins_b y a
              | _ => fun ins_b => {< BlackNode a y (projT2 ins_b) >}
            end (ins b)
    end.

  (** The one new trick is a variation of the convoy pattern.  In each of the last two pattern matches, we want to take advantage of the typing connection between the trees [a] and [b].  We might %\%naive%{}%ly apply the convoy pattern directly on [a] in the first [match] and on [b] in the second.  This satisfies the type checker per se, but it does not satisfy the termination checker.  Inside each [match], we would be calling [ins] recursively on a locally bound variable.  The termination checker is not smart enough to trace the dataflow into that variable, so the checker does not know that this recursive argument is smaller than the original argument.  We make this fact clearer by applying the convoy pattern on _the result of a recursive call_, rather than just on that call's argument.

     Finally, we are in the home stretch of our effort to define [insert].  We just need a few more definitions of non-recursive functions.  First, we need to give the final characterization of [insert]'s return type.  Inserting into a red-rooted tree gives a black-rooted tree where black depth has increased, and inserting into a black-rooted tree gives a tree where black depth has stayed the same and where the root is an arbitrary color. *)

  Definition insertResult c n :=
    match c with
      | Red => rbtree Black (S n)
      | Black => { c' : color & rbtree c' n }
    end.

  (** A simple clean-up procedure translates [insResult]s into [insertResult]s. *)

  Definition makeRbtree c n : insResult c n -> insertResult c n :=
    match c with
      | Red => fun r =>
        match r with
          | RedNode' _ _ _ a x b => BlackNode a x b
        end
      | Black => fun r => r
    end.

  (** We modify Coq's default choice of implicit arguments for [makeRbtree], so that we do not need to specify the [c] and [n] arguments explicitly in later calls. *)

  Implicit Arguments makeRbtree [c n].

  (** Finally, we define [insert] as a simple composition of [ins] and [makeRbtree]. *)

  Definition insert c n (t : rbtree c n) : insertResult c n :=
    makeRbtree (ins t).

  (** As we noted earlier, the type of [insert] guarantees that it outputs balanced trees whose depths have not increased too much.  We also want to know that [insert] operates correctly on trees interpreted as finite sets, so we finish this section with a proof of that fact. *)

  Section present.
    Variable z : nat.

    (** The variable [z] stands for an arbitrary key.  We will reason about [z]'s presence in particular trees.  As usual, outside the section the theorems we prove will quantify over all possible keys, giving us the facts we wanted.

       We start by proving the correctness of the balance operations.  It is useful to define a custom tactic [present_balance] that encapsulates the reasoning common to the two proofs.  We use the keyword %\index{Vernacular commands!Ltac}%[Ltac] to assign a name to a proof script.  This particular script just iterates between [crush] and identification of a tree that is being pattern-matched on and should be destructed. *)

    Ltac present_balance :=
      crush;
      repeat (match goal with
                | [ _ : context[match ?T with Leaf => _ | _ => _ end] |- _ ] =>
                  dep_destruct T
                | [ |- context[match ?T with Leaf => _ | _ => _ end] ] => dep_destruct T
              end; crush).

    (** The balance correctness theorems are simple first-order logic equivalences, where we use the function [projT2] to project the payload of a [sigT] value. *)

    Lemma present_balance1 : forall n (a : rtree n) (y : nat) c2 (b : rbtree c2 n),
      present z (projT2 (balance1 a y b))
      <-> rpresent z a \/ z = y \/ present z b.
      destruct a; present_balance.
    Qed.

    Lemma present_balance2 : forall n (a : rtree n) (y : nat) c2 (b : rbtree c2 n),
      present z (projT2 (balance2 a y b))
      <-> rpresent z a \/ z = y \/ present z b.
      destruct a; present_balance.
    Qed.

    (** To state the theorem for [ins], it is useful to define a new type-level function, since [ins] returns different result types based on the type indices passed to it.  Recall that [x] is the section variable standing for the key we are inserting. *)

    Definition present_insResult c n :=
      match c return (rbtree c n -> insResult c n -> Prop) with
        | Red => fun t r => rpresent z r <-> z = x \/ present z t
        | Black => fun t r => present z (projT2 r) <-> z = x \/ present z t
      end.

    (** Now the statement and proof of the [ins] correctness theorem are straightforward, if verbose.  We proceed by induction on the structure of a tree, followed by finding case analysis opportunities on expressions we see being analyzed in [if] or [match] expressions.  After that, we pattern-match to find opportunities to use the theorems we proved about balancing.  Finally, we identify two variables that are asserted by some hypothesis to be equal, and we use that hypothesis to replace one variable with the other everywhere. *)

    Theorem present_ins : forall c n (t : rbtree c n),
      present_insResult t (ins t).
      induction t; crush;
        repeat (match goal with
                  | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
                  | [ |- context[if ?E then _ else _] ] => destruct E
                  | [ _ : context[match ?C with Red => _ | Black => _ end]
                      |- _ ] => destruct C
                end; crush);
        try match goal with
              | [ _ : context[balance1 ?A ?B ?C] |- _ ] =>
                generalize (present_balance1 A B C)
            end;
        try match goal with
              | [ _ : context[balance2 ?A ?B ?C] |- _ ] =>
                generalize (present_balance2 A B C)
            end;
        try match goal with
              | [ |- context[balance1 ?A ?B ?C] ] =>
                generalize (present_balance1 A B C)
            end;
        try match goal with
              | [ |- context[balance2 ?A ?B ?C] ] =>
                generalize (present_balance2 A B C)
            end;
        crush;
          match goal with
            | [ z : nat, x : nat |- _ ] =>
              match goal with
                | [ H : z = x |- _ ] => rewrite H in *; clear H
              end
          end;
          tauto.
    Qed.

    (** The hard work is done.  The most readable way to state correctness of [insert] involves splitting the property into two color-specific theorems.  We write a tactic to encapsulate the reasoning steps that work to establish both facts. *)

    Ltac present_insert :=
      unfold insert; intros n t; inversion t;
        generalize (present_ins t); simpl;
          dep_destruct (ins t); tauto.

    Theorem present_insert_Red : forall n (t : rbtree Red n),
      present z (insert t)
      <-> (z = x \/ present z t).
      present_insert.
    Qed.

    Theorem present_insert_Black : forall n (t : rbtree Black n),
      present z (projT2 (insert t))
      <-> (z = x \/ present z t).
      present_insert.
    Qed.
  End present.
End insert.


Require Import ConstructiveEpsilon.
Module Enum_WO.
Definition Dec {X} (p : X -> Prop) := forall x : X, {p x} + {~p x}.
Definition Enum X := { g & forall x : X, exists n : nat, g n = Some x}.
Definition WO X := forall p : X -> Prop, Dec p -> ex p -> sigT p.
Definition WO_nat := constructive_indefinite_ground_description_nat.
(* Every enumerable type has a witness operator. *)
Lemma lemma X : Enum X -> WO X.
Proof.
  intros [g Hg] p Dec_p H.
  enough (exists n, match g n with Some x => p x | _ => False end) as [n Gn]%WO_nat.
  - destruct (g n); now eauto.
  - intros n. destruct (g n); auto.
  - destruct H as [x ], (Hg x) as [n Hn].
    exists n. now rewrite Hn.
Qed.
End Enum_WO.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Nat.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Inductive queue : Type :=
  | Queue : lst -> lst -> queue.

Fixpoint len (l : lst) : nat :=
match l with
  | Nil => 0
  | Cons a l1 => 1 + (len l1)
end.

Definition qlen (q : queue) : nat :=
match q with
  | Queue l1 l2 => (len l1) + (len l2)
end.

Fixpoint app (l : lst) (m: lst): lst :=
match l with
  | Nil => m
  | Cons a l1 => Cons a (app l1 m)
end.

Fixpoint rev (l: lst): lst :=
match l with
  | Nil => Nil
  | Cons a l1 => app (rev l1) (Cons a Nil)
end.

Fixpoint leb (n m : nat) : bool :=
match (n, m) with
  | (0, _) => true
  | (S n', S m') => leb n' m'
  | _ => false
end.

Definition amortizeQueue (l1 l2 : lst) : queue :=
  if leb (len l2)  (len l1) then Queue l1 l2
  else Queue (app l1 (rev l2)) Nil.

Definition qpush (q : queue) (n : nat) : queue :=
match q with
  | Queue l1 l2 => amortizeQueue l1 (Cons n l2)
end.

Lemma len_app : forall l1 l2, len (app l1 l2) = (len l1) + (len l2).
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Lemma plus_comm: forall m n, m + n = n + m.
Proof.
induction m.
- intros. simpl. rewrite <- plus_n_O. reflexivity.
- intros. simpl. rewrite IHm. rewrite plus_n_Sm. reflexivity.
Qed.

Lemma len_rev : forall l, len (rev l) = len l.
Proof.
induction l.
- reflexivity.
- simpl. rewrite len_app. simpl. lfind. Admitted.


(******************************************************************************)
(*   Copyright (c) 2019--2022 - Paulo Torrens <paulotorrens AT gnu DOT org>   *)
(******************************************************************************)

Require Import Lia.
Require Export List.
Require Import Arith.
Require Import Equality.
Import ListNotations.

(** To help proof automation, create a hint database. *)

Create HintDb cps.

(** A lot of proofs on pseudoterm lists may be solved by simple induction on the
    [Forall P] proposition over them, so we'll add a tactic for that. *)

Tactic Notation "list" "induction" "over" hyp(H) :=
  induction H; simpl;
  [ reflexivity
  | f_equal; auto ].

(** A predicate indicating an object is the nth element of a list. *)

Inductive item {T} (e: T): list T -> nat -> Prop :=
  | item_car:
    forall cdr,
    item e (e :: cdr) 0
  | item_cdr:
    forall car cdr n,
    item e cdr n -> item e (car :: cdr) (S n).

Global Hint Constructors item: cps.

Lemma item_ignore_head:
  forall {T} xs x ys k,
  k >= length xs ->
  @item T x (xs ++ ys) k -> @item T x ys (k - length xs).
Proof.
  induction xs; intros.
  - simpl in H0 |- *.
    rewrite Nat.sub_0_r.
    assumption.
  - simpl in H, H0 |- *.
    destruct k.
    + exfalso.
      inversion H.
    + inversion_clear H0.
      apply IHxs; auto.
      lia.
Qed.

Lemma item_ignore_tail:
  forall {T} xs x ys k,
  length xs > k ->
  @item T x (xs ++ ys) k -> @item T x xs k.
Proof.
  induction xs; intros.
  - inversion H.
  - simpl in H, H0 |- *.
    destruct k.
    + inversion_clear H0; auto.
      constructor.
    + inversion_clear H0.
      constructor.
      eapply IHxs; eauto.
      lia.
Qed.

Lemma item_insert_head:
  forall {T} xs ys x k,
  @item T x ys k -> @item T x (xs ++ ys) (k + length xs).
Proof.
  induction xs; simpl; intros.
  - rewrite Nat.add_0_r.
    assumption.
  - replace (k + S (length xs)) with (S (k + length xs)); try lia.
    constructor; auto.
Qed.

Lemma item_insert_tail:
  forall {T} xs ys x k,
  @item T x xs k -> @item T x (xs ++ ys) k.
Proof.
  induction 1.
  - constructor.
  - constructor; auto.
Qed.

Lemma item_valid_index:
  forall {T} x xs k,
  @item T x xs k ->
  k < length xs.
Proof.
  induction 1; simpl; auto with arith.
Qed.

Lemma item_exists:
  forall {T} xs k,
  k < length xs ->
  exists x,
  @item T x xs k.
Proof.
  induction xs; intros.
  - inversion H.
  - destruct k.
    + exists a.
      constructor.
    + destruct IHxs with k.
      * simpl in H; lia.
      * exists x.
        constructor.
        assumption.
Qed.

Lemma item_repeat:
  forall {T} x y k p,
  @item T x (repeat y k) p ->
  x = y.
Proof.
  induction k; intros.
  - inversion H.
  - destruct p.
    + inversion H; auto.
    + inversion H; eauto.
Qed.

Lemma nth_item:
  forall {T} x xs y k,
  @item T x xs k -> nth k xs y = x.
Proof.
  induction 1; simpl.
  - reflexivity.
  - assumption.
Qed.

Lemma item_nth:
  forall {T} x xs y k,
  nth k xs y = x ->
  x <> y ->
  @item T x xs k.
Proof.
  induction xs; intros.
  - destruct k; simpl in H; congruence.
  - destruct k; simpl in H.
    + rewrite H.
      constructor.
    + constructor.
      apply IHxs with y; auto.
Qed.

Lemma item_rev:
  forall {T} x xs k,
  @item T x xs k ->
  @item T x (rev xs) (length xs - S k).
Proof.
  induction xs; simpl; intros.
  - inversion H.
  - destruct k.
    * dependent destruction H.
      replace (length xs - 0) with (0 + length xs); try lia.
      rewrite <- rev_length.
      apply item_insert_head.
      constructor.
    * dependent destruction H.
      apply item_insert_tail.
      apply IHxs; auto.
Qed.

Lemma Forall2_length:
  forall {A} {B} R xs ys,
  @Forall2 A B R xs ys ->
  length xs = length ys.
Proof.
  induction 1; simpl; lia.
Qed.

Section SetoidFix.

  (* The code in this section is taken from coq-ext-lib and slightly adapted;
     the original is on GitHub: https://github.com/coq-community/coq-ext-lib. *)

  Variable A: Type.
  Variable R: A -> A -> Prop.
  Variable Rwf: well_founded R.
  Variable P: A -> Type.
  Variable F: forall x, (forall y, R y x -> P y) -> P x.
  Variable r: forall x, P x -> P x -> Prop.

  Hypothesis Hstep:
    forall x f g,
    (forall y p, r y (f y p) (g y p)) ->
    r x (@F x f) (@F x g).

  Lemma Fix_F_equiv_inv:
    forall x r' s',
    r x (Fix_F _ F r') (Fix_F _ F s').
  Proof.
    intros.
    induction (Rwf x).
    rewrite <- (Fix_F_eq _ F r').
    rewrite <- (Fix_F_eq _ F s').
    apply Hstep; auto.
  Qed.

  Theorem Fix_equiv:
    forall x,
    r x (Fix Rwf P F x) (@F x (fun y _ => Fix Rwf P F y)).
  Proof.
    intros.
    unfold Fix.
    rewrite <- Fix_F_eq.
    apply Hstep; intros.
    apply Fix_F_equiv_inv.
  Qed.

End SetoidFix.