(*-------------Description ------------------------------------------------------

This file implements maps on lists. Here we define functions to calculate range
of a function on list l. We also define one-one function predicate and its boolean
counterpart.

Following are the notions defined in this file:

 s_map f l                  : range set of f on list l
 one_one_on l f             : f is one one on l
 one_one_onb l f            : boolean counterpart of (one_one_on l f)

Lemma one_one_onP (l:list A) (f: A->B)(Hl: NoDup l):
    reflect (one_one_on l f)(one_one_onb l f).

Furthermore, we have results relating the cardinality of domain and range
for various kinds of functions (many one/one one).

---------------------------------------------------------------------------------*)

Require Export SetReflect.
Require Export OrdList.
Require Export OrdSet.

Set Implicit Arguments.

Section Set_maps.
  Context { A B: ordType }.

  Lemma EM_A: forall x y: A, x=y \/  x<>y.
  Proof.  eauto.  Qed.
  Lemma EM_B: forall x y:B, x=y \/ x<>y.
  Proof. eauto.  Qed.

  Fixpoint img (f:A->B) (l:list A): list B:= match l with
                                        | nil => nil
                                        | a1::l1 => add (f a1) (img f l1)
                                              end.

  Lemma IsOrd_img (f:A->B) (l:list A):  IsOrd (img f l).
  Proof. { induction l. simpl. constructor. simpl. eauto. } Qed.

  Lemma NoDup_img (f:A->B) (l:list A):  NoDup (img f l).
    Proof. cut (IsOrd (img f l)). eauto. apply IsOrd_img. Qed.

  Lemma img_intro1(f: A->B)(l: list A)(a:A)(y: B): In y (img f l)-> In y (img f (a::l)).
    Proof. simpl. eapply set_add_intro1. Qed.
  Lemma img_intro2 (f: A->B)(l: list A)(x:A): In x l -> In (f x) (img f l).
  Proof.  { induction l. simpl.  tauto.
          cut (x=a \/ x <> a).
          intro H;destruct H as [Hl | Hr].
          { intro H. rewrite Hl. simpl. eapply set_add_intro2. auto. }
          { intro H. cut (In x l). intro H1. eapply img_intro1;eauto.
            eapply in_inv2;eauto.  } eauto. } Qed.

  Lemma img_elim (f:A->B) (l: list A)(a0:A)(fa:B): In (fa) (img f (a0::l))->
                                                    fa = f(a0) \/ In fa (img f l).
    Proof. simpl. eapply set_add_elim. Qed.

  Lemma img_elim2 (f:A->B) (l: list A)(a0:A)(fa:B): In (fa) (img f (a0::l))->
                                                   fa <> f(a0) -> In fa (img f l).
  Proof. simpl. eapply set_add_elim2.  Qed.

  Lemma img_elim3 (f:A->B)(l:list A)(a:A): ~ In a l -> In (f a) (img f l) ->
                                           (exists y, In y l /\ f a = f y).
  Proof. { intros H H1. induction l. inversion H1.
         assert (H2: ~ In a l). intro H2; apply H. simpl;tauto.
         cut ( f a = f a0 \/ f a <> f a0 ). intro H3; destruct H3 as [H3a | H3b]. exists a0.
         split; auto. assert (H4: In (f a) (img f l)). eapply img_elim2.
         eapply H1. exact H3b. assert (H5: exists y : A, In y l /\ f a = f y). eauto.
         destruct H5 as [y0 H5]. exists y0. split;  simpl. tauto. tauto.
         eapply EM_B. } Qed.
  Lemma img_elim4 (f: A->B)(l: list A)(b:B): In b (img f l)-> (exists a, In a l /\ b = f a).
  Proof. { induction l.
         { simpl. tauto. }
         { intro H. apply img_elim in H as H1. destruct H1.
           { exists a. split;auto. }
           { apply IHl in H0 as H1.
             destruct H1 as [a' H1]; destruct H1 as [H1 H2].
             exists a'. split;auto. } } } Qed.

  Hint Resolve IsOrd_img NoDup_img : core.
  Hint Resolve img_intro1 img_intro2 img_elim: core.
  Hint Resolve img_elim2 img_elim3 img_elim4: core.

  Lemma funP (f: A->B)(x y: A): f x <> f y -> x <> y.
  Proof. intros H H1. apply H;rewrite H1; auto. Qed.

  Definition one_one (f: A->B): Prop:= forall x y, x <> y -> f x <> f y.

  Lemma one_oneP1 (f:A->B): one_one f -> forall x y, f x = f y -> x =y.
  Proof. { unfold one_one;intros H x y H1. elim (EM_A x y). tauto.
           intro H2; absurd (f x = f y); auto. } Qed.

  Hint Immediate one_oneP1: core.

  Definition one_one_on (l: list A) (f: A-> B):Prop:= forall x y, In x l-> In y l ->  x<>y -> f x <> f y.

  Lemma one_one_on_elim (l:list A)(f: A-> B): one_one_on l f ->
                                         (forall x y, In x l-> In y l-> f x = f y -> x = y).
  Proof. { unfold one_one_on. intros H x y H1 H2. elim (EM_A x y). tauto.
           intros H3 H4. absurd (f x = f y); auto. } Qed.
  Lemma one_one_on_intro(l:list A)(f: A-> B): (forall x y, In x l-> In y l-> f x = f y -> x = y) ->
                                         (one_one_on l f).
  Proof. { intros H.  unfold one_one_on.
         intros x y H1 H2 H3 H4. apply H3. auto. } Qed.

  Lemma one_one_on_nil (f:A->B): one_one_on nil f.
  Proof. unfold one_one_on. intros x y H H0 H1 H2. inversion H. Qed.

  Lemma one_one_on_intro1(l:list A) (f: A->B)(a:A):
             (~ In (f a) (img f l)) -> (one_one_on l f) -> one_one_on (a::l) f.
  Proof. { unfold one_one_on. intros H H1.
         intros x y H2 H3. destruct H2; destruct H3.
         rewrite <- H0; rewrite <- H2.  tauto.
         rewrite <- H0. intros H3 H4. assert (H5: In (f a) (img f l)). rewrite H4.
         apply img_intro2;auto. absurd (In (f a) (img f l)); assumption.
         rewrite <- H2. intros H3 H4. absurd (In (f a) (img f l)). assumption.
         rewrite <- H4. apply img_intro2;auto. apply H1; auto. } Qed.

  Lemma one_one_on_elim1 (l:list A) (f: A->B)(a: A): one_one_on (a::l) f -> one_one_on l f.
  Proof. { unfold one_one_on.  intro H. intros x y H1 H2. eapply H; auto. } Qed.

  Lemma one_one_on_elim2 (l:list A) (f: A->B)(a: A)(Hl: NoDup (a::l)):
    one_one_on (a::l) f -> ~ In (f a)(img f l).
  Proof. { unfold one_one_on.  intros H H1.
         assert (H2: (exists y, In y l /\ f a = f y)).
         { eapply img_elim3. intro H2; inversion Hl;contradiction. auto. }
         destruct H2 as [b H2]; destruct H2 as [H2 H3].
         eapply H with (x:=a)(y:=b); auto. intro H4. rewrite <- H4 in H2.
         inversion Hl;contradiction. } Qed.

  Hint Immediate one_one_on_nil one_one_on_elim one_one_on_elim1 one_one_on_elim2 : core.
  Hint Immediate one_one_on_intro one_one_on_intro1: core.

  Fixpoint one_one_onb (l: list A) (f: A->B): bool:=
    match l with
    |nil => true
    | a1::l1 => (negb ( memb (f a1) (img f l1))) && (one_one_onb l1 f)
    end.

   Lemma one_one_onP (l:list A) (f: A->B)(Hl: NoDup l):
    reflect (one_one_on l f)(one_one_onb l f).
  Proof. { apply reflect_intro. split.
         { induction l.
           { unfold one_one_onb. reflexivity. }
           { intro H. simpl one_one_onb. apply /andP. split. cut (~ In (f a)(img f l)).
             intro H1. assert (H2:  memb (f a) (img f l) = false ). apply /membP.
             auto. rewrite H2. simpl. reflexivity. eapply one_one_on_elim2.
             apply Hl. auto. apply IHl.
             eauto. eauto. } }
         { induction l.
           { auto.  }
           { simpl. move /andP. intro H; destruct H as [H H1].
             apply one_one_on_intro1.
             intro H2. unfold negb in H.
             replace (memb (f a) (img f l)) with true in H. inversion H.
             symmetry; apply /membP; eauto. apply IHl. eauto. apply H1. } }  } Qed.

  (*--------- Some more properties of imgs-----------------------------------*)

  Lemma one_one_img_elim (l: list A)(f: A->B)(x: A):
    one_one f -> In (f x) (img f l) -> In x l.
  Proof. { intros H H1. assert (H2: exists a, In a l /\ f x = f a). auto.
         destruct H2 as [a H2]. destruct H2 as [H2 H3].
         cut (x = a). intros; subst x; auto. eauto. } Qed.

  Lemma img_subset (l s: list A)(f: A->B): l [<=] s -> (img f l) [<=] (img f s).
  Proof. { intros H fx H1. assert (H2: exists x, In x l /\ fx = f x). auto.
         destruct H2 as [x H2]. destruct H2 as [H2 H3]. subst fx; auto. } Qed.

  Lemma img_size_less (l: list A)(f: A->B): |img f l| <= |l|.
  Proof.  { induction l.
          { simpl;auto. }
          { simpl. assert (H: (| add (f a) (img f l) |) <= S (| img f l |)).
            auto. omega. } } Qed.

  Lemma img_size_same (l: list A)(f: A->B): NoDup l -> one_one_on l f-> |l|=| img f l|.
  Proof.  { induction l.
          { simpl. auto. }
          { intros H H1.
            assert (Hl: NoDup l). eauto.
            assert (H1a: one_one_on l f). eauto.
            assert (H2: (| l |) = (| img f l |)). auto.
            simpl. assert (H3: ~ In (f a) (img f l)). auto.
            rewrite H2; symmetry;auto. }  } Qed.

  Hint Resolve img_subset img_size_less img_size_same: core.

  Lemma img_strict_less (l: list A)(f: A->B):
    NoDup l -> (|img f l| < |l|) -> ~ one_one_on l f.
  Proof. intros H H1 H2. assert(H3: |l|=| img f l|). auto. omega. Qed.

  Hint Immediate one_one_img_elim  img_strict_less : core.

  Lemma one_one_on_intro2 (l: list A)(f: A->B):
    NoDup l -> (|img f l| = |l|)->  one_one_on l f.
  Proof.  { induction l.
          { simpl; auto. }
          { intros H H0.
            assert (Ha: NoDup l). eauto.
            assert (Hb: ~ In a l ). auto.
            assert (H1: |img f l| = |l|).
            { match_up  (| img f l |)  (| l |).
              { auto. }
              { assert ((| img f (a :: l) |) <b (| a :: l |)).
                { move /ltP in H1. apply /ltP. simpl.
                  cut ((| add (f a) (img f l) |) <= S (|img f l|)). omega.
                  auto. } by_conflict. }
              { assert (H2: |img f l| <= |l|). auto.
                move /lebP in H2. auto. } }
            assert (H2: one_one_on l f). auto.
            assert (H3: ~ In (f a) (img f l)).
            { intro H3.
              assert (H4: img f (a :: l) = (img f l)).
              { simpl. eapply add_same. auto. auto. }
              rewrite H4 in H0. rewrite H1 in H0. simpl in H0. omega. } auto. } } Qed.

  Lemma one_one_on_intro3 (l s: list A)(f: A-> B): s [<=] l -> one_one_on l f -> one_one_on s f.
  Proof. intros H0 H1; unfold one_one_on; auto. Qed.

  Hint Immediate one_one_on_intro2 one_one_on_intro3 : core.

  (* ------------ set maps and set add interaction ------------------------ *)

  Lemma img_add (a: A)(l: list A)(f: A-> B): img f (add a l) = add (f a) (img f l).
  Proof. { apply set_equal;auto.
         induction l.
         { simpl. auto. }
         {  simpl.
           assert (H:  img f (add a l) = add (f a) (img f l)).
           apply set_equal; auto.
           destruct IHl as [IHl IHl1].  match_up a  a0.
           { subst a. simpl. auto. }
           { simpl. auto. }
           { simpl. rewrite H. auto. } }  } Qed.

  Lemma img_same (l: list A) (f g: A->B): (forall x, In x l -> f x = g x)-> (img f l = img g l).
  Proof. {  induction l.
         { simpl; auto. }
         { intro h1. simpl. replace (g a) with (f a). replace (img g l) with (img f l).
           auto. apply IHl. intros x h2. apply h1; auto. apply h1; auto. } } Qed.

  Hint Resolve img_add img_same: core.

  Lemma img_inter1 (l s: list A)(f: A-> B): img f (l [i] s) [<=] (img f l) [i] (img f s).
  Proof. Admitted.
  Lemma img_inter2 (l s: list A)(f: A-> B): one_one_on l f -> one_one_on s f->
                                             img f (l [i] s) = (img f l) [i] (img f s).
  Proof. Admitted.

  Lemma img_union (l s: list A)(f: A-> B): img f (l [u] s) = (img f l) [u] (img f s).
  Proof. Admitted.

  Lemma img_diff (l s: list A)(f: A-> B): one_one_on l f -> one_one_on s f->
                                           img f (l [\] s) = (img f l) [\] (img f s).
  Proof. Admitted.

  Hint Resolve img_inter1 img_inter2 img_union img_diff: core.

End Set_maps.

Hint Resolve IsOrd_img NoDup_img : core.
Hint Resolve img_intro1 img_intro2 img_elim: core.
Hint Resolve img_elim2 img_elim3 img_elim4 : core.
Hint Immediate one_oneP1: core.
Hint Immediate one_one_on_nil one_one_on_elim one_one_on_elim1 one_one_on_elim2 : core.
Hint Immediate one_one_on_intro one_one_on_intro1: core.
Hint Resolve one_one_onP: core.

Hint Resolve img_subset img_size_less img_size_same: core.
Hint Immediate one_one_img_elim img_strict_less : core.

Hint Immediate one_one_on_intro2 one_one_on_intro3 : core.

Hint Resolve img_add img_same: core.

Hint Resolve img_inter1 img_inter2 img_union img_diff: core.

Section Map_composition.

  Context {A B C: ordType}.

  (*-------------------------  A  --f-->  B  --g-->  C    --------------------------------*)

  Lemma range_of_range (l:list A)(f: A->B)(g: B->C):
    img g (img f l) = img ( fun x => g (f x)) l.
  Proof. { assert (H: Equal  (img g (img f l)) (img ( fun x => g (f x)) l) ).
         { unfold Equal.
           split.
           { unfold Subset. intros c Hc.
             assert (Hb: exists b, In b (img f l) /\ c = g b). auto.
             destruct Hb as [b Hb]. destruct Hb as [Hb Hb1].
             assert (Ha: exists a, In a l /\ b = f a). auto.
             destruct Ha as [a Ha]. destruct Ha as [Ha Ha1].
             rewrite Hb1. set (gf := (fun x : A => g (f x))).
             rewrite Ha1.
             assert (H: (g (f a)) = (gf a)). unfold gf. auto.
             rewrite H. eapply img_intro2. auto. }
           { unfold Subset. intros c Hc.
             assert (Ha: exists a, In a l /\ c = g (f a)). auto.
             destruct Ha as [a Ha]. destruct Ha as [Ha1 Ha2].
             subst c. auto. } }  auto. } Qed.

  Hint Resolve range_of_range: core.
End Map_composition.

Hint Resolve range_of_range: core.

Section Maps_on_A.
  Context {A: ordType}.

    (*----------Identity map and its properties ---------------------------------*)

  Definition id:= fun (x:A)=> x.

  Lemma id_is_identity1 (l:list A) : l [=] img id l.
  Proof.  { induction l.
          { simpl. auto. }
          { simpl.  split.
           { intros x h. destruct h as [h | h].
             subst a. unfold id. auto.
             cut (In x (img id l)). auto.  apply IHl. auto. }
           { unfold id. fold id. intros x h.
             cut (x=a \/ In x (img id l)).
             intro h1. destruct h1 as [h1a | h1b].
             subst x. all: auto. cut (In x l). auto. apply IHl. auto. } } }  Qed.

  Lemma id_is_identity (l:list A)(hl: IsOrd l): l = img id l.
  Proof. { induction l.
         { simpl. auto. }
         { apply set_equal. auto. auto.
           simpl. replace (img id l) with l.
           split.
           { intros x h. destruct h as [h | h].
             subst a. unfold id. auto. unfold id. auto. }
           { unfold id. intros x h. cut (x=a \/ In x l).
             intro h1. destruct h1 as [h1a | h1b].
             subst x. all: auto. } eauto. } }  Qed.

  Hint Immediate id_is_identity id_is_identity1: core.

  End Maps_on_A.

  Hint Immediate id_is_identity id_is_identity1: core.


Require Export Chap4.

Definition symmetric {X} (R : relation X) :=
  forall x y, R x y -> R y x.

Theorem asym_imp_alio :
  forall {X} (R : relation X), asymmetrical R -> aliorelative R.
Proof.
  unfold asymmetrical. unfold aliorelative.
  intros. intro.
  remember H0. clear Heqr.
  generalize r.
  apply H. assumption.
Qed.

Definition many_many {X} (R : relation X) : Prop := True. (* tautology *)

(* page 47:
One-many relations may be defined as relations such that, if x has the
relation in question to y, there is no other term x' which also has the
relation to y.
*)
Definition one_many {X} (R : relation X) : Prop :=
  forall x y, R x y -> forall x', R x' y -> x = x'.

(*
Or, again, they may be defined as follows: Given two terms x and x',
the terms to which x has the given relation and those to which x' has
it have no member in common.
*)
Definition one_many' {X} (R : relation X) : Prop :=
  forall x x' y, R x y /\ R x' y -> x = x'.

(* Or, again, they may be defined as relations such that the relative *)
(*product of one of them and its converse implies identity, where the *)
(*“relative product” of two relations R and S is that relation which *)
(*holds between x and z when there is an intermediate term y, such *)
(*that x has the relation R to y and y has the relation S to z. *)

Inductive relative_product
          {X} (R: relation X) (S: relation X) : relation X :=
  | rp0 : forall x y, forall z, R x y -> S y z -> relative_product R S x z.

Inductive converse {X} (R : relation X) : relation X :=
  | cv0 : forall x y, R x y -> converse R y x.
Inductive id {X} : relation X :=
  | id0 : forall x, id x x.

Definition one_many'' {X} (R : relation X) : Prop :=
  forall x y, relative_product R (converse R) x y -> id x y.

(* I'll try to prove the equivalence between these three definitions *)

Theorem one_many_eqv1 :
  forall {X} (R : relation X), one_many R -> one_many' R.
Proof.
  unfold one_many. unfold one_many'.
  intros. inversion H0.
  apply H with y; assumption.
Qed.

Theorem one_many_eqv2 :
  forall {X} (R : relation X), one_many' R -> one_many R.
Proof.
  unfold one_many. unfold one_many'.
  intros.

  apply H with y. split; assumption.
Qed.

Lemma id_eqv : forall {X} (x:X) (y:X), x = y <-> id x y.
Proof.
  intros. split.
  intro. rewrite H. apply id0.
  intro. inversion H. reflexivity.
Qed.

(* I asked a question about this on stackoverflow:
   http://stackoverflow.com/q/25477855/1232832
*)

Definition my_one_many'' {X} (R : relation X) :=
  forall x y, R x y -> forall x', converse R y x' -> x = x'.

Lemma expand_one_many'' :
  forall {X} (R : relation X),
    one_many'' R <-> my_one_many'' R.
Proof.
  intros. unfold one_many''. unfold my_one_many''. split.

  intros.
  assert (relative_product R (converse R) x x' -> id x x'). apply H.

  apply id_eqv. apply H2.
  apply rp0 with y. assumption. assumption.

  intros.
  inversion H0. subst.
  apply id_eqv. apply H with y0.
  assumption. assumption.
Qed.

Theorem one_many_eqv3 :
  forall {X} (R : relation X), one_many R -> my_one_many'' R.
Proof.
  unfold my_one_many''. unfold one_many.
  intros.
  inversion H1. subst. clear H1.
  apply H with y; assumption.
Qed.

Theorem one_many_eqv4 :
  forall {X} (R : relation X), my_one_many'' R -> one_many R.
Proof.
  unfold one_many; unfold my_one_many''.
  intros.
  apply H with y. assumption.
  apply cv0. assumption.
Qed.

Definition many_one {X} (R : relation X) : Prop :=
  forall x y, R x y -> forall y', R x y' -> y = y'.
Definition one_one {X} (R : relation X) : Prop :=
  many_one R /\ one_many R.

Inductive domain {X} (R : relation X) : X -> Prop :=
  | domain_intro : forall x y, R x y -> domain R x.
Inductive converse_domain {X} (R : relation X) : X -> Prop :=
  | converse_domain_intro : forall x y, R x y -> converse_domain R y.


From mathcomp Require Export all_ssreflect.
Require Export Classical.

Notation "∅" := set0.
Notation "x ∈ X" := (x \in X)(at level 50).
Notation "A ∩ B" := (setI A B)(at level 40).
Notation "A ∪ B" := (setU A B)(at level 40).
Notation "A ⊂ B" := (A \subset B)(at level 30).
Notation "A // B" := (setD A B)(at level 40).
Notation "¬ A" := (setC A)(at level 40).
Notation "pow[ A ]" := (powerset A).
Notation "⊓ X" := (\bigcap_(x in X) x) (at level 30).
Notation "⊔ X" := (\bigcup_(x in X) x) (at level 30).

Lemma bigUP {T : finType} (x : T) (X : {set {set T}}) :
    reflect (exists Y : {set T}, x ∈ Y /\ Y ∈ X)(x ∈ ⊔ X).
Proof.
    apply (iffP idP).
    +   move /bigcupP => [i iX xi]; exists i => //.
    +   move => [Y [xY YX]].
        apply /bigcupP; exists Y => //.
Qed.

Lemma bigIP {T : finType} (x : T) (X : {set {set T}}) :
    reflect (forall Y : {set T}, Y ∈ X -> x ∈ Y) (x ∈ ⊓ X).
Proof.
    apply (iffP idP).
    +   move /bigcapP => H Y YX; apply H => //.
    +   move => H; apply /bigcapP => Y YX; apply H => //.
Qed.

Lemma extension {T : finType} (A B : {set T}) :
    A ⊂ B -> B ⊂ A -> A = B.
Proof.
    move => AB BA; apply /setP /subset_eqP /andP => //.
Qed.


Require Export P04.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f x b.
  rewrite -> x.
  rewrite -> x.
  destruct b.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.


Require Export Bool.
Require Export ZArith.

Open Scope Z_scope.

Inductive Z_inf_branch_tree : Set :=
  Z_inf_leaf : Z_inf_branch_tree
| Z_inf_node : Z->(nat->Z_inf_branch_tree)->Z_inf_branch_tree.

Fixpoint any_true (n:nat)(f:nat->bool){struct n}:bool :=
 match n with
   0%nat => f 0%nat
 | S p => orb (f (S p)) (any_true p f)
 end.

Fixpoint izero_present (n:nat)(t:Z_inf_branch_tree) {struct t} :bool :=
 match t with
 | Z_inf_leaf => false
 | Z_inf_node v f =>
   match v with
   |  0 => true
   | _ => any_true n (fun p => izero_present n (f p))
   end
 end.


Require Import Arith.
Require Import ZFnats ZFwf ZFwfr.
Require Export ZF.

(** This file defines and develop the basic theory of ordinals in
    intuitionistic set theory. We use directed plump ordinals.
 *)

(** * Definition and elementary properties *)

(** Directed set (finite union) *)
Definition isDir o := forall x y,
  x < o -> y < o -> exists2 z, z < o & x ⊆ z /\ y ⊆ z.

Global Instance isDir_morph : Proper (eq_set==>iff) isDir.
do 2 red; intros; unfold isDir.
apply fa_morph; intros x0.
apply fa_morph; intros y0.
rewrite H.
apply fa_morph; intros _.
apply fa_morph; intros _.
apply ex2_morph; red; intros; auto with *.
rewrite H; reflexivity.
Qed.

(** Directed plump ordinals.

   Plumpness is the property that
   forall ordinal x s.t. z ⊆ y ∈ x, we have z ∈ x

   Since the plumpness property is not monotonic (if we have more
   ordinals, the plumpness requirement becomes tighter), we could
   not separate the directedness property from the plumpness one.

   Even if plumpness is not monotonic, it can be defined by recursion
   over the rank (since the rank of z is smaller than that of x). So
   we go by first defining well-founded sets (cf ZFwf.v), then
   well-founded, and finally define plumpness.
 *)

(** Any property could replace directedness *)
Local Notation Q:=isDir.
Local Notation Qm:=isDir_morph.

(** Not resorting to higher-order: *)

Section FirstOrder.

(** The set of plump ordinals included in ub, given [f] the sets of plump ordinals
    of smaller rank. *)
Let plump_set f ub :=
   subset (power ub)
    (fun x =>
      isWf x /\
      (forall y, y ∈ ub -> y ∈ x -> y ∈ f y) /\
      (forall z y, y ∈ ub -> z ∈ f y -> z ⊆ y -> y ∈ x -> z ∈ x) /\
      Q x).

Let R x y := isWf x /\ x ∈ y.

Local Instance Rmorph : Proper (eq_set==>eq_set==>iff) R.
unfold R; do 3 red; intros.
rewrite H,H0; reflexivity.
Qed.

Definition plumps := WFR R plump_set.

Let plumps_m :
  Proper ((eq_set ==> eq_set) ==> eq_set ==> eq_set) plump_set.
do 3 red; intros; unfold plump_set.
apply subset_morph.
 apply power_morph; trivial.

 red; intros.
 apply and_iff_morphism; auto with *.
 apply and_iff_morphism.
  apply fa_morph; intros yy.
  rewrite <- H0.
  rewrite (H _ _ (reflexivity _)); reflexivity.

  apply and_iff_morphism; auto with *.
  apply fa_morph; intros zz.
  apply fa_morph; intros yy.
  rewrite H0; rewrite (H _ _ (reflexivity _)); reflexivity.
Qed.

Let isWf_accR x : isWf x -> Acc R x.
intros.
apply isWf_ind with (2:=H); intros.
constructor; destruct 1; auto.
Qed.

Let plump_eqn ub x :
  isWf ub ->
  (x ∈ plumps ub <->
   x ⊆ ub /\
   (forall y, y ∈ ub -> y ∈ x -> y ∈ plumps y) /\
   (forall z y, y ∈ ub -> z ∈ plumps y -> z ⊆ y -> y ∈ x -> z ∈ x) /\
   Q x).
intro.
revert x; induction H using isWf_ind; intros.
unfold plumps at 1; rewrite WFR_eqn; fold plumps; trivial with *.
 unfold plump_set; rewrite subset_ax.
 rewrite power_ax.
 apply and_iff_morphisml; auto with *.
  intros _ xincla.
  split; intros.
   destruct H1 as (x',?,(?&?&?&?)).
   split; [|split]; intros; try rewrite H1 in *; eauto.

   exists x; auto with *.
   split; auto.
   apply isWf_incl with a; trivial.

 intros; apply subset_morph; auto with *.
 red; intros.
 apply and_iff_morphisml; auto with *.
 intros _ wfx1.
 assert (forall z, z ∈ x1 -> z ∈ x0 -> R z x0).
  split; trivial.
  apply isWf_inv with x1; trivial.
 apply and_iff_morphism.
  apply fa_morph; intros y.
  apply fa_morph; intros h0.
  apply fa_morph; intros h1.
  rewrite (H2 y y); auto with *.
 apply and_iff_morphism; auto with *.
 apply fa_morph; intros z.
 apply fa_morph; intros y.
 apply fa_morph; intros h.
 split; intros.
  apply H5; trivial.
  rewrite (H2 y y); auto with *.

  apply H5; trivial.
  rewrite <- (H2 y y); auto with *.

 apply isWf_accR; trivial.
Qed.

Instance plumps_morph : morph1 plumps.
do 2 red; intros; unfold plumps.
apply WFR_morph; trivial.
apply Rmorph.
Qed.

Lemma plump_bound : forall ub1 ub2 x,
 isWf ub1 ->
 isWf ub2 ->
 x ⊆ ub2 ->
 x ∈ plumps ub1 -> x ∈ plumps ub2.
intros.
rewrite plump_eqn in H2|-*; trivial.
destruct H2 as (?,(?,(?,?))).
eauto 10.
Qed.

(** The class of directed plump ordinals *)
Definition isOrd x := isWf x /\ x ∈ plumps x.

Lemma isOrd_wf o : isOrd o -> isWf o.
destruct 1; trivial.
Qed.
Hint Resolve isOrd_wf.

Lemma isOrd_ext : forall x y, x == y -> isOrd x -> isOrd y.
destruct 2.
unfold isOrd; rewrite H in H0,H1; auto.
Qed.

Global Instance isOrd_morph : Proper (eq_set ==> iff) isOrd.
do 2 red; split; intros.
 apply isOrd_ext with x; trivial.

 symmetry in H.
 apply isOrd_ext with y; trivial.
Qed.

Lemma isOrd_inv : forall x y,
  isOrd x -> y < x -> isOrd y.
intros.
destruct H.
split.
 apply isWf_inv with x; trivial.

 rewrite plump_eqn in H1; trivial.
 destruct H1 as (_,(?,_)); auto.
Qed.

Lemma isOrd_plump : forall z, isOrd z ->
 forall x y, isOrd x -> x ⊆ y -> y ∈ z -> x ∈ z.
destruct 1; intros.
rewrite plump_eqn in H0; trivial.
destruct H0 as (_,(_,(?,_))).
apply H0 with y; auto with *.
destruct H1.
apply plump_bound with x; auto with *.
apply isWf_inv with z; trivial.
Qed.

Lemma isOrd_dir : forall z, isOrd z -> Q z.
destruct 1; intros.
rewrite plump_eqn in H0; trivial.
destruct H0 as (_,(_,(_,?))); trivial.
Qed.

Lemma isOrd_intro : forall x,
  (forall a b, isOrd a -> a ⊆ b -> b ∈ x -> a ∈ x) ->
  Q x ->
  (forall y, y ∈ x -> isOrd y) ->
  isOrd x.
intros.
assert (wfx : isWf x).
 apply isWf_intro; intros; apply isOrd_wf; apply H1; trivial.
split; trivial.
rewrite plump_eqn; trivial.
split; [|split;[|split]]; intros; auto with *.
 apply H1; trivial.

 apply H with y; trivial.
 assert (wfy : isWf y).
  apply isWf_inv with x; trivial.
 assert (wfz : isWf z).
  apply isWf_intro; intros; apply isWf_inv with y; auto.
 split; trivial.
 apply plump_bound with y; auto with *.
Qed.

Lemma isOrd_trans : forall x y z,
  isOrd x -> z < y -> y < x -> z < x.
unfold lt.
intros.
assert (isWf x) by auto.
revert H y z H0 H1.
induction H2 using isWf_ind; intros.
apply isOrd_plump with y; auto.
 apply isOrd_inv with y; trivial.
 apply isOrd_inv with a; trivial.

 red; intros.
 apply H with z; trivial.
 apply isOrd_inv with a; trivial.
Qed.

Lemma isOrd_ind : forall x (P:set->Prop),
  (forall y, isOrd y ->
   y ⊆ x ->
   (forall z, z < y -> P z) -> P y) ->
  isOrd x -> P x.
intros.
assert (isWf x).
 destruct H0; trivial.
cut (forall x', x' == x -> P x'); auto with *.
revert H0 H .
induction H1 using isWf_ind; simpl; intros.
apply H2; intros; auto with *.
 rewrite H3; trivial.

 rewrite H3; reflexivity.

 rewrite H3 in H4; clear x' H3.
 apply H with z; auto with *.
  apply isOrd_inv with a; trivial.

  intros; apply H2; trivial.
  red; intros; apply isOrd_trans with z; auto.
  red; auto.
Qed.
End FirstOrder.

(** Alternative definition of ordinals, slightly shorter by using Coq's accessibility
   predicate, and the plump property below by well-founded induction.
 *)
Module HigherOrder.

Fixpoint plump ub (p:Acc in_set ub) x : Prop :=
  (forall y (q: y ∈ ub), y ∈ x -> plump y (Acc_inv p _ q) y) /\
  (forall z y (q: y ∈ ub), plump y (Acc_inv p _ q) z ->
   z ⊆ y -> y ∈ x -> z ∈ x) /\
  isDir x.

Lemma plump_morph : forall x x' p p' y y',
  x == x' -> y == y' -> (plump x p y <-> plump x' p' y').
intros x x' p; revert x'.
induction p using Acc_indd; simpl; intros.
destruct p'; simpl.
split; destruct 1 as (?,(?,?)); (split; [|split]); intros.
 assert (q' := q).
 rewrite <- H0 in q'.
 rewrite <- H1 in H5.
 rewrite <- (H y0 q' _ _ y0 y0); auto with *.

 assert (q' := q).
 rewrite <- H0 in q'.
 rewrite <- H1 in H7|-*.
 rewrite <- (H y0 q' _ _ z z) in H5; eauto with *.

 red; intros.
 destruct H4 with x0 y0.
  rewrite H1; trivial.
  rewrite H1; trivial.
  exists x1; trivial.
  rewrite <- H1; trivial.

 assert (q' := q).
 rewrite H0 in q'.
 rewrite H1 in H5.
 rewrite (H _ _ y0 (a0 _ q') _ y0); auto with *.

 assert (q' := q).
 rewrite H0 in q'.
 rewrite H1 in H7|-*.
 rewrite (H _ _ y0 (a0 _ q') _ z) in H5; eauto with *.

 red; intros.
 destruct H4 with x0 y0.
  rewrite <- H1; trivial.
  rewrite <- H1; trivial.
  exists x1; trivial.
  rewrite H1; trivial.
Qed.

Lemma plump_bound : forall ub1 ub2 p1 p2 x,
 x ⊆ ub1 ->
 plump ub1 p1 x -> plump ub2 p2 x.
destruct p1; destruct p2; simpl; intros.
destruct H0 as (?,(?,?)).
split; [|split]; intros; trivial.
 assert (y ∈ ub1).
  apply H; trivial.
 rewrite (plump_morph _ y _ (a _ H4) _ y); auto with *.

 assert (y ∈ ub1).
  apply H; trivial.
 rewrite (plump_morph _ y _ (a _ H6) _ z) in H3; auto with *.
 apply H1 with y H6; auto.
Qed.

Lemma plump_Acc : forall ub p x,
  plump ub p x -> x ⊆ ub -> Acc in_set x.
induction p using Acc_indd; simpl; intros.
destruct H0.
constructor; intros.
apply H with y (H1 _ H3); auto with *.
Qed.

Definition isOrd x :=
  { p:Acc in_set x | plump x p x }.

Lemma isOrd_ext : forall x y, x == y -> isOrd x -> isOrd y.
destruct 2.
generalize x0; rewrite H; intro.
exists H0.
rewrite <- (plump_morph x y x0 H0 x y); trivial.
Qed.

Instance isOrd_morph : Proper (eq_set ==> iff) isOrd.
do 2 red; split; intros.
 apply isOrd_ext with x; trivial.

 symmetry in H.
 apply isOrd_ext with y; trivial.
Qed.

Lemma isOrd_inv : forall x y,
  isOrd x -> y < x -> isOrd y.
intros.
destruct H.
exists (Acc_inv x0 _ H0).
destruct x0; simpl in *.
destruct p; auto.
Qed.

Lemma isOrd_plump : forall z, isOrd z ->
 forall x y, isOrd x -> x ⊆ y -> y ∈ z -> x ∈ z.
destruct 1; intros.
revert p.
destruct x;simpl; intros.
destruct p as (_,(?,_)).
apply H2 with y H1; trivial.
destruct H.
apply plump_bound with (2:=p); reflexivity.
Qed.

Lemma isOrd_dir : forall z, isOrd z -> isDir z.
destruct 1; intros.
revert p.
destruct x;simpl; intros.
destruct p as (_,(_,?)); trivial.
Qed.

Lemma isOrd_intro : forall x,
  (forall a b, isOrd a -> a ⊆ b -> b ∈ x -> a ∈ x) ->
  isDir x ->
  (forall y, y ∈ x -> isOrd y) ->
  isOrd x.
intros.
exists (Acc_intro _ (fun y h => proj1_sig (H1 y h))); simpl.
split; [|split]; intros; trivial.
 destruct (H1 y H2).
 rewrite <- (plump_morph y y x0 _ y y); auto with *.

 apply H with y; trivial.
 exists (plump_Acc _ _ _ H2 H3).
 apply plump_bound with (2:=H2); trivial.
Qed.

Lemma isOrd_trans : forall x y z,
  isOrd x -> z < y -> y < x -> z < x.
unfold lt.
destruct 1.
revert y z p.
induction x0 using Acc_indd; simpl; intros.
assert (isOrd x).
 exists (Acc_intro _ a); simpl; trivial.
destruct p.
apply isOrd_plump with y; trivial.
 apply isOrd_inv with y; trivial.
 apply isOrd_inv with x; trivial.

 red; intros.
 apply H with H1 z; auto.
Qed.

Lemma isOrd_ind : forall x (P:set->Prop),
  (forall y, isOrd y ->
   y ⊆ x ->
   (forall z, z < y -> P z) -> P y) ->
  isOrd x -> P x.
intros.
destruct H0.
cut (forall x', x' == x -> P x'); auto with *.
revert p H .
induction x0 using Acc_indd; simpl; intros.
destruct p.
assert (isOrd x).
 exists (Acc_intro _ a); simpl; split; trivial.
apply H0; intros; auto with *.
 rewrite H1; trivial.

 red; intros.
 rewrite <- H1; trivial.

rewrite H1 in H5.
clear x' H1.
apply H with (r:=H5); intros; auto with *.
apply H0; intros; auto.
red; intros.
apply isOrd_trans with z; auto.
apply H6; trivial.
Qed.
End HigherOrder.

(** * Simple theory of ordinals *)

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

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

 red; intros.
 elim empty_ax with x; trivial.

 elim empty_ax with y; trivial.
Qed.

(** Successor *)
Definition osucc x := subset (power x) isOrd.

Instance osucc_morph : morph1 osucc.
unfold osucc; do 2 red; intros.
apply subset_morph.
 rewrite H; reflexivity.

 red; auto with *.
Qed.

Lemma lt_osucc : forall x, isOrd x -> x < osucc x.
unfold osucc, lt; intros.
apply subset_intro; trivial.
apply power_intro; auto.
Qed.

Hint Resolve isOrd_zero lt_osucc.

Lemma olts_le : forall x y, x < osucc y -> x ⊆ y.
red; intros.
apply subset_elim1 in H.
apply power_elim with (1:=H); trivial.
Qed.

Lemma ole_lts : forall x y, isOrd x -> x ⊆ y -> x < osucc y.
intros.
apply subset_intro; trivial.
apply power_intro; trivial.
Qed.

Lemma oles_lt : forall x y,
  isOrd x ->
  osucc x ⊆ y ->
  x < y.
intros.
apply H0.
apply lt_osucc; trivial.
Qed.

Lemma le_lt_trans : forall x y z, isOrd z -> x < osucc y -> y < z -> x < z.
intros.
apply isOrd_plump with y; trivial.
 apply subset_elim2 in H0; destruct H0.
 rewrite H0; trivial.

 apply olts_le; trivial.
Qed.

Lemma ord_lt_le : forall o o', isOrd o -> o' ∈ o -> o' ⊆ o.
red; intros; apply isOrd_trans with o'; trivial.
Qed.
Hint Resolve ord_lt_le.

Lemma isOrd_succ : forall n, isOrd n -> isOrd (osucc n).
unfold osucc.
intros.
apply isOrd_intro; intros.
 apply subset_intro; trivial.
 apply subset_elim1 in H2.
 apply power_intro; intros.
 apply H1 in H3.
 apply power_elim with (1:=H2); trivial.

 red; intros.
 exists n.
  apply subset_intro; trivial.
  apply power_intro; auto.

  split.
   red; intros.
   apply power_elim with x; trivial.
   apply subset_elim1 in H0; trivial.

   red; intros.
   apply power_elim with y; trivial.
   apply subset_elim1 in H1; trivial.

 apply subset_elim2 in H0.
 destruct H0.
 rewrite H0; trivial.
Qed.
Hint Resolve isOrd_succ.

Lemma lt_osucc_compat : forall n m, isOrd m -> n < m -> osucc n < osucc m.
intros.
apply ole_lts; auto.
 apply isOrd_succ.
 apply isOrd_inv with m; trivial.

 red; intros.
 apply le_lt_trans with n; trivial.
Qed.

Lemma osucc_mono : forall n m, isOrd n -> isOrd m -> n ⊆ m -> osucc n ⊆ osucc m.
red; intros.
apply ole_lts.
 apply isOrd_inv with (osucc n); auto.

 apply olts_le in H2.
 transitivity n; trivial.
Qed.

  Lemma lt_osucc_inv : forall o o',
    isOrd o ->
    osucc o < osucc o' ->
    o < o'.
unfold osucc; intros.
rewrite subset_ax in H0; destruct H0.
destruct H1.
rewrite power_ax in H0.
apply H0.
apply subset_intro; trivial.
apply power_intro; auto.
Qed.

Lemma isOrd_eq : forall o, isOrd o -> o == sup o osucc.
intros.
apply eq_intro; intros.
 rewrite sup_ax.
 2:do 2 red; intros; apply osucc_morph; trivial.
 exists z; auto.
 apply lt_osucc.
 apply isOrd_inv with o; trivial.

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

(** Examples: ordinals of rank less than 2 *)
Module Examples.

Definition ord_0 := empty.
Definition ord_1 := osucc ord_0.
Definition ord_2 := osucc ord_1.

(** 1 = {0} *)
Lemma ord1 : forall x, x ∈ ord_1 <-> x == zero.
intros.
unfold ord_1, osucc.
rewrite subset_ax.
split; intros.
 destruct H.
 rewrite power_ax in H.
 apply empty_ext.
 red; intros.
 apply H in H1.
 apply empty_ax with (1:=H1).

 split.
  apply power_intro; intros.
  rewrite H in H0; trivial.

  exists zero; auto.
Qed.

Definition ord_rk_1 P := subset ord_1 (fun _ => P).

Lemma rk1_order : forall P Q, ord_rk_1 P ⊆ ord_rk_1 Q <-> (P->Q).
split; intros.
 assert (zero ∈ ord_rk_1 P).
  apply subset_intro; trivial.
  unfold ord_1; apply lt_osucc; auto.
 apply H in H1.
 apply subset_elim2 in H1.
 destruct H1; trivial.

 red; intros.
 apply subset_intro.
  apply subset_elim1 in H0; trivial.

  apply subset_elim2 in H0.
  destruct H0; auto.
Qed.

Lemma isOrd_rk_1 : forall P, isOrd (ord_rk_1 P).
intros.
apply isOrd_intro; intros.
 unfold ord_rk_1 in H1; rewrite subset_ax in H1; destruct H1.
 destruct H2.
 clear x H2.
 apply subset_intro; auto.
 apply isOrd_plump with b; auto.
 unfold ord_1; auto.

 red; intros.
 assert P.
  apply subset_elim2 in H; destruct H; trivial.
 apply subset_elim1 in H.
 apply subset_elim1 in H0.
 apply ord1 in H.
 apply ord1 in H0.
 exists empty.
  apply subset_intro; trivial.
  apply ord1; reflexivity.

  rewrite H; rewrite H0; split; reflexivity.

 apply subset_elim1 in H.
 apply isOrd_inv with (osucc zero); auto.
Qed.

Definition isOrd2 x := exists P:Prop, x == ord_rk_1 P.

(** 2 = {o| 0<=o<=1 } is isomorphic to Prop *)
Lemma ord2 : forall x, x ∈ ord_2 <-> exists P, x == ord_rk_1 P.
intros.
unfold ord_2, osucc at 1.
rewrite subset_ax.
rewrite power_ax.
split; intros.
 destruct H.
 destruct H0.
 rewrite <- H0 in H1; clear H0 x0.
 exists (zero ∈ x).
 apply subset_ext; intros; auto.
  apply ord1 in H0.
  rewrite H0; trivial.

  exists x0; auto with *.
  specialize H with (1:=H0).
  apply ord1 in H.
  rewrite H in H0; trivial.

 destruct H.
 split; intros.
  rewrite H in H0; clear H x.
  apply subset_elim1 with (1:=H0).

  exists x; auto with *.
  rewrite H.
  apply isOrd_rk_1.
Qed.

Definition ord_rk_2 (P2:Prop->Prop) :=
  subset ord_2 (fun x => exists2 P, x == ord_rk_1 P & P2 P).

Definition decr_2 (P2:Prop->Prop) :=
   (forall P Q:Prop, (P -> Q) -> (P2 Q -> P2 P)) /\
   (forall P Q:Prop, P2 P -> P2 Q -> P2 (P\/Q)).

Lemma isOrd_rk_2 : forall P2, decr_2 P2 -> isOrd (ord_rk_2 P2).
intros.
apply isOrd_intro; intros.
 assert (a ∈ ord_2).
  apply isOrd_plump with b; auto.
  unfold ord_2, ord_1; auto.
  apply subset_elim1 in H2; trivial.
 apply subset_intro; auto.
 rewrite ord2 in H3.
 destruct H3.
 exists x; trivial.
 unfold ord_rk_2 in H2; rewrite subset_ax in H2; destruct H2.
 destruct H4.
 destruct H5.
 apply (proj1 H x x1); trivial.
 rewrite H4 in H1; rewrite H5 in H1; rewrite H3 in H1.
 rewrite <- rk1_order; trivial.

 red; intros.
  unfold ord_rk_2 in H0,H1.
  rewrite subset_ax in H0; destruct H0.
  destruct H2.
  destruct H3 as (P,?,?).
  rewrite <- H2 in H3; clear x0 H2.
  rewrite subset_ax in H1; destruct H1.
  destruct H2.
  destruct H5 as (Q,?,?).
  rewrite <- H2 in H5; clear x0 H2.
  exists (ord_rk_1 (P\/Q)).
   apply subset_intro.
    apply ord2.
    exists (P\/Q); auto with *.

    exists (P\/Q); auto with *.
    apply (proj2 H); trivial.

   split.
    rewrite H3; apply rk1_order; auto.
    rewrite H5; apply rk1_order; auto.

 apply subset_elim1 in H0.
 apply isOrd_inv with (osucc (osucc zero)); auto.
Qed.

(** 3 is isomorphic to decreasing functions of type Prop->Prop
    (and closed by union to ensure directedness) *)
Lemma ord3 : forall x,
  x ∈ osucc ord_2 <-> exists2 P2, decr_2 P2 & x == ord_rk_2 P2.
intros.
unfold osucc.
rewrite subset_ax.
rewrite power_ax.
split; intros.
 destruct H.
 destruct H0.
 rewrite <- H0 in H1; clear H0 x0.
 exists (fun P => ord_rk_1 P ∈ x).
  split; intros.
   apply isOrd_plump with (ord_rk_1 Q); trivial.
    assert (ord_rk_1 P ∈ ord_2).
     rewrite ord2.
     exists P; auto with *.
    apply isOrd_inv with ord_2; auto.
    unfold ord_2, ord_1; auto.

    rewrite rk1_order; trivial.

   destruct (isOrd_dir _ H1 _ _ H0 H2).
   destruct H4.
   apply isOrd_plump with x0; trivial.
    apply isOrd_rk_1.

    assert (h := H _ H3).
    apply ord2 in h.
    destruct h as (R,h).
    rewrite h in H4,H5|-*.
    apply rk1_order; destruct 1.
     apply (proj1 (rk1_order P R)); trivial.
     apply (proj1 (rk1_order Q R)); trivial.

  apply subset_ext; intros; auto.
   apply ord2 in H0.
   destruct H2.
   rewrite H2; trivial.
   exists x0; auto with *.
   specialize H with (1:=H0).
   apply ord2 in H.
   destruct H.
   exists x1; trivial.
   rewrite H in H0; trivial.

 destruct H.
 split; intros.
  rewrite H0 in H1; clear H0 x.
  apply subset_elim1 with (1:=H1).

  exists x; auto with *.
  rewrite H0.
  apply isOrd_rk_2; trivial.
Qed.

End Examples.

(** Increasing sequences *)

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

Lemma increasing_is_ext : forall F,
  increasing F ->
  forall o, isOrd o ->
  ext_fun o F.
intros F Fincr o H.
red; red; intros.
apply eq_intro.
 apply Fincr.
  rewrite <- H1; eauto using isOrd_inv.
  eauto using isOrd_inv.
  rewrite H1; reflexivity.
 apply Fincr.
  eauto using isOrd_inv.
  rewrite <- H1; eauto using isOrd_inv.
  rewrite H1; reflexivity.
Qed.
Hint Resolve increasing_is_ext.

Definition increasing_bounded o F :=
  forall x x', x' < o -> x < x' -> F x ⊆ F x'.

(** Successor ordinals *)

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

(** Limit ordinals *)

Definition limitOrd o := isOrd o /\ (forall x, x < o -> lt (osucc x) o).

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

Lemma limit_union : forall o, limitOrd o -> union o == o.
destruct 1.
apply eq_intro; intros.
 apply union_elim in H1; destruct H1.
 apply isOrd_trans with x; trivial.

 apply union_intro with (osucc z).
  apply lt_osucc.
  apply isOrd_inv with o; trivial.

  apply H0; trivial.
Qed.

Lemma limit_union_intro : forall o, isOrd o -> union o == o -> limitOrd o.
split; trivial.
unfold lt; intros.
assert (isOrd x).
 apply isOrd_inv with o; trivial.
rewrite <- H0 in H1.
apply union_elim in H1; destruct H1.
apply isOrd_plump with x0; auto.
red; intros.
apply le_lt_trans with x; trivial.
apply isOrd_inv with o; trivial.
Qed.

Lemma discr_lim_succ : forall o, limitOrd o -> succOrd o -> False.
destruct 1; destruct 1.
assert (lt (osucc x) o).
 apply H0.
 rewrite H2; auto.
rewrite <- H2 in H3.
elim lt_antirefl with o; trivial.
Qed.

Lemma isOrd_inter2 : forall x y,
  isOrd x -> isOrd y -> isOrd (x ∩ y).
intros.
revert y H0; apply isOrd_ind with (2:=H); intros.
clear x H H1; rename y into x; rename y0 into y.
apply isOrd_intro; intros.
 rewrite inter2_def in H4|-*; destruct H4; split.
  apply isOrd_plump with b; trivial.
  apply isOrd_plump with b; trivial.

 red; intros.
 rewrite inter2_def in H; destruct H.
 rewrite inter2_def in H1; destruct H1.
 destruct (isOrd_dir _ H0 _ _ H H1).
 destruct H7.
 destruct (isOrd_dir _ H3 _ _ H4 H5).
 destruct H10.
 exists (x1 ∩ x2).
  rewrite inter2_def; split.
   apply isOrd_plump with x1; trivial.
    apply H2; trivial.
    apply isOrd_inv with y; trivial.

    apply inter2_incl1.

   apply isOrd_plump with x2; trivial.
    apply H2; trivial.
    apply isOrd_inv with y; trivial.

    apply inter2_incl2.

  split; red; intros; rewrite inter2_def; split; auto.

 rewrite inter2_def in H; destruct H.
 apply isOrd_inv with x; trivial.
Qed.

Lemma inter2_succ : forall x y,
  isOrd x -> isOrd y ->
  osucc x ∩ osucc y == osucc (x ∩ y).
intros.
apply eq_intro; intros.
 rewrite inter2_def in H1.
 destruct H1.
 apply ole_lts; eauto using isOrd_inv.
 apply olts_le in H1; apply olts_le in H2.
 red; intros; rewrite inter2_def; auto.

 assert (isOrd z).
  apply isOrd_inv with (osucc (x ∩ y)); trivial.
  apply isOrd_succ; apply isOrd_inter2; trivial.
 rewrite inter2_def; split.
  apply ole_lts; eauto using isOrd_inv.
  apply olts_le in H1.
  transitivity (x ∩ y); trivial.
  apply inter2_incl1.

  apply ole_lts; eauto using isOrd_inv.
  apply olts_le in H1.
  transitivity (x ∩ y); trivial.
  apply inter2_incl2.
Qed.

(** * Transfinite recursion *)

(*begin hide *)
Require Import ZFpairs ZFrelations.
Require Import ZFrepl.

Module FirstOrderStyle.

Section TransfiniteRecursion.

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

  Variable ord : set.
  Hypothesis Fmorph :
    forall x f f', isOrd x -> x ⊆ ord -> eq_fun x f f' -> F f x == F f' x.

  Definition isTR_rel P :=
    forall o y,
    couple o y ∈ P ->
    exists2 f, (forall n, n ∈ o -> couple n (cc_app f n) ∈ P) &
      y == F (cc_app f) o.

  Lemma isTR_rel_fun P P' o y y':
    isOrd o ->
    o ⊆ ord ->
    isTR_rel P ->
    isTR_rel P' ->
    couple o y ∈ P ->
    couple o y' ∈ P' ->
    y == y'.
intros oo ole istr istr' inP inP'; revert y y' inP inP'; elim oo using isOrd_ind; intros.
destruct istr with (1:=inP) as (f,?,?).
destruct istr' with (1:=inP') as (f',?,?).
rewrite H3; rewrite H5; apply Fmorph; auto.
 transitivity o; trivial.

 red; intros.
 rewrite <- H7; clear x' H7.
 apply H1 with x; auto.
Qed.

Instance isTR_rel_morph : Proper (eq_set==>iff) isTR_rel.
do 2 red; intros.
apply fa_morph; intro o.
apply fa_morph; intro y'.
rewrite H.
apply fa_morph; intros ?.
apply ex2_morph; red; intros; auto with *.
apply fa_morph; intros n.
rewrite H; reflexivity.
Qed.

  Definition TR_rel o y :=
    exists2 P, isTR_rel P & couple o y ∈ P.

  Instance TR_rel_morph : Proper (eq_set ==> eq_set ==> iff) TR_rel.
do 3 red; intros.
apply ex2_morph; red; intros; auto with *.
rewrite H; rewrite H0; reflexivity.
Qed.

  Lemma TR_rel_intro x f :
    morph1 f ->
    isOrd x ->
    x ⊆ ord ->
    (forall y, y ∈ x -> TR_rel y (f y)) ->
    TR_rel x (F f x).
intros fm xo xle Hsub.
exists (singl (couple x (F f x)) ∪ replf x (fun y' => couple y' (f y'))).
 red; intros.
 rewrite union2_ax in H; destruct H.
  apply singl_elim in H.
  apply couple_injection in H; destruct H.
  exists (cc_lam o f); intros.
   rewrite H in H1|-*; clear o H.
   apply union2_intro2.
   rewrite replf_ax. 2:do 2 red; intros; apply couple_morph; auto.
   exists n; auto with *.
   rewrite cc_beta_eq; auto with *.

   rewrite H; clear o H.
   rewrite H0.
   apply Fmorph; auto.
   red; intros.
   rewrite <- H1; clear x' H1.
   rewrite cc_beta_eq; auto with *.

  rewrite replf_ax in H. 2:do 2 red; intros; apply couple_morph; auto.
  destruct H.
  apply couple_injection in H0; destruct H0.
  rewrite <- H0 in H,H1; clear x0 H0.
  destruct Hsub with (1:=H) as (P,?,?).
  assert (oo : isOrd o).
   apply isOrd_inv with x; trivial.
  assert (ole : o ⊆ ord).
   red; intros; apply xle; apply isOrd_trans with o; trivial.
  exists (cc_lam o f).
   intros.
   apply union2_intro2.
   rewrite replf_ax. 2:do 2 red; intros; apply couple_morph; auto.
   exists n; auto with *.
    apply isOrd_trans with o; trivial.
   rewrite cc_beta_eq; auto with *.

   rewrite H1.
   destruct H0 with (1:=H2) as (g,?,?).
   rewrite H4.
   apply Fmorph; auto.
   red; intros.
   rewrite <- H6; clear x' H6.
   assert (x0o: isOrd x0).
    apply isOrd_inv with o; trivial.
   assert (x0le : x0 ⊆ ord).
    red; intros; apply ole; apply isOrd_trans with x0; trivial.
   rewrite cc_beta_eq; auto with *.
   apply isTR_rel_fun with P P x0; auto.
   destruct Hsub with x0 as (P',?,?).
    apply isOrd_trans with o; trivial.
   rewrite <- (isTR_rel_fun _ _ _ _ _) with (3:=H0) (4:=H6) (5:=H3 _ H5) (6:=H7); auto. (* ?*)

 apply union2_intro1.
 apply singl_intro.
Qed.

  Lemma TR_rel_ex o :
    isOrd o -> o ⊆ ord ->
    uchoice_pred (TR_rel o).
intros oo.
elim oo using isOrd_ind; intros.
split;[|split]; intros.
 rewrite <- H3; trivial.

 exists (F (fun y' => uchoice (TR_rel y')) y).
 assert (chm : morph1 (fun n => uchoice (TR_rel n))).
  do 2 red; intros; apply uchoice_morph_raw.
  red; intros.
  apply TR_rel_morph; trivial.
 apply TR_rel_intro; intros; trivial.
 apply uchoice_def; apply H1; trivial.
 red; intros; apply H2; apply isOrd_trans with y0; trivial.

 destruct H3 as (P,?,?).
 destruct H4 as (P',?,?).
 apply isTR_rel_fun with P P' y; auto.
Qed.

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

  Lemma TR_eqn0 : forall o, isOrd o -> o ⊆ ord ->
     uchoice (fun y => TR_rel o y) == F (fun o => uchoice (fun y => TR_rel o y)) o.
intros.
specialize TR_rel_ex with (1:=H) (2:=H0); intro.
apply uchoice_def in H1.
destruct H1 as (P,?,?).
destruct H1 with (1:=H2) as (f,?,?).
rewrite H4.
apply Fmorph; auto.
red; intros.
rewrite H6 in H5|-*; clear x H6.
apply uchoice_ext.
 apply TR_rel_ex.
  apply isOrd_inv with o; trivial.

  red; intros; apply H0; apply isOrd_trans with x'; trivial.

 exists P; auto.
Qed.

End TransfiniteRecursion.

  Global Instance TR_morph0 : forall F, morph1 (TR F).
do 2 red; intros.
unfold TR.
apply uchoice_morph_raw.
red; intros.
assert (trm := TR_rel_morph).
rewrite H; rewrite H0; reflexivity.
Qed.

  Global Instance TR_morph :
    Proper (((eq_set ==> eq_set) ==> eq_set ==> eq_set) ==> eq_set ==> eq_set) TR.
do 3 red; intros.
unfold TR.
apply uchoice_morph_raw; red; intros.
unfold TR_rel.
apply ex2_morph; red; intros.
 apply fa_morph; intros o.
 apply fa_morph; intros y'.
 apply fa_morph; intros _.
 apply ex2_morph; red; intros; auto with *.
 split; intros h; rewrite h;[|symmetry];
   (apply H; [apply cc_app_morph|]; reflexivity).

 rewrite H0; rewrite H1; reflexivity.
Qed.

End FirstOrderStyle.
(*end hide *)

(** Higher-order style: quantification over relations *)

Section TransfiniteRecursion.

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

  Let R o o' := o < o'.

  Local Instance Rm : Proper (eq_set==>eq_set==>iff) R.
unfold R; do 3 red; intros.
rewrite H,H0; reflexivity.
Qed.

  Definition TR := WFR R F.

Global Instance TR_morph0 : morph1 TR.
clear Fm; do 2 red; intros.
unfold TR.
apply WFR_morph0; trivial.
Qed.

  Lemma TR_eqn o :
    isOrd o ->
    (forall x f f', isOrd x -> x ⊆ o -> eq_fun x f f' -> F f x == F f' x) ->
    TR o == F TR o.
intros oo Fext.
unfold TR.
apply WFR_eqn_gen; auto with *.
elim oo using isOrd_ind; intros; constructor; intros; auto.
Qed.

  Lemma TR_ind : forall o (P:set->set->Prop),
    Proper (eq_set ==> eq_set ==> iff) P ->
    isOrd o ->
    (forall x f f', isOrd x -> x ⊆ o -> eq_fun x f f' -> F f x == F f' x) ->
    (forall y, isOrd y -> y ⊆ o ->
     (forall x, x < y -> P x (TR x)) ->
     P y (F TR y)) ->
    P o (TR o).
intros o P Pm oo Fmorph.
revert Fmorph; induction oo using isOrd_ind; intros.
rewrite TR_eqn; trivial.
apply H1; auto with *; intros.
apply H0; intros; trivial.
  assert (x0 ⊆ y).
   transitivity x; auto.
 auto.
apply H1; trivial.
transitivity x; auto.
Qed.

  Lemma TR_typ : forall o X,
    isOrd o ->
    (forall x f f', isOrd x -> x ⊆ o -> eq_fun x f f' -> F f x == F f' x) ->
    morph1 X ->
    (forall y f, morph1 f -> isOrd y -> y ⊆ o ->
     (forall z, z < y -> f z ∈ X z) -> F f y ∈ X y) ->
    TR o ∈ X o.
intros o X oo Fmorph Xm Hrec.
apply TR_ind with (o:=o); intros; trivial.
 do 3 red; intros.
 rewrite H; rewrite H0; reflexivity.

 apply Fmorph; trivial.

 apply Hrec; trivial; intros.
 apply TR_morph0.
Qed.

End TransfiniteRecursion.

Global Instance TR_morph :
    Proper (((eq_set ==> eq_set) ==> eq_set ==> eq_set) ==> eq_set ==> eq_set) TR.
do 3 red; intros.
apply WFR_morph; trivial.
 do 2 red; intros.
 rewrite H1, H2; reflexivity.
Qed.

  Lemma TR_ext_ord F F' o o' :
  (forall f f' oo,
   morph1 f ->
   morph1 f' ->
   (forall z, z ∈ oo -> f z == f' z) ->
   isOrd oo ->
   oo ⊆ o ->
   F f oo == F' f' oo) ->
 isOrd o ->
 o == o' ->
 TR F o == TR F' o'.
intros.
apply WFR_ext; auto with *.
 do 2 red; intros.
 rewrite H2; reflexivity.
intros.
assert (isOrd y /\ y ⊆ o).
 apply Kstar_rel with (3:=H5); auto with *.
  do 2 red; intros.
  rewrite H6; reflexivity.

  destruct 2; split.
   apply isOrd_inv with y0; trivial.
   rewrite <- H8; auto.
clear H5; destruct H6.
apply H; trivial.
Qed.

(** 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')).

Let Gm : Proper ((eq_set ==> eq_set) ==> eq_set ==> eq_set) G.
do 3 red; intros.
unfold G.
apply sup_morph; trivial.
red; intros.
apply Fmorph.
apply H; trivial.
Qed.

Let Gmorph : forall o f f', eq_fun o f f' -> G f o == G f' o.
unfold G; intros.
apply sup_morph; auto with *.
red; auto.
Qed.

  Definition TI := TR G.

  Instance TI_morph : morph1 TI.
unfold TI; do 2 red; intros.
apply TR_morph0; auto with *.
Qed.

  Lemma TI_fun_ext : forall x, ext_fun x (fun y => F (TI y)).
do 2 red; intros.
apply Fmorph.
apply TI_morph; 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', o' < o & x ∈ F (TI o').
intros.
rewrite TI_eq in H0; trivial.
rewrite sup_ax in H0; auto.
Qed.

  Lemma TI_mono : increasing TI.
do 2 red; intros.
apply TI_elim in H2; intros; auto with *.
destruct H2.
apply TI_intro with x0; auto with *.
apply H1 in H2; trivial.
Qed.

  Lemma TI_incl : forall o, isOrd o ->
    forall o', o' < o ->
    TI o' ⊆ TI o.
intros.
apply TI_mono; trivial; auto.
apply isOrd_inv with o; trivial.
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, isOrd m -> m ⊆ n ->
     ext_fun m G ->
     (forall x, 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 with *.
apply H.
apply H2; trivial; intros.
apply H3; auto.
red; intros.
apply H6 in H9.
apply isOrd_trans with x; trivial.
Qed.

End TransfiniteIteration.
Hint Resolve TI_fun_ext.

Global Instance TI_morph_gen :
  Proper ((eq_set==>eq_set)==>eq_set==>eq_set) TI.
do 3 red; intros.
unfold TI.
apply TR_morph; trivial.
do 2 red; intros.
apply sup_morph; trivial.
red; intros.
apply H; apply H1; trivial.
Qed.

(** * Supremum of directed ordinals *)

(** ** Binary supremum *)

Section BinarySup.

  Definition isCouple c := c == couple (fst c) (snd c).
  Global Instance isCouple_morph : Proper (eq_set==>iff) isCouple.
do 2 red; intros; unfold isCouple.
rewrite H; reflexivity.
Qed.
  Lemma isCouple_couple a b : isCouple (couple a b).
red.
rewrite fst_def, snd_def; reflexivity.
Qed.
Hint Resolve isCouple_couple.

  Let R xy xy' := isCouple xy /\ fst xy < fst xy'.
  Let Rm : Proper (eq_set==>eq_set==>iff) R.
unfold R; do 3 red; intros.
rewrite H,H0; reflexivity.
Qed.

  Let F f xy :=
    let x := fst xy in
    let y := snd xy in
    x ∪ y ∪ sup x (fun x' => replf y (fun y' => f (couple x' y'))).
  Let Fm : Proper ((eq_set==>eq_set)==>eq_set==>eq_set) F.
unfold F; do 3 red; intros.
apply union2_morph.
 rewrite H0; reflexivity.
apply sup_morph;[rewrite H0;reflexivity|].
red; intros.
apply replf_morph;[rewrite H0;reflexivity|].
red; intros.
apply H; rewrite H2,H4; reflexivity.
Qed.

  Definition osup2 x y := WFR R F (couple x y).

Infix "⊔" := osup2 (at level 50). (* input method: \sqcup *)
(* ⋓ = \Cup would be nicer, but poor html rendering... *)

Instance osup2_morph : morph2 osup2.
unfold osup2; do 3 red; intros.
rewrite H,H0; reflexivity.
Qed.

  Lemma osup2_def : forall x y, isOrd x ->
    x ⊔ y == x ∪ y ∪ sup x (fun x' => replf y (fun y' => x' ⊔ y')).
intros.
unfold osup2 at 1.
rewrite WFR_eqn; auto.
 unfold F.
 apply union2_morph.
  rewrite fst_def,snd_def; reflexivity.
 apply sup_morph.
  apply fst_def.
 red; intros.
 apply replf_morph.
  apply snd_def.
 red; intros.
 apply osup2_morph; trivial.

 intros.
 apply union2_morph; auto with *.
 apply sup_morph; auto with *.
 red; intros.
 apply replf_morph; auto with *.
 red; intros.
 apply H1.
  red.
  rewrite fst_def; auto.

  rewrite H3,H5; reflexivity.

 revert y; elim H using isOrd_ind; intros.
 constructor; destruct 1.
 rewrite fst_def in H4.
 eapply wf_morph with  (3:=Rm)(4:=H3) ; auto with *.
Qed.

Lemma osup2_ax : forall x y z,
  isOrd x ->
  (z ∈ x ⊔ y <->
   z ∈ x \/ z ∈ y \/
   exists2 x', x' ∈ x & exists2 y', y' ∈ y & z == x' ⊔ y').
intros x y z wfx.
rewrite osup2_def; trivial.
split; intros.
 apply union2_elim in H; destruct H.
  apply union2_elim in H; destruct H; auto.

  rewrite sup_ax in H.
   destruct H.
   rewrite replf_ax in H0.
    destruct H0; eauto.

    red; red; intros.
    apply osup2_morph; auto with *.

   red; red; intros.
   apply replf_morph; auto with *.
   red; intros.
   apply osup2_morph; trivial.

 destruct H as [?|[?|?]].
  apply union2_intro1; apply union2_intro1; trivial.

  apply union2_intro1; apply union2_intro2; trivial.

  apply union2_intro2.
  destruct H.
  destruct H0.
  rewrite sup_ax.
   exists x0; trivial.
   rewrite replf_ax.
    exists x1; trivial.

    red; red; intros.
    apply osup2_morph; auto with *.

   red; red; intros.
   apply replf_morph; auto with *.
   red; intros.
   apply osup2_morph; trivial.
Qed.

Lemma osup2_incl1 : forall x y, isOrd x -> x ⊆ x ⊔ y.
red; intros.
rewrite osup2_ax; auto.
Qed.

Lemma osup2_incl2 : forall x y, isOrd x -> y ⊆ x ⊔ y.
red; intros.
rewrite osup2_ax; auto.
Qed.

Lemma osup2_mono x x' y y' :
  isOrd x' ->
  isOrd x ->
  x ⊆ x' -> y ⊆ y' ->
  x ⊔ y ⊆ x' ⊔ y'.
red; intros.
rewrite osup2_ax in H3|-*; trivial.
destruct H3 as [?|[?|(a,?,(b,?,?))]]; auto.
right; right.
exists a; auto.
exists b; auto with *.
Qed.

Lemma isDir_osup2 : forall x y, isOrd x -> isDir x -> isDir y -> isDir (x ⊔ y).
red; unfold lt; intros x y wfx H H0; intros.
assert (wfi := isOrd_inv).
rewrite osup2_ax in H1,H2; trivial.
destruct H1 as [?|[?|(x1,?,(x2,?,?))]];
  destruct H2 as [?|[?|(y1,?,(y2,?,?))]].
 (* case 1. *)
 destruct (H x0 y0); trivial.
 exists x1; trivial.
 apply osup2_incl1; trivial.
 (* case 2. *)
 exists (x0 ⊔ y0).
  rewrite osup2_ax; trivial; right; right; eauto with *.

  split.
   apply osup2_incl1; eauto.
   apply osup2_incl2; eauto.
 (* case 3. *)
 destruct (H x0 y1); trivial.
 destruct H6.
 exists (x1 ⊔ y2).
  rewrite osup2_ax; trivial; right; right; eauto with *.

  split.
   transitivity x1; trivial.
   apply osup2_incl1; eauto.

   rewrite H4; apply osup2_mono; eauto with *.
 (* case 4. *)
 exists (y0 ⊔ x0).
  rewrite osup2_ax; trivial; right; right; eauto with *.

  split.
   apply osup2_incl2; eauto.
   apply osup2_incl1; eauto.
 (* case 5. *)
 destruct (H0 x0 y0); trivial.
 exists x1; trivial.
 apply osup2_incl2; trivial.
 (* case 6. *)
 destruct (H0 x0 y2); trivial.
 destruct H6.
 exists (y1 ⊔ x1).
  rewrite osup2_ax; trivial; right; right; eauto with *.

  split.
   transitivity x1; trivial.
   apply osup2_incl2; eauto.

   rewrite H4; apply osup2_mono; eauto with *.
 (* case 7. *)
 destruct (H x1 y0); trivial.
 destruct H6.
 exists (x3 ⊔ x2).
  rewrite osup2_ax; trivial; right; right; eauto with *.

  split.
   rewrite H4; apply osup2_mono; eauto with *.

   transitivity x3; trivial; apply osup2_incl1; eauto.
 (* case 8. *)
 destruct (H0 x2 y0); trivial.
 destruct H6.
 exists (x1 ⊔ x3).
  rewrite osup2_ax; trivial; right; right; eauto with *.

  split.
   rewrite H4; apply osup2_mono; eauto with *.

   transitivity x3; trivial; apply osup2_incl2; eauto.
 (* case 9. *)
 destruct (H x1 y1); trivial.
 destruct H8.
 destruct (H0 x2 y2); trivial.
 destruct H11.
 exists (x3 ⊔ x4).
  rewrite osup2_ax; trivial; right; right; eauto with *.

  split.
   rewrite H4; apply osup2_mono; eauto with *.

   rewrite H6; apply osup2_mono; eauto with *.
Qed.

Lemma osup2_proof : forall x, isOrd x -> forall y, isOrd y ->
  isOrd (x ⊔ y) /\
  (forall z, isOrd z -> z ∩ (x ⊔ y) == z ∩ x ⊔ z ∩ y).
induction 1 using isOrd_ind.
clear H0 x; rename y into x; rename H1 into Hrecx.
intros y yo.
rename H into xo.
split.
 (* isOrd *)
 apply isOrd_intro; intros.
  (* plump *)
  rewrite osup2_ax in H1|-*; auto.
  destruct H1 as [?|[?|(x',?,(y',?,?))]].
   left; apply isOrd_plump with b; trivial.

   right; left; apply isOrd_plump with b; trivial.

   right; right.
   exists (a ∩ x').
    apply isOrd_plump with x'; trivial.
     apply isOrd_inter2; eauto using isOrd_inv.
     apply inter2_incl2.

    exists (a ∩ y').
     apply isOrd_plump with y'; trivial.
      apply isOrd_inter2; eauto using isOrd_inv.
      apply inter2_incl2.

     destruct Hrecx with x' y' as (_,?); eauto using isOrd_inv.
     rewrite <- H4; trivial.
     apply eq_intro; intros.
      rewrite inter2_def; split; trivial.
      rewrite <- H3; auto.

      apply inter2_def in H5; destruct H5; trivial.

  (* dir *)
  apply isDir_osup2; auto.

  apply isOrd_dir; trivial.
   apply isOrd_dir; trivial.

  (* trans *)
  apply osup2_ax in H; auto.
  destruct H as [?|[?|(x',?,(y',?,?))]]; eauto using isOrd_inv.
  rewrite H1; apply Hrecx; eauto using isOrd_inv.

 (* inter distrib *)
 intros.
 assert (wfizx : isOrd (z ∩ x)).
  apply isOrd_inter2; auto.
 assert (wfizy : isOrd (z ∩ y)).
  apply isOrd_inter2; auto.
 assert (Hrec: forall x' y' z, x' ∈ x -> y' ∈ y -> isOrd z ->
                 z ∩ (x' ⊔ y') == z ∩ x' ⊔ z ∩ y').
  intros; apply Hrecx; eauto using isOrd_inv.
 apply eq_intro; intros.
  rewrite inter2_def in H0; trivial; destruct H0.
  rewrite osup2_ax in H1; auto.
  destruct H1 as [?|[?|(x',?,(y',?,?))]].
   apply osup2_incl1; trivial.
   rewrite inter2_def; auto.

   apply osup2_incl2; trivial.
   rewrite inter2_def; auto.

   rewrite osup2_ax; trivial; right; right.
   exists (z0 ∩ x').
    rewrite inter2_def; split.
     apply isOrd_plump with z0; auto.
      apply isOrd_inter2; eauto using isOrd_inv.
      apply inter2_incl1.
     apply isOrd_plump with x'; auto.
      apply isOrd_inter2; eauto using isOrd_inv.
      apply inter2_incl2.
   exists (z0 ∩ y').
    rewrite inter2_def; split.
     apply isOrd_plump with z0; auto.
      apply isOrd_inter2; eauto using isOrd_inv.
      apply inter2_incl1.
     apply isOrd_plump with y'; auto.
      apply isOrd_inter2; eauto using isOrd_inv.
      apply inter2_incl2.
   rewrite <- Hrec; eauto using isOrd_inv.
   rewrite incl_inter2; auto with *.
   rewrite H3; reflexivity.

  rewrite osup2_ax in H0; trivial.
  destruct H0 as [?|[?|(x',?,(y',?,?))]].
   rewrite inter2_def in H0; destruct H0; rewrite inter2_def; split; trivial.
   apply osup2_incl1; auto.

   rewrite inter2_def in H0; destruct H0; rewrite inter2_def; split; trivial.
   apply osup2_incl2; auto.

   rewrite inter2_def in H0; destruct H0.
   rewrite inter2_def in H1; destruct H1.
   rewrite H2; clear z0 H2.
   destruct (isOrd_dir _ H x' y'); trivial.
   destruct H5.
   rewrite inter2_def; split.
    apply isOrd_plump with x0; trivial.
     apply Hrecx; eauto using isOrd_inv.
     rewrite <- (incl_inter2 _ _) with (1:=H5). (*!*)
     rewrite <- (incl_inter2 _ _) with (1:=H6). (*!*)
     rewrite (inter2_comm x' x0); rewrite (inter2_comm y' x0).
     rewrite <- Hrec; eauto using isOrd_inv.
     apply inter2_incl1.

    rewrite (osup2_ax x y); auto; right; right; eauto with *.
Qed.

Lemma isOrd_osup2 : forall x y,
  isOrd x ->
  isOrd y ->
  isOrd (x ⊔ y).
intros.
apply osup2_proof; trivial.
Qed.

Lemma osup2_lub : forall x y z,
  isOrd x -> isOrd y -> isOrd z ->
  x ⊆ z -> y ⊆ z -> x ⊔ y ⊆ z.
intros.
rewrite <- (incl_inter2 _ _) with (1:=H2). (*!*)
rewrite <- (incl_inter2 _ _) with (1:=H3). (*!*)
rewrite (inter2_comm x z); rewrite (inter2_comm y z).
destruct osup2_proof with (1:=H)(2:=H0) as (_,dint); rewrite <- dint; trivial.
apply inter2_incl1.
Qed.

Lemma osup2_refl x : isOrd x -> x ⊔ x == x.
intros.
apply eq_intro; intros.
 revert H0; apply osup2_lub; auto with *.

 apply osup2_incl1; auto.
Qed.

Lemma osup2_lt x y z : isOrd z -> x ∈ z -> y ∈ z -> x ⊔ y ∈ z.
intros.
destruct (isOrd_dir _ H x y); trivial.
destruct H3.
apply isOrd_plump with x0; trivial.
 apply isOrd_osup2; eauto using isOrd_inv.

 apply osup2_lub; eauto using isOrd_inv.
Qed.

Lemma isDir_succ : forall o,
  isOrd o -> isDir (osucc o).
red; intros.
assert (xo : isWf x) by (apply isOrd_inv with (osucc o); auto).
exists (x ⊔ y).
 apply osup2_lt; auto.

 split.
  apply osup2_incl1; eauto using isOrd_inv.
  apply osup2_incl2; eauto using isOrd_inv.
Qed.

Lemma osup2_sym : forall x y, isOrd x -> isOrd y -> x ⊔ y == y ⊔ x.
intros x y wfx wfy.
revert y wfy ; apply isOrd_ind with (2:=wfx); intros.
apply eq_intro; intros.
 rewrite osup2_ax in H2|-*; trivial.
 destruct H2 as [?|[?|(x',?,(y',?,?))]];[right;left|left|right;right]; trivial.
 exists y'; trivial.
 exists x'; trivial.
 rewrite H4; apply H1; eauto using isOrd_inv.

 rewrite osup2_ax in H2|-*; trivial.
 destruct H2 as [?|[?|(x',?,(y',?,?))]];[right;left|left|right;right]; trivial.
 exists y'; trivial.
 exists x'; trivial.
 rewrite H4; symmetry; apply H1; eauto using isOrd_inv.
Qed.

Lemma osup2_assoc : forall x y z, isOrd x -> isOrd y -> isOrd z ->
  x ⊔ (y ⊔ z) == x ⊔ y ⊔ z.
intros x y z wfx; revert y z; apply isOrd_ind with (2:=wfx); intros.
apply eq_intro; intros.
 rewrite osup2_ax in H4|-*; auto.
 2:apply isOrd_osup2; trivial.
 rewrite osup2_ax; auto.
 destruct H4 as [?|[?|(x',?,(w',?,?))]]; auto.
  rewrite osup2_ax in H4; auto.
  destruct H4 as [?|[?|(y',?,(z',?,?))]]; auto.
  right; right.
  exists y';[|exists z']; trivial.
  apply osup2_incl2; auto.

  rewrite osup2_ax in H5; auto.
  destruct H5 as [?|[?|(y'',?,(z',?,?))]]; auto.
   left; right; right; exists x'; [trivial|exists w';trivial].

   right; right; exists x'; [|exists w';trivial].
   apply osup2_incl1; auto.

   right; right; exists (x' ⊔ y'');[|exists z']; trivial.
    rewrite osup2_ax; [right; right; exists x'; [trivial|exists y'']; auto with *|auto].

    rewrite <- H1; eauto using isOrd_inv.
    rewrite <- H8; trivial.

 rewrite osup2_ax in H4|-*; auto.
 2:apply isOrd_osup2; trivial.
 rewrite osup2_ax; auto.
 destruct H4 as [?|[?|(w',?,(z',?,?))]]; auto.
  rewrite osup2_ax in H4; auto.
  destruct H4 as [?|[?|(y',?,(z',?,?))]]; auto.
  right; right.
  exists y';[|exists z']; trivial.
  apply osup2_incl1; auto.

  rewrite osup2_ax in H4; auto.
  destruct H4 as [?|[?|(x',?,(y',?,?))]]; auto.
   right; right; exists w'; [trivial|exists z';trivial].
   apply osup2_incl2; auto.

   right; left; right; right; exists w'; [trivial|exists z';trivial].

   right; right; exists x';[|exists (y' ⊔ z')]; trivial.
    rewrite osup2_ax; [right; right; exists y'; [trivial|exists z']; auto with *|auto].

    rewrite H1; eauto using isOrd_inv.
    rewrite <- H8; trivial.
Qed.

End BinarySup.
Infix "⊔" := osup2 (at level 50). (* input method: \sqcup *)

(** ** Indexed supremum of monotonic family *)

Section OrdinalUpperBound.

  Variable I : set.
  Variable f : set -> set.
  Hypothesis f_ext : ext_fun I f.
  Hypothesis f_ord : forall x, x ∈ I -> isOrd (f x).

  Lemma isOrd_supf_intro : forall n, n ∈ I -> f n ⊆ sup I f.
red; intros.
rewrite sup_ax; trivial.
exists n; trivial.
Qed.

  Lemma isOrd_supf_elim : forall x, x < sup I f -> exists2 n, n ∈ I & x < f n.
intros.
rewrite sup_ax in H; trivial.
Qed.

  (* Directed union: *)
  Hypothesis supf_dir : forall x y, x ∈ I -> y ∈ I ->
    exists2 z, z ∈ I & f x ⊆ f z /\ f y ⊆ f z.

  Lemma isDir_ord_sup : isDir (sup I f).
red; intros.
rewrite sup_ax in H; trivial; destruct H.
rewrite sup_ax in H0; trivial; destruct H0.
assert (xo : isOrd x).
 apply isOrd_inv with (f x0); auto.
destruct supf_dir with x0 x1; trivial.
destruct H4.
exists (x ⊔ y).
 rewrite sup_ax; trivial.
 exists x2; trivial.
 apply osup2_lt; auto.

 split.
  apply osup2_incl1; trivial.
  apply osup2_incl2; trivial.
Qed.

  Lemma isOrd_supf : isOrd (sup I f).
apply isOrd_intro; intros.
 elim isOrd_supf_elim with (1:=H1); intros.
 apply isOrd_supf_intro with x; trivial.
 apply isOrd_plump with b; auto.

 apply isDir_ord_sup.

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

End OrdinalUpperBound.

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

Require Import ZFrepl.

Section LimOrd.

  Variable f : nat -> set.
  Variable ford : forall n, isOrd (f n).
  Variable fmono : forall m n, (m <= n)%nat -> f m ⊆ f n.

  Let F x := uchoice (fun y => exists2 n, x == nat2set n & f n == y).

  Let Fm : morph1 F.
do 2 red; intros.
apply uchoice_morph_raw.
red; intros.
apply ex2_morph.
 red; intros.
 rewrite H; reflexivity.

 red; intros.
 rewrite H0; reflexivity.
Qed.

  Let Fch : forall x, x ∈ N ->
    uchoice_pred (fun y => exists2 n, x == nat2set n & f n == y).
intros.
split;[|split]; intros.
 revert H1; apply ex2_morph; red; intros; auto with *.
 rewrite H0; reflexivity.

 elim H using N_ind; intros.
  revert H2; apply ex_morph.
  red; intros.
  apply ex2_morph; red; intros; auto with *.
  rewrite H1; reflexivity.

  exists (f 0); exists 0; simpl; auto with *.

  destruct H1 as (y,(m,?,?)).
  exists (f (S m)); exists (S m); simpl; auto with *.
  apply succ_morph; trivial.

 destruct H0; destruct H1.
 rewrite <- H2; rewrite <- H3; rewrite H0 in H1; apply nat2set_inj in H1.
 rewrite H1; reflexivity.
Qed.

  Definition ord_sup := sup N F.

  Lemma isOrd_sup_intro : forall n, f n ⊆ ord_sup.
unfold ord_sup.
red; intros.
rewrite sup_ax; trivial.
2:do 2 red; intros; apply Fm; trivial.
exists (nat2set n).
 apply nat2set_typ.

 destruct (uchoice_def _ (Fch _ (nat2set_typ n))).
 unfold F; rewrite <- H1.
 apply nat2set_inj in H0; rewrite <- H0; trivial.
Qed.

  Lemma isOrd_sup_elim : forall x, x < ord_sup -> exists n, x < f n.
unfold ord_sup; intros.
rewrite sup_ax in H.
2:do 2 red; intros; apply Fm; trivial.
destruct H.
destruct (uchoice_def _ (Fch _ H)).
exists x1; rewrite H2; trivial.
Qed.

  Lemma isOrd_sup : isOrd ord_sup.
apply isOrd_intro; intros.
 elim isOrd_sup_elim with (1:=H1); intros.
 apply isOrd_sup_intro with x.
 apply isOrd_plump with b; auto.

 red; intros.
 apply isOrd_sup_elim in H; destruct H.
 apply isOrd_sup_elim in H0; destruct H0.
 assert (xo : isOrd x).
  apply isOrd_inv with (f x0); trivial.
 exists (x ⊔ y).
  destruct (isOrd_dir _ (ford (x0+x1)) x y).
   apply (fmono x0); auto with arith.
   apply (fmono x1); auto with *.

   destruct H2.
   apply (isOrd_sup_intro (x0+x1)).
   apply isOrd_plump with x2; auto.
    apply isOrd_osup2; eauto using isOrd_inv.

    apply osup2_lub; eauto using isOrd_inv.

  split.
   apply osup2_incl1; trivial.
   apply osup2_incl2; trivial.

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

  Lemma ord_sup_typ X :
    (forall n, f n ∈ X) ->
    (forall g, morph1 g -> (forall n, n ∈ N -> g n ∈ X) -> sup N g ∈ X) ->
    ord_sup ∈ X.
unfold ord_sup.
intros.
apply H0; trivial; intros.
destruct (uchoice_def _ (Fch _ H1)).
unfold F; rewrite <- H3; trivial.
Qed.

End LimOrd.

Lemma isOrd_union : forall x,
  (forall y, y ∈ x -> isOrd y) ->
  (forall a a', a ∈ x -> a' ∈ x -> exists2 b, b ∈ x & a ⊆ b /\ a' ⊆ b) ->
 isOrd (union x).
intros.
rewrite union_is_sup.
apply isOrd_supf; auto.
do 2 red; trivial.
Qed.

Lemma isOrd_inter : forall x,
  (forall y, y ∈ x -> isOrd y) -> isOrd (inter x).
intros.
apply isOrd_intro; intros.
 apply inter_intro; trivial.
  intros.
  apply isOrd_plump with b; auto.
  apply inter_elim with (1:=H2); trivial.

  destruct inter_non_empty with (1:=H2); eauto.

 red; intros.
 destruct inter_non_empty with (1:=H0) as (w,?,?).
 assert (x0o : isOrd x0).
  apply isOrd_inv with w; auto.
 exists (x0 ⊔ y).
  apply inter_intro; intros; eauto.
  apply osup2_lt; auto.
   apply inter_elim with (1:=H0); trivial.
   apply inter_elim with (1:=H1); trivial.

  split.
   apply osup2_incl1; trivial.
   apply osup2_incl2; trivial.

 destruct inter_non_empty with (1:=H0).
 eauto using isOrd_inv.
Qed.

Fixpoint nat2ordset n :=
  match n with
  | 0 => zero
  | S k => osucc (nat2ordset k)
  end.

Lemma nat2ordset_typ : forall n, isOrd (nat2ordset n).
induction n; simpl; intros.
 apply isOrd_zero.
 apply isOrd_succ; trivial.
Qed.
Hint Resolve nat2ordset_typ.

(** Ordinal omega *)

Definition omega := ord_sup nat2ordset.

Lemma isOrd_omega : isOrd omega.
apply isOrd_sup; trivial.
induction 1; intros; auto with *.
simpl.
transitivity (nat2ordset m0); trivial.
red; intros.
apply isOrd_trans with (2:=H0); auto.
Qed.
Hint Resolve isOrd_omega.

Lemma zero_omega : lt zero omega.
apply isOrd_sup_intro with 1; simpl.
apply lt_osucc; trivial.
Qed.
Hint Resolve zero_omega.

Lemma osucc_omega : forall n, lt n omega -> lt (osucc n) omega.
intros.
apply isOrd_sup_elim in H; destruct H.
apply isOrd_sup_intro with (S x); simpl.
apply lt_osucc_compat; auto.
Qed.
Hint Resolve osucc_omega.

Lemma omega_limit_ord : limitOrd omega.
split; auto.
Qed.
Hint Resolve omega_limit_ord.

(* f^w(o) *)
Definition iter_w (f:set->set) o :=
  ord_sup(nat_rect(fun _=>set) o (fun _ => f)).

Lemma isOrd_iter_w : forall f o,
  o ⊆ f o ->
  (forall x y, isOrd x -> isOrd y -> x ⊆ y -> f x ⊆ f y) ->
  (forall x, isOrd x -> isOrd (f x)) ->
  isOrd o ->
  isOrd (iter_w f o).
intros.
unfold iter_w.
apply isOrd_sup.
 induction n; simpl; intros; auto.

 induction m; simpl; intros.
  revert o H H2; elim n; simpl; intros; auto with *.
  transitivity (f o); trivial.
  apply H0; auto.
  elim n0; simpl; auto.

  destruct n; simpl.
   inversion H3.
  apply H0; auto with arith.
   elim m; simpl; auto.
   elim n; simpl; auto.
Qed.

Definition plus_w := iter_w osucc.

(** ** Indexed supremum of arbitrary family *)

Section DirOrdinalSup.

  Variable I : set.
  Variable f : set -> set.
  Hypothesis f_ext : ext_fun I f.
  Hypothesis f_ord : forall x, x ∈ I -> isOrd (f x).

  (** Taking the supremum pairwise *)
  Definition osupf X := sup X (fun x => replf X (fun y => x ⊔ y)).
  Definition osupfn n := nat_rect (fun _ => set) (sup I f) (fun _ => osupf) n.
  (** Iterating ω times, we get a fixpoint *)
  Definition osup := ord_sup osupfn.

  Lemma osupf_def X z : z ∈ osupf X <-> exists2 x, x ∈ X & exists2 y, y ∈ X & z == x ⊔ y.
unfold osupf; rewrite sup_ax.
 apply ex2_morph.
  red; reflexivity.

  red; intros.
  rewrite replf_ax.
   reflexivity.

   do 2 red; intros; apply osup2_morph; auto with *.

 do 2 red; intros; apply replf_morph; auto with *.
 red; intros; apply osup2_morph; trivial.
Qed.

  Lemma osupf_mono X Y :
    X ⊆ Y ->
    osupf X ⊆ osupf Y.
red; intros.
rewrite osupf_def in H0|-*.
destruct H0 as (x,?,(y,?,?)); exists x; auto.
exists y; auto.
Qed.

  Lemma osupfn_mono m n : (m <= n)%nat -> osupfn m ⊆ osupfn n.
revert n; induction m; simpl; intros.
 clear H; induction n; simpl; auto with *.
 apply osupf_mono in IHn.
 red; intros; apply IHn.
 rewrite osupf_def.
 exists z; trivial.
 exists z; trivial.
 symmetry; apply osup2_refl.
 rewrite sup_ax in H; trivial.
 destruct H.
 apply isOrd_inv with (f x); auto.

 destruct n; simpl.
  inversion H.
 apply osupf_mono; apply IHm; auto with arith.
Qed.

  Lemma osup_intro : forall x, x ∈ I -> f x ⊆ osup.
red; intros.
unfold osup.
apply isOrd_sup_intro with (n:=0); simpl.
rewrite sup_ax; eauto.
Qed.

  Lemma isOrd_osupfn : forall n x, x ∈ osupfn n -> isOrd x.
induction n; simpl; intros.
 rewrite sup_ax in H; trivial.
 destruct H; eauto using isOrd_inv.

 rewrite osupf_def in H.
 destruct H as (y,?,(y',?,?)).
 rewrite H1; apply isOrd_osup2; eauto using isOrd_inv.
Qed.

  Lemma isOrd_osup : isOrd osup.
unfold osup.
apply isOrd_intro; intros.
 apply isOrd_sup_elim in H1.
 destruct H1 as (n,?).
 apply isOrd_sup_intro with n.
 revert a b H H0 H1.
 induction n; simpl; intros.
  rewrite sup_ax in H1|-*; trivial.
  destruct H1.
  exists x; trivial.
  apply isOrd_plump with b; auto.

  rewrite osupf_def in H1|-*.
  destruct H1 as (x,?,(y,?,?)).
  assert (xo : isOrd x).
   apply isOrd_osupfn in H1; trivial.
  assert (yo : isOrd y).
   apply isOrd_osupfn in H2; trivial.
  exists (a ∩ x).
   apply IHn with x; trivial.
    apply isOrd_inter2; trivial.

    apply inter2_incl2.

  exists (a ∩ y).
   apply IHn with y; trivial.
    apply isOrd_inter2; trivial.

    apply inter2_incl2.

   destruct osup2_proof with x y as (_,?); trivial.
   rewrite <- H4; trivial.
   apply eq_intro; intros.
    rewrite inter2_def; split; trivial.
    rewrite <- H3; auto.

    rewrite inter2_def in H5; destruct H5; trivial.

 red; intros.
 apply isOrd_sup_elim in H; destruct H as (n,?).
 apply isOrd_sup_elim in H0; destruct H0 as (m,?).
 assert (xo : isOrd x).
  apply isOrd_osupfn in H; trivial.
 assert (yo : isOrd y).
   apply isOrd_osupfn in H0; trivial.
 exists (x ⊔ y).
  apply isOrd_sup_intro with (S(n+m)); simpl.
  rewrite osupf_def; exists x.
   revert H; apply osupfn_mono; auto with arith.
  exists y; auto with *.
   revert H0; apply osupfn_mono; auto with arith.

  split.
   apply osup2_incl1; apply xo.
   apply osup2_incl2; apply xo.

 apply isOrd_sup_elim in H; destruct H as (n,?).
 apply isOrd_osupfn in H; trivial.
Qed.

  Lemma osup_lub z :
    isOrd z ->
    (forall x, x ∈ I -> f x ⊆ z) ->
    osup ⊆ z.
red; intros.
apply isOrd_sup_elim in H1; destruct H1 as (n,?).
revert z0 H1; induction n; simpl; intros.
 rewrite sup_ax in H1; trivial.
 destruct H1.
 revert H2; apply H0; trivial.

 rewrite osupf_def in H1; destruct H1 as (x,?,(y,?,?)).
 rewrite H3; apply osup2_lt; auto.
Qed.

  Lemma osup_univ U :
    (forall X F, ext_fun X F -> X ∈ U -> (forall x, x ∈ X -> F x ∈ U) ->
     sup X F ∈ U) ->
    (forall X x y, X ∈ U -> isOrd x -> x ∈ X -> y ∈ X -> singl (x ⊔ y) ∈ U) ->
    N ∈ U ->
    I ∈ U ->
    (forall x, x ∈ I -> f x ∈ U) ->
    osup ∈ U.
intros.
unfold osup.
apply ord_sup_typ; intros.
 induction n; simpl; intros; auto.
 unfold osupf.
 apply H; intros; trivial.
  do 2 red; intros; apply replf_morph; auto with *.
  red; intros; apply osup2_morph; auto.

  intros.
  rewrite replf_is_sup.
  2:do 2 red; intros; apply osup2_morph; auto with *.
  apply H; eauto.
   do 2 red; intros; apply singl_morph; apply osup2_morph; auto with *.

   intros.
   apply H0 with (1:=IHn); trivial.
   apply isOrd_osupfn in H4; auto.
 apply H; trivial.
 do 2 red; intros; apply H4; trivial.
Qed.

End DirOrdinalSup.

Lemma isOrd_eq_osup : forall o, isOrd o -> o == osup o osucc.
intros.
apply incl_eq.
 red; intros.
 apply osup_intro with (x:=z); trivial.
  do 2 red; intros; apply osucc_morph; trivial.

  apply lt_osucc; eauto using isOrd_inv.

 apply osup_lub; trivial.
  do 2 red; intros; apply osucc_morph; trivial.

  red; intros.
  apply le_lt_trans with x; trivial.
Qed.

  Lemma osup_morph : forall x x' f f',
    x == x' -> eq_fun x f f' -> osup x f == osup x' f'.
unfold osup, ord_sup; intros.
apply sup_morph; auto with *.
red; intros.
apply uchoice_morph_raw.
red; intros.
apply ex2_morph; red; intros.
 rewrite H2; reflexivity.

 assert (osupfn x f a == osupfn x' f' a).
  induction a; simpl; intros.
   apply sup_morph; auto.

   apply incl_eq; apply osupf_mono; rewrite IHa; reflexivity.
 rewrite H4; rewrite H3; reflexivity.
Qed.

(** * Projection toward ordinals *)

Definition toOrd (x : set) :=
  osup (subset x isOrd) osucc.

Instance toOrd_morph : morph1 toOrd.
do 2 red; intros.
unfold toOrd.
apply osup_morph.
 apply subset_morph; auto with *.

 red; intros; rewrite H1; reflexivity.
Qed.

Lemma toOrd_isOrd : forall x, isOrd (toOrd x).
intros.
unfold toOrd.
apply isOrd_osup; intros.
 red; red; intros.
 rewrite H0; reflexivity.

 apply isOrd_succ.
 destruct subset_elim2 with (1:=H).
 rewrite H0; trivial.
Qed.

Lemma toOrd_ord : forall o, isOrd o -> toOrd o == o.
intros.
unfold toOrd.
apply incl_eq.
 apply osup_lub; trivial.
  do 2 red; intros; apply osucc_morph; trivial.

  intros.
  red; intros.
  assert (isOrd x).
   apply subset_elim2 in H0; destruct H0.
   rewrite H0; trivial.
  apply subset_elim1 in H0.
  apply isOrd_plump with x; eauto using isOrd_inv.
  apply olts_le in H1; trivial.

 red; intros.
 assert (z ∈ osucc z).
  apply lt_osucc.
  apply isOrd_inv with o; trivial.
 revert H1; apply osup_intro.
  do 2 red; intros; apply osucc_morph; auto.

  apply subset_intro; trivial.
  apply isOrd_inv with o; trivial.
Qed.


C02W82DBHV2R:~ i847419$ coqtop
Welcome to Coq 8.8.0 (April 2018)

Coq < Require Import Classical.

Coq < Theorem exp020 : (forall P Q : Prop, ((P -> Q) -> (~~P -> Q))).
1 subgoal

  ============================
  forall P Q : Prop, (P -> Q) -> ~ ~ P -> Q

exp020 < intros.
1 subgoal

  P, Q : Prop
  H : P -> Q
  H0 : ~ ~ P
  ============================
  Q

exp020 < tauto.
No more subgoals.

exp020 < Qed.
exp020 is defined


(* Software Foundations *)
(* Exercice 1 star, dictionary_invariant1 *)

Module Dictionary.
Inductive natoption: Type :=
|Some: nat -> natoption
|None: natoption.

Inductive dictionary: Type :=
|empty: dictionary
|record: nat -> nat -> dictionary -> dictionary.

Definition insert(k v: nat)(d: dictionary): dictionary :=
  (record k v d).

Fixpoint find(key: nat)(d: dictionary): natoption :=
match d with
|empty         => None
|record k v d' => if (Nat.eqb key k) then Some v else find key d'
end.

Lemma nat_eq_self: forall n: nat, Nat.eqb n n = true.
Proof.
    intros. induction n as [|n'].
    reflexivity.
    simpl. rewrite IHn'. reflexivity.
Qed.

Theorem dictionary_invariant1: forall (d: dictionary)(k v: nat),
  find k (insert k v d) = Some v.
Proof.
    intros. induction d as [|k' v' d'].
    simpl. rewrite nat_eq_self. reflexivity.
    simpl. rewrite nat_eq_self. reflexivity.
Qed.

End Dictionary.


(* fibonacci_numbers.v *)
(* dIFP 2014-2015, Q1 *)
(* Teacher: Olivier Danvy <danvy@cs.au.dk> *)

(* Student name: ... *)
(* Student number: ... *)

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

(* The goal of this project is to study
   the Fibonacci function and
   properties of Fibonacci numbers. *)

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

Require Import Arith.
Require Import unfold_tactic.

Lemma unfold_plus_bc :
  forall j : nat,
    plus 0 j = j.
Proof.
  unfold_tactic plus.
Qed.

Lemma unfold_plus_ic :
  forall i' j : nat,
    plus (S i') j = S (plus i' j).
Proof.
  unfold_tactic plus.
Qed.

Proposition plus_1_S :
  forall n : nat,
    S n = plus 1 n.
Proof.
  intro n.
  induction n as [ | n' IHn'].
    rewrite -> (plus_0_r 1).
    reflexivity.

    rewrite -> (unfold_plus_ic).
    rewrite -> (plus_0_l (S n')).
    reflexivity.
Qed.

Lemma nat_ind2 :
  forall P : nat -> Prop,
    P 0 ->
    P 1 ->
    (forall i : nat,
      P i -> P (S i) -> P (S (S i))) ->
    forall n : nat,
      P n.
Proof.
  intros P H_P0 H_P1 H_PSS n.
  assert(consecutive :
           forall x : nat,
             P x /\ P (S x)).
    intro x.
    induction x as [ | x' [IHx' IHSx']].
      split.
        exact H_P0.
      exact H_P1.

      split.
        exact IHSx'.
      exact (H_PSS x' IHx' IHSx').

      destruct (consecutive n) as [ly _].

      exact ly.
Qed.

Definition square (x : nat) : nat :=
  x * x.

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

(* You are given the two following specifications
   of the Fibonacci function:
*)

Definition specification_of_fibonacci (fib : nat -> nat) :=
  fib 0 = 0
  /\
  fib 1 = 1
  /\
  forall n'' : nat,
    fib (S (S n'')) = fib (S n'') + fib n''.

Definition specification_of_fibonacci_alt (fib : nat -> nat) :=
  fib 0 = 0
  /\
  fib 1 = 1
  /\
  fib 2 = 1
  /\
  forall p q : nat,
    fib (S (p + q)) =
    fib (S p) * fib (S q) + fib p * fib q.

(* Prove that each of these specifications
   specifies a unique function.
*)

Lemma specification_of_fibonacci_is_unique :
  forall (f g : nat -> nat),
    specification_of_fibonacci f ->
    specification_of_fibonacci g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_fibonacci.
  intros [f0 [f1 fn]] [g0 [g1 gn]].
  intro n.

  induction n as [ | | n' IHn' IHSn'] using nat_ind2.

  rewrite -> f0.
  rewrite -> g0.
  reflexivity.

  rewrite -> f1.
  rewrite -> g1.
  reflexivity.

  rewrite -> fn.
  rewrite -> gn.
  rewrite -> IHn'.
  rewrite -> IHSn'.
  reflexivity.
Qed.

Lemma specification_of_fibonacci_alt_is_unique :
  forall (f g : nat -> nat),
    specification_of_fibonacci_alt f ->
    specification_of_fibonacci_alt g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_fibonacci_alt.
  intros [f0 [f1 [f2 fn]]] [g0 [g1 [g2 gn]]].
  intro n.

  induction n as [ | | n' IHn' IHSn'] using nat_ind2.

  rewrite -> f0.
  rewrite -> g0.
  reflexivity.

  rewrite -> f1.
  rewrite -> g1.
  reflexivity.

  rewrite -> (plus_1_S).
  rewrite <- (plus_n_Sm).
  rewrite -> fn.
  rewrite -> gn.
  rewrite -> IHn'.
  rewrite -> IHSn'.
  rewrite -> f2.
  rewrite -> f1.
  rewrite -> g2.
  rewrite -> g1.
  reflexivity.
Qed.

(* If we removed the clause "fib 2 = 1" in
   specification_of_fibonacci_alt,
   would the specification still specify a unique function?
*)

Definition specification_of_fibonacci_alt_alt (fib : nat -> nat) :=
  fib 0 = 0
  /\
  fib 1 = 1
  /\
  forall p q : nat,
    fib (S (p + q)) =
    fib (S p) * fib (S q) + fib p * fib q.

Lemma specification_of_fibonacci_alt_alt_is_unique :
  forall (f g : nat -> nat),
    specification_of_fibonacci_alt_alt f ->
    specification_of_fibonacci_alt_alt g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_fibonacci_alt_alt.
  intros [f0 [f1 fn]] [g0 [g1 gn]].
  intro n.

  induction n as [ | | n' IHn' IHSn'] using nat_ind2.

  rewrite -> f0.
  rewrite -> g0.
  reflexivity.

  rewrite -> f1.
  rewrite -> g1.
  reflexivity.

  rewrite <- (plus_0_r (S n')).
  rewrite -> fn.
  rewrite -> gn.

  Abort.
(* Hvordan skriver vi det i bevis at det ikke findes? *)

(*
   Show that these specifications are equivalent,
   i.e., prove the following proposition:
*)

Proposition equivalence_of_the_specifications_of_fibonacci:
  forall fib: nat -> nat,
    specification_of_fibonacci fib
    <->
    specification_of_fibonacci_alt fib.

(* Suppose that you have only proved
   that one of the two specifications is unique.
   Deduce that the other specification is also unique (i.e.,
   do not prove it from scratch: prove that it is a consequence
   of the uniqueness of the first specification).
*)

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

(* Given either of the specifications
   of the Fibonacci function above,
   prove the following propositions:
*)

Proposition about_fibonacci_numbers_whose_index_is_even :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall n : nat,
      fib (2 * (S n)) + square (fib n) =
      square (fib (S (S n))).
Proof.
  intro fib.
  unfold specification_of_fibonacci.
  intros [f0 [f1 fn]].
  intro n.

  induction n as [ | | n' IHn' IHSn'] using nat_ind2.
  rewrite -> (mult_1_r).
  rewrite -> f0.
  rewrite -> fn.
  rewrite -> f0.
  rewrite ->2 (plus_0_r).
  unfold square.
  rewrite -> f1.
  rewrite -> (mult_1_r).
  reflexivity.

  rewrite -> f1.
  rewrite -> (fn 1).
  rewrite -> (mult_succ_r 2).
  rewrite -> (mult_1_r).
  rewrite -> (plus_1_S 1) at 2.
  rewrite -> (plus_assoc 2 1 1).
  rewrite <- (plus_n_Sm 2 0).
  rewrite -> (plus_0_r).
  rewrite <- (plus_n_Sm 3 0).
  rewrite -> (plus_0_r).
  rewrite -> (fn 2).
  rewrite -> (fn 1).
  rewrite -> f1.
  rewrite  -> (fn 0).
  rewrite -> f1.
  rewrite -> f0.
Abort.

Proposition d_Occagne_s_identity :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall n : nat,
      fib (2 * (S n)) = fib (S n) * (fib (S (S n)) + fib n).
Proof.
  intro fib.
  unfold specification_of_fibonacci.
  intros [f0 [f1 fn]].
  intro n.

  induction n as [ | | n' IHn' IHSn'] using nat_ind2.
  rewrite -> (mult_1_r).
  rewrite -> f1.
  rewrite -> f0.
  rewrite -> (plus_0_r).
  rewrite -> (mult_1_l).
  reflexivity.

Abort.

Proposition Cassini_s_identity_for_even_numbers :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall n : nat,
      square (fib (S (2 * n))) =
      S ((fib (2 * (S n))) * (fib (2 * n))).
Proof.
Abort.

Proposition Cassini_s_identity_for_odd_numbers :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall n : nat,
      S (square (fib (2 * (S n)))) =
      (fib (S (2 * (S n)))) * (fib (S (2 * n))).
Proof.
Abort.

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

(* Here is the sum function from Week 37: *)

Fixpoint sum_ds (f : nat -> nat) (n : nat) : nat :=
  match n with
  | 0 => f 0
  | S n' => sum_ds f n' + f n
  end.

Definition sum  (f : nat -> nat) (n : nat) : nat :=
  sum_ds f n.

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

(* Given either of the specifications
   of the Fibonacci function above,
   prove the following propositions:
*)

Proposition sum_of_the_first_fibonacci_numbers :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall n : nat,
      S (sum fib n) = fib (S (S n)).
Proof.
Abort.

Proposition sum_of_the_first_fibonacci_numbers_whose_index_is_even :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall n : nat,
      S (sum (fun i => fib (2 * i)) n) = fib (S (2 * n)).
Proof.
Abort.

Proposition sum_of_the_first_fibonacci_numbers_whose_index_is_odd :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall n : nat,
      sum (fun i => fib (S (2 * i))) n = fib (2 * (S n)).
Proof.
Abort.

Proposition sum_of_the_squares_of_the_first_fibonacci_numbers :
  forall fib : nat -> nat,
    specification_of_fibonacci fib ->
    forall n : nat,
      sum (fun i => square (fib i)) n = fib n * fib (S n).
Proof.
Abort.

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

(* end of fibonacci_numbers.v *)


(* Copyright (C) 2005-2008 Sebastien Briais *)
(* http://lamp.epfl.ch/~sbriais/ *)

(* This library is free software; you can redistribute it and/or modify *)
(* it under the terms of the GNU Lesser General Public License as *)
(* published by the Free Software Foundation; either version 2.1 of the *)
(* License, or (at your option) any later version. *)

(* This library is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU *)
(* Lesser General Public License for more details. *)

(* You should have received a copy of the GNU Lesser General Public *)
(* License along with this library; if not, write to the Free Software *)
(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA *)
(* 02110-1301 USA *)

(** First, we show the following theorem: *)
(** if p is a prime number and gcd(p,k)=1 then sqrt(p*k) is not rational *)

(** Then, we strengthen the result to the n-th root of p^r*k *)
(** where 0 < r < n obtaining the theorem: *)
(**  if p is a prime number, gcd(p,k)=1 and 0 < r < n then the n-th root of p^r*k is not rational *)

Require Import missing.
Require Import division.
Require Import gcd.
Require Import primes.
Require Import power.

Unset Standard Proposition Elimination Names.

(** now, we show the result claimed in the header *)
Lemma sqrt_prime_irrat_aux : forall (p k a b:nat),(is_prime p)->(rel_prime p k)->(rel_prime a b)->(p*k*(square b) <> (square a)).
  intros.
  intro.
  assert (divides a p).
  apply prime_square;trivial.
  exists (k*(square b)).
  rewrite <- H2;ring.
  elim H3;intro n_a;intro.
  rewrite H4 in H2;rewrite square_mult_lemma in H2;unfold square in H2.
  assert (k*(b*b)=p*(n_a*n_a)).
  apply mult_lemma6 with p.
  intro H5;rewrite H5 in H;apply not_prime_zero;trivial.
  rewrite mult_assoc;rewrite H2;ring.
  assert (divides b p).
  apply prime_square;trivial;unfold square.
  apply gauss with k.
  apply rel_prime_sym;trivial.
  exists (n_a*n_a);trivial.
  assert (p=1).
  unfold rel_prime in H1.
  elim H1;intros.
  apply divides_antisym;try (apply one_min_div).
  apply H8;red;tauto.
  elim H;tauto.
Qed.

(** Theorem: if p is prime, p and k are relatively prime, then sqrt(p*k) is not rationnal *)
Theorem sqrt_prime_irrat : forall (p k a b:nat),(is_prime p)->(rel_prime p k)->(b<>O)->(p*k*(square b) <> (square a)).
  intros.
  generalize (gcd_is_gcd a b);intro.
  generalize (quo_is_quo a (gcd a b) (gcd_div_l (gcd a b) a b H2));intro.
  generalize (quo_is_quo b (gcd a b) (gcd_div_r (gcd a b) a b H2));intro.
  intro.
  rewrite H3 in H5.
  replace (square b) with (square (gcd a b * quo b (gcd a b) (gcd_div_r (gcd a b) a b H2))) in H5;auto.
  rewrite square_mult_lemma in H5;rewrite square_mult_lemma in H5.
  assert (p*k*(square (quo b (gcd a b) (gcd_div_r (gcd a b) a b H2)))=(square (quo a (gcd a b) (gcd_div_l (gcd a b) a b H2)))).
  apply mult_lemma6 with (square (gcd a b)).
  unfold square.
  generalize (gcd_non_zero (gcd a b) a b H1 H2);intro.
  intro;apply H6.
  case (mult_lemma2 (gcd a b) (gcd a b) H7);trivial.
  rewrite <- H5;ring.
  apply (sqrt_prime_irrat_aux p k (quo a (gcd a b) (gcd_div_l (gcd a b) a b H2)) (quo b (gcd a b) (gcd_div_r (gcd a b) a b H2)));auto.
  apply gcd_rel_prime;apply (gcd_non_zero (gcd a b) a b);trivial.
Qed.

(** if p is prime then sqrt(p) is not rationnal *)
Fact sqrt_prime : forall (p:nat),(is_prime p)->forall (a b:nat),(b<>O)->(p*(square b)<>(square a)).
  intros.
  replace p with (p*1);try (auto with arith).
  apply sqrt_prime_irrat;trivial;apply rel_prime_1.
Qed.

(** We now deduce from this theorem that sqrt(2) is not rationnal *)
(** here is it! *)
Fact sqrt_2_irrat : forall (p q:nat),(q<>O)->(2*(square q)<>(square p)).
  intros.
  apply sqrt_prime;trivial.
  apply is_prime_2.
Qed.

(** generalisation *)
Lemma nth_root_irrat_aux : forall (p k a b n r:nat),(is_prime p)->(rel_prime p k)->(0<r)->(r<n)->(rel_prime a b)->((power p r)*k*(power b n) <> (power a n)).
  intros.
  intro.
  assert (divides a p).
  apply prime_power with n;trivial.
  generalize (power_divides_lemma1 r p H1);intro.
  elim H5;intro q;intros.
  rewrite H6 in H4.
  rewrite <- H4;exists (q*k*(power b n));ring.
  assert (divides b p).
  elim H5;intro q;intros.
  rewrite H6 in H4.
  rewrite power_mult_lemma1 in H4.
  assert ((power p n)=(power p (r+(n-r)))).
  rewrite <- le_plus_minus;try (auto with arith).
  rewrite H7 in H4;rewrite power_plus_lemma1 in H4.
  assert ((power p r)<>O).
  intro.
  apply not_prime_zero.
  assert (p=O).
  apply power_zero with r;trivial.
  rewrite H9 in H;trivial.
  rewrite <- mult_assoc in H4;rewrite <- mult_assoc in H4;generalize (mult_lemma6 (k*(power b n)) ((power p (n-r))*(power q n)) (power p r) H8 H4);intro.
  assert (divides (power p (n-r)) p).
  apply power_divides_lemma1;apply minus_lt_lemma1;trivial.
  apply prime_power with n;trivial.
  apply gauss with k;try (apply rel_prime_sym;trivial).
  rewrite H9;apply divides_mult;trivial.
  elim H3;intros.
  elim H;intros.
  apply H9;apply divides_antisym;try (apply one_min_div).
  apply H8;red;tauto.
Qed.

(** generalization of the theorem: if p is a prime number, 0 < r < n and gcd(p,k)=1 then the n-th root of p^r*k is not rationnal! *)
Theorem nth_root_irrat : forall (p k a b n r:nat),(is_prime p)->(rel_prime p k)->(0<r)->(r<n)->(b<>0)->((power p r)*k*(power b n) <> (power a n)).
  intros.
  intro.
  generalize (gcd_is_gcd a b);intro.
  generalize (quo_is_quo a (gcd a b) (gcd_div_l (gcd a b) a b H5));intro.
  generalize (quo_is_quo b (gcd a b) (gcd_div_r (gcd a b) a b H5));intro.
  assert ((power a n)=(power (gcd a b * quo a (gcd a b) (gcd_div_l (gcd a b) a b H5)) n));try (rewrite <- H6;trivial).
  assert ((power b n)=(power (gcd a b * quo b (gcd a b) (gcd_div_r (gcd a b) a b H5)) n));try (rewrite <- H7;trivial).
  rewrite power_mult_lemma1 in H8;rewrite H8 in H4.
  rewrite power_mult_lemma1 in H9;rewrite H9 in H4.
  rewrite mult_lemma7 in H4.
  assert ((power (gcd a b) n)<>O).
  intro.
  generalize (power_zero n (gcd a b) H10);intro.
  apply (gcd_non_zero (gcd a b) a b);trivial.
  generalize (mult_lemma6 (power p r * k * power (quo b (gcd a b) (gcd_div_r (gcd a b) a b H5)) n) (power (quo a (gcd a b) (gcd_div_l (gcd a b) a b H5)) n) (power (gcd a b) n) H10 H4).
  fold ((power p r * k * power (quo b (gcd a b) (gcd_div_r (gcd a b) a b H5)) n)<>(power (quo a (gcd a b) (gcd_div_l (gcd a b) a b H5)) n)).
  apply nth_root_irrat_aux;trivial.
  apply gcd_rel_prime;apply (gcd_non_zero (gcd a b) a b);trivial.
Qed.

(** Generalization of the previous theorem *)
Theorem nth_root_irrational : forall (p k a b n q r:nat),(is_prime p)->(rel_prime p k)->(0<r)->(r<n)->(b<>0)->((power p (q*n+r))*k*(power b n) <> (power a n)).
  intros.
  intro.
  rewrite power_plus_lemma1 in H4.
  assert (divides a (power p q)).
  apply prime_power_qn with n;try (auto with arith);try omega.
  exists ((power p r)*k*(power b n)).
  rewrite <- H4;ring.
  assert (0<n);try omega.
  elim H5;intro a';intro.
  rewrite H7 in H4.
  rewrite power_mult_lemma1 in H4;rewrite power_power_lemma1 in H4.
  assert ((power p (q*n))<>0).
  intro;apply not_prime_zero;generalize (power_zero (q*n) p H8);intro;rewrite H9 in H;trivial.
  rewrite <- (mult_assoc (power p (q*n))) in H4;rewrite <- (mult_assoc (power p (q*n))) in H4.
  generalize (mult_lemma6 (power p r*k*power b n) (power a' n) (power p (q*n)) H8 H4).
  fold (power p r * k * power b n <> power a' n).
  apply nth_root_irrat;trivial.
Qed.

(** let x and n be two numbers such that n > 0, then either the n-th root of x is a natural number of it is not rationnal *)
Theorem nth_root : forall (x n:nat),(n>0)->{y:nat | x=(power y n)}+{forall (a b:nat),(b<>0)->x*(power b n)<>(power a n)}.
  intros.
  case (is_power_m_dec x n H);intro;try tauto.
  elim s;intro p;intro.
  elim p0;intro q;intro.
  elim p1;intro r;intro.
  elim p2;intro k;intro.
  right;intros.
  assert (x=(power p (q*n+r))*k);try tauto.
  rewrite H1;apply nth_root_irrational;tauto.
Qed.