Require Export Base.

Inductive Tree :=
  | node: list Tree -> Tree.

Definition of_tree (x: Tree): list Tree :=
  match x with
  | node l => l
  end.

Definition tree_rect (P: Tree -> Type) (tnil: P (node nil)) (tcons: forall (hd: Tree) (tl: list Tree) (c: P (node tl)), P (node (hd :: tl)%list)) (x: Tree): P x :=
  let rect := fix rect (l: list Tree): P (node l) :=
    match l with
    | nil => tnil
    | cons x tl => tcons x tl (rect tl)
    end
  in
  match x with
  | node l => rect l
  end.

Definition tree_ind (P: Tree -> Prop) (tnil: P (node nil)) (tcons: forall (hd: Tree) (tl: list Tree) (c: P (node tl)), P (node (hd :: tl)%list)) (x: Tree): P x :=
  let rect := fix rect (l: list Tree): P (node l) :=
    match l with
    | nil => tnil
    | cons x tl => tcons x tl (rect tl)
    end
  in
  match x with
  | node l => rect l
  end.

Fixpoint tree_ind_in (P: Tree -> Prop) (IH: forall l, (forall x, List.In x l -> P x) -> P (node l)) (x: Tree) {struct x}: P x :=
  let rect := fix rect (l: list Tree): forall x, List.In x l -> P x :=
    match l return forall x, List.In x l -> P x with
    | nil => fun _ => False_ind _
    | cons x tl => fun e (H: x = e \/ List.In e tl) =>
      match H with
      | or_introl H => match H in _ = y return P y with eq_refl => tree_ind_in P IH x end
      | or_intror H => rect tl e H
      end
    end
  in
  match x with
  | node l => IH l (rect l)
  end.

Inductive tree_eq: Tree -> Tree -> Prop :=
| tree_eq_intro xs ys:
    (forall x, List.In x xs -> exists y, List.In y ys /\ tree_eq x y) ->
    (forall y, List.In y ys -> exists x, List.In x xs /\ tree_eq x y) ->
    tree_eq (node xs) (node ys).

Lemma tree_eq_elm (xs ys: Tree):
  tree_eq xs ys ->
  (forall x, List.In x (of_tree xs) -> exists y, List.In y (of_tree ys) /\ tree_eq x y) /\
  (forall y, List.In y (of_tree ys) -> exists x, List.In x (of_tree xs) /\ tree_eq x y).
Proof.
  destruct xs as [xs], ys as [ys].
  simpl.
  intros H.
  now inversion_clear H.
Qed.

Instance tree_equiv: Equivalence tree_eq.
Proof.
  split.
  + intros x.
    induction x using tree_ind_in.
    constructor.
    all: intros x Hx.
    all: exists x; split.
    1, 3: exact Hx.
    all: apply H, Hx.
  + intros x.
    induction x as [xs IH] using tree_ind_in.
    intros [ys] H.
    apply tree_eq_elm in H.
    destruct H as [H1 H2].
    constructor.
    1: intros x Hx.
    2: intros y Hy.
    1: specialize (H2 x Hx).
    2: specialize (H1 y Hy).
    1: destruct H2 as [y [Hy H]].
    2: destruct H1 as [x [Hx H]].
    1: exists y.
    2: exists x.
    all: split.
    1, 3: assumption.
    all: now apply IH.
  + intros x.
    induction x as [xs IH] using tree_ind_in.
    intros [ys] [zs] H1 H2.
    apply tree_eq_elm in H1.
    apply tree_eq_elm in H2.
    destruct H1 as [xy yx], H2 as [yz zy].
    constructor.
    1: clear yx zy.
    2: clear xy yz.
    1: intros x Hx.
    2: intros z Hz.
    1: specialize (xy x Hx).
    2: specialize (zy z Hz).
    1: destruct xy as [y [Hy xy]].
    2: destruct zy as [y [Hy yz]].
    1: specialize (yz y Hy).
    2: specialize (yx y Hy).
    1: destruct yz as [z [Hz yz]].
    2: destruct yx as [x [Hx xy]].
    1: exists z.
    2: exists x.
    all: split.
    1, 3: assumption.
    all: now apply (IH x Hx y).
Qed.

Definition tree_in (x xs: Tree): Prop :=
  exists y, List.In y (of_tree xs) /\ tree_eq y x.

Lemma tree_eq_iff (x y: Tree): tree_eq x y <-> forall e, tree_in e x <-> tree_in e y.
Proof.
  split.
  + intros H e.
    apply tree_eq_elm in H.
    destruct H as [Hx Hy].
    split.
    all: intros [e1 [H1 H]].
    1: specialize (Hx e1 H1).
    2: specialize (Hy e1 H1).
    1: destruct Hx as [e2 [H2 H3]].
    2: destruct Hy as [e2 [H2 H3]].
    all: exists e2; split.
    1, 3: exact H2.
    all: now transitivity e1.
  + intros H.
    destruct x as [xs], y as [ys].
    constructor.
    all: intros e He.
    all: specialize (H e).
    all: [> apply proj1 in H | apply proj2 in H].
    all: destruct H as [e1 [H1 H]].
    1, 3: now exists e.
    all: now exists e1.
Qed.

Instance tree_in_morph: Proper (tree_eq ==> tree_eq ==> iff) tree_in.
Proof.
  enough (Proper (tree_eq ==> tree_eq ==> impl) tree_in).
  now split; apply H.
  intros x y H1 X Y H2 [e [He H]].
  apply tree_eq_elm, proj1 in H2.
  specialize (H2 e He).
  destruct H2 as [e1 [He1 H2]].
  exists e1.
  split.
  exact He1.
  now rewrite <- H2, H.
Qed.

Definition sub_tree (x y: Tree) := forall e, tree_in e x -> tree_in e y.

Instance sub_tree_preorder: PreOrder sub_tree.
Proof.
  split.
  + intros x y H.
    exact H.
  + intros x y z xy yz e H.
    apply yz, xy, H.
Qed.

Instance sub_tree_partialorder: PartialOrder tree_eq sub_tree.
Proof.
  intros x y.
  simpl.
  rewrite tree_eq_iff.
  split.
  + intros H.
    split.
    all: intros e.
    all: apply H.
  + intros [H1 H2] e.
    split.
    apply H1.
    apply H2.
Qed.

Lemma tin_ind (P: Tree -> Prop):
  Proper (tree_eq ==> iff) P ->
  (forall X, (forall x, tree_in x X -> P x) -> P X) ->
  forall X, P X.
Proof.
  intros HP IH X.
  induction X using tree_ind_in.
  apply IH.
  intros x [e [He H1]].
  rewrite <- H1.
  apply H, He.
Qed.

Definition ɛ_tree: (Tree -> Prop) -> Tree :=
  epsilon (inhabits (node nil)).

Lemma ɛ_tree_correct (P: Tree -> Prop): (exists x, P x) -> P (ɛ_tree P).
Proof. apply epsilon_spec. Qed.

Instance ɛ_tree_ext: Proper (pointwise_relation _ iff ==> eq) ɛ_tree.
Proof.
  intros P Q H.
  f_equal.
  extensionality x.
  apply propositional_extensionality, H.
Qed.

Definition Nf (X: Tree): Tree := ɛ_tree (tree_eq X).

Lemma tree_eq_Nf (X: Tree): tree_eq X (Nf X).
Proof.
  unfold Nf.
  apply ɛ_tree_correct.
  now exists X.
Qed.

Lemma Nf_idem (X: Tree): Nf (Nf X) = Nf X.
Proof.
  apply ɛ_tree_ext.
  intros Y.
  split; intro H.
  all: rewrite <- H.
  2: symmetry.
  all: apply tree_eq_Nf.
Qed.

Lemma tree_Nf_eq (X Y: Tree): tree_eq X Y <-> Nf X = Nf Y.
Proof.
  split.
  + intros H.
    apply ɛ_tree_ext.
    intro x.
    now rewrite H.
  + intros H.
    rewrite tree_eq_Nf, H.
    symmetry.
    apply tree_eq_Nf.
Qed.

Structure fset: Type := tree_fset {
  fset_tree: {X | Nf X = X};
}.

Declare Scope fset_scope.
Delimit Scope fset_scope with fset.
Bind Scope fset_scope with fset.
Local Open Scope fset_scope.

Definition NSf (X: Tree): fset := tree_fset (exist _ (Nf X) (Nf_idem X)).

Lemma tree_eq_NSf (X: Tree): tree_eq X (proj1_sig (fset_tree (NSf X))).
Proof. apply tree_eq_Nf. Qed.

Definition fIn (X Y: fset): Prop := tree_in (proj1_sig (fset_tree X)) (proj1_sig (fset_tree Y)).

Infix "∈" := fIn (at level 70): fset_scope.
Notation "x ∉ X" := (~fIn x X) (at level 70): fset_scope.

Lemma tree_in_fset (X Y: fset): tree_in (proj1_sig (fset_tree X)) (proj1_sig (fset_tree Y)) -> X ∈ Y.
Proof. intro H. exact H. Qed.

Lemma tree_in_NSf (X Y: Tree): tree_in X Y -> NSf X ∈ NSf Y.
Proof.
  intro H.
  apply tree_in_fset.
  simpl.
  rewrite <- !tree_eq_Nf.
  exact H.
Qed.

Definition subfset (X Y: fset): Prop :=
  forall z, z ∈ X -> z ∈ Y.

Infix "⊆" := subfset (at level 70): fset_scope.

Instance subfset_preorder: PreOrder subfset.
Proof.
  constructor.
  easy.
  intros X Y Z XY YZ x H.
  apply YZ, XY, H.
Qed.

Theorem subfset_subtree (X Y: fset): sub_tree (proj1_sig (fset_tree X)) (proj1_sig (fset_tree Y)) -> X ⊆ Y.
Proof.
  intros XY z zX.
  apply XY, zX.
Qed.

Instance subfset_partialorder: PartialOrder eq subfset.
Proof.
  intros X Y.
  split.
  intros H.
  subst Y.
  split; reflexivity.
  intros [XY YX].
  destruct X as [[x Hx]], Y as [[y Hy]].
  f_equal.
  enough (x = y).
  subst y.
  f_equal.
  apply proof_irrelevance.
  rewrite <- Hx, <- Hy.
  apply tree_Nf_eq.
  apply antisymmetry.
  1: clear YX.
  2: clear XY; rename YX into XY.
  all: intros a H.
  all: rewrite tree_eq_Nf in H |- *.
  all: exact (XY (NSf a) H).
Qed.

Theorem fset_eq_ext (X Y: fset): (forall z, z ∈ X <-> z ∈ Y) <-> X = Y.
Proof.
  split.
  intros H.
  apply antisymmetry.
  1, 2: intro z.
  1, 2: apply H.
  intros H z.
  now subst Y.
Qed.

Theorem fset_tree_eq (X Y: fset): tree_eq (proj1_sig (fset_tree X)) (proj1_sig (fset_tree Y)) -> X = Y.
Proof.
  intros H.
  apply partial_order_equivalence in H.
  destruct H as [XY YX].
  apply antisymmetry.
  all: now apply subfset_subtree.
Qed.

Definition indexf (X: fset): list fset :=
  match proj1_sig (fset_tree X) with
  | node l => List.map NSf l
  end.

Definition fset_of (l: list fset): fset :=
  tree_fset (exist _ (Nf (node (List.map (fun x => proj1_sig (fset_tree x)) l))) (Nf_idem _)).

Lemma fset_of_indexf (X: fset): fset_of (indexf X) = X.
Proof.
  apply fset_tree_eq.
  unfold indexf; simpl.
  generalize (proj1_sig (fset_tree X)).
  clear X; intros [X].
  simpl.
  rewrite <- tree_eq_Nf.
  rewrite tree_eq_iff.
  intros e.
  split.
  all: intros [a [Ha H]].
  all: simpl in Ha.
  apply List.in_map_iff in Ha.
  destruct Ha as [a' [Ha Ha']].
  subst a.
  apply List.in_map_iff in Ha'.
  destruct Ha' as [a [Ha' Ha]].
  subst a'.
  simpl in H.
  rewrite <- tree_eq_Nf in H.
  now exists a.
  exists (Nf a).
  simpl.
  split.
  apply List.in_map_iff.
  exists (NSf a).
  simpl.
  repeat split.
  apply List.in_map, Ha.
  rewrite <- tree_eq_Nf.
  exact H.
Qed.

Theorem in_fset_of x xs: x ∈ fset_of xs <-> List.In x xs.
Proof.
  unfold fIn.
  simpl.
  rewrite <- tree_eq_Nf.
  split.
  + intros [a [Ha H]].
    simpl in Ha.
    apply List.in_map_iff in Ha.
    destruct Ha as [e [Ha He]].
    subst a.
    apply fset_tree_eq in H.
    now subst e.
  + intros H.
    exists (proj1_sig (fset_tree x)).
    simpl.
    split.
    now apply (List.in_map (fun x => proj1_sig (fset_tree x))).
    reflexivity.
Qed.

Theorem in_indexf (x X: fset): x ∈ X <-> List.In x (indexf X).
Proof.
  rewrite <- (fset_of_indexf X) at 1.
  apply in_fset_of.
Qed.

Lemma fset_NSf (X: fset): exists x: Tree, X = NSf x.
Proof.
  destruct X as [[X H]].
  exists X.
  apply fset_tree_eq, tree_eq_Nf.
Qed.

Lemma fset_ind (P: fset -> Prop):
  (forall X, (forall x, x ∈ X -> P x) -> P X) ->
  forall X, P X.
Proof.
  intros IH X.
  destruct (fset_NSf X) as [x H].
  subst X.
  revert x.
  apply tin_ind.
  intros X Y XY.
  f_equiv.
  apply fset_tree_eq.
  simpl.
  rewrite <- !tree_eq_Nf.
  exact XY.
  intros X H.
  apply IH.
  intros Y Hx.
  destruct (fset_NSf Y) as [x H0].
  subst Y.
  apply H.
  rewrite (tree_eq_Nf x).
  rewrite (tree_eq_Nf X).
  exact Hx.
Qed.

Definition empty: fset := fset_of nil.
Notation Ø := empty.

Theorem in_empty (x: fset): x ∉ Ø.
Proof.
  exact (proj1 (in_fset_of x nil)).
Qed.

Theorem not_empty (x: fset): x <> Ø <-> exists z, z ∈ x.
Proof.
  split.
  + intros H.
    destruct (dec (forall z, z ∉ x)).
    destruct H.
    symmetry.
    apply antisymmetry.
    1, 2: intros z Hz.
    now apply in_empty in Hz.
    now specialize (n z).
    destruct (dec (exists z, z ∈ x)).
    exact e.
    destruct n.
    intros z Hz.
    destruct n0.
    now exists z.
  + intros [z Hz] H.
    subst x.
    now apply in_empty in Hz.
Qed.

Definition single (x: fset): fset :=
  fset_of (x :: nil).

Theorem in_single (z x: fset): z ∈ single x <-> z = x.
Proof.
  unfold single.
  rewrite in_fset_of.
  split.
  now intros [].
  intros H.
  now left.
Qed.

Theorem single_inj (x y: fset): single x = single y <-> x = y.
Proof.
  symmetry.
  split.
  all: intros H.
  now subst y.
  rewrite <- fset_eq_ext in H.
  specialize H with x.
  rewrite !in_single in H.
  now apply H.
Qed.

Theorem single_not_empty (x: fset): single x <> Ø.
Proof.
  apply not_empty.
  exists x.
  now apply in_single.
Qed.

Definition upair (X Y: fset): fset :=
  fset_of (X :: Y :: nil).

Notation "{ x , y }" := (upair x y) (at level 0, x at level 99, y at level 99): fset_scope.

Theorem in_upair (z x y: fset): z ∈ {x, y} <-> z = x \/ z = y.
Proof.
  unfold upair.
  rewrite in_fset_of.
  simpl.
  f_equiv.
  easy.
  split.
  now intros [].
  intros H.
  now left.
Qed.

Lemma upair_not_empty (x y: fset): upair x y <> Ø.
Proof.
  apply not_empty.
  exists x.
  apply in_upair.
  now left.
Qed.

Lemma upair_refl (x: fset): upair x x = single x.
Proof.
  apply fset_eq_ext.
  intros z.
  rewrite in_upair, in_single.
  split.
  now intros [H | H].
  intros H.
  now left.
Qed.

Definition union (X: fset): fset :=
  fset_of (List.flat_map indexf (indexf X)).

Notation "∪ X" := (union X) (at level 40): fset_scope.

Theorem in_union (x X: fset): x ∈ ∪ X <-> exists y, y ∈ X /\ x ∈ y.
Proof.
  unfold union.
  rewrite in_fset_of.
  split.
  + intros H.
    apply List.in_flat_map in H.
    destruct H as [a [Ha Hx]].
    exists a.
    split.
    all: now apply in_indexf.
  + intros [y [yX xy]].
    apply List.in_flat_map.
    exists y.
    split.
    all: now apply in_indexf.
Qed.

Definition union_single (x: fset): ∪ (single x) = x.
Proof.
  apply fset_eq_ext.
  intros z.
  rewrite in_union.
  setoid_rewrite in_single.
  split.
  + intros [y [Hy Hz]].
    now subst y.
  + intros Hz.
    now exists x.
Qed.

Definition map (f: fset -> fset) (X: fset): fset :=
  fset_of (List.map f (indexf X)).

Notation "{ y | x ⋴ X }" := (map (fun x => y) X) (at level 0, y at level 99, x, X at level 89): fset_scope.

Lemma in_map (z: fset) (f: fset -> fset) (X: fset): z ∈ { f x | x ⋴ X } <-> exists x, x ∈ X /\ z = f x.
Proof.
  unfold map.
  rewrite in_fset_of.
  rewrite List.in_map_iff.
  f_equiv.
  intros x.
  rewrite and_comm.
  f_equiv.
  symmetry.
  apply in_indexf.
  easy.
Qed.

Lemma in_map' (z: fset) (f: fset -> fset) (X: fset): z ∈ X -> f z ∈ { f x | x ⋴ X}.
Proof.
  intros Hz.
  apply in_map.
  now exists z.
Qed.

Lemma map_id (X: fset): {x | x ⋴ X} = X.
Proof.
  apply fset_eq_ext.
  intros z.
  rewrite in_map.
  split.
  intros [x [Hx Hz]].
  now subst z.
  intros Hz.
  now exists z.
Qed.

Lemma map_comp (f g: fset -> fset) (X: fset): {f y | y ⋴ {g x | x ⋴ X}} = {f (g x) | x ⋴ X}.
Proof.
  apply antisymmetry.
  + intros z Hz.
    apply in_map in Hz.
    destruct Hz as [y [Hy Hf]].
    apply in_map in Hy.
    destruct Hy as [x [Hx Hg]].
    subst y z.
    apply (in_map' x), Hx.
  + intros z Hz.
    apply in_map in Hz.
    destruct Hz as [x [Hx Hz]].
    subst z.
    apply in_map'.
    apply in_map'.
    exact Hx.
Qed.

Lemma map_single (f: fset -> fset) (x: fset): {f x | x ⋴ single x} = single (f x).
Proof.
  apply fset_eq_ext.
  intros z.
  rewrite in_map.
  setoid_rewrite in_single.
  split.
  + intros [y [Hy Hz]].
    now subst y.
  + intros H.
    now exists x.
Qed.

Lemma in_flat_map (z: fset) (f: fset -> fset) (X: fset): z ∈ ∪ {f x | x ⋴ X} <-> exists y, y ∈ X /\ z ∈ f y.
Proof.
  split.
  + intros Hz.
    apply in_union in Hz.
    destruct Hz as [v [Hv Hz]].
    apply in_map in Hv.
    destruct Hv as [y [Hy Hv]].
    subst v.
    now exists y.
  + intros [y [Hy Hz]].
    apply in_union.
    exists (f y).
    split.
    apply in_map.
    now exists y.
    exact Hz.
Qed.

Definition sep (P: fset -> Prop) (X: fset): fset :=
  fset_of (List.filter (fun x => if dec (P x) then true else false) (indexf X)).

Notation "{ x ⋴ X | P }" := (sep (fun x => P) X) (at level 0, x, X at level 99, P at level 99): fset_scope.

Lemma in_sep (z: fset) (P: fset -> Prop) (X: fset): z ∈ { x ⋴ X | P x } <-> z ∈ X /\ P z.
Proof.
  unfold sep.
  rewrite in_fset_of.
  rewrite List.filter_In.
  f_equiv.
  symmetry.
  apply in_indexf.
  now destruct (dec (P z)).
Qed.

Definition intersect (X: fset) :=
  { x ⋴ ∪ X | forall y, y ∈ X -> x ∈ y}.

Notation "∩ X" := (intersect X) (at level 40): fset_scope.

Lemma in_intersect (z X: fset): X <> Ø -> z ∈ ∩ X <-> forall x, x ∈ X -> z ∈ x.
Proof.
  intros HX.
  unfold intersect.
  rewrite in_sep, in_union.
  split.
  now intros [_ H].
  intros Hz.
  split.
  destruct (dec (forall x, x ∉ X)).
  destruct HX.
  apply antisymmetry.
  1, 2: intros x Hx.
  now specialize (n x).
  now apply in_empty in Hx.
  destruct (dec (exists x, x ∈ X)).
  destruct e as [x Hx].
  exists x.
  split.
  exact Hx.
  apply Hz, Hx.
  destruct n.
  intros x Hx.
  destruct n0.
  now exists x.
  exact Hz.
Qed.

Lemma intersect_single (x: fset): ∩ single x = x.
Proof.
  apply fset_eq_ext.
  intros z.
  rewrite in_intersect.
  2: apply single_not_empty.
  setoid_rewrite in_single.
  split; intros Hz.
  now apply Hz.
  intros e H.
  now subst e.
Qed.

Definition binunion (x y: fset) := ∪ {x, y}.
Infix "∪" := binunion (at level 50, left associativity): fset_scope.

Lemma in_binunion (z x y: fset): z ∈ x ∪ y <-> z ∈ x \/ z ∈ y.
Proof.
  unfold binunion.
  rewrite in_union.
  setoid_rewrite in_upair.
  split.
  + intros [p [[Hp | Hp] Hz]].
    all: subst p.
    now left.
    now right.
  + intros [Hz | Hz].
    1: exists x.
    2: exists y.
    all: split.
    2, 4: exact Hz.
    now left.
    now right.
Qed.

Definition binintersect (X Y: fset) := {x ⋴ X | x ∈ Y}.
Infix "∩" := binintersect (at level 50, left associativity): fset_scope.

Lemma in_binintersect (z x y: fset): z ∈ x ∩ y <-> z ∈ x /\ z ∈ y.
Proof.
  unfold binintersect.
  exact (in_sep _ _ _).
Qed.

Definition diff (X Y: fset) := {x ⋴ X | x ∉ Y}.
Infix "\" := diff (at level 50, left associativity): fset_scope.

Lemma in_diff (z X Y: fset): z ∈ X \ Y <-> z ∈ X /\ z ∉ Y.
Proof.
  unfold diff.
  rewrite in_sep.
  reflexivity.
Qed.

Fixpoint pow_index (l: list fset): list fset :=
  match l with
  | nil => Ø :: nil
  | cons x tl => (pow_index tl ++ List.map (fun s => single x ∪ s) (pow_index tl))%list
  end.

Definition pow (X: fset): fset :=
  fset_of (pow_index (indexf X)).

Lemma in_pow (z X: fset): z ∈ pow X <-> z ⊆ X.
Proof.
  unfold pow, subfset.
  rewrite in_fset_of.
  setoid_rewrite in_indexf at 2.
  generalize (indexf X).
  clear X; intros xs.
  split.
  + induction xs in z |- *; simpl.
    intros [H | []].
    subst z.
    apply in_empty.
    rewrite List.in_app_iff.
    rewrite List.in_map_iff.
    intros [H | [x [Hz H]]] e He.
    right.
    now apply (IHxs z).
    subst z.
    rewrite in_binunion in He.
    rewrite in_single in He.
    destruct He; [left | right].
    now symmetry.
    now apply (IHxs x).
  + intros H.
    induction xs in z, H |- *; simpl.
    left.
    apply fset_eq_ext.
    intros e.
    split.
    1, 2: intros He.
    1, 2: apply False_ind.
    eapply in_empty, He.
    eapply H, He.
    apply List.in_or_app.
    destruct (dec (a ∈ z)).
    all: [> right | left].
    apply List.in_map_iff.
    exists (z \ single a).
    split.
    apply fset_eq_ext.
    intros e.
    rewrite in_binunion, in_diff, in_single.
    split.
    intros [He | [He _]].
    now subst a.
    exact He.
    intros He.
    destruct (dec (e = a)).
    1, 2: now [> left | right].
    all: apply IHxs.
    all: intros e He.
    rewrite in_diff, in_single in He.
    destruct He as [He Hn].
    all: specialize (H e He).
    all: destruct H.
    2, 4: exact H.
    now destruct Hn.
    now subst a.
Qed.

Definition pair (x y: fset): fset :=
  { single x, { x, y } }.

Lemma in_pair (z x y: fset): z ∈ pair x y <-> z = single x \/ z = {x, y}.
Proof. apply in_upair. Qed.

Lemma pair_not_empty (x y: fset): pair x y <> Ø.
Proof. apply upair_not_empty. Qed.

Lemma pair_refl (x: fset): pair x x = single (single x).
Proof.
  unfold pair.
  rewrite upair_refl.
  apply upair_refl.
Qed.

Lemma pair_inj (x y z v: fset): pair x y = pair z v <-> x = z /\ y = v.
Proof.
  symmetry.
  split.
  intros [].
  now subst z v.
  intros H.
  rewrite <- fset_eq_ext in H.
  assert (x = z).
  + specialize (H (single x)).
    apply proj1 in H.
    rewrite !in_pair in H.
    specialize (H (or_introl eq_refl)).
    destruct H.
    apply single_inj, H.
    rewrite <- fset_eq_ext in H.
    specialize (H x) as Hx.
    apply proj1 in Hx.
    rewrite in_single, in_upair in Hx.
    specialize (Hx eq_refl).
    destruct Hx as [Hx | Hx].
    exact Hx.
    subst v.
    specialize (H z).
    apply proj2 in H.
    rewrite in_single, in_upair in H.
    specialize (H (or_introl eq_refl)).
    now symmetry.
  + split.
    exact H0.
    subst z.
    specialize (H {x, y}) as Hy.
    rewrite !in_pair in Hy.
    apply proj1 in Hy.
    specialize (Hy (or_intror eq_refl)).
    destruct Hy as [Hy | Hy].
    all: rewrite <- fset_eq_ext in Hy.
    - specialize (Hy y).
      rewrite in_upair, in_single in Hy.
      apply proj1 in Hy.
      specialize (Hy (or_intror eq_refl)).
      subst y.
      specialize (H {x, v}).
      apply proj2 in H.
      rewrite !in_pair in H.
      specialize (H (or_intror eq_refl)).
      destruct H.
      rewrite <- fset_eq_ext in H.
      specialize (H v).
      rewrite in_upair, in_single in H.
      apply proj1 in H.
      specialize (H (or_intror eq_refl)).
      now symmetry.
      rewrite <- fset_eq_ext in H.
      specialize (H v).
      rewrite !in_upair in H.
      apply proj1 in H.
      specialize (H (or_intror eq_refl)).
      now destruct H.
    - specialize (Hy y) as H0.
      rewrite !in_upair in H0.
      apply proj1 in H0.
      specialize (H0 (or_intror eq_refl)).
      destruct H0.
      subst y.
      specialize (Hy v).
      rewrite !in_upair in Hy.
      apply proj2 in Hy.
      specialize (Hy (or_intror eq_refl)).
      now destruct Hy.
      exact H0.
Qed.

Lemma union_pair (x y: fset): ∪ pair x y = {x, y}.
Proof.
  apply fset_eq_ext.
  intros z.
  rewrite in_union, in_upair.
  setoid_rewrite in_pair.
  split.
  + intros [p [[Hp | Hp] Hz]].
    all: subst p.
    left.
    apply in_single, Hz.
    apply in_upair, Hz.
  + intros [H | H].
    all: subst z.
    all: exists {x, y}.
    all: split.
    1, 3: now right.
    all: apply in_upair.
    now left.
    now right.
Qed.

Lemma intersect_pair (x y: fset): ∩ pair x y = single x.
Proof.
  apply fset_eq_ext.
  intros z.
  rewrite in_intersect, in_single.
  2: apply pair_not_empty.
  setoid_rewrite in_pair.
  split.
  + intros H.
    specialize (H (single x) (or_introl eq_refl)).
    apply in_single, H.
  + intros H p [Hp | Hp].
    all: subst z p.
    now apply in_single.
    apply in_upair.
    now left.
Qed.

Definition cartisian (X Y: fset): fset :=
  ∪ { { pair x y | y ⋴ Y } | x ⋴ X }.

Lemma in_cartisian (z X Y: fset): z ∈ cartisian X Y <-> exists x y, x ∈ X /\ y ∈ Y /\ z = pair x y.
Proof.
  unfold cartisian.
  rewrite in_flat_map.
  setoid_rewrite in_map.
  split.
  + intros [x [Hx [y [Hy H]]]].
    now exists x, y.
  + intros [x [y [Hx [Hy H]]]].
    exists x.
    split.
    exact Hx.
    now exists y.
Qed.

Lemma in_cartisian' (x y X Y: fset): pair x y ∈ cartisian X Y <-> x ∈ X /\ y ∈ Y.
Proof.
  rewrite in_cartisian.
  split.
  + intros [x' [y' [Hx [Hy H]]]].
    apply pair_inj in H.
    destruct H.
    now subst x' y'.
  + intros [Hx Hy].
    now exists x, y.
Qed.

Lemma cartisian_inj (X Y Z V: fset): X <> Ø -> Y <> Ø -> cartisian X Y = cartisian Z V <-> X = Z /\ Y = V.
Proof.
  intros HX HY.
  assert (exists x, x ∈ X).
    destruct (dec (forall x, x ∉ X)).
    destruct HX.
    apply antisymmetry.
    1, 2: intros z Hz.
    now destruct (n z).
    now apply in_empty in Hz.
    destruct (dec (exists x, x ∈ X)).
    assumption.
    destruct n.
    intros z Hz.
    destruct n0.
    now exists z.
  assert (exists y, y ∈ Y).
    destruct (dec (forall y, y ∉ Y)).
    destruct HY.
    apply antisymmetry.
    1, 2: intros z Hz.
    now destruct (n z).
    now apply in_empty in Hz.
    destruct (dec (exists y, y ∈ Y)).
    assumption.
    destruct n.
    intros z Hz.
    destruct n0.
    now exists z.
  clear HX HY.
  destruct H as [x HX].
  destruct H0 as [y HY].
  symmetry.
  split.
  intros [].
  now subst Z V.
  intros H.
  rewrite <- fset_eq_ext in H.
  assert (x ∈ Z /\ y ∈ V).
    specialize (H (pair x y)).
    rewrite !in_cartisian' in H.
    now apply H.
  destruct H0 as [HZ HV].
  split.
  + apply fset_eq_ext.
    intros z.
    specialize (H (pair z y)).
    rewrite !in_cartisian' in H.
    split.
    2: symmetry in H.
    all: apply proj1 in H.
    all: intros Hz.
    all: now apply H.
  + apply fset_eq_ext.
    intros z.
    specialize (H (pair x z)).
    rewrite !in_cartisian' in H.
    split.
    2: symmetry in H.
    all: apply proj1 in H.
    all: intros Hz.
    all: now apply H.
Qed.

Module FinSet.
Section category.
Let obj := fset.

Structure hom (S T: obj) := Hom {
  rel: fset;
  sign: rel ⊆ cartisian S T;
  functional: forall x, x ∈ S -> exists! y, pair x y ∈ rel
}.

Coercion rel: hom >-> fset.

Lemma hom_eq {S T: obj} (f g: hom S T): f = g <-> (forall x y, pair x y ∈ f <-> pair x y ∈ g).
Proof.
  split; intros H.
  now subst g.
  destruct f as [f Hf1 Hf2], g as [g Hg1 Hg2].
  simpl in H.
  enough (f = g).
  subst g.
  f_equiv; apply proof_irrelevance.
  apply fset_eq_ext.
  intros p.
  split.
  all: intros Hp.
  1: specialize (Hf1 p Hp) as e.
  2: specialize (Hg1 p Hp) as e.
  all: apply in_cartisian in e.
  all: destruct e as [x [y [Hx [Hy e]]]].
  all: subst p.
  all: apply H, Hp.
Qed.

Program Definition homFun {X Y: fset} (f: fset -> fset) (Hf: forall x, x ∈ X -> f x ∈ Y): hom X Y := {|
  rel := { pair x (f x) | x ⋴ X };
|}.
Next Obligation.
  intros p Hp.
  apply in_map in Hp.
  destruct Hp as [x [Hx Hp]].
  subst p.
  apply in_cartisian'.
  split.
  exact Hx.
  apply Hf, Hx.
Qed.
Next Obligation.
  exists (f x).
  split.
  apply (in_map' x), H.
  intros y Hy.
  apply in_map in Hy.
  destruct Hy as [x' [_ Hp]].
  apply pair_inj in Hp.
  destruct Hp as [Hx' Hy].
  now subst x'.
Qed.

Lemma Fun_def {X Y: fset} (f: hom X Y) (x: fset): sig (fun y => x ∈ X -> pair x y ∈ f).
Proof.
  exists (epsilon (inhabits x) (fun y => x ∈ X -> pair x y ∈ f)).
  apply epsilon_spec.
  destruct (classic (x ∈ X)).
  apply (functional _ _ f) in H.
  destruct H as [y [H _]].
  now exists y.
  now exists Ø.
Qed.

Definition Fun {X Y: fset} (f: hom X Y) (x: fset): fset := proj1_sig (Fun_def f x).
Definition Fun_spec {X Y: fset} (f: hom X Y) (x: fset): x ∈ X -> pair x (Fun f x) ∈ f := proj2_sig (Fun_def f x).

Lemma Fun_unique {X Y: fset} (f: hom X Y) (x y: fset): pair x y ∈ f -> Fun f x = y.
Proof.
  intros H.
  assert (x ∈ X) as Hx.
  apply sign in H.
  now apply in_cartisian' in H.
  destruct (functional _ _ f x Hx) as [y' [_ Hy]].
  specialize (Hy y H) as e.
  subst y'.
  symmetry.
  apply Hy.
  now apply Fun_spec.
Qed.

Lemma Fun_unique' {X Y: fset} (f: hom X Y) (x y: fset): x ∈ X -> Fun f x = y -> pair x y ∈ f.
Proof.
  intros Hx Hy.
  subst y.
  apply Fun_spec, Hx.
Qed.

Lemma Fun_to {X Y: fset} (f: hom X Y) (x: fset): x ∈ X -> Fun f x ∈ Y.
Proof.
  intros Hx.
  apply (Fun_spec f) in Hx.
  apply sign in Hx.
  now apply in_cartisian' in Hx.
Qed.

Lemma hom_ext {X Y: fset} (f g: hom X Y): f = g <-> forall x, x ∈ X -> Fun f x = Fun g x.
Proof.
  split.
  all: intros H.
  now subst g.
  apply hom_eq.
  intros x.
  split.
  all: intros Hp.
  all: specialize (sign _ _ _ _ Hp) as He.
  all: apply in_cartisian' in He.
  all: destruct He as [Hx Hy].
  all: specialize (H x Hx).
  all: apply Fun_unique in Hp.
  all: rewrite Hp in H; clear Hp.
  all: subst y.
  all: apply Fun_spec, Hx.
Qed.

Lemma Fun_homFun {X Y: fset} (f: fset -> fset) Hf x: x ∈ X -> @Fun X Y (homFun f Hf) x = f x.
Proof.
  intros Hx.
  apply Fun_unique.
  apply (in_map' x), Hx.
Qed.

Lemma homFun_Fun {X Y: fset} (f: hom X Y): homFun (Fun f) (Fun_to f) = f.
Proof.
  apply hom_eq.
  intros x y.
  simpl.
  rewrite in_map.
  split.
  + intros [x' [Hx Hp]].
    apply pair_inj in Hp.
    destruct Hp as [Hx' Hy].
    subst x' y.
    apply Fun_spec, Hx.
  + intros Hp.
    exists x.
    split.
    apply sign in Hp.
    now apply in_cartisian' in Hp.
    f_equal.
    symmetry.
    apply Fun_unique, Hp.
Qed.

Definition id (A: obj): hom A A :=
  homFun (fun x => x) (fun x Hx => Hx).

Definition comp {A B C: obj} (f: hom B C) (g: hom A B): hom A C :=
  homFun (fun x => Fun f (Fun g x)) (fun x Hx => Fun_to f _ (Fun_to g _ Hx)).

Lemma comp_assoc {A B C D: obj} (f: hom C D) (g: hom B C) (h: hom A B): comp f (comp g h) = comp (comp f g) h.
Proof.
  apply hom_ext.
  intros x Hx.
  transitivity (Fun f (Fun g (Fun h x))).
  2: symmetry.
  all: apply Fun_unique.
  all: apply in_map.
  all: exists x; split.
  1, 3: exact Hx.
  all: f_equal.
  f_equal.
  all: symmetry.
  all: apply Fun_unique.
  apply (in_map' x), Hx.
  apply (in_map' (Fun h x)).
  apply Fun_to, Hx.
Qed.

Lemma comp_id_l {S T: obj} (f: hom S T): comp (id T) f = f.
Proof.
  apply hom_ext.
  intros x Hx.
  apply Fun_unique.
  apply in_map.
  exists x; split.
  exact Hx.
  f_equal.
  symmetry.
  apply Fun_unique.
  apply (in_map' (Fun f x) (fun x => pair x x)).
  apply Fun_to, Hx.
Qed.

Lemma comp_id_r {S T: obj} (f: hom S T): comp f (id S) = f.
Proof.
  apply hom_ext.
  intros x Hx.
  apply Fun_unique.
  apply in_map.
  exists x; split.
  exact Hx.
  do 2 f_equal.
  symmetry.
  apply Fun_unique.
  apply (in_map' x (fun x => pair x x)).
  exact Hx.
Qed.

Definition cat_mixin: Category.mixin_of obj :=
  Category.Mixin obj hom id (@comp) (@comp_assoc) (@comp_id_l) (@comp_id_r).

Canonical cat := Category.Pack obj cat_mixin.

Lemma Fun_id {X: cat} (x: fset): x ∈ X -> Fun (Categories.id X) x = x.
Proof.
  intros Hx.
  apply Fun_unique.
  apply (in_map' x (fun x => pair x x)).
  exact Hx.
Qed.

Lemma Fun_comp {X Y Z: cat} (f: Y ~> Z) (g: X ~> Y) (x: fset): x ∈ X -> Fun (f ∘ g) x = Fun f (Fun g x).
Proof.
  intros Hx.
  apply Fun_unique.
  apply (in_map' x), Hx.
Qed.

End category.

End FinSet.

Coercion FinSet.rel: FinSet.hom >-> fset.
Coercion FinSet.Fun: FinSet.hom >-> Funclass.
Canonical FinSet.cat.
Notation FinSet := FinSet.cat.


Require Import init.

Require Export topology_basis.
Require Export topology_axioms.

(** This file contains the definition of the order topology and a few basic
 facts (like "closed intervals are closed").  Anything interesting about the
 order topology is in topology_order.
 *)

(* begin hide *)
Section OrderTopology.

Local Open Scope set_scope.

Context {U} `{
    Order U,
    Reflexive U le,
    Connex U le,
    Antisymmetric U le,
    Transitive U le,
    NotTrivial U
}.
(* end hide *)
Program Instance order_topology : TopologyBasis U := {
    top_basis S :=
        (∃ a b, S = open_interval a b) ∨
        (∃ a b, S = open_closed_interval a b ∧ ∀ x, x ≤ b) ∨
        (∃ a b, S = closed_open_interval a b ∧ ∀ x, a ≤ x)
}.
Next Obligation.
    specialize (not_trivial2 x) as [y neq].
    classic_case (∀ a, a ≤ x) as [x_max|x_nmax].
    2: classic_case (∀ b, x ≤ b) as [x_min|x_nmin].
    -   exists (open_closed_interval y x).
        split.
        +   right; left.
            exists y, x.
            split.
            *   reflexivity.
            *   exact x_max.
        +   split.
            *   split.
                --  apply x_max.
                --  rewrite neq_sym; exact neq.
            *   apply refl.
    -   exists (closed_open_interval x y).
        split.
        +   right; right.
            exists x, y.
            split.
            *   reflexivity.
            *   exact x_min.
        +   split.
            *   apply refl.
            *   split.
                --  apply x_min.
                --  exact neq.
    -   clear y neq.
        rewrite not_all in x_nmax, x_nmin.
        destruct x_nmax as [b b_ltq].
        destruct x_nmin as [a a_ltq].
        rewrite nle_lt in b_ltq, a_ltq.
        exists (open_interval a b).
        split.
        +   left.
            exists a, b.
            reflexivity.
        +   split; assumption.
Qed.
Next Obligation.
    rename H7 into x1.
    rename H8 into x2.
    destruct H5 as [ [a [b eq1]] |[ [a [b [eq1 b_max]]] | [a [b [eq1 a_min]]] ]].
    all: destruct H6 as [ [c [d eq2]] |[ [c [d [eq2 d_max]]] | [c [d [eq2 c_min]]] ]].
    all: subst.
    -   classic_case (a ≤ c) as [ac|ca].
        all: classic_case (b ≤ d) as [bd|db].
        +   exists (open_interval c b).
            split.
            2: split.
            *   left.
                exists c, b.
                reflexivity.
            *   split.
                --  apply x2.
                --  apply x1.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply (le_lt_trans ac).
                        apply y_in.
                    ++  apply y_in.
                --  split.
                    ++  apply y_in.
                    ++  apply (lt_le_trans2 bd).
                        apply y_in.
        +   rewrite nle_lt in db.
            exists (open_interval c d).
            split.
            2: split.
            *   left.
                exists c, d.
                reflexivity.
            *   split.
                --  apply x2.
                --  apply x2.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply (le_lt_trans ac).
                        apply y_in.
                    ++  apply (trans2 db).
                        apply y_in.
                --  split.
                    ++  apply y_in.
                    ++  apply y_in.
        +   rewrite nle_lt in ca.
            exists (open_interval a b).
            split.
            2: split.
            *   left.
                exists a, b.
                reflexivity.
            *   split.
                --  apply x1.
                --  apply x1.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply y_in.
                    ++  apply y_in.
                --  split.
                    ++  apply (trans ca).
                        apply y_in.
                    ++  apply (lt_le_trans2 bd).
                        apply y_in.
        +   rewrite nle_lt in ca, db.
            exists (open_interval a d).
            split.
            2: split.
            *   left.
                exists a, d.
                reflexivity.
            *   split.
                --  apply x1.
                --  apply x2.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply y_in.
                    ++  apply (trans2 db).
                        apply y_in.
                --  split.
                    ++  apply (trans ca).
                        apply y_in.
                    ++  apply y_in.
    -   classic_case (a ≤ c) as [ac|ca].
        +   exists (open_interval c b).
            split.
            2: split.
            *   left.
                exists c, b.
                reflexivity.
            *   split.
                --  apply x2.
                --  apply x1.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply (le_lt_trans ac).
                        apply y_in.
                    ++  apply y_in.
                --  split.
                    ++  apply y_in.
                    ++  apply d_max.
        +   rewrite nle_lt in ca.
            exists (open_interval a b).
            split.
            2: split.
            *   left.
                exists a, b.
                reflexivity.
            *   exact x1.
            *   intros y y_in.
                split.
                --  exact y_in.
                --  split.
                    ++  apply (trans ca).
                        apply y_in.
                    ++  apply d_max.
    -   classic_case (b ≤ d) as [bd|db].
        +   exists (open_interval a b).
            split.
            2: split.
            *   left.
                exists a, b.
                reflexivity.
            *   exact x1.
            *   intros y y_in.
                split.
                --  exact y_in.
                --  split.
                    ++  apply c_min.
                    ++  apply (lt_le_trans2 bd).
                        apply y_in.
        +   rewrite nle_lt in db.
            exists (open_interval a d).
            split.
            2: split.
            *   left.
                exists a, d.
                reflexivity.
            *   split.
                --  apply x1.
                --  apply x2.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply y_in.
                    ++  apply (trans2 db).
                        apply y_in.
                --  split.
                    ++  apply c_min.
                    ++  apply y_in.
    -   classic_case (a ≤ c) as [ac|ca].
        +   exists (open_interval c d).
            split.
            2: split.
            *   left.
                exists c, d.
                reflexivity.
            *   exact x2.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply (le_lt_trans ac).
                        apply y_in.
                    ++  apply b_max.
                --  apply y_in.
        +   rewrite nle_lt in ca.
            exists (open_interval a d).
            split.
            2: split.
            *   left.
                exists a, d.
                reflexivity.
            *   split.
                --  apply x1.
                --  apply x2.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply y_in.
                    ++  apply b_max.
                --  split.
                    ++  apply (trans ca).
                        apply y_in.
                    ++  apply y_in.
    -   classic_case (a ≤ c) as [ac|ca].
        +   exists (open_closed_interval c d).
            split.
            2: split.
            *   right; left.
                exists c, d.
                split.
                --  reflexivity.
                --  apply d_max.
            *   exact x2.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply (le_lt_trans ac).
                        apply y_in.
                    ++  apply b_max.
                --  exact y_in.
        +   rewrite nle_lt in ca.
            exists (open_closed_interval a d).
            split.
            2: split.
            *   right; left.
                exists a, d.
                split.
                --  reflexivity.
                --  apply d_max.
            *   split.
                --  apply x1.
                --  apply x2.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply y_in.
                    ++  apply b_max.
                --  split.
                    ++  apply (trans ca).
                        apply y_in.
                    ++  apply y_in.
    -   exists (open_interval a d).
        split.
        2: split.
        +   left.
            exists a, d.
            reflexivity.
        +   split.
            *   apply x1.
            *   apply x2.
        +   intros y y_in.
            split.
            *   split.
                --  apply y_in.
                --  apply b_max.
            *   split.
                --  apply c_min.
                --  apply y_in.
    -   classic_case (b ≤ d) as [bd|db].
        +   exists (open_interval c b).
            split.
            2: split.
            *   left.
                exists c, b.
                reflexivity.
            *   split.
                --  apply x2.
                --  apply x1.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply a_min.
                    ++  apply y_in.
                --  split.
                    ++  apply y_in.
                    ++  apply (lt_le_trans2 bd).
                        apply y_in.
        +   rewrite nle_lt in db.
            exists (open_interval c d).
            split.
            2: split.
            *   left.
                exists c, d.
                reflexivity.
            *   exact x2.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply a_min.
                    ++  apply (trans2 db).
                        apply y_in.
                --  exact y_in.
    -   exists (open_interval c b).
        split.
        2: split.
        +   left.
            exists c, b.
            reflexivity.
        +   split.
            *   apply x2.
            *   apply x1.
        +   intros y y_in.
            split.
            *   split.
                --  apply a_min.
                --  apply y_in.
            *   split.
                --  apply y_in.
                --  apply d_max.
    -   classic_case (b ≤ d) as [bd|db].
        +   exists (closed_open_interval a b).
            split.
            2: split.
            *   right; right.
                exists a, b.
                split.
                --  reflexivity.
                --  apply a_min.
            *   exact x1.
            *   intros y y_in.
                split.
                --  exact y_in.
                --  split.
                    ++  apply c_min.
                    ++  apply (lt_le_trans2 bd).
                        apply y_in.
        +   rewrite nle_lt in db.
            exists (closed_open_interval a d).
            split.
            2: split.
            *   right; right.
                exists a, d.
                split.
                --  reflexivity.
                --  apply a_min.
            *   split.
                --  apply x1.
                --  apply x2.
            *   intros y y_in.
                split.
                --  split.
                    ++  apply y_in.
                    ++  apply (trans2 db).
                        apply y_in.
                --  split.
                    ++  apply c_min.
                    ++  apply y_in.
Qed.

Theorem open_interval_open : ∀ a b, open (open_interval a b).
Proof.
    intros a b x x_in.
    exists (open_interval a b).
    split.
    2: split.
    -   left.
        exists a, b.
        reflexivity.
    -   exact x_in.
    -   apply refl.
Qed.

Theorem open_inf_interval_open : ∀ a, open (open_inf_interval a).
Proof.
    intros a.
    classic_case (∃ b, ∀ x, x ≤ b) as [b_max|no_max].
    -   destruct b_max as [b b_max].
        intros x x_in.
        exists (open_closed_interval a b).
        split.
        2: split.
        +   right; left.
            exists a, b.
            split.
            *   reflexivity.
            *   exact b_max.
        +   split.
            *   apply x_in.
            *   apply b_max.
        +   intros y y_in.
            apply y_in.
    -   rewrite not_ex in no_max.
        pose (SS S := ∃ b, S = open_interval a b).
        assert (open_inf_interval a = ⋃ SS) as eq.
        {
            apply predicate_ext.
            intros x.
            split.
            -   intros ax.
                specialize (no_max x).
                rewrite not_all in no_max.
                destruct no_max as [b b_gt].
                rewrite nle_lt in b_gt.
                exists (open_interval a b).
                split.
                +   exists b.
                    reflexivity.
                +   split.
                    *   exact ax.
                    *   exact b_gt.
            -   intros [S [[b S_eq] Sx]].
                rewrite S_eq in Sx.
                apply Sx.
        }
        rewrite eq.
        apply union_open.
        intros S [b S_eq].
        rewrite S_eq.
        apply open_interval_open.
Qed.

Theorem inf_open_interval_open : ∀ a, open (inf_open_interval a).
Proof.
    intros b.
    classic_case (∃ a, ∀ x, a ≤ x) as [a_min|no_min].
    -   destruct a_min as [a a_min].
        intros x x_in.
        exists (closed_open_interval a b).
        split.
        2: split.
        +   right; right.
            exists a, b.
            split.
            *   reflexivity.
            *   exact a_min.
        +   split.
            *   apply a_min.
            *   apply x_in.
        +   intros y y_in.
            apply y_in.
    -   rewrite not_ex in no_min.
        pose (SS S := ∃ a, S = open_interval a b).
        assert (inf_open_interval b = ⋃ SS) as eq.
        {
            apply predicate_ext.
            intros x.
            split.
            -   intros bx.
                specialize (no_min x).
                rewrite not_all in no_min.
                destruct no_min as [a a_lt].
                rewrite nle_lt in a_lt.
                exists (open_interval a b).
                split.
                +   exists a.
                    reflexivity.
                +   split.
                    *   exact a_lt.
                    *   exact bx.
            -   intros [S [[a S_eq] Sx]].
                rewrite S_eq in Sx.
                apply Sx.
        }
        rewrite eq.
        apply union_open.
        intros S [a S_eq].
        rewrite S_eq.
        apply open_interval_open.
Qed.

Theorem closed_interval_closed : ∀ a b, closed (closed_interval a b).
Proof.
    intros a b.
    unfold closed.
    assert (𝐂 (closed_interval a b) =
        inf_open_interval a ∪ open_inf_interval b) as eq.
    {
        unfold 𝐂, closed_interval, inf_open_interval,
            open_inf_interval, union.
        apply predicate_ext; intros x.
        rewrite not_and.
        do 2 rewrite nle_lt.
        reflexivity.
    }
    rewrite eq.
    apply union_open2.
    -   apply inf_open_interval_open.
    -   apply open_inf_interval_open.
Qed.

Theorem closed_inf_interval_closed : ∀ a, closed (closed_inf_interval a).
Proof.
    intros a.
    unfold closed.
    assert (𝐂 (closed_inf_interval a) = inf_open_interval a) as eq.
    {
        unfold 𝐂, closed_inf_interval, inf_open_interval.
        apply predicate_ext; intros x.
        rewrite nle_lt.
        reflexivity.
    }
    rewrite eq.
    apply inf_open_interval_open.
Qed.

Theorem inf_closed_interval_closed : ∀ a, closed (inf_closed_interval a).
Proof.
    intros a.
    unfold closed.
    assert (𝐂 (inf_closed_interval a) = open_inf_interval a) as eq.
    {
        unfold 𝐂, inf_closed_interval, open_inf_interval.
        apply predicate_ext; intros x.
        rewrite nle_lt.
        reflexivity.
    }
    rewrite eq.
    apply open_inf_interval_open.
Qed.

(* begin hide *)
Lemma order_hausdorff_wlog : ∀ a b, a < b →
    ∃ S1 S2, open S1 ∧ open S2 ∧ S1 a ∧ S2 b ∧ disjoint S1 S2.
Proof.
    intros a b ab.
    classic_case (∃ c, a < c ∧ c < b) as [between|near].
    -   destruct between as [c [ac cb]].
        exists (inf_open_interval c), (open_inf_interval c).
        split. 2: split. 3: split. 4: split.
        +   apply inf_open_interval_open.
        +   apply open_inf_interval_open.
        +   exact ac.
        +   exact cb.
        +   apply empty_eq.
            intros x [cx xc].
            unfold inf_open_interval in cx.
            unfold open_inf_interval in cx.
            pose proof (trans cx xc) as contr.
            destruct contr; contradiction.
    -   rewrite not_ex in near.
        exists (inf_open_interval b), (open_inf_interval a).
        split. 2: split. 3: split. 4: split.
        +   apply inf_open_interval_open.
        +   apply open_inf_interval_open.
        +   exact ab.
        +   exact ab.
        +   apply empty_eq.
            intros x [bx ax].
            unfold inf_open_interval in bx.
            unfold open_inf_interval in ax.
            specialize (near x).
            rewrite not_and_impl in near.
            specialize (near ax).
            contradiction.
Qed.
(* end hide *)
Program Instance order_hausdorff : HausdorffSpace U.
Next Obligation.
    rename H5 into neq.
    destruct (trichotomy x1 x2) as [[ltq|eq]|ltq].
    -   exact (order_hausdorff_wlog x1 x2 ltq).
    -   contradiction.
    -   pose proof (order_hausdorff_wlog x2 x1 ltq) as [S1 [S2 HH]].
        exists S2, S1.
        unfold disjoint.
        rewrite inter_comm.
        repeat split; apply HH.
Qed.
(* begin hide *)
End OrderTopology.
(* end hide *)


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat ssrint.
From mathcomp Require Import fintype (*tuple *) finfun bigop  (*fingroup perm*).
From mathcomp Require Import ssralg (*zmodp matrix mxalgebra poly (* polydiv *)
  mxpoly. *).
From mathcomp Require Import finset.

(*From mathcomp Require Import algC.*)
Require Import Lia.
From Hammer Require Import Tactics .

(*Require Import Friendship.adj2_matrix.*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*Import GroupScope.*)
Import GRing.Theory.
Local Open Scope ring_scope.

From mathcomp Require Import tuple seq.

Section bigops.

  (*
    Lära mig finset ?
    Predikat för positiv och negativ rot.
    Vill visa att SUMMAN av alla rötter

   *)
  Local Open Scope set_scope.

  Lemma big_bool [R: ringType] [S : Type]
           [I : seq S]  (a : pred S) (F : bool -> R):
    \sum_(i <- I) F (a i) =
      ((F true) *+ (count a I)) +
        ((F false) *+ (count (negb \o a) I)).

    elim: I => [| x I indH]. {
      rewrite big_nil //=; sauto.
    } {
      rewrite big_cons {}indH.
      set ax := (a x); have axx : (a x) = ax by [].
      move: axx.
      case: ax => axx; rewrite //= axx //= add0n mulrS addrA. {
        by [].
      } {
        by rewrite [in RHS] addrA;  rewrite [in X in X + (_ *+ _)]addrC.
      }
    }
  Qed.

End bigops.


(*************************
 * Group 0 - Definitions *
 *************************)

Axiom Point  : Type.
Axiom Line   : Type.
(*Axiom Plane  : Type*)

(* Line Equality *)
Axiom EqLine : Line -> Line -> Prop.

(* Point-Line Congruence *)
Axiom Cong : Point -> Point -> Point -> Point -> Prop.

(* Incidental Lines *)
Axiom Incide : Point -> Line -> Prop.

(* Colinear Points *)
Definition Coline : Point -> Point -> Point -> Prop :=
  fun A B C =>
  exists l, Incide A l /\ Incide B l /\ Incide C l.

(* Between Points *)
Axiom Between : Point -> Point -> Point -> Prop.

Axiom point_equality_decidable:
  forall A B : Point, A = B \/ ~ A = B.

Axiom incidental_eqline_morphism:
  forall P l m,
  Incide P l -> EqLine l m -> Incide P m.

Axiom incidental_decidable:
  forall P l,
  Incide P l \/ ~ Incide P l.

(***********************
 * Group 1 - Incidence *
 ***********************)

Axiom line_existence:
  forall A B,
  A <> B -> exists l, Incide A l /\ Incide B l.

Axiom line_uniqueness:
  forall A B l m,
  Incide A l /\ Incide B l ->
  Incide A m /\ Incide B m ->
  EqLine m l.

Axiom two_point_line_existence:
  exists A B l,
  Incide A l /\ Incide B l.

Axiom three_point_line_not_incidental:
  exists A B C l,
  ~ ( Incide A l /\ Incide B l /\ Incide C l ).

(*******************
 * Group 2 - Order *
 *******************)

Axiom between_colinear:
  forall A B C, A <> B /\ B <> C ->
  Between A B C ->
  Coline A B C.

Axiom between_neq:
  forall A B C,
  Between A B C -> A <> C.

Axiom between_commutative:
  forall A B C,
  Between A B C -> Between C B A.

Axiom between_exists:
  forall A C, A <> C ->
  exists B, Between A B C.

Axiom between_unique:
  forall A B C,
  Between A B C -> ~ Between B C A.

Definition cut: Line -> Point -> Point -> Prop :=
  fun l A B =>
    ~ (Incide A l \/ Incide B l) /\
    exists I, Incide I l /\ Between A I B.

Axiom pasch:
  forall A B C l,
  ~ Coline A B C -> ~ Incide C l -> cut l A B ->
  cut l A C \/ cut l B C.

Definition disjoint : Point -> Point -> Point -> Point -> Prop :=
  fun A B C D => ~ exists P, Between A P B /\ Between C P D.

(************************
 * Group 3 - Congruence *
 ************************)

Axiom congruence_intro:
  forall A B A' l l',
  Incide A l /\ Incide B l ->
  Incide A' l' ->
  exists B', Cong A B A' B'.

Axiom congruence_permutation : forall A B C D, Cong A B C D -> Cong A B D C.

Axiom congruence_pseudotransitive:
  forall A B C D E F,
  Cong A B C D -> Cong A B E F -> Cong C D E F.

Axiom congruence_addition:
  forall A B C A' B' C',
  A  <> B  /\ A  <> C  ->
  A' <> B' /\ A' <> C' ->
  Cong A B A' B' /\ Cong B C B' C' -> Cong A C A' C'.

(****************************
 * Group 4 - Parallel Lines *
 ****************************)

Definition parallel: Line -> Line -> Prop :=
  fun l l' => ~ exists X, Incide X l /\ Incide X l'.

Axiom parallel_unique:
  forall A l l1 l2,
  ~ Incide A l ->
  parallel l l1  -> Incide A l1  ->
  parallel l l2 -> Incide A l2 ->
  EqLine l1 l2.

(************************
 * Group 5 - Continuity *
 ************************)

(* TODO *)


Require Import stdpp.list.
Require Import ssreflect.
From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
Local Open Scope Z.

(* upd_Znth 0
                 (upd_Znth 31 (map (fun x : ℤ => Vint (Int.repr x)) (firstn 31 contents_n) ++ [Vundef])
                    (Vint
                       (Int.zero_ext 8
                          (Int.or (Int.and (Int.repr (Znth 31 contents_n 0)) (Int.repr 127)) (Int.repr 64)))))
                 (Vint
                    (cast_int_int I8 Unsigned
                       (Int.and (Int.repr (Znth 0 (firstn 31 contents_n) 0)) (Int.repr 248))))
 *)
(*
z = n
z[31]=(n[31]&127)|64;
z[0]&=248;
*)

(* Eval compute in Z.ones 255. *)
(* 57896044618658097711785492504343953926634992332820282019728792003956564819967 *)

Definition ZUnpack25519 (n : Z) : Z := Z.land n (Z.ones 255).

Lemma Zunpack_bounded: forall x, 0 <= x < 2^255 - 19 -> 0 <= ZUnpack25519 x < 2 ^ 255 - 19.
Proof.
move => x Hx.
rewrite /ZUnpack25519.
rewrite Z.land_ones //=.
rewrite Zmod_small //=.
split ; omega.
Qed.


Require Import Undecidability.Synthetic.EnumerabilityFacts.
Require Import Undecidability.L.L.
Require Cantor.
Require Import Lia.

Fixpoint term_enum_rec (k n: nat) : term :=
  match k with
  | 0 => var 0
  | S k =>
    match Cantor.of_nat n with
    | (0, n') => var n'
    | (S (S n1), n2) => app (term_enum_rec k n1) (term_enum_rec k n2)
    | (1, n') => lam (term_enum_rec k n')
    end
  end.

Opaque Cantor.to_nat Cantor.of_nat.

Definition term_enumerator__T (n : nat) := Some (term_enum_rec (S n) n).
Lemma enumerator__T_term :
  enumerator__T term_enumerator__T term.
Proof.
  intros t. unfold term_enumerator__T.
  enough (exists n, forall m, n <= m -> term_enum_rec (S m) n = t) as [n Hn].
  { exists n. f_equal. now apply Hn. }
  induction t as [n|s [n1 IHs] t [n2 IHt]|s [n IH]].
  - exists (Cantor.to_nat (0, n)). cbn.
    now rewrite Cantor.cancel_of_to.
  - exists (Cantor.to_nat (S (S n1), n2)). cbn.
    assert (H' := Cantor.to_nat_non_decreasing (S (S n1)) n2).
    intros [|m] ?. { lia. }
    rewrite !Cantor.cancel_of_to, IHs, IHt; [easy | lia | lia].
  - exists (Cantor.to_nat (1, n)). cbn.
    assert (H' := Cantor.to_nat_non_decreasing 1 n).
    intros [|m] ?. { lia. }
    rewrite !Cantor.cancel_of_to, IH; [easy | lia ].
Qed.


Require Export theories.Well_Ordering.

(* ORDINALS *)

Module Ord.

(* VII Axiom of regularity : If x ≠ Φ there is a member y of x such x∩y = Φ. *)

Axiom Axiom_Regularity : forall x, x ≠ Φ -> exists y, y ∈ x /\ x ∩ y = Φ.

Hint Resolve Axiom_Regularity : set.

(* 101 notin_fix  x ∉ x. *)

Theorem notin_fix : forall x, x ∉ x.
Proof.
  intros; intro.
  assert ([x] ≠ Φ).
  { apply not_zero_exist_bel; exists x; apply Axiom_Scheme; split; Ens. }
  apply Axiom_Regularity in H0; destruct H0, H0.
  assert (x0 = x).
  { apply Axiom_Scheme in H0; destruct H0; apply H2; apply bel_universe_set; Ens. }
  subst x0; assert (x ∈ ([x] ∩ x)). { apply Axiom_Scheme; repeat split; Ens. }
  rewrite H1 in H2; generalize (not_bel_zero x); intro; contradiction.
Qed.

Hint Resolve notin_fix : set.

(* 102 Theorem  It is false that x∈y and y∈x. *)

Theorem not_bel_and : forall x y, ~ (x ∈ y /\ y ∈ x).
Proof.
  intros; intro; destruct H.
  assert (\{ λ z, z = x \/ z =y \} ≠ Φ).
  { apply not_zero_exist_bel; exists x; apply Axiom_Scheme; split; Ens. }
  apply Axiom_Regularity in H1; destruct H1, H1; apply Axiom_Scheme in H1.
  destruct H1, H3; subst x0.
  + assert (y ∈ (\{ λ z, z = x \/ z = y \} ∩ x)).
    { apply Axiom_Scheme; repeat split; Ens; apply Axiom_Scheme; split; Ens. }
    rewrite H2 in H3; generalize (not_bel_zero y); intro; contradiction.
  + assert (x ∈ (\{ λ z, z = x \/ z = y \} ∩ y)).
    { apply Axiom_Scheme; repeat split; Ens; apply Axiom_Scheme; split; Ens. }
    rewrite H2 in H3; generalize (not_bel_zero x); intro; contradiction.
Qed.

Hint Resolve not_bel_and : set.

(* 103 Definition  E = { [x,y] : x∈y}. *)

Definition E : Class := \{\ λ x y, x ∈ y \}\.

Hint Unfold E : set.

(* 104 Theorem  E is not a set. *)

Lemma bel_tran_false : forall a b c, a ∈ b -> b ∈ c -> c ∈ a -> False.
Proof.
  intros.
  assert (\{ λ x, x = a \/ x =b \/ x = c \} ≠ Φ).
  { apply not_zero_exist_bel; exists a; apply Axiom_Scheme; split; Ens. }
  apply Axiom_Regularity in H2; destruct H2, H2; apply Axiom_Scheme in H2; destruct H2.
  destruct H4 as [H4 | [H4 | H4]]; subst x.
  + assert (c ∈ (\{ λ x, x = a \/ x =b \/ x = c \} ∩ a)).
    { apply Axiom_Scheme; repeat split; Ens; apply Axiom_Scheme; split; Ens. }
    rewrite H3 in H4; generalize (not_bel_zero c); intro; contradiction.
  + assert (a ∈ (\{ λ x, x = a \/ x =b \/ x = c \} ∩ b)).
    { apply Axiom_Scheme; repeat split; Ens; apply Axiom_Scheme; split; Ens. }
    rewrite H3 in H4; generalize (not_bel_zero a); intro; contradiction.
  + assert (b ∈ (\{ λ x, x = a \/ x =b \/ x = c \} ∩ c)).
    { apply Axiom_Scheme; repeat split; Ens; apply Axiom_Scheme; split; Ens. }
    rewrite H3 in H4; generalize (not_bel_zero b); intro; contradiction.
Qed.

Theorem not_set_E : ~ Ensemble E.
Proof.
  intro; generalize (sing_set _ H); intro.
  assert (E ∈ [E]). { apply Axiom_Scheme; split; auto. }
  assert ([E, [E]] ∈ E).
  { apply Axiom_SchemeP; split; auto; apply ord_set; tauto. }
  assert ([E] ∈ [E, [E]]).
  { apply Axiom_Scheme; split; Ens; left; apply Axiom_Scheme; split; auto. }
  eapply bel_tran_false; eauto.
Qed.

Hint Resolve not_set_E : set.

(* 105 Definition  x is full iff each member of x is a subset of x. *)

Definition full x : Prop := forall m, m∈x -> m⊂x.

Corollary Property_Full : forall x,
  full x <-> (forall u v : Class, v ∈ x /\ u ∈ v -> u ∈ x).
Proof.
  intros; split; intros.
  - unfold full in H; destruct H0; apply H in H0; auto.
  - unfold full; intros; unfold Subclass; intros; apply H with m; tauto.
Qed.

Hint Unfold full : set.
Hint Resolve Property_Full : set.

(* 106 Definition  x is an ordinal iff E connects x and x is full. *)

Definition Ordinal x : Prop := Connect E x /\ full x.

Hint Unfold Ordinal : set.

(* 107 Theorem  If x is an ordinal E well-orders x. *)

Theorem ord_well_order : forall x,
  Ordinal x -> WellOrdered E x.
Proof.
  intros.
  unfold Ordinal in H; destruct H; unfold WellOrdered.
  intros; split; auto; intros; destruct H1.
  apply Axiom_Regularity in H2; destruct H2, H2.
  exists x0; unfold FirstMember; intros.
  split; auto; intros; intro.
  unfold Rrelation in H5; apply Axiom_SchemeP in H5; destruct H5.
  assert (y0 ∈ (y ∩ x0)). { apply Axiom_Scheme; split; Ens. }
  rewrite H3 in H7; generalize (not_bel_zero y0); intro; contradiction.
Qed.

Hint Resolve ord_well_order : set.

(* 108 Theorem  If x is an ordinal, y⊂x, y≠x, and y is full, then y∈x. *)

Theorem ord_sub_full_bel : forall x y,
  Ordinal x -> y ⊂ x -> y≠x -> full y -> y ∈ x.
Proof.
  intros.
  assert (Section y E x).
  { apply ord_well_order in H; unfold Section; intros.
    split; auto; split; auto; intros; destruct H3, H4.
    unfold Rrelation in H5; apply Axiom_SchemeP in H5; destruct H5.
    unfold full in H2; apply H2 in H4; auto. }
  generalize (Lemma_xy _ _ H3 H1); intro.
  apply sec_noteq_exist_set in H4; destruct H4, H4.
  assert (x0 = \{ λ u : Class,u ∈ x /\ Rrelation u E x0 \}).
  { apply Axiom_Extent; split; intros; AssE z.
    - apply Axiom_Scheme; split; auto.
      unfold Ordinal in H; destruct H.
      double H4; unfold full in H8; apply H8 in H4.
      split; auto; apply Axiom_SchemeP; split; auto.
      apply ord_set; split; Ens.
    - apply Axiom_Scheme in H6; destruct H6, H8.
      unfold Rrelation in H9; apply Axiom_SchemeP in H9; tauto. }
  rewrite <- H6 in H5; subst x0; auto.
Qed.

Hint Resolve ord_sub_full_bel : set.

(* 109 Theorem  If x is an ordinal an y is an ordinal, then x⊂y or y⊂x. *)

Lemma ord_full_int : forall x y,
  Ordinal x /\ Ordinal y -> full (x ∩ y).
Proof.
  intros; destruct H; unfold Ordinal in H, H0; destruct H, H0.
  unfold full in *; intros; apply Axiom_Scheme in H3; destruct H3, H4.
  apply H1 in H4; apply H2 in H5.
  unfold Subclass; intros; apply Axiom_Scheme; repeat split; Ens.
Qed.

Lemma ord_int_or : forall x y,
  Ordinal x /\ Ordinal y -> ((x ∩ y) = x) \/ ((x ∩ y) ∈ x).
Proof.
  intros.
  generalize (classic ((x ∩ y) = x)); intro; destruct H0; try tauto.
  assert ((x ∩ y) ⊂ x).
  { unfold Subclass; intros; apply bel_inter in H1; tauto. }
  elim H; intros; apply ord_full_int in H.
  eapply ord_sub_full_bel in H2; eauto.
Qed.

Theorem ord_sub_or : forall x y,
  Ordinal x /\ Ordinal y -> x ⊂ y \/ y ⊂ x.
Proof.
  intros; elim H; intros; generalize (Lemma_xy _ _ H1 H0); intro.
  apply ord_int_or in H; apply ord_int_or in H2; destruct H.
  - apply inter_sub in H; tauto.
  - destruct H2.
    + apply inter_sub in H2; tauto.
    + assert ((x ∩ y) ∈ (x ∩ y)).
      { rewrite inter_com in H2; apply Axiom_Scheme; repeat split; Ens. }
      apply notin_fix in H3; elim H3.
Qed.

Hint Resolve ord_sub_or : set.

(* 110 Theorem  If x is an ordinal an y is an ordinal, then x∈y or y∈x or
   x = y. *)

Theorem ord_bel_eq : forall x y,
  Ordinal x /\ Ordinal y -> x ∈ y \/ y ∈ x \/ x = y.
Proof.
  intros; generalize (classic (x = y)); intro; destruct H0; try tauto.
  elim H; intros; apply ord_sub_or in H; destruct H.
  - left; unfold Ordinal in H1; destruct H1; eapply ord_sub_full_bel; eauto.
  - right; left; unfold Ordinal in H2; destruct H2.
    eapply ord_sub_full_bel; eauto; intro; auto.
Qed.

Hint Resolve ord_bel_eq : set.

(* 111 Theorem  If x is an ordinal and y∈x, then y is an ordinal. *)

Theorem ord_bel_ord : forall x y, Ordinal x /\ y ∈ x -> Ordinal y.
Proof.
  intros; destruct H; double H; unfold Ordinal in H; destruct H.
  assert (Connect E y).
  { unfold Connect; intros; unfold Ordinal in H1; apply H1 in H0.
    unfold Connect in H; destruct H3; apply H; auto. }
  unfold Ordinal; split; auto.
  unfold full; intros; unfold Subclass; intros.
  apply ord_well_order in H1; unfold Ordinal in H1.
  assert (y ⊂ x); auto; assert (m ∈ x); auto.
  assert (m ⊂ x); auto; assert (z ∈ x); auto.
  apply well_tran_asy in H1; destruct H1.
  unfold Transitive in H1; specialize H1 with z m y.
  assert (Rrelation z E y).
  { apply H1; repeat split; Ens.
    - unfold Rrelation; apply Axiom_SchemeP; split; auto.
      apply ord_set; split; Ens.
    - unfold Rrelation; apply Axiom_SchemeP; split; auto.
      apply ord_set; split; Ens. }
  unfold Rrelation in H11; apply Axiom_SchemeP in H11; tauto.
Qed.

Hint Resolve ord_bel_ord : set.

(* 112 Definition  R = { x : x is an ordinal }. *)

Definition R : Class := \{ λ x, Ordinal x \}.

Hint Unfold R : set.

(* 113 Theorem  R is an ordinal and R is not a set. *)

Lemma Lemma113 :forall u v,
  Ensemble u -> Ensemble v -> Ordinal u /\ Ordinal v ->
  (Rrelation u E v \/ Rrelation v E u \/ u = v) .
Proof.
  intros; apply ord_bel_eq in H1; repeat split.
  destruct H1 as [H1 | [H1 | H1]].
  - left; unfold Rrelation; apply Axiom_SchemeP; split; Ens.
    apply ord_set; auto.
  - right; left; apply Axiom_SchemeP; split; Ens.
    apply ord_set; auto.
  - right; right; auto.
Qed.

Theorem ord_not_set_R : Ordinal R /\ ~ Ensemble R.
Proof.
  intros.
  assert (Ordinal R).
  { unfold Ordinal; intros; split.
    - unfold Connect; intros; destruct H.
      apply Axiom_Scheme in H; destruct H; apply Axiom_Scheme in H0; destruct H0.
      generalize (Lemma_xy _ _ H1 H2); intro; apply Lemma113; auto.
    - unfold full; intros; apply Axiom_Scheme in H; destruct H.
      unfold Subclass; intros; apply Axiom_Scheme; split; Ens.
      eapply ord_bel_ord; eauto. }
  split; auto; intro.
  assert (R ∈ R). { apply Axiom_Scheme; split; auto. }
  apply notin_fix in H1; auto.
Qed.

Hint Resolve ord_not_set_R : set.

(* 114 Theorem  Each E-section of R is an ordinal. *)

Theorem sec_R_ord : forall x, Section x E R -> Ordinal x.
Proof.
  intros.
  generalize (classic (x = R)); intro; destruct H0.
  - rewrite H0; apply ord_not_set_R.
  - generalize (Lemma_xy _ _ H H0); intro.
    apply sec_noteq_exist_set in H1; destruct H1, H1.
    assert (x0 = \{ λ u, u ∈ R /\ Rrelation u E x0 \}).
    { apply Axiom_Extent; split; intros.
      - apply Axiom_Scheme; repeat split; Ens.
        + apply Axiom_Scheme in H1; destruct H1.
          apply Axiom_Scheme; split; Ens; eapply ord_bel_ord; eauto.
        + unfold Rrelation; apply Axiom_SchemeP; split; auto.
          apply ord_set; Ens.
      - apply Axiom_Scheme in H3; destruct H3, H4.
        unfold Rrelation in H5; apply Axiom_SchemeP in H5; tauto. }
    subst x; rewrite H3 in H1; apply Axiom_Scheme in H1; tauto.
Qed.

Corollary ord_sec_R : forall x, Ordinal x -> Section x E R.
Proof.
  intros; unfold Section; split.
  - unfold Subclass; intros; apply Axiom_Scheme; split; try Ens.
    eapply ord_bel_ord; eauto.
  - split; intros; try apply ord_well_order; try apply ord_not_set_R.
    destruct H0, H1; unfold Ordinal in H2; apply Axiom_SchemeP in H2.
    destruct H2; unfold Ordinal in H; destruct H; apply H4 in H1; auto.
Qed.

Hint Resolve sec_R_ord : set.

(* 115 Definition  x is an ordinal number iff x ∈ R. *)

Definition Ordinal_Number x : Prop := x ∈ R.

Hint Unfold Ordinal_Number : set.

(* 116 Definition  x ≺ y if and only if x ∈ y. *)

Definition Less x y : Prop := x ∈ y.

Notation "x ≺ y" := (Less x y)(at level 67, left associativity).

Hint Unfold Less : set.

(* 117 Definition  x ≼ y if and only if x ∈ y or x = y. *)

Definition LessEqual x y := x ∈ y \/ x=y.

Notation "x ≼ y" := (LessEqual x y)(at level 67, left associativity).

(* 118 Theorem  If x and y are ordinals, then x ≼ y if and only if x ⊂ y. *)

Theorem ord_sub_iff_le : forall x y,
  Ordinal x /\ Ordinal y -> (x ⊂ y <-> x ≼ y).
Proof.
  intros; destruct H; split; intros.
  - unfold LessEqual.
    generalize (classic (x = y)); intro; destruct H2; try tauto.
    unfold Ordinal in H; destruct H.
    left; apply ord_sub_full_bel; auto.
  - unfold LessEqual in H1; destruct H1.
    + unfold Ordinal in H0; destruct H0; auto.
    + rewrite H1; auto; unfold Subclass; intros; auto.
Qed.

Hint Resolve ord_sub_iff_le : set.

(* 119 Theorem  If x is an ordinal, then x = { y : y ∈ R /\ y ≺ x }. *)

Theorem ord_set_eq : forall x,
  Ordinal x -> x = \{ λ y, y ∈ R /\ y ≺ x \}.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme; repeat split; Ens.
    apply Axiom_Scheme; split; Ens; eapply ord_bel_ord; eauto.
  - apply Axiom_Scheme in H0; destruct H0, H1; auto.
Qed.

Hint Resolve ord_set_eq : set.

(* 120 Theorem  If x ⊂ R, then ∪x is an ordinal. *)

Theorem sub_ord_eleU : forall x, x ⊂ R -> Ordinal (∪ x).
Proof.
  intros; red; split.
  - unfold Connect; intros; destruct H0; apply Axiom_Scheme in H0.
    apply Axiom_Scheme in H1; destruct H0, H2, H2, H1, H4, H4.
    apply H in H3; apply H in H5; apply Axiom_Scheme in H3.
    destruct H3; apply Axiom_Scheme in H5; destruct H5.
    assert (Ordinal u). { eapply ord_bel_ord; eauto. }
    assert (Ordinal v). { eapply ord_bel_ord; eauto. }
    generalize (Lemma_xy _ _ H8 H9); intro; apply Lemma113; auto.
  - apply Property_Full; intros; destruct H0.
    apply Axiom_Scheme in H0; destruct H0, H2, H2.
    apply Axiom_Scheme; split; Ens; exists x0; split; auto.
    apply H in H3; apply Axiom_Scheme in H3; destruct H3 as [_ H3].
    unfold Ordinal in H3; destruct H3; apply H4 in H2; auto.
Qed.

Hint Resolve sub_ord_eleU : set.

(* 121 Theorem  If x ⊂ R and x ≠ Φ, then ∩x ∈ x. *)

Lemma sub_noteq_firstmemb : forall x, x ⊂ R /\ x ≠ Φ -> FirstMember (∩ x) E x.
Proof.
  intros; destruct H.
  generalize (ord_not_set_R); intro; destruct H1.
  apply ord_well_order in H1; unfold WellOrdered in H1; destruct H1.
  generalize (Lemma_xy _ _ H H0); intro; apply H3 in H4; destruct H4.
  double H4; unfold FirstMember in H4; destruct H4.
  assert ((∩ x) = x0).
  { apply Axiom_Extent; split; intros.
    - apply Axiom_Scheme in H7; destruct H7; apply H8; auto.
    - apply Axiom_Scheme; split; Ens; intros.
      assert (~ Rrelation y E x0); auto.
      assert (Ordinal x0). { apply H in H4; apply Axiom_Scheme in H4; tauto. }
      assert (Ordinal y). { apply H in H8; apply Axiom_Scheme in H8; tauto. }
      generalize (Lemma_xy _ _ H10 H11); intro; apply ord_bel_eq in H12.
      destruct H12 as [H12 | [H12 | H12]].
      + apply H in H8; apply Axiom_Scheme in H8; destruct H8 as [_ H8].
        unfold Ordinal in H8; destruct H8; generalize (Property_Full y); intro.
        destruct H14; eapply H14; eauto.
      + elim H9; unfold Rrelation; apply Axiom_SchemeP; split; auto.
        apply ord_set; Ens.
      + subst x0; auto. }
  rewrite H7 ; auto.
Qed.

Theorem sub_noteq_eleI : forall x, x ⊂ R /\ x ≠ Φ -> (∩ x) ∈ x.
Proof.
  intros; apply sub_noteq_firstmemb in H.
  unfold FirstMember in H; tauto.
Qed.

Hint Resolve sub_noteq_eleI : set.

(* 122 Definition  x + 1 = x ∪ {x}. *)

Definition PlusOne x := x ∪ [x].

Hint Unfold PlusOne: set.

(* 123 Theorem  If x∈R, then x+1 is the E-first member of {y : y∈R and x≺y}. *)

Lemma ordnum_succ_ordnum : forall x, x ∈ R -> (PlusOne x) ∈ R.
Proof.
  intros; apply Axiom_Scheme; split.
  - apply Axiom_Union; split; Ens; apply sing_set; Ens.
  - unfold Connect; split.
    + unfold Connect; intros; destruct H0.
      apply Axiom_Scheme in H0; apply Axiom_Scheme in H1; destruct H0, H1, H2, H3.
      * apply Axiom_Scheme in H; destruct H as [_ H].
        assert (Ordinal u). { eapply ord_bel_ord; eauto. }
        assert (Ordinal v). { eapply ord_bel_ord; eauto. }
        generalize (Lemma_xy _ _ H4 H5); intro; apply Lemma113; auto.
      * apply Axiom_Scheme in H3; destruct H3.
        AssE x; apply bel_universe_set in H5; apply H4 in H5; subst v.
        left; unfold Rrelation; apply Axiom_SchemeP; split; auto.
        apply ord_set; tauto.
      * apply Axiom_Scheme in H2; destruct H2.
        AssE x; apply bel_universe_set in H5; apply H4 in H5; subst u.
        right; left; unfold Subclass; apply Axiom_SchemeP; split; auto.
        apply ord_set; tauto.
      * AssE x; apply bel_universe_set in H4; double H4.
        apply Axiom_Scheme in H2; destruct H2; apply H6 in H4.
        apply Axiom_Scheme in H3; destruct H3; apply H7 in H5.
        subst u; subst v; tauto.
    + unfold full; intros; unfold Subclass; intros.
      apply Axiom_Scheme in H; apply Axiom_Scheme in H0; destruct H, H0.
      apply Axiom_Scheme; split; Ens; destruct H3.
      * unfold Ordinal in H2; destruct H2.
        unfold full in H4; left; eapply H4; eauto.
      * apply Axiom_Scheme in H3; destruct H3.
        apply bel_universe_set in H; apply H4 in H; subst m; tauto.
Qed.

Theorem ordnum_firstmemb : forall x,
  x ∈ R -> FirstMember (PlusOne x) E (\{ λ y, (y ∈ R /\ Less x y) \}).
Proof.
  intros; unfold FirstMember; split; intros.
  - apply Axiom_Scheme; repeat split.
    + unfold Ensemble; exists R; apply ordnum_succ_ordnum; auto.
    + apply ordnum_succ_ordnum; auto.
    + unfold Less; intros; apply Axiom_Scheme; split; Ens.
      right; apply Axiom_Scheme; split; Ens.
  - intro; apply Axiom_Scheme in H0; destruct H0, H2.
    unfold Rrelation in H1; apply Axiom_SchemeP in H1; destruct H1.
    apply Axiom_Scheme in H4; destruct H4; unfold Less in H3; destruct H5.
    + eapply not_bel_and; eauto.
    + AssE x; apply bel_universe_set in H6; apply Axiom_Scheme in H5; destruct H5.
      apply H7 in H6; subst y; eapply notin_fix; eauto.
Qed.

Hint Resolve ordnum_firstmemb : set.

(* 124 Theorem  If x ∈ R, then ∪(x+1) = x. *)

Theorem ordnum_eleU_succ_eq : forall x,
  x ∈ R -> ∪ PlusOne x = x.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme in H0; destruct H0, H1, H1.
    apply Axiom_Scheme in H2; destruct H2, H3.
    + apply Axiom_Scheme in H; destruct H, H4.
      generalize (Property_Full x); intro; destruct H6.
      apply H6 with (u:=z) (v:=x0) in H5; tauto.
    + apply Axiom_Scheme in H3; destruct H3.
      rewrite <- H4; auto; try (apply bel_universe_set; Ens).
  - apply Axiom_Scheme; split; Ens; exists x; split; auto.
    apply Axiom_Scheme; split; Ens; right; apply Axiom_Scheme; Ens.
Qed.

Hint Resolve ordnum_eleU_succ_eq : set.

(* 125 Definition  f|x = f ∩ (x × μ). *)

Definition Restriction f x : Class := f ∩ (x × μ).

Notation "f | ( x )" := (Restriction f x)(at level 30).

Hint Unfold Restriction: set.

(* 126 Theorem  If f is a function, f|x is a function whose domain is
   x ∩ (domain f) and (f|x)[y] = f[y] for each y in domain f|x. *)

Theorem fun_res_fun : forall f x,
  Function f -> Function (f|(x)) /\ dom(f|(x)) = x ∩ dom( f) /\
  (forall y, y ∈ dom(f|(x)) -> (f|(x)) [y] = f [y]).
Proof.
  intros; repeat split; intros.
  - unfold Relation; intros; apply Axiom_Scheme in H0; destruct H0, H1.
    PP H2 a b; eauto.
  - destruct H0; apply Axiom_Scheme in H0; destruct H0 as [_ [H0 _]].
    apply Axiom_Scheme in H1; destruct H1 as [_ [H1 _]].
    unfold Function in H; eapply H; eauto.
  - apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H0; destruct H0, H1.
      apply Axiom_Scheme in H1; destruct H1, H2.
      apply Property_dom in H2; apply Axiom_SchemeP in H3.
      apply Axiom_Scheme; split; tauto.
    + apply Axiom_Scheme in H0; destruct H0, H1.
      apply Axiom_Scheme; split; auto.
      apply Property_Value in H2; auto.
      exists f[z]; apply Axiom_Scheme; repeat split; Ens.
      apply Axiom_SchemeP; repeat split; Ens; apply bel_universe_set.
      apply Property_ran in H2; Ens.
  - apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H1; destruct H1.
      apply Axiom_Scheme in H0; destruct H0, H3.
      apply Axiom_Scheme in H3; destruct H3, H4.
      apply Property_dom in H4; apply H2.
      assert (Ensemble f[y]). { apply bel_universe_set; apply dom_value; auto. }
      apply Axiom_Scheme; split; Ens; apply Axiom_Scheme; repeat split.
      * apply ord_set; auto.
      * apply Property_Value in H4; auto.
      * apply Axiom_SchemeP in H5; apply bel_universe_set in H6.
        apply Axiom_SchemeP; repeat split; try tauto; try apply ord_set; Ens.
    + apply Axiom_Scheme in H1; destruct H1.
      apply Axiom_Scheme; split; auto; intros.
      apply Axiom_Scheme in H3; destruct H3; apply Axiom_Scheme in H4.
      apply H2; apply Axiom_Scheme; split; tauto.
Qed.

Hint Resolve fun_res_fun : set.

(* 127 Theorem  Let f be a function such that domain f is an ordinal and
   f[u] = g[f|u] for u in domain f. If h is also a function such that domain h
   is an ordinal and h[u] = g[h|u] for u in domain h, then h ⊂ f or f ⊂ h. *)

Theorem lem_fun_ord_res_sub : forall f h,
  dom( f) ⊂ dom( h) -> Function f -> Function h ->
  \{ λ a,a ∈ (dom( f) ∩ dom( h)) /\ f [a] ≠ h [a] \} = Φ -> f ⊂ h.
Proof.
  intros.
  unfold Subclass; intros; rewrite fun_set_eq in H3; auto; PP H3 a b.
  double H4; rewrite <- fun_set_eq in H4; auto; apply Property_dom in H4.
  apply Axiom_SchemeP in H5; destruct H5.
  rewrite fun_set_eq; auto; apply Axiom_SchemeP; split; auto; rewrite H6.
  generalize (classic (f[a] = h[a])); intro; destruct H7; auto.
  assert (a ∈ \{ λ a, a ∈ (dom(f) ∩ dom(h)) /\ f[a] ≠ h[a] \}).
  { apply inter_sub in H; rewrite H; apply Axiom_Scheme; split; Ens. }
  rewrite H2 in H8; generalize (not_bel_zero a); contradiction.
Qed.

Theorem fun_ord_res_sub : forall f h g,
  Function f -> Ordinal dom(f) ->
  (forall u0, u0 ∈ dom(f) -> f[u0] = g[f|(u0)]) ->
  Function h -> Ordinal dom(h) ->
  (forall u1, u1 ∈ dom(h) -> h[u1] = g [h|(u1)]) -> h ⊂ f \/ f ⊂ h.
Proof.
  intros.
  generalize (Lemma_xy _ _ H0 H3); intro; apply ord_sub_or in H5.
  generalize (classic (\{ λ a, a ∈ (dom(f) ∩ dom(h)) /\ f[a] ≠ h[a] \} = Φ));
  intro; destruct H6.
  - destruct H5.
    + right; apply lem_fun_ord_res_sub; auto.
    + left; rewrite lem_order_pre_sec_sub'' in H6; apply lem_fun_ord_res_sub; auto.
  - assert (exists u, FirstMember u E \{λ a, a∈(dom(f)∩dom(h))/\f[a]≠h[a]\}).
    { apply ord_well_order in H0; unfold WellOrdered in H0; apply H0; split; auto.
      unfold Subclass; intros; apply Axiom_Scheme in H7; destruct H7, H8.
      apply Axiom_Scheme in H8; tauto. }
    destruct H7 as [u H7]; unfold FirstMember in H7; destruct H7.
    apply Axiom_Scheme in H7; destruct H7, H9.
    apply Axiom_Scheme in H9; destruct H9 as [_[H9 H11]].
    generalize (H1 _ H9); generalize (H4 _ H11); intros.
    assert ((h | (u)) = (f | (u))).
    { apply Axiom_Extent; intros; split; intros.
      - apply Axiom_Scheme in H14; destruct H14, H15.
        apply Axiom_Scheme; repeat split; auto; PP H16 a b.
        apply Axiom_SchemeP in H17; destruct H17 ,H18.
        generalize H15 as H22; intro; apply Property_dom in H22.
        rewrite fun_set_eq in H15; auto; rewrite fun_set_eq; auto.
        apply Axiom_SchemeP in H15; destruct H15.
        apply Axiom_SchemeP; split; auto.
        rewrite H20; symmetry.
        generalize (classic (f [a] = h [a])); intro; destruct H21; auto.
        assert (a ∈ \{ λ a, a ∈ (dom(f) ∩ dom(h)) /\ f[a] ≠ h[a] \}).
        { apply Axiom_Scheme.
          repeat split; Ens; apply Axiom_Scheme; repeat split; Ens.
          unfold Ordinal in H0; destruct H0; apply H23 in H9; auto. }
        apply H8 in H23; elim H23; unfold Rrelation, E.
        apply Axiom_SchemeP; split; auto; apply ord_set; split; Ens.
      - apply Axiom_Scheme in H14; destruct H14, H15.
        apply Axiom_Scheme; repeat split; auto; PP H16 a b.
        apply Axiom_SchemeP in H17; destruct H17 ,H18.
        generalize H15 as H22; intro; apply Property_dom in H22.
        rewrite fun_set_eq in H15; auto; rewrite fun_set_eq; auto.
        apply Axiom_SchemeP in H15; destruct H15.
        apply Axiom_SchemeP; split; auto.
        rewrite H20; symmetry.
        generalize (classic (f[a] = h[a])); intro; destruct H21; auto.
        assert (a ∈ \{ λ a, a ∈ (dom(f) ∩ dom(h)) /\ f[a] ≠ h[a] \}).
        { apply Axiom_Scheme.
          repeat split; Ens; apply Axiom_Scheme; repeat split; Ens.
          unfold Ordinal in H3; destruct H3; apply H23 in H11; auto. }
        apply H8 in H23; elim H23; unfold Rrelation, E.
        apply Axiom_SchemeP; split; auto; apply ord_set; split; Ens. }
  rewrite <- H14 in H13; rewrite <- H12 in H13; contradiction.
Qed.

Hint Resolve fun_ord_res_sub : set.

(* 128 Theorem  For each g there is a unique function f such that domain f is
   an ordinal and f[x] = g[f|x] for each ordinal number x. *)

Definition En_f' g := \{\ λ u v, u ∈ R /\ (exists h, Function h /\
  Ordinal dom(h) /\ (forall z, z ∈ dom(h) -> h[z] = g [h | (z)] ) /\
  [u,v] ∈ h ) \}\.

Lemma lem_fun_ord_dom_value_res_eq : forall u v w,
  Ordinal u -> v ∈ u -> w ∈ v -> w ∈ u.
Proof.
  intros; unfold Ordinal in H; destruct H.
  unfold full in H2; eapply H2; eauto.
Qed.

Lemma lem_fun_ord_dom_value_res_eq' : forall f x,
  Function f -> Ordinal dom(f) -> Ordinal_Number x ->
  ~ x ∈ dom(f) -> f | (x) = f .
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme in H3; tauto.
  - apply Axiom_Scheme; split; Ens; split; auto.
    unfold Function, Relation in H; destruct H as [H _].
    double H3; apply H in H4; destruct H4 as [a [b H4]]; rewrite H4 in *.
    clear H H4; apply Axiom_SchemeP; split; Ens; split.
    + unfold Ordinal in H1; apply Axiom_Scheme in H1; destruct H1.
      assert (Ordinal dom(f) /\ Ordinal x); auto.
      apply ord_bel_eq in H4; apply Property_dom in H3; auto.
      destruct H4 as [H4 | [H4 | H4]]; try contradiction.
      * eapply lem_fun_ord_dom_value_res_eq; eauto.
      * rewrite H4 in H3; auto.
    + apply Property_ran in H3; apply bel_universe_set; Ens.
Qed.

Theorem fun_ord_dom_value_res_eq :  forall g,
  exists f, Function f /\ Ordinal dom(f) /\
  (forall x, Ordinal_Number x -> f [x] = g [f | (x)]).
Proof.
  intros; exists (En_f' g).
  assert (Function (En_f' g)).
  { unfold Function; intros; split; intros.
    - unfold Relation; intros; PP H a b; eauto.
    - destruct H; apply Axiom_SchemeP in H; apply Axiom_SchemeP in H0.
      destruct H, H1, H2, H2, H3, H4, H0, H6, H7, H7, H8, H9.
      generalize (fun_ord_res_sub _ _ _ H2 H3 H4 H7 H8 H9); intro; destruct H11.
      + apply H11 in H10; eapply H2; eauto.
      + apply H11 in H5; eapply H7; eauto. }
  split; auto.
  - assert (Ordinal dom(En_f' g)).
    { apply sec_R_ord; unfold Section; intros; split.
      - unfold Subclass; intros; apply Axiom_Scheme in H0.
        destruct H0, H1; apply Axiom_SchemeP in H1; tauto.
      - split; intros.
        + apply ord_well_order; apply ord_not_set_R.
        + destruct H0, H1; apply Axiom_Scheme in H1; destruct H1, H3.
          apply Axiom_SchemeP in H3; destruct H3, H4, H5, H5, H6, H7.
          apply Axiom_SchemeP in H2; destruct H2.
          apply ord_set in H2; destruct H2.
          apply Axiom_Scheme; split; auto; apply Property_dom in H8.
          assert (u ∈ dom( x0)). { eapply lem_fun_ord_dom_value_res_eq; eauto. }
          exists (x0[u]); apply Axiom_SchemeP.
          split; try apply ord_set; split; auto.
          * apply bel_universe_set; apply dom_value; auto.
          * exists x0; split; auto; split; auto; split; auto.
            apply Property_Value; auto. }
    split; intros; auto.
    generalize (classic (x ∈ dom(En_f' g))); intro; destruct H2.
    + apply Axiom_Scheme in H2; destruct H2, H3; apply Axiom_SchemeP in H3.
      destruct H2, H3, H4, H5 as [h [H5 [H6 [H7 H8]]]].
      assert (h ⊂ En_f' g).
      { double H5; unfold Subclass; intros; unfold Function, Relation in H9.
        destruct H9 as [H9 _]; double H10; apply H9 in H11.
        destruct H11 as [a [b H11]]; rewrite H11 in *; clear H9 H11 z.
        apply Axiom_SchemeP; split; try Ens.
        double H10; apply Property_dom in H9.
        split; try apply Axiom_Scheme; Ens; split; Ens.
        eapply ord_bel_ord; eauto. }
      double H8; apply H9 in H10; double H8.
      apply Property_dom in H11; apply H7 in H11.
      double H8; apply Property_dom in H12; apply Property_dom in H8.
      apply Property_Value in H8; auto; apply Property_dom in H10.
      apply Property_Value in H10; auto; apply H9 in H8.
      assert (h [x] = (En_f' g) [x]). { eapply H; eauto. }
      rewrite <- H13; clear H13.
      assert (h | (x) = En_f' g | (x)).
      { apply Axiom_Extent.
        split; intros; apply Axiom_Scheme in H13; destruct H13, H14.
        - apply Axiom_Scheme; repeat split; auto.
        - apply Axiom_Scheme; repeat split; auto; rewrite fun_set_eq; auto.
          PP H15 a b; apply Axiom_SchemeP in H16.
          apply Axiom_SchemeP; split; auto.
          destruct H16, H17; assert (a ∈ dom(h)). { eapply lem_fun_ord_dom_value_res_eq; eauto. }
          apply Property_Value in H19; auto; apply H9 in H19; eapply H; eauto. }
      rewrite <- H13; auto.
    + generalize H2; intro; apply dom_value in H2; auto.
      rewrite (lem_fun_ord_dom_value_res_eq' _ _ H H0 H1 H3).
      generalize (classic (En_f' g ∈ dom(g))); intro; destruct H4.
      * generalize ord_not_set_R; intro; destruct H5 as [H5 _].
        apply ord_well_order in H5; unfold WellOrdered in H5; destruct H5.
        assert ((R ~ dom(En_f' g)) ⊂ R /\ (R ~ dom(En_f' g)) ≠ Φ).
        { split; try (red; intros; apply Axiom_Scheme in H7; tauto).
          intro; generalize (ord_sec_R _ H0); intro.
          unfold Section in H8; destruct H8.
          apply Property_Φ in H8; apply H8 in H7.
          rewrite <- H7 in H3; contradiction. }
        apply H6 in H7; destruct H7 as [y H7].
        assert (((En_f' g) ∪ [[y,g[En_f' g]]]) ⊂ (En_f' g)).
        { unfold Subclass; intros.
          apply Axiom_Scheme in H8; destruct H8, H9; auto.
          assert (Ensemble ([y, g [En_f' g]])).
          { destruct H7; AssE y; apply dom_value in H4.
            apply bel_universe_set in H4; apply ord_set; tauto. }
          apply Axiom_Scheme in H9; destruct H9.
          rewrite H11; try apply bel_universe_set; auto.
          apply Axiom_SchemeP; split; auto; split.
          - unfold FirstMember in H7; destruct H7.
            apply Axiom_Scheme in H7; tauto.
          - exists ((En_f' g) ∪ [[y,g[En_f' g]]]).
            assert (Function (En_f' g ∪ [[y, g [En_f' g]]])).
            { unfold Function; split; intros.
              - unfold Relation; intros; apply Axiom_Scheme in H12.
                destruct H12, H13; try PP H13 a b; eauto.
                apply Axiom_Scheme in H13; destruct H13; apply bel_universe_set in H10.
                apply H14 in H10; eauto.
              - destruct H12; apply Axiom_Scheme in H12.
                destruct H12 as [_ H12].
                apply Axiom_Scheme in H13; destruct H13 as [_ H13].
                unfold FirstMember in H7; destruct H7.
                apply Axiom_Scheme in H7; destruct H7 as [_ [_ H7]].
                apply Axiom_Scheme in H7; destruct H7, H12, H13.
                + eapply H; eauto.
                + apply Axiom_Scheme in H13; destruct H13.
                  apply bel_universe_set in H10.
                  apply H16 in H10; apply ord_eq in H10;
                  destruct H10; try apply ord_set; auto; rewrite H10 in H12.
                  apply Property_dom in H12; contradiction.
                + apply Axiom_Scheme in H12; destruct H12.
                  apply bel_universe_set in H10.
                  apply H16 in H10; apply ord_eq in H10; destruct H10;
                  try apply ord_set; auto; rewrite H10 in H13.
                  apply Property_dom in H13; contradiction.
                + double H12; apply Axiom_Scheme in H12.
                  apply Axiom_Scheme in H13.
                  destruct H12, H13; double H10.
                  apply bel_universe_set in H10; apply H17 in H10.
                  apply bel_universe_set in H19; apply H18 in H19.
                  apply ord_eq in H10; destruct H10;
                  apply ord_set in H12; auto.
                  apply ord_eq in H19; destruct H19;
                  apply ord_set in H13; auto.
                  rewrite H20, H21; auto. }
            split; auto; split.
            + apply sec_R_ord; unfold Section; intros; split.
              * unfold Subclass; intros.
                apply Axiom_Scheme in H13; destruct H13, H14.
                apply Axiom_Scheme in H14; destruct H14, H15.
                -- apply Property_dom in H15; apply Axiom_Scheme.
                   split; Ens; eapply ord_bel_ord; eauto.
                -- apply Axiom_Scheme in H15; destruct H15.
                   apply bel_universe_set in H10.
                   apply H16 in H10; apply ord_eq in H10; destruct H10;
                   try apply ord_set; auto; destruct H7.
                   apply Axiom_Scheme in H7; rewrite H10; tauto.
              * split; try (apply ord_well_order; apply ord_not_set_R); intros.
                destruct H13, H14; apply Axiom_Scheme in H14; destruct H14, H16.
                apply Axiom_Scheme in H16; destruct H16, H17.
                -- apply Axiom_Scheme; split; Ens.
                   assert ([u, (En_f' g) [u]] ∈ (En_f' g)).
                   { apply Property_Value; auto; apply Property_dom in H17.
                     unfold Rrelation in H15; apply Axiom_SchemeP in H15.
                     destruct H15; eapply lem_fun_ord_dom_value_res_eq; eauto. }
                   exists ((En_f' g) [u]); apply Axiom_Scheme; split; Ens.
                -- assert ([u, (En_f' g) [u]] ∈ (En_f' g)).
                   { apply Property_Value; auto.
                     apply Axiom_Scheme in H17; destruct H17.
                     apply bel_universe_set in H10; apply H18 in H10.
                     apply ord_eq in H10;
                     destruct H10; try apply ord_set; auto.
                     subst v; unfold FirstMember in H7; destruct H7.
                     generalize (classic (u ∈ dom( En_f' g))); intro.
                     destruct H20; auto.
                     absurd (Rrelation u E y); auto; try apply H10.
                     apply Axiom_Scheme; repeat split; Ens.
                     apply Axiom_Scheme; split; Ens. }
                   apply Axiom_Scheme; split; Ens; exists ((En_f' g) [u]).
                   apply Axiom_Scheme; split; Ens.
            + split; intros.
              * apply Property_Value in H13; auto.
                apply Axiom_Scheme in H13; destruct H13, H14.
                -- apply Axiom_SchemeP in H14; destruct H14, H15.
                   destruct H16 as [h [H16 [H17 [H18 H19]]]].
                   double H19; apply Property_dom in H20.
                   rewrite fun_set_eq in H19; auto.
                   apply Axiom_SchemeP in H19; destruct H19.
                   assert (h ⊂ En_f' g).
                   { unfold Subclass; intros; double H16.
                     unfold Function, Relation in H23; destruct H23 as [H23 _].
                     double H22; apply H23 in H24; destruct H24 as [a [b H24]].
                     rewrite H24 in *; clear H23 H24; apply Axiom_SchemeP.
                     split; try Ens; double H22; apply Property_dom in H23.
                     split; try apply Axiom_Scheme; Ens.
                     split; try Ens; eapply ord_bel_ord; eauto. }
                   assert ((En_f' g ∪ [[y, g[En_f' g]]])|(z0) = En_f' g|(z0)).
                   { unfold Restriction; rewrite inter_com; rewrite union_dist.
                     assert ((z0) × μ ∩ [[y, g [En_f' g]]] = Φ).
                     { apply Axiom_Extent; split; intros.
                       - apply Axiom_Scheme in H23; destruct H23, H24; auto.
                         PP H24 a b; apply Axiom_SchemeP in H26.
                         destruct H26, H27.
                         apply Axiom_Scheme in H25; destruct H25.
                         apply bel_universe_set in H10; apply H29 in H10.
                         apply ord_eq in H10; apply ord_set in H25; auto.
                         destruct H10; rewrite H10 in H27.
                         assert (y ∈ dom( h)).   { eapply lem_fun_ord_dom_value_res_eq; eauto. }
                         apply Property_Value in H31; auto.
                         apply H22 in H31; apply Property_dom in H31.
                         unfold FirstMember in H7; destruct H7.
                         apply Axiom_Scheme in H7; destruct H7, H33.
                         apply Axiom_Scheme in H34; destruct H34; contradiction.
                       - generalize (not_bel_zero z1); contradiction. }
                     rewrite H23, union_com, zero_union; apply inter_com. }
                   rewrite H21, H23.
                   assert (h | (z0) = En_f' g | (z0)).
                   { apply Axiom_Extent; split; intros.
                     - apply Axiom_Scheme in H24; destruct H24, H25.
                       apply Axiom_Scheme; repeat split; auto.
                     - apply Axiom_Scheme in H24; destruct H24, H25.
                       apply Axiom_Scheme.
                       repeat split; auto; rewrite fun_set_eq; auto.
                       PP H26 a b; apply Axiom_SchemeP in H27.
                       apply Axiom_SchemeP.
                       split; auto; destruct H27 as [_ [H27 _]].
                       assert (a ∈ dom(h)). { eapply lem_fun_ord_dom_value_res_eq; eauto. }
                       apply Property_Value in H28; auto; apply H22 in H28.
                       eapply H; eauto. }
                   rewrite <- H24; auto.
                -- apply Axiom_Scheme in H14; destruct H14.
                   double H10; apply bel_universe_set in H10; apply H15 in H10.
                   apply ord_eq in H10; apply ord_set in H13; auto.
                   destruct H10; subst z0; rewrite H17.
                   assert ((En_f' g ∪ [[y, g [En_f' g]]])|(y) = En_f' g|(y)).
                   { apply Axiom_Extent; split; intros.
                     - apply Axiom_Scheme in H10; destruct H10, H18.
                       apply Axiom_Scheme in H18; destruct H18, H20.
                       + apply Axiom_Scheme; tauto.
                       + PP H19 a b; apply Axiom_SchemeP in H21.
                         destruct H21, H22.
                         apply Axiom_Scheme in H20; destruct H20.
                         apply bel_universe_set in H16; apply H24 in H16.
                         apply ord_eq in H16; apply ord_set in H21; auto.
                         destruct H16; rewrite H16 in H22.
                         generalize (notin_fix y); intro; contradiction.
                     - unfold Restriction; rewrite inter_com, union_dist.
                       apply Axiom_Scheme.
                       split; Ens; left; rewrite inter_com; Ens. }
                   rewrite H10; unfold FirstMember in H7; destruct H7.
                   apply Axiom_Scheme in H7; destruct H7, H19.
                   apply Axiom_Scheme in H20; destruct H20.
                   rewrite lem_fun_ord_dom_value_res_eq'; auto.
              * apply Axiom_Scheme; split; Ens; right.
                apply Axiom_Scheme; split; Ens. }
        unfold FirstMember in H7; destruct H7.
        assert (y ∈ dom(En_f' g ∪ [[y, g [En_f' g]]])).
        { apply Axiom_Scheme; split; Ens; exists g [En_f' g].
          assert (Ensemble ([y, g [En_f' g]])).
          { apply ord_set; split; Ens.
            apply dom_value in H4; apply bel_universe_set; auto. }
          apply Axiom_Scheme; split; Ens; right; apply Axiom_Scheme; auto. }
        apply Axiom_Scheme in H7; destruct H7, H11; apply Axiom_Scheme in H12.
        destruct H12; elim H13; apply Axiom_Scheme in H10; destruct H10, H14.
        apply H8 in H14; apply Property_dom in H14; auto.
      * apply dom_value in H4; rewrite H2, H4; auto.
Qed.

Lemma lem_fun_ord_dom_value_res_eq'' : forall f h,
  Function f -> Function h -> h ⊂ f -> f | (dom(h)) = h.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme in H2; destruct H2, H3.
    PP H4 a b; apply Axiom_SchemeP in H5; destruct H5, H6; double H3.
    rewrite fun_set_eq; rewrite fun_set_eq in H3; auto.
    apply Axiom_SchemeP in H3; destruct H3.
    apply Axiom_SchemeP; split; Ens; rewrite H9 in *.
    apply Property_Value in H6; auto.
    apply H1 in H6; eapply H; eauto.
  - apply Axiom_Scheme; repeat split; Ens.
    rewrite fun_set_eq in H2; auto.
    PP H2 a b; rewrite <- fun_set_eq in H3; auto.
    apply Axiom_SchemeP; repeat split; Ens.
    + apply Property_dom in H3; auto.
    + AssE [a,b]; apply ord_set in H4.
      apply bel_universe_set; tauto.
Qed.

Lemma lem_fun_ord_dom_value_res_eq''' : forall h, Function h -> h | (dom(h)) = h.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme in H0; tauto.
  - apply Axiom_Scheme; repeat split; Ens.
    rewrite fun_set_eq in H0; auto.
    PP H0 a b; rewrite <- fun_set_eq in H1; auto.
    apply Axiom_SchemeP; repeat split; Ens.
    + apply Property_dom in H1; auto.
    + AssE [a,b]; apply ord_set in H2.
      apply bel_universe_set; tauto.
Qed.

Lemma lem_fun_ord_dom_value_res_eq'''' : forall f g h,
  Function f -> Function h -> Ordinal dom(f) ->
  Ordinal dom( h)-> (forall x, Ordinal_Number x -> f [x] = g [f | (x)]) ->
  (forall x, Ordinal_Number x -> h [x] = g [h | (x)]) -> h ⊂ f -> h = f.
Proof.
  intros.
  generalize (ord_bel_eq _ _ (Lemma_xy _ _ H1 H2)); intro.
  destruct H6 as [H8 | [H6 | H6]].
  - apply Property_Value in H8; auto.
    apply H5 in H8; apply Property_dom in H8.
    apply notin_fix in H8; elim H8.
  - assert (Ordinal_Number dom(h)).
    { unfold Ordinal_Number; apply Axiom_Scheme; split; Ens. }
    double H7; apply H3 in H7; apply H4 in H8.
    rewrite lem_fun_ord_dom_value_res_eq'' in H7; rewrite lem_fun_ord_dom_value_res_eq''' in H8; auto.
    apply dom_value in H6; rewrite H7 in H6.
    generalize (notin_fix dom(h)); intro.
    apply dom_value in H9; rewrite H8 in H9.
    rewrite H9 in H6; apply notin_fix in H6; elim H6.
  - apply sub_eq; split; auto.
    unfold Subclass; intros.
    rewrite fun_set_eq; rewrite fun_set_eq in H7; auto.
    PP H7 a b; double H8; rewrite <- fun_set_eq in H8; auto.
    apply Axiom_SchemeP in H9; destruct H9.
    apply Axiom_SchemeP; split; auto; rewrite H10 in *.
    assert ([a,h[a]] ∈ h).
    { apply Property_Value; auto.
      apply Property_dom in H8; rewrite <- H6; auto. }
    apply H5 in H11; eapply H; eauto.
Qed.

Theorem fun_ord_dom_value_res_eq' :  forall g,
  forall f, Function f /\ Ordinal dom(f) /\
  (forall x, Ordinal_Number x -> f [x] = g [f | (x)]) ->
  forall h, Function h /\ Ordinal dom(h) /\
  (forall x, Ordinal_Number x -> h [x] = g [h | (x)]) -> f = h.
Proof.
  intros; destruct H, H0, H1, H2.
  assert (forall u, u ∈ dom(f) -> f [u] = g [f | (u)]); intros.
  { apply H3; unfold Ordinal_Number; apply Axiom_Scheme; split; Ens.
    apply ord_bel_ord with (x:= dom(f)); auto. }
  assert (forall u, u ∈ dom(h) -> h [u] = g [h | (u)]); intros.
  { apply H4; unfold Ordinal_Number; apply Axiom_Scheme; split; Ens.
    apply ord_bel_ord with (x:= dom(h)); auto. }
  generalize (fun_ord_res_sub f h g H H1 H5 H0 H2 H6); intro; destruct H7.
  - symmetry; eapply lem_fun_ord_dom_value_res_eq''''; eauto.
  - eapply lem_fun_ord_dom_value_res_eq''''; eauto.
Qed.

Hint Resolve fun_ord_dom_value_res_eq : set.

End Ord.

Export Ord.


Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.lemma_paralleldef2B.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelNC.
Require Export GeoCoq.Elements.OriginalProofs.lemma_planeseparation.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_parallelPasch :
   forall A B C D E,
   PG A B C D -> BetS A D E ->
   exists X, BetS B X E /\ BetS C X D.
Proof.
intros.
assert (Par A B C D) by (conclude_def PG ).
assert (Par A D B C) by (conclude_def PG ).
assert (Par C D A B) by (conclude lemma_parallelsymmetric).
assert (TP C D A B) by (conclude lemma_paralleldef2B).
assert (OS A B C D) by (conclude_def TP ).
assert (OS B A C D) by (forward_using lemma_samesidesymmetric).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (neq A D) by (forward_using lemma_betweennotequal).
assert (Col A D D) by (conclude_def Col ).
assert (Col A D E) by (conclude_def Col ).
assert (Col D D E) by (conclude lemma_collinear4).
assert (Col E D D) by (forward_using lemma_collinearorder).
assert (Col C D D) by (conclude_def Col ).
assert (nCol A C D) by (forward_using lemma_parallelNC).
assert (nCol C D A) by (forward_using lemma_NCorder).
assert (TS A C D E) by (conclude_def TS ).
assert (TS B C D E) by (conclude lemma_planeseparation).
rename_H H;let Tf:=fresh in
assert (Tf:exists H, (BetS B H E /\ Col C D H /\ nCol C D B)) by (conclude_def TS );destruct Tf as [H];spliter.
assert (BetS E H B) by (conclude axiom_betweennesssymmetry).
assert (Col D C H) by (forward_using lemma_collinearorder).
assert (neq A D) by (conclude_def Par ).
assert (~ Meet A D B C) by (conclude_def Par ).
assert (~ Meet E D C B).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists p, (neq E D /\ neq C B /\ Col E D p /\ Col C B p)) by (conclude_def Meet );destruct Tf as [p];spliter.
 assert (neq B C) by (conclude lemma_inequalitysymmetric).
 assert (Col B C p) by (forward_using lemma_collinearorder).
 assert (Col E D A) by (forward_using lemma_collinearorder).
 assert (Col D A p) by (conclude lemma_collinear4).
 assert (Col A D p) by (forward_using lemma_collinearorder).
 assert (Meet A D B C) by (conclude_def Meet ).
 contradict.
 }
assert (eq C C) by (conclude cn_equalityreflexive).
assert (neq D E) by (forward_using lemma_betweennotequal).
assert (neq E D) by (conclude lemma_inequalitysymmetric).
assert (neq B C) by (conclude_def Par ).
assert (neq C B) by (conclude lemma_inequalitysymmetric).
assert (Col C C B) by (conclude_def Col ).
assert (BetS D H C) by (conclude lemma_collinearbetween).
assert (BetS C H D) by (conclude axiom_betweennesssymmetry).
close.
Qed.

End Euclid.